unit DSTools;
{---------------  Проект "Маленькие программы помощники"  --------------------
   Генерирование синусоидального сигнала средствами DirectSound.
      Copyright (C) ZHarns58.  Условия использования: бесплатно.
                  http://ZHarns58.La-Ser.ru
------------------------------------------------------------------------------}
interface

uses
  Windows, SysUtils, Dialogs, MMSystem, DirectSound;

var
  SigFreq : real;                       // частота сигнала

procedure InitDS(FormHandle : HWND);    // инициализация DirectSound
procedure PlayBuffer;                   // старт воспроизведения
procedure StopBuffer;                   // стоп воспроизведения
function PlayingStatus: boolean;        // находится ли буфер в состоянии воспроизведения
procedure SetLeftChanelOnly;            // включить только левый канал
procedure SetRightChanelOnly;           // включить только правый канал
procedure SetBothChanels;               // включить оба канала
procedure SetVolume(vol: integer);      // установка уровня громкости

implementation

const
  NChan = 2;      // количество каналов
  DFreq = 44100;  // частота дискретизации
  NBit  = 16;     // количеств разрядов на выборку
  NSamp = 10000;  // размер вторичного буфера в минимальных блоках данных
var
  //  формат буфера
  WFX : TWaveFormatEx =
    ( wFormatTag      : WAVE_FORMAT_PCM;                // тип формата
      nChannels       : NChan;                          // количество каналов
      nSamplesPerSec  : DFreq;                          // частота дискретиозации
      nAvgBytesPerSec : DFreq * NChan * (NBit div 8);   // байтов в секунду
      nBlockAlign     : NChan * (NBit div 8);           // размер минимального блока данных в байтах
      wBitsPerSample  : NBit;                           // бит на выборку
      cbSize          : 0 );                            // для DirectSound всегда 0
  //  описание свойств вторичного буфера
  BufDesc : TDSBufferDesc =
    ( dwSize          : SizeOf(TDSBufferDesc);          // размер самой переменной
      dwFlags         : DSBCAPS_CTRLPOSITIONNOTIFY or   // наличие позиций уведомления
                        DSBCAPS_CTRLPAN or              // управление балансом каналов
                        DSBCAPS_GLOBALFOCUS or          // при отсутсвии фокуса вывод звука продолжается
                        DSBCAPS_GETCURRENTPOSITION2 or  // управление положением курсора воспроизведения
                        DSBCAPS_CTRLVOLUME;             // управление громкостью
      dwBufferBytes   : NSamp * NChan * (NBit div 8);   // размер буфера в байтах
      dwReserved      : 0;
      lpwfxFormat     : @WFX;                           //  адрес переменной с описанием формата
      guid3DAlgorithm : '{00000000-0000-0000-0000-000000000000}' );
  hr     : HRESULT;
  FDS    : IDirectSound;                // главный объект вывода звука
  FDSB   : IDirectSoundBuffer;          // буфер воспроизведения
  FDSN   : IDirectSoundNotify;          // интерфейс уведомлений буфера воспроизведения
  DSCaps : TDSCaps;                     // для свойств оборудования
  dspbd  : TDSBufferDesc;               // для свойств первичного буфера
  // ----------------------
  PlayEvents       : array[0..1] of THandle;             // дескрипторы событий воспроизведения
  PlayEventsPos    : array[0..1] of TDSBPositionNotify;  // позиции уведомлений воспроизведения
  PlayThreadHandle : THandle;                            // дескриптор потока
  PlayThreadID     : DWORD;                              // идентификатор потока
  // ----------------------
  PeriodOffset : real = 0;    // текущее положение в периоде сигнала

procedure CalcSignalForm(ad: pointer; l: DWORD);
const
  pi2 = 2*pi;
