{--------------------------------------------------------}
{
{   Sistema Tradutor Fonético (N.R.L.)
{
{   Função : Traduzir um texto, escrito em uma linguagem qualquer,
{            para a transcrição fonética correspondente
{
{   Autores :
{       . Alexandre Plastino de Carvalho
{       . Sylvia de Oliveira e Cruz
{       . Veronica Lourenco de Herval Costa
{
{   Trabalho de Fim de Curso de Informática
{   Orientador Acadêmico: José Antonio Borges
{
{   Data de criação : Julho de 1987
{   Data de aprovação : Dezembro de 1987
{
{   Adaptado para o DOSVOX por
{        . José Antonio Borges, em Maio de 1994
{   Adaptado para o Sintetizador do Serpro por
{        . José Antonio Borges, em Maio de 2006
{
{--------------------------------------------------------}

unit uttsPortug;
interface
uses sysUtils, dialogs, umbrInic, uttsExcessoes, uttsPreproc, umbrTonica;

function inicTradutor (nomeArqRegras, nomeArqExcessoes: string): boolean;
procedure compilaFonemas (texto: string; var fonemas: string);
procedure fimTradutor;

implementation

{--------------------------------------------------------}
{                   variaveis gerais
{--------------------------------------------------------}

var
   pt_aux : pt_regras;  { Ponteiro auxiliar }
   pos_i,               { Posicao sendo traduzida }
   pos_f,               { Posição final da sequencia de tradução }

   ind_teste_contexto : integer;
                        { indice para o caracter da palavra
                          a ser testado no teste de contexto }

   satisfeito,          { Indica se a regra satisfaz ou nao }
   aceito : boolean;    { Indica se a regra foi aceita ou nao }


   traduzEspec: boolean;  { traduz simbolos especiais }

{--------------------------------------------------------}
{             inicializacao dos conjuntos
{--------------------------------------------------------}

const
   CRLF = #$0d + #$0a;
   
   alfabeto: set of char =
        ['A','E','I','O','U','À','Á','Â','Ã','É','Ê','Ê','Ì','Í','Ó','Ô','Õ','Ù','Ú','Ü',
         'a','e','i','o','u','à','á','â','ã','é','ê','ê','ì','í','ó','ô','õ','ù','ú','ü',
         'b'..'d','f'..'h','j'..'n','p'..'t','v'..'z', 'ç', 'ñ',
         'B'..'D','F'..'H','J'..'N','P'..'T','V'..'Z', 'Ç', 'Ñ'];

   delimitadores: set of char = [' ', ',' , ':' , ';' , '.' , '!' , '?'];

   consoante: set of char =
        ['b'..'d','f'..'h','j'..'n','p'..'t','v'..'z', 'ç', 'ñ',
         'B'..'D','F'..'H','J'..'N','P'..'T','V'..'Z', 'Ç', 'Ñ'];

   vogal: set of char =
        ['A','E','I','O','U','À','Á','Â','Ã','É','Ê','Ê','Ì','Í','Ó','Ô','Õ','Ù','Ú','Ü',
         'a','e','i','o','u','à','á','â','ã','é','ê','ê','ì','í','ó','ô','õ','ù','ú','ü'];

   acentos: set of char =
        ['Á','Â','Ã','É','Ê','Ê','Í','Ó','Ô','Õ','Ú',
         'á','â','ã','é','ê','ê','í','ó','ô','õ','ú'];

   incombinantes: set of char =
       ['b','c','d','f','g','j','k','m','n','p','q','s','t','v','x','z'];

   QG: set of char = ['q' , 'g'];

   AO: set of char = ['A' , 'O' , 'a' , 'o',
                      'Á' , 'Ó' , 'á' , 'ó',
                      'Â' , 'Ô' , 'â' , 'ô'];

   EI: set of char = ['E' , 'I' , 'e' , 'i',
                      'É' , 'Í' , 'é' , 'í'];

   RL: set of char = ['R' , 'L' , 'r' , 'l'];

   S:  set of char = ['S' , 's'];

   H:  set of char = ['H' , 'h'];

   LMNRZ: set of char = ['L','M','N','R','Z',  'l','m','n','r','z'];

   NRS: set of char = ['N', 'R', 'S',  'n','r','s'];

procedure traduz (palavra: string; tonica: integer; pegraProsodia: char; var fonemas: string);

{--------------------------------------------------------}
{       verifica se contexto `a direita satisfaz
{--------------------------------------------------------}

function contexto_a_direita_satisfaz : boolean;

        {--------------------------------------------------------}

        procedure testa_fim_silaba;
        begin
           if (ind_teste_contexto < pos_f) and
              ((not (palavra[ind_teste_contexto] in consoante)) or
                (palavra[ind_teste_contexto] in H)) then
                     aceito := false;
        end;

        {--------------------------------------------------------}

        procedure testa_consoante_muda;
        begin
           if (ind_teste_contexto = 0) or
              (ind_teste_contexto > pos_f) then
                  aceito := false
           else
              if (not (palavra[ind_teste_contexto] in consoante)) or
                 (palavra[ind_teste_contexto] in RL) then
                     aceito := false;
        end;

        {--------------------------------------------------------}

        procedure testa_e_ou_i;
        begin
           if (ind_teste_contexto = 0) or
              (ind_teste_contexto > pos_f) or
              (not (palavra[ind_teste_contexto] in EI))  then
               aceito := false
           else
               ind_teste_contexto := ind_teste_contexto + 1;
        end;
        {--------------------------------------------------------}

        procedure testa_vogal_seguinte;
        begin
           if (ind_teste_contexto <> 0) and (ind_teste_contexto <= pos_f) then
              begin
                  if not (palavra[ind_teste_contexto] in vogal) then
                      aceito := false
                  else
                      ind_teste_contexto := ind_teste_contexto + 1;
              end
           else
              aceito := false;
        end;

        {--------------------------------------------------------}

        procedure testa_s;
        begin
           if ( ind_teste_contexto <= pos_f) then
              if ( palavra[ind_teste_contexto] in S) then
                 ind_teste_contexto := ind_teste_contexto + 1;
        end;

        {--------------------------------------------------------}

        procedure testa_lnmrz;
        begin
           if (ind_teste_contexto <= pos_f) then
              if not (palavra[ind_teste_contexto] in LMNRZ) then
                  aceito := false
              else
                  ind_teste_contexto := ind_teste_contexto + 1
           else
              aceito := false;
        end;

        {--------------------------------------------------------}

        procedure testa_lim_palavra;
        begin
           if (ind_teste_contexto <> 0) and
              (ind_teste_contexto <= pos_f) then
                  aceito := false;
        end;

   {--------------------------------------------------------}

   {.... corpo da rotina ....}

var
   j : integer;
begin
   with pt_aux^ do
      begin
         aceito := true;
         ind_teste_contexto := pos_i + length (contexto);
         j := 1;

         while aceito and (j <= length (contexto_a_direita)) do
            begin
               case contexto_a_direita[j] of
                  '[' : testa_fim_silaba;
                  '*' : testa_consoante_muda;
                  '+' : testa_e_ou_i;
                  '%' : testa_lim_palavra;
                  '#' : testa_vogal_seguinte ;
                  '\' : testa_s;
                  '&' : testa_lnmrz;
               else
                   if (ind_teste_contexto < pos_f + 1) and
                      (contexto_a_direita[j] = upcase (palavra[ind_teste_contexto])) then
                          ind_teste_contexto := ind_teste_contexto + 1
                   else
                       aceito := false;
               end;

               j := j + 1;
            end;

         contexto_a_direita_satisfaz := aceito;
      end;
end;

{--------------------------------------------------------}
{       verifica se contexto `a esquerda satisfaz
{--------------------------------------------------------}

function contexto_a_esquerda_satisfaz : boolean;

        {--------------------------------------------------------}

        procedure testa_lim_palavra;
        begin
           if (ind_teste_contexto <> 0) and
              (ind_teste_contexto <= pos_f) then
                  aceito := false;
        end;

        {--------------------------------------------------------}

        procedure testa_vogal_antes;
        begin
           if (ind_teste_contexto <> 0) and (ind_teste_contexto <= pos_f) then
              begin
                  if not (palavra[ind_teste_contexto] in vogal) then
                     aceito := false
                  else
                     ind_teste_contexto := ind_teste_contexto - 1;
              end
           else
              aceito := false;
        end;

        {--------------------------------------------------------}

        procedure testa_a_ou_o;
        begin
           if (ind_teste_contexto = 0) or
              (ind_teste_contexto > pos_f) or
              (not (palavra[ind_teste_contexto] in AO))  then
               aceito := false
           else
               ind_teste_contexto := ind_teste_contexto + 1;
        end;

        {--------------------------------------------------------}

        procedure testa_vogal_ou_inic_palavra;
        begin
           if not (ind_teste_contexto = 0) then
              if (palavra[ind_teste_contexto] in vogal) then
                 ind_teste_contexto := ind_teste_contexto - 1
              else
                  aceito := false;
        end;

        {--------------------------------------------------------}

        procedure testa_antecessor_l;
        begin
           if ( ind_teste_contexto <> 0) and
              ( palavra[ind_teste_contexto] in NRS) then
              ind_teste_contexto := ind_teste_contexto - 1
           else
              aceito := false;
        end;

var
   j : integer;
begin
   with pt_aux^ do
      begin
         aceito := true;
         ind_teste_contexto := pos_i - 1;
         j := length (contexto_a_esquerda);

         while (aceito) and (j > 0) do
            begin
               case contexto_a_esquerda[j] of
                  '%' : testa_lim_palavra;
                  '#' : testa_vogal_antes;
                  ']' : testa_a_ou_o;
                  '_' : testa_vogal_ou_inic_palavra;
                  '|' : testa_antecessor_l;

                  else if (ind_teste_contexto <> 0) and
                          (contexto_a_esquerda[j] = upcase (palavra[ind_teste_contexto])) then
                          ind_teste_contexto := ind_teste_contexto - 1

                       else
                          aceito := false;
               end;

               j := j - 1;
            end;

         contexto_a_esquerda_satisfaz := aceito
      end;
end;

{--------------------------------------------------------}
{                verifica se contexto satisfaz
{--------------------------------------------------------}

function contexto_satisfaz: boolean;
var
   j : integer;                        { Variavel auxiliar }

begin
   with pt_aux^ do
      begin
          aceito := true;
          j := 1;

          while (aceito) and (j <= length (contexto)) do
              begin
                  if ((pos_i + j - 1) > pos_f) or
                     (contexto[j] <> upcase (palavra[pos_i + j - 1])) then
                          aceito := false
                 else
                          j := j + 1;
               end;

          contexto_satisfaz := aceito;
      end;
end;

{--------------------------------------------------------}
{                    traduz uma palavra
{--------------------------------------------------------}

// ..... corpo da procedure traduz
var
   j : integer;                        { Variavel auxiliar }
   seq_fonemas : string[11];           { Var. p/ onde sao lidos os fonemas                                         existentes na regra selecionada   }
   ind_regra: char;

begin
   pos_i := 1;
   pos_f := length (palavra);

   while pos_i <= pos_f do
      begin
         ind_regra := palavra[pos_i];
         satisfeito := false;

         if ind_regra in [' '..#255] then
             pt_aux := regras[ind_regra]
         else
             pt_aux := NIL;

         while (not satisfeito) and (pt_aux <> nil) do

            if contexto_satisfaz and
               contexto_a_esquerda_satisfaz and
               contexto_a_direita_satisfaz then

               satisfeito := true

            else
               pt_aux := pt_aux^.prox;

         if pt_aux <> NIL then
             begin
                 seq_fonemas := pt_aux^.fonemas;
                 for j := 1 to length (seq_fonemas) do
                     begin
                         if pos_i >= tonica then
                             begin
                                 fonemas := fonemas + '>';
                                 tonica := 255;
                             end;

                     //  if seq_fonemas[j] <> '¨' then
                             if seq_fonemas[j] = '&' then
                                 fonemas := fonemas + ' 100' + CRLF
                             else
                                 fonemas := fonemas + seq_fonemas[j];
                     end;

                 if seq_fonemas <> '' then
                     fonemas := fonemas + ' 100' + CRLF;
             end;

         if pt_aux <> NIL then
             pos_i := pos_i + length (pt_aux^.contexto)
         else
             pos_i := pos_i + 1;
      end;

   fonemas := fonemas + CRLF;
end;

{--------------------------------------------------------}

function geraSoletragem (c: char): string;
var palavra, fonemas: string;
begin
    palavra := soletragem(c);
    compilaFonemas (palavra, fonemas);
    result := fonemas;
end;

{--------------------------------------------------------}

function isola_prox_palavra (texto: string; var posTexto, ncarac: integer): boolean;
var
    pletra: integer;

begin
    while (posTexto <= length (texto)) and (texto[posTexto] = ' ') do
        posTexto := posTexto + 1;
    if posTexto > length (texto) then
        begin
            ncarac := 0;
            result := false;
            exit;
        end;

    if not (texto [posTexto] in alfabeto) then
        begin
            ncarac := 1;
            result := true;
            exit;
        end;

    pletra := posTexto;
    while (pletra <= length (texto)) and (texto[pletra] in alfabeto) do
        inc (pletra);

    ncarac := pletra - posTexto;
    result := true;
    exit;
end;

{--------------------------------------------------------}

procedure trataPontuacao (c: char; var fonemas: string);
begin
    if c = ',' then
        fonemas := fonemas + '_ 100' + CRLF
    else
    if c = ':' then
        fonemas := fonemas + '_ 250' + CRLF
    else
    if c = ';' then
        fonemas := fonemas + '_ 150' + CRLF
    else
    if c = '.' then
        fonemas := fonemas + '_ 200' + CRLF;
end;

{--------------------------------------------------------}

procedure removeUltimoFonema (var fonemas: string);
var n, i: integer;
begin
    i := length (fonemas);

    for n := 1 to 2 do
        begin
            if i = 0 then exit;
            repeat
                delete (fonemas, i, 1);
                 i := i - 1;
            until (i = 0) or (fonemas [i] = #$0a);
        end;

    fonemas := fonemas + CRLF;
end;

{--------------------------------------------------------}

procedure trataIncompatibilidades (ultPalavra, palavra: string; var fonemas: string);
var c1, c2: char;
begin
    // melhorar esta rotina

    if (ultPalavra = '') or (palavra = '') then exit;
    c1 := ultPalavra [length(ultPalavra)];
    c2 := palavra [1];

    if (c1 = 'S') and (c2 in vogal) then
        begin
            removeUltimoFonema (fonemas);
            fonemas := fonemas + '¨z 100' + CRLF;
        end
    else
    if (c1 = 'R') and (c2 in vogal) then
        begin
            removeUltimoFonema (fonemas);
            fonemas := fonemas + '¨r 100' + CRLF;
        end;
end;

{--------------------------------------------------------}

procedure compilaFonemas (texto: string; var fonemas: string);
var
    posTexto, ncarac: integer;
    tonica: integer;
    palavra, ultPalavra: string;

begin
    fonemas := '';
    posTexto := 1;
    ultPalavra := ' ';

    texto := preProcessa (texto);

    fonemas := '_ 100' + CRLF + CRLF;
    while isola_prox_palavra (texto, posTexto, ncarac) do    // a variável palavra é global
       begin
          palavra := AnsiUpperCase(copy (texto, posTexto, ncarac));
          posTexto := posTexto + ncarac;

          trataIncompatibilidades (ultPalavra, palavra, fonemas);
          ultPalavra := palavra;

          if palavra[1] in delimitadores then
              trataPontuacao (palavra[1], fonemas)
          else
              begin
                  trata_excessoes (palavra);
                  tonica := descobreTonica (palavra);
                  if tonica = 0 then // soConsoantes
                      fonemas := fonemas + geraSoletragem (palavra[1])
                  else
                      traduz (palavra, tonica, ' ', fonemas);
              end;
       end;
end;

{--------------------------------------------------------}

procedure falaEspeciais (opcao: boolean);
begin
    traduzEspec := opcao;
end;

{--------------------------------------------------------}

function inicTradutor (nomeArqRegras, nomeArqExcessoes: string): boolean;
var ok: boolean;
begin
    n_excessoes := 0;

    ok := inicVarsTradutor(nomeArqRegras);
    if ok then
        ok := carregaExcessoes(nomeArqExcessoes);

    inicTradutor := ok;
end;

procedure fimTradutor;
begin
    libMemTradutor;
end;

end.