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

uses
  Windows, SysUtils, Dialogs, MMSystem, DirectSound;

const
  DFreq = 44100;                         // частота дискретизации
var
  SigFreq : real;                        // частота выходного сигнала
  Cap     : array of array of SmallInt;  // данные из половины входного буфера
  CapIs   : boolean = false;             // наличие необработанных данных в Cap

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

implementation

const
  NChan = 2;      // количество каналов
  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;
  DS     : IDirectSound;                // главный объект вывода звука
  DSCaps : TDSCaps;                     // для свойств оборудования
  DSB    : IDirectSoundBuffer;          // буфер воспроизведения
  DSN    : IDirectSoundNotify;          // интерфейс уведомлений буфера воспроизведения
  dspbd  : TDSBufferDesc;               // для свойств первичного буфера
  //  описание свойств буфера ввода
  CBufDesc : TDSCBufferDesc =
    ( dwSize          : SizeOf(TDSCBufferDesc);        // размер самой переменной
      dwFlags         : 0;                             // флаги
      dwBufferBytes   : NSamp * NChan * (NBit div 8);  // размер буфера в байтах
      dwReserved      : 0;
      lpwfxFormat     : @WFX );                        // адрес переменной с описанием формата
  DSC     : IDirectSoundCapture;        // главный объект ввода звука
  DSCCaps : TDSCCaps;                   // для свойств оборудования по вводу
  DSCB    : IDirectSoundCaptureBuffer;  // буфер ввода
  DSCN    : IDirectSoundNotify;         // интерфейс уведомлений буфера ввода
  // ----------------------
  Events     : array[0..3] of THandle;             // дескрипторы событий для вывода и ввода
  EventsPos  : array[0..1] of TDSBPositionNotify;  // позиции уведомлений воспроизведения
  CEventsPos : array[0..1] of TDSBPositionNotify;  // позиции уведомлений ввода
  ThrHandle  : THandle;                            // дескриптор потока
  ThrID      : DWORD;                              // идентификатор потока
  // ----------------------
  PeriodOffset : real = 0; // текущее положение в периоде сигнала
  blank   : boolean;       // буфер еще пуст (первое событие после запуска)

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 := DSB.Lock(offset, l, @ad1, @l1, @ad2, @l2, 0);
  if failed(hr) then begin
    ShowMessage('Ошибка при блокировании звукового буфера');
    halt;
  end;
  //----------------
  CalcSignalForm(ad1, l1);
  //----------------
  hr := DSB.UnLock( ad1, l1, ad2, l2);
  if failed(hr) then begin
    ShowMessage('Ошибка при разблокировании звукового буфера');
    halt;
  end;
end;

procedure ReadBufferSegment(offset, l : DWORD);
  // offset, l - положение и длина в байтах копируемого сегмента буфера
var
  ad1, ad2 : pointer;
  l1, l2   : DWORD;
  i,j : DWORD;
  ls  : DWORD;    // длина сегмента буфера в минимальных блоках данных
begin
  //  блокирование буфера
  ad1:= nil;
  ad2:= nil;
  hr:= DSCB.Lock(offset, l, @ad1, @l1, @ad2, @l2, 0);
  if failed(hr) then begin
    ShowMessage('Ошибка при блокировании входного звукового буфера');
    halt;
  end;
  //--- копирование сегмента в массив Cap ---
  if not Assigned(Cap) or (Length(Cap) <> WFX.nChannels) then
    SetLength(Cap, WFX.nChannels);
  ls:= l1 div WFX.nBlockAlign;
  for j:=0 to WFX.nChannels-1 do begin
    if not Assigned(Cap[j]) or (Length(Cap[j]) <> ls) then
      SetLength(Cap[j], ls);
    for i:=0 to ls-1 do
      Cap[j,i]:= PSmallInt(DWORD(ad1) + i*WFX.nBlockAlign + 2*j)^;
  end;
  //-----------------------------------------
  hr := DSCB.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(4, PWOHandleArray(@Events), false, INFINITE);
    //  определение индекса события
    evt:= evt - WAIT_OBJECT_0;
    //  произошло ли событие вывода или ввода
    if evt < 2 then begin
      //  событие вывода: определение заполняемой половины буфера
      if evt = 0
        then offset:= EventsPos[1].dwOffset  // заполняется вторая половина
        else offset:= 0;                     // заполняется первая половина
      //-------------------------------------------------
      FillBufferSegment(offset, EventsPos[1].dwOffset);
      //-------------------------------------------------
    end
    else begin
      //  событие ввода
      if blank then begin  // сразу после старта буфер ещё пуст
        blank:= false;
        Continue;
      end;
      if CapIs then    // предыдущие данные еще не обработаны
        Continue;
      evt:= evt - 2;
      //  определение копируемой половины буфера
      if evt = 0
        then offset:= CEventsPos[1].dwOffset  // копируется вторая половина
        else offset:= 0;                      // копируется первая половина
      //----------------------------------------------
      ReadBufferSegment(offset, CEventsPos[1].dwOffset);
      CapIs:= true;
      //----------------------------------------------
    end;
  end;
