unit uttsSintese;

interface
uses Windows, Classes, Dialogs, sysutils, uttsSaida;

var
    suavizaJuncao: boolean;
    autoProsodia: boolean;
    
procedure carregaBaseDifones (base: string);
procedure falaDifones (lines: TStrings; nomeArq: string);

implementation

type
    TVETAMOSTRAS = array [0..100000] of smallInt;
    PVETAMOSTRAS = ^TVETAMOSTRAS;

var
    fala, bufAux: array [0..100000] of smallInt;
    ifala: integer;

type
    TDifo = record
        dif1, dif2: string[2]; { difones }
        nomeArqDifo, ident: string;
        iini, ifront, ifim: integer;         { posição do início, fronteira e fim }
        iiniCorte, ifimCorte: integer;       { intervalo para remoção para velocidade rápida }
        periodo: integer;                    { indica o tamanho aproximado do período }
    end;

var veloc: integer;
    ndifo: integer;
    tabDifo: array [1..2000] of TDIFO;
    nomeBase: string;

    especProxFreq: string;
    durFonema, durProxFonema: integer;
    especProsodia, EspecProxProsodia: string;

    totalAmostras: integer;
    ultProsodia: char;

function pegaPalavra (var s: string): string;
var p: string;
begin
    p := '';
    while (s <> '') and ((s[1] = ' ') or (s[1] = ^i)) do
       delete (s, 1, 1);
    while (s <> '') and ((s[1] <> ' ') and (s[1] <> ^i)) do
        begin
            p := p + s[1];
            delete (s, 1, 1);
        end;
    while (s <> '') and ((s[1] = ' ') or (s[1] = ^i)) do
       delete (s, 1, 1);
    result := p;
end;

procedure carregaBaseDifones (base: string);
var arq: textFile;
    s: string;
begin
    nomeBase := base;
    assignFile (arq, nomeBase);

    ndifo := 0;
    try
        reset (arq);
        while not eof (arq) do
             begin
                 readln (arq, s);
                 if s = '' then continue;

                 if s[1] = '!' then
                     veloc := strToInt (copy (s, 2, 9))
                 else
                     begin
                         ndifo := ndifo + 1;
                         with tabDifo [ndifo] do
                             begin
                                 dif1 := pegaPalavra (s);
                                 dif2 := pegaPalavra (s);
                                 nomeArqDifo := pegaPalavra (s);
                                 ident  := pegaPalavra (s);
                                 iini   := strToInt (pegaPalavra(s));
                                 ifront := strToInt (pegaPalavra(s));
                                 ifim   := strToInt (pegaPalavra(s));

                                 // extensões ao arquivo gerado pelo DStudio
                                 iiniCorte := 0;
                                 ifimCorte := 0;
                                 periodo   := 0;
                                 if trim (s) <> '' then
                                     begin
                                         iiniCorte := strToInt (pegaPalavra(s));
                                         ifimCorte := strToInt (pegaPalavra(s));
                                     end;
                                 if trim (s) <> '' then
                                     periodo  := strToInt (pegaPalavra(s)) - iiniCorte;
                             end;
                     end;
             end;
        closeFile (arq);
    except
        showMessage ('Base ' + nomeBase + ' não encontrada');
    end;
end;

function buscaDifone (ultdifo, difo: string): integer;
var i: integer;
begin
    for i := 1 to ndifo do   // colocar aqui uma busca binária
        if (tabDifo[i].dif1 = ultDifo) and (tabDifo[i].dif2 = difo) then
            begin
                buscaDifone := i;
                exit;
            end;

    buscaDifone := 0;
end;

procedure crossFadeJuncao (idif: integer);
type
    TVetSuaviza = array [0..199] of smallInt;
var
    p: ^TVetSuaviza;
    x: integer;
    t: real;
    bufAux: TVetSuaviza;
begin
    with tabDifo[idif] do
        begin
            if iIni < 200 then exit;

            seek (arqSom, waveHeaderSize + (iIni-200) * 2);
            blockRead (arqSom, bufaux, 200 * 2);
            p := @fala[ifala-200];
            for x := 0 to 199 do
                begin
                    t := x / 200;
                    p^[x] := trunc ((1-t) * p^[x] + t * bufaux[x]);
                end;
        end;
end;

procedure rampaFrequencia (pOrig: PVETAMOSTRAS; nOrig: integer;
                           pDest: PVETAMOSTRAS; var nDest: integer;
                           perc1, perc2: real);
