{--------------------------------------------------------}
{
{   Sistema de Sintese da Fala
{
{   Funcao : A partir do texto compilado pelo modulo
{            traduvox, falar o texto
{
{   Autor  :  Jose' Antonio Borges
{   Data de criacao : Junho de 1994
{
{   Alterado por : Kelly Christine Correa
{   Data de Alteracao : outubro de 1994
{
{   Transcrito para Windows por Jose' Antonio Borges
{   Data de Alteracao: janeiro de 1998
{
{--------------------------------------------------------}

unit dvinter;
interface
uses mmsystem, winprocs, wintypes, strings, dvtradut, dvcrt;

function tradInic: integer;
procedure tradFim;

procedure falaFonemas (fonemas: string; comPontuacao: boolean);
procedure paramFala (quanto, minimo, interv: integer; corta, acelera: boolean);

var dirLetras, dirDifones: string [80];
var sintBDSom: string [8];

implementation

{--------------------------------------------------------}
{           modulo de interpretacao da fala
{--------------------------------------------------------}

const
    VOGAIS: set of char = ['a','e','i','o','u','w','y',
                           'A','E','I','O','U'];

    VOGAIS_MESMO: set of char = ['a','e','i','o','u',
                                'A','E','I','O','U'];

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

    SEMIVOGAIS: set of char = ['y','w'];

    ACENTOS: set of char = ['~', '^'];

type
    VETBYTE = array [0..65534] of byte;
    PBYTE = ^VETBYTE;

    INFODIFONE = record
        nomedifo: string[8];
        tamdifo: word;
        posdifo: longint;
    end;

    TABDIFONES = array [0..2000] of INFODIFONE;

    stringPeq = string[40];
    stringuinha = string[12];

var
    tabDifo: ^TABDIFONES;
    tamTabDifo: integer;

    arqDifones: file;
    nomarqDifones: string[80];

    pf: integer;
    silabaForte: integer;
    difone: boolean;
    Pant : PBYTE;
    TamArqAnt: word;

    intervalo: integer;
    intPonto, intVirgula, intPtVirgula, intDoisPontos: integer;
    quantoCorta, minimoResto: integer;

    tamFalaFinal: longint;
    cortando, acelerando: boolean;

    hsom1, hsom2: THandle;
    pvetSom, pvetSom1, pvetSom2: PBYTE;

{--------------------------------------------------------}
{             gera cabecalho do formato WAV
{--------------------------------------------------------}

const
    TAMCABWAV = 44;

    cabWav: array [0..TAMCABWAV-1] of byte = (
        $52, $49, $46, $46, $ff, $ff, $ff, $ff, $57, $41, $56, $45, $66, $6d, $74, $20,
        $10, $00, $00, $00, $01, $00, $01, $00, $11, $2b, $00, $00, $11, $2b, $00, $00,
        $01, $00, $08, $00, $64, $61, $74, $61, $ff, $ff, $ff, $ff);

procedure geraCabWav (tamSom: longint);
var l: longint;
begin
    l := tamSom;
    move (l, cabWav[40], 4);
    l := l + 36;
    move (l, cabWav[4], 4);

    if acelerando then
       l := 17000
    else
       l := 11025;
    move (l, cabWav[24], 4);
    move (l, cabWav[28], 4);

    move (cabWav, pvetSom^, 44);
end;

{--------------------------------------------------------}
{             inicializa arquivo de fala
{--------------------------------------------------------}

procedure inicArqFala;
begin
    tamFalaFinal := 0;
    geraCabWav (0);
end;

{-------------------------------------------------------------}
{              descarrega fala até ali
{-------------------------------------------------------------}

procedure descarregaFala;
begin
    geraCabWav (tamFalaFinal);

    repeat until keypressed or sndplaysound (NIL, snd_async+snd_nostop);
        { não remova o keypressed }
    sndPlaySound (pchar (pVetSom), SND_MEMORY+SND_ASYNC);
    if pvetSom = pvetSom1 then
        pvetSom := pvetSom2
    else
        pvetSom := pvetSom1;

    inicArqFala;
end;

{-------------------------------------------------------------}
{              checa se cabe no buffer de fala
{-------------------------------------------------------------}

procedure checaTamFala (tam: integer);
begin
    if tamFalaFinal+TAMCABWAV+tam >= sizeof (VETBYTE) then
         descarregaFala;
end;

{--------------------------------------------------------}
{                     trata silencio
{--------------------------------------------------------}

Procedure silencio (espaco: integer);
var i: integer;
    som: array [0..99] of byte;
begin
    fillchar (som, 100, $80);
    for i := 1 to espaco div 100 do
        begin
            checaTamFala (100);
            move (som, pvetSom^[TAMCABWAV+tamFalaFinal], 100);
            tamFalaFinal := tamFalaFinal + 100;
        end;
end;

{--------------------------------------------------------}
{           carrega o buffer de fala do arquivo
{--------------------------------------------------------}

procedure falaRuido;
const
    TAMRUIDO = 300;
var
    i: integer;
    som: array [0..TAMRUIDO-1] of byte;

begin
    checaTamFala (TAMRUIDO);
    for i := 0 to TAMRUIDO-1 do
        som[i] := $80 + random(80) - 40;
    move (som, pvetSom^[TAMCABWAV+tamFalaFinal], TAMRUIDO);
    tamFalaFinal := tamFalaFinal + TAMRUIDO;
end;

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

function falaLetra (nomearq: stringuinha): boolean;
var arq: file;
    tamArq: word;
    Pmem: PBYTE;
    result: integer;

begin
    falaLetra := false;

    assign (arq, dirLetras + nomearq+'.wav');
    {$i-} reset (arq, 1);  {$i+}
    result := ioresult;

    if result = 0 then
        begin
            seek (arq, 0);
            TamArq := filesize(arq) - 44;
            getmem (PMem, TamArq);

            seek (arq, 44);
            blockread (arq, Pmem^, TamArq) ;

            checaTamFala (TamArq);
            move (pmem^, pvetSom^[TAMCABWAV+tamFalaFinal], TamArq);
            tamFalaFinal := tamFalaFinal + tamArq;
            close (arq);

            freemem (PMem, TamArq);
            falaLetra := true;
        end;
end;

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

function compactaFala (Pmem: PBYTE; tamArq: integer): integer;
{ retorna o numero de bytes apos compactacao }
var
    i: integer;
    origem, destino, posmax, tam: integer;
    maximo: byte;

begin
    maximo := 0;                          { acha primeiro ponto de maximo }
    for i := 200 to 200+130 do
        if pmem^[i] > maximo then
            begin
                maximo := pmem^[i];
                posmax := i;
            end;

    origem := posmax;                     { ali comecara a compactacao }
    destino := origem;

    while origem < tamArq - 2*(80+50) do
        begin
             maximo := 0;              { acha proximo ponto de maximo }
             origem := origem + 80;
             for i := origem to origem + 50 do
                if pmem^[i] > maximo then
                    begin
                        maximo := pmem^[i];
                        posmax := i;
                    end;

             origem := posmax;             { ali comecara a compactacao }
             maximo := 0;
             for i := origem+80 to origem+80+50 do
                if pmem^[i] > maximo then
                    begin
                        maximo := pmem^[i];
                        posmax := i;
                    end;

             tam := posmax-origem+1;
             move (pmem^[origem], pmem^[destino], tam);
             origem := posmax;
             destino := destino + tam;
        end;

    while abs (pmem^[destino] - 128) > 20 do
        begin
            pmem^[destino] := pmem^[origem];
            destino := destino + 1;
            origem := origem + 1;
        end;

    compactaFala := destino;
end;

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

function falaDifone (nomearq: stringuinha; silabaForte: integer;
                     perc: real): boolean;
var
    inicio, fim, indTab: integer;
    tamArq, tamCortado, i, j: integer;
    posArq: longint;
    Pmem: PBYTE;
    p: ^byte;

label achou;

begin
    for i := 1 to length (nomearq) do
         nomearq[i] := upcase (nomearq[i]);

    falaDifone := true;
    inicio := 0;
    fim := tamTabDifo;

    while (inicio <= fim) do
        begin
            indTab := (inicio + fim) div 2;

            with tabDifo^[indTab] do
                begin
                    if nomeDifo = nomearq then
                        goto achou;
                    if nomearq > nomeDifo then
                        inicio := indTab+1
                    else
                        fim := indTab-1;
                end;
        end;

    falaDifone := false;
    exit;

achou:
    with tabDifo^[indTab] do
        begin
            posArq := posDifo;
            TamArq := tamDifo;

            if (silabaForte < 2) and (length (nomearq) > 2) then
                begin
                    tamArq := tamDifo - quantocorta;
                    if (tamArq < minimoResto) then
                        if tamDifo < minimoResto then
                            tamArq := tamDifo
                        else
                            TamArq := minimoResto;

                end;

            if maxAvail < tamArq then
                begin
                    falaDifone := false;
                    exit;
                end;

            seek (arqDifones, posArq);
            tamArq := trunc (tamArq * perc);

            getmem (pmem, TamArq);
            blockread (arqDifones, Pmem^, TamArq);
            if not cortando then
                begin
                    checaTamFala (TamArq);
                    move (pmem^, pvetSom^[TAMCABWAV+tamFalaFinal], TamArq);
                    tamFalaFinal := tamFalaFinal + TamArq;
                end
            else
                begin
                    tamCortado := compactaFala (pmem, tamArq);
                    checaTamFala (TamCortado);
                    move (pmem^, pvetSom^[TAMCABWAV+tamFalaFinal], TamCortado);
                    tamFalaFinal := tamFalaFinal + tamCortado;
                end;

            freemem (pmem, TamArq);
        end;
end;

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

Procedure CarregaBufFala (nomearq: stringuinha;
                          Perc: real; silabaForte: integer);
var
    leu: boolean;
    vogal: char;

begin
    if nomearq [1] = '_' then
        leu := falaLetra (nomearq)
    else
        leu := falaDifone (nomearq, silabaForte, perc);

    if (not leu) and (length (nomearq) <= 2) then
        begin
            falaRuido;     { nao houve jeito de sintetizar }
            exit;
        end;

    if not leu then   { se nao existe difone, sintetiza mais ou menos }
        begin
            if nomearq [length (nomearq)] in VOGAIS then
                 begin
                     carregaBufFala (copy (nomearq, 1, length(nomearq)-1),
                                                    Perc*0.9, silabaForte);
                     carregaBufFala ('$'+nomearq[length(nomearq)],
                                                    Perc, silabaForte);
                     exit;
                 end;

            if (copy (nomearq, length (nomearq)-3, 4) = 'CIRC') and
                     (length (nomearq) > 6) then
                begin
                    CarregaBufFala (copy (nomearq, 1, length (nomearq)-5),
                                                   perc*0.9, silabaForte);
                    carregaBufFala ('$'+ copy (nomearq,
                                   length (nomearq)-4, 5), Perc, silabaForte);
                    exit;
                end;

            if copy (nomearq, length (nomearq)-2, 3) = 'TIL' then
                begin
                    nomearq := copy (nomearq, 1, length(nomearq)-3);
                    vogal := upcase (nomearq [length (nomearq)]);
                    if (vogal = 'I') or (vogal = 'U') then
                        carregaBufFala (nomearq, Perc*0.9, silabaForte)
                    else
                        carregaBufFala (nomearq+'CIRC', Perc*0.9, 2);

                    carregaBufFala ('$nn', 0.9, 1);
                    exit;
                end;
       end;
end;

{--------------------------------------------------------}
{         seleciona arquivos para carga na memoria
{--------------------------------------------------------}

const
    MAIUSCULAS: set of char = ['A','E','I','O','U'];

Procedure CarregaFala (s: stringuinha; Perc: real);
var
    i: integer;
    nomearq: stringuinha;
    tonica: boolean;
begin
    tonica := false;

    nomearq := '$';
    if s[1] = '_' then
        begin
            str (ord(s[2]), nomearq);
            nomearq := '_' + nomearq;
        end
    else
        for i := 1 to length (s) do
            begin
                if (s[i] in MAIUSCULAS) then
                    begin
                        tonica := true;
                        silabaForte := 2;   { para garantir dois acentos }
                    end;

                case s[i] of
                    '^' :  begin
                             carregaBufFala (nomearq+'CIRC', Perc, silabaForte);
                             nomearq := '$';
                           end;

                    '~' :  begin
                             carregaBufFala (nomearq+'TIL', Perc,silabaForte);
                             nomearq := '$';
                           end;
                else
                    nomearq := nomearq + s[i];
                end;

    end;

    if nomearq <> '$' then
        carregaBufFala (nomearq, Perc, silabaForte);

    if tonica then
        silabaForte := 0;
end;

{--------------------------------------------------------}
{    traduz do fonema compilado para nome de arquivos
{--------------------------------------------------------}

procedure traduzSilaba (s: stringPeq; Perc: real);
begin
    if (length (s) = 0) then exit;

    if length (s) = 1 then
        begin
            carregaFala (s, Perc);
            exit;
        end;

    if length (s) > 2 then
        begin
            if (s[1] in CONSOANTES) and (s[2] in CONSOANTES) then
                begin
                    if (copy (s, 1, 2) <> 'dj') and
                       (copy (s, 1, 2) <> 'nh') and
                       (copy (s, 1, 2) <> 'rr') and
                       (copy (s, 1, 2) <> 'ks') and
                       (copy (s, 1, 3) <> 'tch') then
                       begin
                           carregaFala (s[1], 1.0);
                           traduzSilaba (copy (s, 2, length(s)-1),Perc);
                           exit;
                       end;
                end;

            if copy (s, length(s)-1, 2) = 'rr' then
                begin
                    traduzSilaba (copy (s, 1, length(s)-2),Perc);
                    carregaFala ('rr',Perc);
                    exit;
                end;

            if s[length(s)] in CONSOANTES then
                begin
                    traduzSilaba (copy (s, 1, length(s)-1),Perc);
                    traduzSilaba (s[length(s)],Perc);
                    exit;
                end;
        end;

    if s[length(s)] in SEMIVOGAIS then
        begin
            if s[length(s)-1] in VOGAIS then
                begin
                    if length (s) > 2 then
                        begin
                            traduzSilaba (copy (s, 1, length(s)-1), 0.4);
                            CarregaFala (copy (s, length(s)-1, 2), Perc);
                            exit;
                        end;
                end;

            if s[length(s)-1] in ACENTOS then
                if length (s) > 3 then
                    begin
                        if s [length(s)-1] = '~' then
                            traduzSilaba (copy (s, 1, length(s)-2)+'^', 0.4)
                        else
                            traduzSilaba (copy (s, 1, length(s)-1), 0.4);
                        carregaFala (s[length(s)-2]+s[length(s)]
                                     +s[length(s)-1],Perc);
                        exit;
                    end
                else
                    begin
                        carregaFala (s[1]+s[3]+s[2],Perc);
                        exit;
                    end;

        end;

    if (s <> '_s') and (s[length(s)] = 's') then
        begin
            traduzSilaba (copy (s, 1, length(s)-1), 0.5);
            carregaFala ('s',Perc);
            exit;
        end;

    CarregaFala (s, Perc);
end;

{--------------------------------------------------------}
{                   rotina geral de fala
{--------------------------------------------------------}

procedure falaFonemas (fonemas: string; comPontuacao: boolean);

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

    function isolaSilaba: stringPeq;
    var s: stringPeq;
        pequeno: boolean;
    begin
        if fonemas [pf] = '[' then
            begin
                silabaForte := 1;
                pf := pf + 1;
            end;

        s := '';
        pequeno := true;
        while (pf < 254) and (not (fonemas [pf] in [ ']', ' '])) and pequeno do
            begin
                case fonemas [pf] of
                    '_':  begin
                              pf := pf + 1;
                              s := s + '_' + fonemas [pf];
                          end;

                    '|':  s := '_TRACO';

                    '/':  begin
                              pequeno := length (s) <= 8;
                              if not pequeno then pf := pf - 1;
                          end;
                else
                          s := s + fonemas [pf];
                end;

                pf := pf + 1;
            end;

        pf := pf + 1;

        if (not comPontuacao) and (s[1] = '_') and (length(s) = 2) then
                case s[2] of
                    ',':  begin
                              s := '';  silencio (intVirgula);
                          end;

                    '.':  begin
                              s := '';  silencio (intPonto);
                          end;

                    ';':  begin
                              s := '';  silencio (intPtVirgula);
                          end;

                    ':':  begin
                              s := '';  silencio (intDoisPontos);
                          end;
                end;

        isolaSilaba := s;
    end;

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

var fon: stringPeq;

begin
    inicArqFala;

    pf := 1;
    silabaForte := 1;
    Pant := nil;
    tamArqAnt := 0;

    While pf <= length (fonemas) do
        begin
            fon := isolaSilaba;
            traduzSilaba (fon, 1.0);

            if fonemas[pf-1] <> ' ' then
                 silencio (intervalo);
        end;

    descarregaFala;
end;

{--------------------------------------------------------}
{               inicializa os diretorios
{--------------------------------------------------------}

function inicFonemas: boolean;
var dir, dirDiscoLetras: string;
    porta: stringuinha;
    arqIndice: file;
    erro: integer;
    corte, sobra, interv: integer;

label fim;

begin
    tabDifo := NIL;
    inicFonemas := false;

    getdir (0, dir);

    dirLetras[0] := chr (GetPrivateProfileString ('TRADUTOR', 'dirLetras',
          'c:\dosvox\som\letras', @dirLetras[1], 80, 'DOSVOX.INI'));
    {$I-}  chdir (copy (dirLetras, 1, 2)); {$I+}
    if ioresult <> 0 then;
    getdir (0, dirDiscoLetras);

    {$I-} chdir (dirLetras); {$I+}
    if ioresult <> 0 then
        goto fim;
    if dirLetras [length (dirLetras)] <> '\' then
        dirLetras:= dirLetras + '\';

    dirDifones[0] := chr (GetPrivateProfileString ('TRADUTOR', 'DIRDIFONES',
          'c:\dosvox\som\difones', @dirDifones[1], 80, 'DOSVOX.INI'));
    {$I-} chdir (dirDifones); {$I+}
    if ioresult <> 0 then
        goto fim;
    if dirDifones [length (dirDifones)] <> '\' then
        dirDifones:= dirDifones + '\';

    assign (arqIndice, dirDifones + sintBDsom + '.IND');
    {$i-} reset (arqIndice, 1); {$i+}
    if ioresult <> 0 then goto fim;

    tamTabDifo := filesize (arqIndice) div sizeof (INFODIFONE);
    if maxAvail < filesize (arqIndice) then
        begin
            close (arqIndice);
            goto fim;
        end;

    getMem (tabdifo, filesize (arqIndice));
    blockread (arqIndice, tabdifo^, filesize (arqIndice));
    close(arqIndice);

    assign (arqDifones, dirDifones + sintBDSom + '.DIF');
    {$i-} reset (arqDifones, 1); {$i+}
    if ioresult <> 0 then goto fim;

    inicFonemas := true;

fim:
    chdir (dirDiscoLetras);
    chdir (dir);
end;

{--------------------------------------------------------}
{               corta um pouco da fala                   }
{--------------------------------------------------------}

procedure paramFala (quanto, minimo, interv: integer; corta, acelera: boolean);
begin
    quantoCorta := quanto;
    minimoResto := minimo;
    intervalo := interv;
    cortando := corta;
    acelerando := acelera;
end;

{--------------------------------------------------------}
{               fecha o arquivo de fonemas               }
{--------------------------------------------------------}

procedure tradFim;
var c: char;
begin
    if pvetSom <> NIL then
        begin
            globalUnlock (hsom1);
            globalFree (hsom1);
            globalUnlock (hsom2);
            globalFree (hsom2);
        end;
    pvetSom := NIL;

    libMemTradutor;
    {$I-} close (arqDifones); {$I+}
    if ioresult <> 0 then ;

    if tabDifo <> NIL then
        freemem (tabDifo, tamTabDifo * sizeof (INFODIFONE));
    tabDifo := NIL;
end;

{--------------------------------------------------------}
{               inicializacao do tradutor
{--------------------------------------------------------}

function tradInic: integer;
begin
    if not inicFonemas then
        begin
            tradinic := 1;
            exit;
        end;

    if not inicTradutor (dirDifones + 'regras.rgr') then
        begin
            tradinic := 2;
            exit;
        end;

    if not carregaExcessoes (dirDifones + 'portug.exc') then
        begin
            tradinic := 2;
            exit;
        end;

    tradinic := 0;

    hsom1 := globalAlloc (GMEM_MOVEABLE or GMEM_SHARE, sizeof (VETBYTE));
    hsom2 := globalAlloc (GMEM_MOVEABLE or GMEM_SHARE, sizeof (VETBYTE));
    pvetSom1 := globalLock (hsom1);
    pvetSom2 := globalLock (hsom2);
    pvetSom := pvetSom1;
end;

begin
    sintBDSom := 'DIFONES2';
    intervalo := 100;
    intPonto  := 10000;
    intVirgula := 6000;
    intPtVirgula := 8000;
    intDoisPontos  := 10000;
    paramFala (400, 0, 100, false, false);
    tabDifo := NIL;
    pvetSom := NIL;
end.