end;

procedure InitDS(FormHandle : HWND);
var
  i : DWORD;
begin
  //  создание главного объекта DirectSound
  hr := DirectSoundCreate(nil, DS, nil);
  if failed(hr) then begin
    ShowMessage('Невозможно создать главный объект DirectSound');
    halt;
  end;
  //  установка режима доступа к звуковому оборудованию
  hr := DS.SetCooperativeLevel(FormHandle, DSSCL_EXCLUSIVE);
  if failed(hr) then begin
    ShowMessage('Ошибка при установке режима доступа'#13
              + 'к звуковому оборудованию');
    halt;
  end;
  //  определение возможностей звукового оборудования
  ZeroMemory(@DSCaps, SizeOf(DSCaps));
  DSCaps.dwSize := SizeOf(DSCaps);
  hr:= DS.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 := DS.CreateSoundBuffer(dspbd, DSB, nil);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании звукового буфера');
    halt;
  end;
  hr:= DSB.SetFormat(@WFX);
  DSB := nil;
  //  создание вторичного звукового буфера
  hr := DS.CreateSoundBuffer(BufDesc, DSB, nil);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании звукового буфера');
    halt;
  end;
  //  создание интерфейса уведомлений
  hr := DSB.QueryInterface(IID_IDirectSoundNotify, DSN);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании интерфейса уведомлений');
    halt;
  end;
  //  создание событий буфера воспроизведения
  for i:=0 to High(EventsPos) do begin
    Events[i] := CreateEvent(nil, false, false, nil);
    EventsPos[i].hEventNotify := Events[i];
    EventsPos[i].dwOffset := i*(BufDesc.dwBufferBytes div 2);
  end;
  //  Включение уведомлений
  hr := DSN.SetNotificationPositions(2, @EventsPos[0]);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании интерфейса уведомлений воспроизведения');
    halt;
  end;
  //  ----------- ввод звука -----------
  //  создание объекта DirectSoundCapture
  hr := DirectSoundCaptureCreate(nil, DSC, nil);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании объекта DirectSoundCapture');
    halt;
  end;
  //  Определение возможностей звукового оборудования по вводу
  ZeroMemory(@DSCCaps, SizeOf(DSCCaps));
  DSCCaps.dwSize := SizeOf(DSCCaps);
  hr:= DSC.GetCaps(DSCCaps);
  if (DSCCaps.dwFormats and WAVE_FORMAT_4S16) = 0 then begin
    ShowMessage('Слабая звуковая карта');
    halt;
  end;
      //  создание входного звукового буфера
  hr := DSC.CreateCaptureBuffer(CBufDesc, DSCB, nil);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании буфера ввода');
    halt;
  end;
  //  создание интерфейса уведомлений буфера ввода
  hr := DSCB.QueryInterface(IID_IDirectSoundNotify, DSCN);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании интерфейса уведомлений ввода');
    halt;
  end;
  //  задание позиций уведомлений буфера ввода
  for i:=0 to High(CEventsPos) do begin
    Events[i+2] := CreateEvent(nil, false, false, nil);
    CEventsPos[i].hEventNotify := Events[i+2];
    CEventsPos[i].dwOffset := i*(CBufDesc.dwBufferBytes div 2);
  end;
  //  Включение уведомлений буфера ввода
  hr := DSCN.SetNotificationPositions(2, @CEventsPos[0]);
  if failed(hr) then begin
    ShowMessage('Ошибка при создании интерфейса уведомлений');
    halt;
  end;
  //  создание и запуск потока ожидания
  ThrHandle := CreateThread(nil, 0, TFNThreadStartRoutine(@PlayExecute), nil, 0, ThrID);
end;

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

procedure StartCapture;
begin
  blank:= true;
  CapIs:= false;
  hr := DSCB.Start( DSBPLAY_LOOPING );
  if failed(hr) then
    ShowMessage('Ошибка при записи звука');
end;

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

procedure StopCapture;
begin
  hr := DSCB.stop;
  if failed(hr) then
    ShowMessage('Ошибка при прекращении записи');
end;

function PlayingStatus: boolean;
var
  BufStat : DWORD;
begin
  BufStat := 0;
  hr := DSB.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 := DSB.SetPan(DSBPAN_LEFT);
  if failed(hr) then
    ShowMessage('Ошибка при включении только левого канала');
end;

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

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

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

initialization
begin
  DSCN := nil;
  DSCB := nil;
  DSC := nil;
  DSN := nil;
  DSB := nil;
  DS := nil;
end;

finalization
begin
  if Assigned(DSCN) then DSCN := nil;
  if Assigned(DSCB) then DSCB := nil;
  if Assigned(DSC) then DSC := nil;
  if Assigned(DSN) then DSN := nil;
  if Assigned(DSB) then DSB := nil;
  if Assigned(DS) then DS := nil;
end;

end.