var
    delta, vari: real;
    t, x, y: real;
    i, x0: integer;

begin
    delta := perc1;
    vari  := (perc2-perc1) / norig;

    x := 0;
    i := 0;
    repeat
        t := frac (x);
        x0 := trunc (x);
        y := (1-t)*porig^[x0] + t*porig^[x0 + 1];
        pDest^[i] := trunc(y);
        x := x + delta + (i*vari);
        i := i + 1;
    until x0 >= nOrig-1;

    nDest := i;
end;

procedure geraRampasFrequencia (especProsodia: string;
          nAmostrasFonema: integer; var iSaida: integer);
const
    tabPerc: array ['1'..'9'] of real = (0.90, 0.93, 0.95, 0.97, 1.0, 1.03, 1.05, 1.07, 1.10);
var
    i, ind1, ind2: integer;
    perc1, perc2: real;
    ndest: integer;
begin
    if not (especProsodia [1] in ['1'..'9']) then
        especProsodia[1] := ultProsodia;

    ind1 := 0;
    for i := 1 to length (especProsodia)-1 do
        begin
            ind2 := i * nAmostrasFonema div (length(especProsodia)-1);

            if not (especProsodia [i+1] in ['1'..'9']) then
                 especProsodia[i+1] := especProsodia[i];

            perc1 := tabPerc[especProsodia[i]];
            perc2 := tabPerc[especProsodia[i+1]];
            if (perc1 = 1.0) and (perc2 = 1.0) then
                begin
                    ndest := ind2-ind1;
                    move (fala[ind1], saida[isaida], ndest*2)
                end
            else
                rampaFrequencia (@fala[ind1], ind2-ind1,
                                 @saida[iSaida], nDest,
                                 perc1, perc2);
            iSaida := iSaida + ndest;
            ind1 := ind2;
        end;

    ultProsodia := especProsodia[length (especProsodia)];
end;

// Esta rotina abaixo foi criada para não infringir o copyright da
// France Telecom do algoritmo PSOLA, que permitiria a criação de uma rotina
// de compactação de som mais perfeita.  É portanto um método bem mais simples
// e limitado, mas perfeitamente dentro da legalidade.

// Simplificação: esse processamento só pode ser feito na segunda parte do difone
// (ou seja, referente ao fonema que se segue)

function alteraTamanho (bufAux: PVETAMOSTRAS; idif: integer;
                        duracao: integer): integer;
var
    novoTam, r, x: integer;
    ampl: integer;
    t: real;
    p, q: PVETAMOSTRAS;
begin
    if duracao < 30 then
        begin
            alteraTamanho := 0;
            exit;
        end;

    with tabDifo[idif] do
        begin
            // manutenção do som em seu tamanho original

            if ifimCorte = 0 then
                begin
                    move (bufAux^, fala[0], (ifim-ifront) * 2);
                    alteraTamanho := ifim-ifront;
                    exit;
                end;

            // compressão do som

            if duracao <= 100 then
                begin
                    move (bufAux^, fala[0], (iiniCorte-ifront) * 2);
                    move (bufAux^[ifimCorte-ifront], fala[iiniCorte-ifront],
                           (ifim-ifimCorte) * 2);
                    if suavizaJuncao then
                        begin
                            p := @fala[iiniCorte-ifront];
                            q := @bufAux[iiniCorte-ifront];
                            for x := 0 to 600-1 do
                                begin
                                    t := x / 600;
                                    p^[x] := trunc ((1-t) * q^[x] + t * p[x]);
                                end;
                        end;

                    alteraTamanho := (iiniCorte-ifront) + (ifim-ifimCorte);
                    exit;
                end;

            // expansão do som

            move (bufAux^, fala[0], (ifim-ifront) * 2);
            novoTam := ifim-ifront;
            if duracao >= 120+20 then
                begin
                    ampl := (duracao-120) div 20;
                    for r := 0 to ampl-1 do
                        begin
                            move (bufAux^[iiniCorte-ifront],
                                  fala[novoTam], (ifimCorte-iiniCorte)*2);
                            novoTam := novoTam + (ifimCorte-iiniCorte);
                        end;
                end;

            alteraTamanho := novotam;
        end;
end;

function acrescentaFala (ultDifo, difo: string;
                         tam: integer; curvaProsodia: string;
                         var iSaida: integer): integer;