var
  i, j     : integer;
  SampSize : DWORD;    // размер в байтах одной выборки (сэмла) сигнала для одного канала
  ff       : real;     // доля периода сигнала приходящаяся на один период дискретизации
  x        : real;     // положение в периоде сигнала
  amp      : smallint; // выборка (сэмпл) - мгновенная величина сигнала
begin
  SampSize:= WFX.wBitsPerSample div 8;
  //  доля периода сигнала приходящаяся на один период дискретизации
  ff:= SigFreq / WFX.nSamplesPerSec;
  for i:=0 to l div WFX.nBlockAlign - 1 do begin
    x := Frac(i * ff + PeriodOffset);  //  положение в периоде сигнала
    amp := Round(High(smallint) * Sin(pi2*x));
    for j:=1 to WFX.nChannels do begin
      PSmallInt(ad)^ := amp;
      DWORD(ad) := DWORD(ad) + SampSize;
    end;
  end;
  //  положение в периоде для следующего вызова
  PeriodOffset:= Frac((l div WFX.nBlockAlign) * ff + PeriodOffset);
end;

procedure FillBufferSegment(offset, l : DWORD);
  // offset, l - положение и длина заполняемого сегмента буфера
var
  ad1, ad2 : pointer;
  l1, l2   : DWORD;
begin
  //  блокирование буфера
  ad1 := nil;
  ad2 := nil;
  hr := FDSB.Lock(offset, l, @ad1, @l1, @ad2, @l2, 0);
  if failed(hr) then begin
    ShowMessage('Ошибка при блокировании звукового буфера');
    halt;
  end;
  //----------------
  CalcSignalForm(ad1, l1);
  //----------------
  hr := FDSB.UnLock( ad1, l1, ad2, l2);
  if failed(hr) then begin
    ShowMessage('Ошибка при разблокировании звукового буфера');
    halt;
  end;
end;

procedure PlayExecute;
var
  evt    : DWORD;
  offset : DWORD;
begin
  while true do begin
    evt:= WaitForMultipleObjects(2, PWOHandleArray(@PlayEvents),
              false, INFINITE);
    evt:= evt - WAIT_OBJECT_0;
    //  определение заполняемой половины буфера
    if evt = 0
      then offset:= PlayEventsPos[1].dwOffset  // заполняется вторая половина
      else offset:= 0;                         // заполняется первая половина
    //---------------------
    FillBufferSegment(offset, PlayEventsPos[1].dwOffset);
    //---------------------
  end;
end;

procedure InitDS(FormHandle : HWND);
var
  i : DWORD;
