snd_win.pas

delphi编的不错的贪吃蛇

{----------------------------------------------------------------------------}
{                                                                            }
{ File(s): snd_win.c                                                         }
{ Content:  Quake2\win32\ sound & sound FX routines                          }
{                                                                            }
{ Initial conversion by : Massimo Soricetti ([e-mail])               }
{ Initial conversion on : 09-Jan-2002                                        }
{                                                                            }
{ This File contains part of convertion of Quake2 source to ObjectPascal.    }
{ More information about this project can be found at:                       }
{ http://www.sulaco.co.za/quake2/                                            }
{                                                                            }
{ Copyright (C) 1997-2001 Id Software, Inc.                                  }
{                                                                            }
{ This program is free software; you can redistribute it and/or              }
{ modify it under the terms of the GNU General Public License                }
{ as published by the Free Software Foundation; either version 2             }
{ of the License, or (at your option) any later version.                     }
{                                                                            }
{ This program is distributed in the hope that it will be useful,            }
{ but WITHOUT ANY WARRANTY; without even the implied warranty of             }
{ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                       }
{                                                                            }
{ See the GNU General Public License for more details.                       }
{                                                                            }
{----------------------------------------------------------------------------}
{ Updated on : 03-jun-2002                                                   }
{ Updated by : Juha Hartikainen                                              }
{ - Added needed units to uses clause                                        }
{ - Fixed some language errors                                               }
{                                                                            }
{ Updated on : 04-jun-2002                                                   }
{ Updated by : Juha Hartikainen                                              }
{ - Moved some functions to interface                                        }
{                                                                            }
{ Updated on : 05-jul-2002                                                   }
{ Updated by : Sly                                                           }
{ - Added some stub functions because the sound code tends to crash          }
{                                                                            }
{ Updated on : 05-jul-2002                                                   }
{ Updated by : Sly                                                           }
{ - Removed stub functions.  Seems to be not crashing.                       }
{                                                                            }
{----------------------------------------------------------------------------}
{ * Still dependent (to compile correctly) on:                               }
{ none                                                                       }
{----------------------------------------------------------------------------}
{ * TODO:                                                                    }
{ none                                                                       }
{----------------------------------------------------------------------------}

unit snd_win;

interface

uses
  Windows,
  MMsystem,
  q_shared,
  snd_loc,
  client,
  DirectSound;

// 64K is > 1 second at 16-bit, 22050 Hz

function SNDDMA_Init(): boolean;
function SNDDMA_GetDMAPos(): integer;
procedure SNDDMA_BeginPainting();
procedure SNDDMA_Submit();
procedure SNDDMA_Shutdown();

procedure S_Activate(active: qboolean);
procedure FreeSound();

const
  WAV_BUFFERS = 64;
  WAV_MASK = $3F;
  WAV_BUFFER_SIZE = $0400;
  SECONDARY_BUFFER_SIZE = $10000;

type
  sndinitstat = (SIS_SUCCESS, SIS_FAILURE, SIS_NOTAVAIL);

  TWaveHDRArray = array[0..WAV_BUFFERS - 1] of WAVEHDR;

var

  { * Global variables. Must be visible to window-procedure function
    *  so it can unlock and free the data block after it has been played. }

  hData: THANDLE;
  lpData, lpData2: Pointer;
  hWaveHdr: HGLOBAL;                    // GlobalAlloc handle
  lpWaveHdr: ^TWaveHDRArray;
  hWaveOut_: HWAVEOUT;
  wavecaps: WAVEOUTCAPS;
  gSndBufSize: DWORD;

  mmstarttime: MMTIME;

  pDS: IDIRECTSOUND;
  pDSBuf, pDSPBuf: IDIRECTSOUNDBUFFER;

  //  hInstDS: DWORD;

implementation

uses
  Cmd,
  CVar,
  Common,
  vid_dll,
  snd_dma;

var
  s_wavonly: cvar_p;

  dsound_init,
    wav_init: qboolean;
  snd_firsttime: qboolean = true;
  snd_isdirect, snd_iswave,
    primary_format_set: qboolean;

  // starts at 0 for disabled
  snd_buffer_count: integer = 0;
  sample16,
    snd_sent, snd_completed: integer;

function DSoundError(error: integer): Pchar;
begin
  case error of
    DSERR_BUFFERLOST: Result := 'DSERR_BUFFERLOST';
    DSERR_INVALIDCALL: Result := 'DSERR_INVALIDCALLS';
    DSERR_INVALIDPARAM: Result := 'DSERR_INVALIDPARAM';
    DSERR_PRIOLEVELNEEDED: Result := 'DSERR_PRIOLEVELNEEDED';
  else
    Result := 'unknown';
  end;
end;

{
** DS_CreateBuffers
}

function DS_CreateBuffers(): qboolean;
var
  dsbuf: TDSBUFFERDESC;
  dsbcaps: TDSBCAPS;
  pformat, format: TWAVEFORMATEX;
  dwWrite: DWORD;
begin
  FillChar(format, sizeof(format), 0);
  format.wFormatTag := WAVE_FORMAT_PCM;
  format.nChannels := dma.channels;
  format.wBitsPerSample := dma.samplebits;
  format.nSamplesPerSec := dma.speed;
  format.nBlockAlign := format.nChannels * format.wBitsPerSample div 8;
  format.cbSize := 0;
  format.nAvgBytesPerSec := format.nSamplesPerSec * format.nBlockAlign;

  Com_Printf('Creating DS buffers'#10, []);

  Com_DPrintf('...setting EXCLUSIVE coop level: ', []);
  if DS_OK <> pDS.SetCooperativeLevel(cl_hwnd, DSSCL_EXCLUSIVE) then
  begin
    Com_Printf('failed'#10, []);
    FreeSound();
    Result := false;
    Exit;
  end;
  Com_DPrintf('ok'#10, []);

  // get access to the primary buffer, if possible, so we can set the
  // sound hardware format
  FillChar(dsbuf, sizeof(dsbuf), 0);
  dsbuf.dwSize := sizeof(TDSBUFFERDESC);
  dsbuf.dwFlags := DSBCAPS_PRIMARYBUFFER;
  dsbuf.dwBufferBytes := 0;
  dsbuf.lpwfxFormat := nil;

  FillChar(dsbcaps, sizeof(dsbcaps), 0);
  dsbcaps.dwSize := sizeof(dsbcaps);
  primary_format_set := false;

  Com_DPrintf('...creating primary buffer: ', []);
  if DS_OK = pDS.CreateSoundBuffer(dsbuf, pDSPBuf, nil) then
  begin
    pformat := format;

    Com_DPrintf('ok'#10, []);
    if (DS_OK <> pDSPBuf.SetFormat(@pformat)) then
    begin
      if snd_firsttime then
        Com_DPrintf('...setting primary sound format: failed'#10, []);
    end
    else
    begin
      if snd_firsttime then
        Com_DPrintf('...setting primary sound format: ok'#10, []);
      primary_format_set := true;
    end;
  end
  else
    Com_Printf('failed'#10, []);

  if (not primary_format_set) or (s_primary^.value = 0) then
  begin
    // create the secondary buffer we'll actually work with
    FillChar(dsbuf, sizeof(dsbuf), 0);
    dsbuf.dwSize := sizeof(TDSBUFFERDESC);
    dsbuf.dwFlags := DSBCAPS_CTRLFREQUENCY and DSBCAPS_LOCSOFTWARE;
    dsbuf.dwBufferBytes := SECONDARY_BUFFER_SIZE;
    dsbuf.lpwfxFormat := @format;

    FillChar(dsbcaps, sizeof(dsbcaps), 0);
    dsbcaps.dwSize := sizeof(dsbcaps);
    Com_DPrintf('...creating secondary buffer: ', []);
    if (DS_OK <> pDS.CreateSoundBuffer(dsbuf, pDSBuf, nil)) then
    begin
      Com_Printf('failed'#10, []);
      FreeSound();
      Result := false;
      Exit;
    end;
    Com_DPrintf('ok'#10, []);

    dma.channels := format.nChannels;
    dma.samplebits := format.wBitsPerSample;
    dma.speed := format.nSamplesPerSec;

    if (DS_OK <> pDSBuf.GetCaps(dsbcaps)) then
    begin
      Com_Printf('*** GetCaps failed ***'#10, []);
      FreeSound();
      result := false;
      exit;
    end;

    Com_Printf('...using secondary sound buffer'#10, []);
  end
  else
  begin
    Com_Printf('...using primary buffer'#10, []);
    Com_DPrintf('...setting WRITEPRIMARY coop level: ', []);
    if (DS_OK <> pDS.SetCooperativeLevel(cl_hwnd, DSSCL_WRITEPRIMARY)) then
    begin
      Com_Printf('failed'#10, []);
      FreeSound();
      Result := False;
      Exit;
    end;
    Com_DPrintf('ok'#10, []);
    if DS_OK <> pDSPBuf.GetCaps(dsbcaps) then
    begin
      Com_Printf('*** GetCaps failed ***'#10, []);
      Result := false;
      Exit;
    end;

    pDSBuf := pDSPBuf;
  end;

  // Make sure mixer is active
  pDSBuf.Play(0, 0, DSBPLAY_LOOPING);
  if snd_firsttime then
    Com_Printf('   %d channel(s)'#10 +
      '   %d bits/sample'#10 +
      '   %d bytes/sec'#10, [dma.channels, dma.samplebits, dma.speed]);

  gSndBufSize := dsbcaps.dwBufferBytes;

  // we don't want anyone to access the buffer directly w/o locking it first.
  lpData := nil;

  pDSBuf.Stop();
  pDSBuf.GetCurrentPosition(@mmstarttime.sample, @dwWrite);
  pDSBuf.Play(0, 0, DSBPLAY_LOOPING);

  dma.samples := gSndBufSize div (dma.samplebits div 8);
  dma.samplepos := 0;
  dma.submission_chunk := 1;
  dma.buffer := lpData;
  sample16 := dma.samplebits div 8 - 1;

  Result := true;
end;

{
** DS_DestroyBuffers
}

procedure DS_DestroyBuffers();
begin
  Com_DPrintf('Destroying DS buffers'#10, []);
  if Assigned(pDS) then
  begin
    Com_DPrintf('...setting NORMAL coop level'#10, []);
    pDS.SetCooperativeLevel(cl_hwnd, DSSCL_NORMAL);
  end;

  if Assigned(pDSBuf) then
  begin
    Com_DPrintf('...stopping and releasing sound buffer'#10, []);
    pDSBuf.Stop();
    //pDSBuf._Release();
    pDSBuf := nil;
  end;

  // only release primary buffer if it's not also the mixing buffer we just released
  if Assigned(pDSPBuf) and (pDSBuf <> pDSPBuf) then
  begin
    Com_DPrintf('...releasing primary buffer'#10, []);
    //pDSPBuf._Release( );
    pDSPBuf := nil;
  end;
  dma.buffer := nil;
end;

{
=========
FreeSound
=========
}

procedure FreeSound();
var
  i: integer;
begin
  Com_DPrintf('Shutting down sound system'#10, []);

  if pDS <> nil then
    DS_DestroyBuffers();

  if hWaveOut_ <> 0 then
  begin
    Com_DPrintf('...resetting waveOut'#10, []);
    waveOutReset(hWaveOut_);

    if lpWaveHdr <> nil then
    begin
      Com_DPrintf('...unpreparing headers'#10, []);
      for i := 0 to WAV_BUFFERS - 1 do
        waveOutUnprepareHeader(hWaveOut_, @lpWaveHdr[i], sizeof(WAVEHDR));
    end;

    Com_DPrintf('...closing waveOut'#10, []);
    waveOutClose(hWaveOut_);

    if hWaveHdr <> 0 then
    begin
      Com_DPrintf('...freeing WAV header'#10, []);
      GlobalUnlock(hWaveHdr);
      GlobalFree(hWaveHdr);
    end;

    if hData <> 0 then
    begin
      Com_DPrintf('...freeing WAV buffer'#10, []);
      GlobalUnlock(hData);
      GlobalFree(hData);
    end;

  end;

  if pDS <> nil then
  begin
    Com_DPrintf('...releasing DS object'#10, []);
    pDS := nil;
  end;

  Com_DPrintf('...freeing DSOUND.DLL'#10, []);

  hWaveOut_ := 0;
  hData := 0;
  hWaveHdr := 0;
  lpData := nil;
  lpWaveHdr := nil;
  dsound_init := false;
  wav_init := false;
end;

{
=========
SNDDMA_InitDirect

Direct-Sound support
=========
}

function SNDDMA_InitDirect(): sndinitstat;
var
  dscaps: TDSCAPS;
  hresult_: HRESULT;
begin
  dma.channels := 2;
  dma.samplebits := 16;

  if Trunc(s_khz^.value) = 44 then
    dma.speed := 44100;
  if Trunc(s_khz^.value) = 22 then
    dma.speed := 22050
  else
    dma.speed := 11025;

  Com_Printf('Initializing DirectSound'#10, []);

  // Juha: This doesn't look original, since DirectSound.pas does this already
  Com_DPrintf('...loading dsound.dll: ', []);
  if DSoundDLL = 0 then
  begin
    Com_Printf('failed'#10, []);
    Result := SIS_FAILURE;
    Exit;
  end;

  Com_DPrintf('ok'#10, []);

  if @DirectSoundCreate = nil then
  begin
    Com_Printf('*** couldn''t get DS proc addr ***'#10, []);
    Result := SIS_FAILURE;
    Exit;
  end;

  Com_DPrintf('...creating DS object: ', []);

  hresult_ := DirectSoundCreate(nil, pDS, nil);

  while hresult_ <> DS_OK do
  begin
    if hresult_ <> DSERR_ALLOCATED then
    begin
      Com_Printf('failed'#10, []);
      Result := SIS_FAILURE;
      Exit;
    end;

    if (MessageBox(0, 'The sound hardware is in use by another app.'#10#10 +
      'Select Retry to try to start sound again or Cancel to run Quake with no sound.',
      'Sound not available',
      MB_RETRYCANCEL or MB_SETFOREGROUND or MB_ICONEXCLAMATION) <> IDRETRY) then
    begin
      Com_Printf('failed, hardware already in use'#10, []);
      Result := SIS_NOTAVAIL;