{-------------------------------------------------------------}
{     Programa para juntar arquivos WAV
{     Autor:  Antonio Borges
{     Em 24/07/1999
{-------------------------------------------------------------}

{$M 16536,8192}
program juntawav;
uses
    dvcrt, dvwin, mmsystem;

const
    TAMBUF = 16384;
var
    dirTrab, nomeOrig, nomeDest: string;
    arqOrig, arqDest: file;

    velocOrig, velocDest: longint;
    bitsOrig, bitsDest: word;
    canaisOrig, canaisDest: word;
    tamSomOrig, tamSomDest: longint;
    cabecWav: array [0..43] of byte;
    buffer: array [0..TAMBUF-1] of byte;

{-------------------------------------------------------------}
{                 decodifica o cabecalho WAV
{-------------------------------------------------------------}

procedure getWavHdr (pvet: pchar;
      var veloc: longint; var bits, channels: word; var size: longint);

var
    lpFormat: PPCMWAVEFORMAT;

begin
    new (lpFormat);
    move (pvet[20], lpFormat^, sizeof (lpFormat^));
    with lpFormat^, lpFormat^.wf do
        begin
            veloc := nSamplesPerSec;
            bits := wBitsPerSample;
            channels := nChannels;
        end;
    move (pvet[4], size, sizeof (size));
    size := size - 36;
    dispose (lpFormat);
end;

{-------------------------------------------------------------}
{                  codifica o cabecalho WAV
{-------------------------------------------------------------}

procedure genWavHdr (pvet: pchar; veloc: longint; bits, channels: word; size: longint);
const
    wavHdr: array [0..43] of byte = (
        $52, $49, $46, $46,    {'RIFF'}
        $ff, $ff, $ff, $ff,    {riff size}
        $57, $41, $56, $45, $66, $6d, $74, $20,    {'WAVEFMT '}
        $10, $00, $00, $00,    {hdr size}
        $01, $00, $01, $00, $11, $2b, $00, $00, $11, $2b, $00, $00, $01, $00, $08, $00,  {reg}
        $64, $61, $74, $61,    {'data'}
        $ff, $ff, $ff, $ff);   {data size}

var l: longint;
    lpFormat: PPCMWAVEFORMAT;

begin
    new (lpFormat);
    with lpFormat^, lpFormat^.wf do
        begin
            wFormatTag := WAVE_FORMAT_PCM;
            nSamplesPerSec := veloc;
            wBitsPerSample := bits;
            nChannels := channels;
            nBlockAlign := (wBitsPerSample div 8) * nChannels;
            nAvgBytesPerSec := nBlockAlign * nSamplesPerSec;
        end;

    move (lpFormat^, wavHdr[20], sizeof (lpFormat^));
    l := size + 36;
    move (l, wavHdr[4], sizeof (l));
    move (size, wavHdr[40], sizeof (size));

    move (wavHdr, pvet^, sizeof (wavHdr));
    dispose (lpFormat);
end;

{-------------------------------------------------------------}
{                     normaliza o nome dado
{-------------------------------------------------------------}

procedure normalizaNome (var nomeArq: string);
begin
    if (pos ('\', nomeArq) = 0) and (pos (':', nomeArq) = 0) then
        nomeArq := dirTrab + nomeArq;
    if pos ('.', nomeArq) = 0 then
        nomeArq := nomeArq + '.WAV';
end;

{-------------------------------------------------------------}
{                    abre arquivos
{-------------------------------------------------------------}

procedure inicializa;
var
    tipo: string[4];
    c, c2: char;
label erro;
begin
    sintInic (0, '');
    sintWriteln ('Juntador de arquivos WAV');
    writeln;

    getDir (0, dirTrab);
    if dirTrab [length (dirTrab)] <> '\' then dirTrab := dirTrab + '\';

    sintWriteln ('Informe o nome do arquivo WAV de destino');
    sintReadln (nomeDest);
    if nomeDest = '' then doneWinCrt;

    normalizaNome (nomeDest);

    assign (arqDest, nomeDest);
    {$I-}  reset (arqDest);  {$I+}
    if ioresult = 0 then
        begin
            close (arqDest);
            sintWrite ('Arquivo já existia, posso apagar ? ');
            sintLeTecla (c, c2);
            writeln;
            if upcase(c) = 'S' then
                begin
                    {$I-}  erase (arqDest);  {$I+}
                    if ioresult <> 0 then
                        begin
                            sintWriteln ('Não consegui apagar, programa cancelado');
                            sintFim;
                            doneWinCrt;
                        end;
                end
            else
                begin
                    sintWriteln ('Programa cancelado');
                    sintFim;
                    doneWinCrt;
                end;
        end;

    {I-}  rewrite (arqDest, 1);  {$I+}
    if ioresult <> 0 then goto erro;

    {$I-} blockWrite (arqDest, cabecWav, sizeof (cabecWav)); {$I+}
    if ioresult <> 0 then
        begin
            {$I-} close (arqDest); {$I+}
            if ioresult <> 0 then;
            goto erro;
        end;

    velocDest := 0;
    bitsDest := 0;
    canaisDest := 0;
    tamSomDest := 0;

    exit;
erro:
    sintWriteln ('Não consegui criar arquivo, programa cancelado');
    sintFim;
    doneWinCrt;
end;

{-------------------------------------------------------------}
{                       finalizacao
{-------------------------------------------------------------}

procedure finaliza;
begin
    genWavHdr (@cabecWav, velocDest, bitsDest, canaisDest, tamSomDest);

    {I-}  close (arqDest);  {$I+}
    if ioresult <> 0 then
        sintWriteln ('Não consegui fechar o arquivo final');

    {$I-}  reset (arqDest, 1);  {$I+}
    if ioresult = 0 then
        begin
            seek (arqDest, 0);
            {$I-} blockWrite (arqDest, cabecWav, sizeof (cabecWav));  {$I+}
            if ioresult <> 0 then
               sintWriteln ('Não consegui gravar tamanho do arquivo');
        end;

    {I-}  close (arqDest);  {$I+}
    if ioresult <> 0 then
        sintWriteln ('Não consegui fechar o arquivo final');

    sintWriteln ('Fim do programa');
    sintFim;
    doneWinCrt;
end;

{-------------------------------------------------------------}
{                     processa arquivos
{-------------------------------------------------------------}

procedure processa (nomeOrig: string);
var aler: longint;
begin
    assign (arqOrig, nomeOrig);
    {$I-}  reset (arqOrig, 1);  {$I+}
    if ioresult <> 0 then
        begin
            sintWriteln ('Arquivo não encontrado');
            exit;
        end;

    blockRead (arqOrig, cabecWav, sizeof (cabecWav));
    getWavHdr (@cabecWav, velocOrig, bitsOrig, canaisOrig, tamSomOrig);

    if velocDest = 0 then
        begin
            velocDest := velocOrig;
            bitsDest := bitsOrig;
            canaisDest := canaisOrig;
            tamSomDest := tamSomOrig;
        end
    else
        begin
            if (velocDest <> velocOrig) or
               (bitsDest <> bitsOrig) or
               (canaisDest <> canaisOrig) then
                   begin
                       sintWriteln ('Arquivo incompatível com anterior');
                       close (arqOrig);
                       exit;
                   end
            else
                tamSomDest := tamSomDest + tamSomOrig;
        end;

    while tamSomOrig <> 0 do
        begin
            if tamSomOrig > TAMBUF then
                aler := TAMBUF
            else
                aler := tamSomOrig;
            tamSomOrig := tamSomOrig - aler;

            {$I-}  blockRead (arqOrig, buffer, aler); {$I+}
            if ioresult <> 0 then
                 sintWriteln ('Arquivo original danificado');

            {$I-} blockWrite (arqDest, buffer, aler); {$I+}
            if ioresult <> 0 then
                 begin
                     writeln ('Erro ao gravar arquivo, programa cancelado');
                     close (arqOrig);
                     close (arqDest);
                     sintFim;
                     doneWinCrt;
                 end;
        end;

    close (arqOrig);
    sintWriteln ('Ok');
end;

{-------------------------------------------------------------}
{                    programa principal
{-------------------------------------------------------------}

begin
    inicializa;

    repeat
        sintWriteln ('Nome do arquivo a juntar: ');
        sintReadln (nomeOrig);
        if nomeOrig <> '' then
            processa (nomeOrig);
    until nomeOrig = '';

    finaliza;
end.