begin
  //  создание главного объекта DirectSound
  hr := DirectSoundCreate(nil, FDS, nil);
  if failed(hr) then begin
    ShowMessage('Невозможно создать главный объект DirectSound');
    halt;
  end;
  //  установка режима доступа к звуковому оборудованию
  hr := FDS.SetCooperativeLevel(FormHandle, DSSCL_EXCLUSIVE);
  if failed(hr) then begin
    ShowMessage('Ошибка при установке режима доступа'#13
              + 'к звуковому оборудованию');
    halt;
  end;
  //  определение возможностей звукового оборудования
  ZeroMemory(@DSCaps, SizeOf(DSCaps));
  DSCaps.dwSize := SizeOf(DSCaps);
  hr:= FDS.GetCaps(DSCaps);
  if DSCaps.dwMaxSecondarySampleRate < DFreq then begin
    ShowMessage('Доступна частота дискретизации не более ' +
      IntToStr(DSCaps.dwMaxSecondarySampleRate) + ' Гц.' + #13 +
      'Для нормальной работы требуется не менее 44100 Гц.');
    halt;
  end;
  if ((DSCaps.dwFlags and DSCAPS_SECONDARYSTEREO) = 0) or
     ((DSCaps.dwFlags and DSCAPS_SECONDARY16BIT) = 0)
  then begin
    ShowMessage('Отсутствует возможность работы в режиме стерео, 16 бит');
    halt;
  end;
  //  изменение формата первичного звукового буфера
  ZeroMemory(@dspbd, SizeOf(dspbd));
  dspbd.dwSize := SizeOf(dspbd);
  dspbd.dwFlags := DSBCAPS_PRIMARYBUFFER;
  hr := FDS.CreateSoundBuffer(dspbd, FDSB, nil);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании звукового буфера');
    halt;
  end;
  hr:= FDSB.SetFormat(@WFX);
  if failed(hr) then begin
    ShowMessage('Ошибка при изменении формата первичного буфера');
    halt;
  end;
  FDSB := nil;
  //  создание вторичного звукового буфера
  hr := FDS.CreateSoundBuffer(BufDesc, FDSB, nil);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании звукового буфера');
    halt;
  end;
  //  создание интерфейса уведомлений
  hr := FDSB.QueryInterface(IID_IDirectSoundNotify, FDSN);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании интерфейса уведомлений');
    halt;
  end;
  //  создание событий звукового буфера
  for i:=0 to High(PlayEvents) do begin
    PlayEvents[i] := CreateEvent(nil, false, false, nil);
    PlayEventsPos[i].hEventNotify := PlayEvents[i];
    PlayEventsPos[i].dwOffset := i*(BufDesc.dwBufferBytes div 2);
  end;
  //  Включение уведомлений
  hr := FDSN.SetNotificationPositions(2, @PlayEventsPos[0]);
  //  ---------------------
  PlayThreadHandle := CreateThread(nil, 0, TFNThreadStartRoutine(@PlayExecute), nil, 0, PlayThreadID);
end;

procedure PlayBuffer;
begin
  //  установить начальное положение в периоде для расчета выборок
  PeriodOffset:= 0;
  //  заполнение первой половины буфера
  FillBufferSegment(0, PlayEventsPos[1].dwOffset);
  //  установить курсор проигрывания в начало буфера
  hr := FDSB.SetCurrentPosition(0);
  if failed(hr) then begin
    ShowMessage('Ошибка при установке начальной позиции проигрывания');
    exit;
  end;
  //  старт проигрывания
  hr := FDSB.Play(0, 0, DSBPLAY_LOOPING);
  if failed(hr) then
    ShowMessage('Ошибка при проигрывании звукового буфера');
end;

procedure StopBuffer;
begin
  hr := FDSB.Stop;
  if failed(hr) then
    ShowMessage('Ошибка при остановке проигрывания');
end;

function PlayingStatus: boolean;
var
  BufStat : DWORD;
begin
  BufStat := 0;
  hr := FDSB.GetStatus(BufStat);
  if failed(hr) then begin
    ShowMessage('Ошибка при получении состояния звукового буфера');
    halt;
  end;
  if (BufStat and DSBSTATUS_LOOPING) = DSBSTATUS_LOOPING
    then result:= true
    else result:= false;
end;

procedure SetLeftChanelOnly;
begin
  hr := FDSB.SetPan(DSBPAN_LEFT);
  if failed(hr) then
    ShowMessage('Ошибка при включении только левого канала');
end;

procedure SetRightChanelOnly;
begin
  hr := FDSB.SetPan(DSBPAN_RIGHT);
  if failed(hr) then
    ShowMessage('Ошибка при включении только правого канала');
end;

procedure SetBothChanels;
begin
  hr := FDSB.SetPan(DSBPAN_CENTER);
  if failed(hr) then
    ShowMessage('Ошибка при включении обоих каналов');
end;

procedure SetVolume(vol: integer);
begin
  hr := FDSB.SetVolume(vol);
  if failed(hr) then
    ShowMessage('Ошибка при регулировании громкости');
end;

initialization
begin
  FDSN := nil;
  FDSB := nil;
  FDS := nil;
end;

finalization
begin
  if Assigned(FDSN) then FDSN := nil;
  if Assigned(FDSB) then FDSB := nil;
  if Assigned(FDS) then FDS := nil;
end;

end.