var
    dir: string;
    idif: integer;
    nAmostrasFonema: integer;
    isaidaOrig: integer;

begin
    acrescentaFala := 0;
    iSaidaOrig := iSaida;

    // procura e abre o arquivo do difone

    idif := buscaDifone (ultDifo, difo);
    if idif = 0 then    // difone não achado
        begin
            difo := '_';
            idif := buscaDifone (ultDifo, difo);
            if idif = 0 then exit;
        end;

    dir := nomeBase;
    while (dir <> '') and (dir[length(dir)] <> '\') do
        delete (dir, length(dir), 1);

    assignFile (arqSom, dir+ '\' + tabDifo[idif].nomeArqDifo);
    reset (arqSom, 1);

    // usará a duração e freqüência do "próximo fonema" anterior

    durFonema := durProxFonema;
    especProsodia := EspecProxProsodia;

    with tabDifo[idif] do
        begin
            // suaviza com "cross fade" a junção com semi-difone anterior
            // usando um pedacinho do som original antes do difone

            if suavizaJuncao and (ifala >= 200) then
                crossFadeJuncao (idif);

            // traz meio difone  (que é complemento do meio difone anterior )

            seek (arqSom, waveHeaderSize + (iini * 2));
            blockRead (arqSom, fala[ifala], (ifront-iini) * 2);

            nAmostrasFonema := ifala+(ifront-iini);

            // gera a prosódia

            if length (especProsodia) = 0 then
                especProsodia := '00'   // 0 mantém penúltima freqüência
            else
            if length (especProsodia) = 1 then
                especProsodia := '0' + especProsodia[1] + especProsodia[1];

            geraRampasFrequencia (especProsodia, nAmostrasFonema, iSaida);

            // traz a segunda metade do difone e altera o tamanho

            blockRead (arqSom, bufAux, (ifim-ifront) * 2);
            closefile (arqSom);

            ifala := alteraTamanho (@bufAux, idif, tam);
        end;

    durProxFonema := tam;
    especProxProsodia := trim (curvaProsodia);

    acrescentaFala := iSaida - iSaidaOrig;
end;

procedure falaDifones (lines: TStrings; nomeArq: string);
var i: integer;
    lido, difo, ultdifo: string;
    tam: integer;
    curvaProsodia: string;
    ger: integer;
    codAutoProsodia: char;

begin
    ultdifo := '_';
    durProxFonema := 0;
    EspecProxFreq := '';
    totalAmostras := 0;
    ultProsodia := '5';

    ifala := 0;
    inicSaida;

    for i := 0 to lines.count-1 do
        begin
            lido := lines[i];
            if (lido = '') or (lido[1] = ';') then continue;

            difo := pegaPalavra (lido);
            if ultdifo = '_' then ultProsodia := '5';

            codAutoProsodia := ' ';
            if autoProsodia and (difo <> '') then
                if (difo[1] in ['>','.', ',', ';', ':', '?', '!', '(', ')']) then // marca de tônica
                    begin
                         codAutoProsodia := difo[1];
                         delete (difo, 1, 1);
                    end;

            if (difo <> '') and (difo[1] = '¨') then   // marca de sílaba
                 delete (difo, 1, 1);

            if trim (lido) <> '' then
                tam := strToInt (pegaPalavra (lido))
            else
                tam := 100;

            curvaProsodia := trim (lido);
            if autoProsodia and (codAutoProsodia <> ' ') and
               (curvaProsodia = '') and (tam = 100) then
                begin
                     if (difo <> 'y') and (difo <> 'w') then tam := 120;
                     case codAutoProsodia of
                         '>': curvaProsodia := '5575';
                         ',': curvaProsodia := '577';
                         '.': curvaProsodia := '533';
                         ':': curvaProsodia := '56';
                         ';': curvaProsodia := '54';
                         '?': curvaProsodia := '5597';
                         '!': curvaProsodia := '564';
                         '(': curvaProsodia := '574';
                         ')': curvaProsodia := '75';
                     end;
                end;

            ger := acrescentaFala (ultDifo, difo, tam, curvaProsodia, iSaida);
            totalAmostras := totalAmostras + ger;
            ultDifo := difo;
        end;

    if ultDifo <> '' then
        totalAmostras := totalAmostras +
             acrescentaFala (ultDifo, '_', 100, '', iSaida);

    produzSaida (nomeArq, totalAmostras);
end;

end.