{--------------------------------------------------------}
{
{     Rotinas de fala em baixo nível
{
{     Autor: José Antonio Borges
{
{     Em 20/7/2000
{
{--------------------------------------------------------}

unit dvwav;
interface
uses winprocs, wintypes, dvcrt, mmsystem, strings;

type
    PByteArray = array [0..65534] of byte;

function waveIsPlaying: boolean;
function wavePlay (pSound: pchar; soundSize: word;
                      veloc: longint; bits, channels: word): integer;
function wavePlayFile (filename: string): integer;
procedure waveStop;

var keyStopsWave: boolean;
    queueingWaves: boolean;
    speedupWaves: boolean;
    compactWaves: boolean;

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

implementation

const
    SOUND_OK = 0;

    MAXBUF = 8;
    MAXBUFSIZE = 8192;

var
    hWavOut: HWaveOut;

    uWaveOutDeviceId: word;
    lWaveOutveloc: longint;
    nWaveOutBits, nWaveOutChannels: integer;

    f: file;

    hbuf: array [0..maxBuf-1] of THandle;
    pBuf: array [0..maxBuf-1] of pChar;
    hhdr: array [0..maxBuf-1] of THandle;
    bufSize: array [0..maxBuf-1] of word;
    lpWaveOutHdr: array [0..maxBuf-1] of PWaveHdr;
    doneWavBuf, nextWavBuf: integer;

    hdr: array [0..43] of char;

    nbufWaiting: integer;

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

function waveCompact (pmem: PVETBYTE; size: word): word;
var
    i: word;
    origem, destino, posmax, tam: word;
    maximo: byte;

begin
    waveCompact := size;
    if size < 1000 then exit;

    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 < size - 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) and (origem < size) do
        begin
            pmem^[destino] := pmem^[origem];
            destino := destino + 1;
            origem := origem + 1;
        end;

    waveCompact := destino;
end;

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

procedure handleWaveOutMsg (Window: HWnd; WParam: Word; LParam: Longint); far;
var d: integer;
begin
    d := doneWavBuf;
    doneWavBuf := (doneWavBuf + 1) mod MAXBUF;

    with lpWaveOutHdr [d]^ do
        begin
            waveOutUnPrepareHeader(hWavOut, lpWaveOutHdr [d], sizeof (TWaveHdr));

            globalUnlock (hbuf[d]);  globalFree (hbuf[d]);
            globalUnlock (hhdr[d]);  globalFree (hhdr[d]);
            lpWaveOutHdr [d] := NIL;
       end;

    nbufWaiting := nbufWaiting - 1;
end;

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

function openWaveOutDevice : word;
var
    lpFormat: PPcmWaveFormat;
    dwCallback, dwInstance, dwFlags: longint;
    status: word;
    i: integer;
begin
    if hWavOut <> 0 then    { continuação da operação anterior }
        begin
            openWaveOutDevice := 0;
            exit;
        end;

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

    dwCallBack := crtWindow;
    dwInstance := 0;
    dwFlags := CALLBACK_WINDOW or WAVE_ALLOWSYNC;

    mmCallback := handleWaveOutMsg;
    hasmmCallback := true;

    for i := 1 to 100 do
        begin
            status := waveOutOpen(@hWavOut, uWaveOutDeviceID, @lpFormat^,
                          dwCallback, dwInstance, dwFlags);
            if status <> MMSYSERR_ALLOCATED then break;
            delay (100);
        end;

    openWaveOutDevice := status;    {zero significa ok}

    dispose (lpformat);
end;

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

function queueWaveOutBuffer (p: pchar; size: word): boolean;
var b, i: integer;
    status: word;
begin
    queueWaveOutBuffer := true;

    i := 0;
    while (nbufWaiting = MAXBUF) and (i < 100) do    {evita um bloqueio perpétuo}
        begin
           i := i + 1;  delay (10);
        end;

    nbufWaiting := nbufWaiting + 1;

    b := nextWavBuf;
    nextWavBuf := (nextWavBuf + 1) mod MAXBUF;

    hbuf[b] := globalAlloc (GMEM_MOVEABLE or GMEM_SHARE, size);
    pBuf[b] := globalLock (hbuf[b]);
    move (p^, pBuf[b]^, size);

    hhdr[b] := globalAlloc (GMEM_MOVEABLE or GMEM_SHARE, sizeof (TWaveHdr));
    lpWaveOutHdr [b] := globalLock (hhdr[b]);

    fillChar (lpWaveOutHdr [b]^, sizeof (TWaveHdr), 0);
    with lpWaveOutHdr [b]^ do
        begin
            lpData := pBuf[b];       { pointer to locked data buffer }
            dwBufferLength := size;
        end;

    if waveOutPrepareHeader(hWavOut, lpWaveOutHdr [b], sizeof (TWaveHdr)) <> 0 then
        begin
            queueWaveOutBuffer := false;
            exit;
        end;

    waveOutWrite (hWavOut, lpWaveOutHdr [b], sizeof (TWaveHdr));
end;

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

function waveIsPlaying: boolean;
var teclou: boolean;
begin
    { nota: o keypressed é também necessário para ativar o loop de eventos da dvcrt }

    if (keypressed and keyStopsWave) or (nbufWaiting = 0) then
        waveStop;

    waveIsPlaying := nbufWaiting <> 0;
end;

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

procedure waveStop;
begin
    if hWavOut <> 0 then
        begin
            if nbufWaiting <> 0 then
                waveOutReset (hWavOut);
            waveOutClose (hWavOut);
        end;
    hWavOut := 0;
end;

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

function setWaveOutParams (uDeviceId: word; veloc: longint; bits, channels: integer): word;
begin
    if (uWaveOutDeviceId <> uDeviceId) or
       (lWaveOutVeloc <> veloc) or
       (nWaveOutBits <> bits) or
       (nWaveOutChannels <> channels) then
            repeat until not waveIsPlaying;

    uWaveOutDeviceId := uDeviceId;
    lWaveOutVeloc := veloc;
    nWaveOutBits := bits;
    nWaveOutChannels := channels;

    setWaveOutParams := openWaveOutDevice;
end;

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

function wavePlay (pSound: pchar; soundSize: word;
                      veloc: longint; bits, channels: word): integer;
var i, status: integer;
    size, newSize: word;
label interrompeu;
begin
    wavePlay := 0;

    if speedupWaves then
        veloc := trunc(veloc * 1.5);

    status := setWaveOutParams ($FFFF, veloc, bits, channels);   { $FFFF = Wave Mapper }
    if status <> 0 then
        begin
            wavePlay := status;  {não conseguiu abrir canal}
            exit;
        end;

    while soundSize > 0 do
        begin
            while nbufWaiting >= MAXBUF do
                begin
                    if keyStopsWave and keypressed then
                        goto interrompeu;
                    delay (10);
                end;

            if keyStopsWave and keypressed then
                goto interrompeu;

            if soundSize < maxBufSize then
                size := soundSize
            else
                size := maxBufSize;

            if compactWaves then
                newsize := waveCompact (addr (pSound^), size)
            else
                newsize := size;

            queueWaveOutBuffer (pSound, newsize);

            pSound := pSound + size;
            soundSize := soundSize - size;
        end;
    exit;

interrompeu:
    waveStop;
end;

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

function wavePlayFile (filename: string): integer;
var
    veloc: longint;
    bits, channels: word;
    buf: pchar;
    status: integer;
    soundSize: longint;
    size: longint;
    transf: word;
    lpFormat: PPCMWAVEFORMAT;
    f: file;
    achou: boolean;
label fim;
begin
    wavePlayFile := -1;

    assign (f, filename);
    {$I-} reset (f, 1);  {$I+}
    if ioresult <> 0 then exit;

    getmem (buf, MAXBUFSIZE);
    {$I-}  blockread (f, buf^, 12, transf);   {$I+}    { checa cabeçalho RIFF }
    if (ioresult <> 0) or (transf < 12) then goto fim;
    if strlicomp (buf, pchar('RIFF'), 4) <> 0 then goto fim;

    {$I-}  blockread (f, buf^, 8, transf);   {$I+}     { checa fmt }
    if (ioresult <> 0) or (transf < 8) then goto fim;
    if strlicomp (buf, 'fmt ', 4) <> 0 then goto fim;

    move (buf[4], size, 4);
    {$I-}  blockread (f, buf^, size, transf);   {$I+}     { checa fmt }
    if (ioresult <> 0) or (size <> transf) then goto fim;

    lpFormat := @buf[0];
    with lpFormat^, lpFormat^.wf do
        begin
            veloc := nSamplesPerSec;
            bits := wBitsPerSample;
            channels := nChannels;
        end;

    repeat
        {$I-}  blockread (f, buf^, 8, transf);   {$I+}     { ignora chunks até data }
        if (ioresult <> 0) or (transf < 8) then goto fim;
        achou := strlicomp (buf, 'data', 4) = 0;
        move (buf[4], size, 4);
        if not achou then
            begin
               {$I-}  blockread (f, buf^, size, transf);   {$I+}     { checa fmt }
               if (ioresult <> 0) or (size <> transf) then goto fim;
            end;
    until achou;

    soundSize := size;

    status := 0;
    while (soundSize > 0) and (not eof (f)) do
        begin
            status := -1;
            size := MAXBUFSIZE;
            if size > soundSize then size := soundSize;
            {$I-}  blockread (f, buf^, size, transf);   {$I+}
            soundSize := soundSize - size;

            if transf = 0 then break;
            status := wavePlay (buf, transf, veloc, bits, channels);
            if status <> 0 then break;
        end;

fim:
    freemem (buf, MAXBUFSIZE);
    close (f);
    wavePlayFile := status;

    if not queueingWaves then        { para melhorar performance pode-se não esperar }
         while waveIsPlaying do;
end;

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

begin
    keyStopsWave := true;
    queueingWaves := false;
    speedupWaves := false;
    compactWaves := false;

    doneWavBuf := 0;
    nextWavBuf := 0;
    hWavOut := 0;
    nbufWaiting := 0;
end.
