{--------------------------------------------------------}
{
{   Sistema Tradutor Fonetico N.R.L.
{
{   Funcao : Traduzir um texto, escrito em uma linguagem qualquer,
{            para a transcricao fonetica correspondente
{
{   Autores :
{       . Alexandre Plastino de Carvalho
{       . Sylvia de Oliveira e Cruz
{       . Veronica Lourenco de Herval Costa
{
{   Trabalho de Fim de Curso de Informatica
{   Orientador Academico: Jose' Antonio Borges
{
{   Data de criacao : Julho de 1987
{   Data de aprovacao : Dezembro de 1987
{   Adaptado para o DOSVOX em Maio de 1994 por:
{        . Jose' Antonio Borges
{
{--------------------------------------------------------}

unit MbrPort;
interface
uses sysUtils, dialogs, umbrInic, umbrExcessoes, umbrPreproc, umbrTonica;

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

var
   marcaTonica, marcaSilaba: boolean;

implementation

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

var
   pt_aux : pt_regras;  { Ponteiro auxiliar }
   pos_letra,           { Numero de caracteres da palavra a ser traduzida }
   pos_i,               { Posicao sendo traduzida }

   ind_fim_contexto : integer;
                        { indice para o caracter do fim do 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 =
        ['Á','Â','Ã','É','Ê','Ê','Í','Ó','Ô','Õ','Ú',
         'á','â','ã','é','ê','ê','í','ó','ô','õ','ú'];

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_fim_contexto > pos_letra) then
               aceito := false
           else
           if ((not (palavra[ind_fim_contexto] in consoante)) or
                (palavra[ind_fim_contexto] = 'H')) then
                     aceito := false;
        end;

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

        procedure testa_consoante_muda;
        begin
           if ind_fim_contexto > pos_letra then
                  aceito := false
           else
              if (not (palavra[ind_fim_contexto] in consoante)) or
                 (palavra[ind_fim_contexto] = 'R') or
                 (palavra[ind_fim_contexto] = 'L') then
                     aceito := false;
        end;

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

        procedure testa_e_ou_i;
        const
           EI: set of char = ['E' , 'I' , 'É' , 'Í'];

        begin
           if (ind_fim_contexto > pos_letra) or
              (not (palavra[ind_fim_contexto] in EI))  then
               aceito := false
           else
               ind_fim_contexto := ind_fim_contexto + 1;
        end;
        {--------------------------------------------------------}

        procedure testa_vogal_seguinte;
        begin
           if ind_fim_contexto <= pos_letra then
              begin
                  if not (palavra[ind_fim_contexto] in vogal) then
                      aceito := false
                  else
                      ind_fim_contexto := ind_fim_contexto + 1;
              end
           else
              aceito := false;
        end;

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

        procedure testa_s;
        begin
           if ind_fim_contexto <= pos_letra then
              if ( palavra[ind_fim_contexto] = 'S') then
                 ind_fim_contexto := ind_fim_contexto + 1;
        end;

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

        procedure testa_lnmrz;
        const
            LMNRZ: set of char = ['L','M','N','R','Z'];
        begin
           if ind_fim_contexto <= pos_letra then
              if not (palavra[ind_fim_contexto] in LMNRZ) then
                  aceito := false
              else
                  ind_fim_contexto := ind_fim_contexto + 1
           else
              aceito := false;
        end;

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

        procedure testa_lim_palavra;
        begin
           if ind_fim_contexto <= pos_letra then
                  aceito := false;
        end;

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

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

var
   j : integer;
begin
   with pt_aux^ do
      begin
         aceito := true;
         ind_fim_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_fim_contexto < pos_letra + 1) and
                      (contexto_a_direita[j] = upcase (palavra[ind_fim_contexto])) then
                          ind_fim_contexto := ind_fim_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_fim_contexto <> 0) and
              (ind_fim_contexto <= pos_letra) then
                  aceito := false;
        end;

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

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

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

        procedure testa_a_ou_o;
        const
           AO: set of char = ['A' , 'O' , 'Á' , 'Ó' , 'Â' , 'Ô'];

        begin
           if (ind_fim_contexto = 0) or
              (ind_fim_contexto > pos_letra) or
              (not (palavra[ind_fim_contexto] in AO))  then
               aceito := false
           else
               ind_fim_contexto := ind_fim_contexto + 1;
        end;

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

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

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

        procedure testa_antecessor_l;
        const
            NRS: set of char = ['N', 'R', 'S'];
        begin
           if ( ind_fim_contexto <> 0) and
              ( palavra[ind_fim_contexto] in NRS) then
              ind_fim_contexto := ind_fim_contexto - 1
           else
              aceito := false;
        end;

var
   j : integer;
begin
   with pt_aux^ do
      begin
         aceito := true;
         ind_fim_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_fim_contexto <> 0) and
                          (contexto_a_esquerda[j] = upcase (palavra[ind_fim_contexto])) then
                          ind_fim_contexto := ind_fim_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_letra) 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_letra := length (palavra);

   while pos_i <= pos_letra do
      begin
         ind_regra := palavra[pos_i];
         satisfeito := false;
         seq_fonemas := '';

         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;

                 if marcaSilaba and (pos_i = 1) and (seq_fonemas[1] <> '¨') then
                        seq_fonemas := '¨' + seq_fonemas
                 else
                 if (not marcaSilaba) and (seq_fonemas[1] = '¨') then
                     delete (seq_fonemas, 1, 1);

                 for j := 1 to length (seq_fonemas) do
                     begin
                         if pos_i = tonica then
                             begin
                                 if marcaTonica then
                                     fonemas := fonemas + '<';
                                 tonica := 999;
                             end;
                         if seq_fonemas[j] = '&' then
                             fonemas := fonemas + CRLF
                         else
                             fonemas := fonemas + seq_fonemas[j];
                     end;
             end
         else
             fonemas := fonemas + '?' + CRLF;

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

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

   fonemas := fonemas + CRLF;
   if marcaSilaba and (fonemas <> '') and (fonemas[1] <> '¨') and (fonemas[1] <> '_') then
       fonemas := '¨' + fonemas;
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 + '_' + CRLF
    else
    if c = ':' then
        fonemas := fonemas + '_' + CRLF
    else
    if c = ';' then
        fonemas := fonemas + '_' + CRLF + '_' + CRLF
    else
    if c = '.' then
        fonemas := fonemas + '_' + CRLF + '_' + CRLF;
end;

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

procedure removeUltimoFonema (var fonemas: string);
var i: integer;
begin
    i := length (fonemas);
    if i = 0 then exit;
    repeat
        delete (fonemas, i, 1);
        i := i - 1;
    until (i = 0) or (fonemas [i] = #$0a);
end;

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

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

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

    texto := preProcessa (texto);

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

           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;

           ultPalavra := palavra;
       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.