unit IAXSnd;

interface

uses Windows, Messages, Sysutils, Classes, Forms, contnrs, syncobjs,
     MMsystem, DirectSound, Math, ActiveX, Dialogs,
     Controls, MsMixerThorax;


type
  EIAXAudio = class(Exception);

  {  TDirectXDriver  }

  TDirectXDriver = class(TCollectionItem)
  private
    FGUID: PGUID;
    FGUID2: TGUID;
    FDescription: string;
    FDriverName: string;
    procedure SetGUID(Value: PGUID);
  public
    property GUID: PGUID read FGUID write SetGUID;
    property Description: string read FDescription write FDescription;
    property DriverName: string read FDriverName write FDriverName;
  end;

  {  TDirectXDrivers  }

  TDirectXDrivers = class(TCollection)
  private
    function GetDriver(Index: Integer): TDirectXDriver;
  public
    constructor Create;
    property Drivers[Index: Integer]: TDirectXDriver read GetDriver; default;
  end;

  {  TIAXAudio  }

  TIAXAudio = class(TWinControl)
  private
	 	DSound: IDirectSound;
    DSoundC: IDirectSoundCapture8;
    PBuffer: IDirectSoundBuffer;

    FOLevel: Integer;
    FOHistory: Double;

    FOQueue: TQueue;
    SOBuffer: IDirectSoundBuffer;
    SONotify: IDirectSoundNotify;
    SOBlocksFree: Word;
    SOBlocksLoad: Word;

    FILevel: Integer;
    FIHistory: Double;

    FIQueue: TQueue;
    SIBuffer: IDirectSoundCaptureBuffer;
    SINotify: IDirectSoundNotify;

    FMixers: TMsMixerSystem;

    FFormat: PWaveFormatEx;
    FBlockSize: Word;
    FBufferSize: Word;
    FReadBufferSize: Word;
    FNotifyEvents: array [0..3] of THandle;
    FNotifyThread: TThread;
    FMuting: Boolean;
    FPlaying: Boolean;
    FOnUpdate: TNotifyEvent;
    FLock: TCriticalSection;
    function GetFrequency: Integer;
    procedure SetFormat(Value: PWaveFormatEx);
    procedure RecreateBuffer;
    function Space(Value1, Value2: DWORD): DWORD;
    procedure Update(Index: Integer);
    procedure Play;
    procedure FillBuffer(Index: Integer);
    procedure ReadBuffer(Index: Integer);
		function Calc_level(Data: PChar; Samples: Integer; var History: Double): Double;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    class function InputDrivers: TDirectXDrivers;
    class function OutputDrivers: TDirectXDrivers;
    procedure Start;
    procedure Stop;
    procedure WriteBlock(Data: Pointer);
    function ReadBlock(var Size: Integer): Pointer;
    property Format: PWaveFormatEx read FFormat Write SetFormat;
    property OnUpdate: TNotifyEvent read FOnUpdate Write FOnUpdate;
    property Frequency: Integer read GetFrequency;
    property BlocksFree: Word read SOBlocksFree;
    property BlocksLoad: Word read SOBLocksLoad;
    property BlockSize: Word read FBlockSize;

    property OutputLevel: Integer read FOLevel;
    property InputLevel: Integer read FILevel;
  end;


implementation

{  Driver Stuff  }

const
	DRVM_MAPPER   						= $2000;
	DRVM_USER     						= $4000;
	DRVM_MAPPER_STATUS   			= (DRVM_MAPPER+0);
	DRVM_MAPPER_RECONFIGURE 	=	(DRVM_MAPPER+1);
	DRVM_MAPPER_PREFERRED_GET = (DRVM_MAPPER+21);



var
  DirectSoundDrivers: TDirectXDrivers;
  DirectSoundCaptureDrivers: TDirectXDrivers;

function EnumDirectSoundDrivers_DSENUMCALLBACK(lpGuid: PGUID; lpstrDescription: LPCSTR;
  lpstrModule: LPCSTR; lpContext: Pointer): BOOL; stdcall;
begin
  Result := True;
  with TDirectXDriver.Create(TDirectXDrivers(lpContext)) do
  begin
    Guid := lpGuid;
    Description := lpstrDescription;
    DriverName := lpstrModule;
  end;
end;

function EnumDirectSoundDrivers: TDirectXDrivers;
begin
  if DirectSoundDrivers=nil then
  begin
    DirectSoundDrivers := TDirectXDrivers.Create;
    try
      DirectSoundEnumerate(@EnumDirectSoundDrivers_DSENUMCALLBACK, DirectSoundDrivers);
    except
      DirectSoundDrivers.Free;
      raise;
    end;
  end;

  Result := DirectSoundDrivers;
end;

function EnumDirectSoundCaptureDrivers: TDirectXDrivers;
begin
  if DirectSoundCaptureDrivers=nil then
  begin
    DirectSoundCaptureDrivers := TDirectXDrivers.Create;
    try
      DirectSoundEnumerate(@EnumDirectSoundDrivers_DSENUMCALLBACK, DirectSoundCaptureDrivers);
    except
      DirectSoundCaptureDrivers.Free;
      raise;
    end;
  end;

  Result := DirectSoundCaptureDrivers;
end;


{  TDirectXDriver  }

procedure TDirectXDriver.SetGUID(Value: PGUID);
begin
  if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
  begin
    FGUID2 := Value^;
    FGUID := @FGUID2;
  end else
    FGUID := Value;
end;

{  TDirectXDrivers  }

constructor TDirectXDrivers.Create;
begin
  inherited Create(TDirectXDriver);
end;

function TDirectXDrivers.GetDriver(Index: Integer): TDirectXDriver;
begin
  Result := (inherited Items[Index]) as TDirectXDriver;
end;


type
  TNotifyThread = class(TThread)
  private
    EventIndex: DWORD;
    FAudio: TIAXAudio;
    constructor Create(Audio: TIAXAudio);
    destructor Destroy; override;
    procedure Execute; override;
    procedure Update;
    procedure ThreadTerminate(Sender: TObject);
  end;

constructor TNotifyThread.Create(Audio: TIAXAudio);
begin
  FAudio := Audio;
  OnTerminate := ThreadTerminate;

  FAudio.FNotifyThread := Self;

  FreeOnTerminate := True;
  Priority:=tpTimeCritical;
  inherited Create(False);
end;

destructor TNotifyThread.Destroy;
begin
  FreeOnTerminate := False;
  Suspend;
  SetEvent(FAudio.FNotifyEvents[0]);
  SetEvent(FAudio.FNotifyEvents[1]);
  SetEvent(FAudio.FNotifyEvents[2]);
  SetEvent(FAudio.FNotifyEvents[3]);
  inherited Destroy;

  FAudio.FNotifyThread := nil;
end;

procedure TNotifyThread.ThreadTerminate(Sender: TObject);
begin
  FAudio.FNotifyThread := nil;
end;

procedure TNotifyThread.Execute;
var
  EventCount: DWORD;
  Msg: TMsg;
begin
  EventCount:=4;
  while not Terminated do
  begin
    EventIndex := MsgWaitForMultipleObjects(EventCount,
      FAudio.FNotifyEvents, False, INFINITE, QS_ALLINPUT);
    Dec(EventIndex,WAIT_OBJECT_0);  // Normalisierung
    if EventIndex >= EventCount then
    begin // Botschaft von Windows -> Reguläre Verarbeitung
      while (PeekMessage(Msg, 0, 0,0, PM_REMOVE)) do
        if Msg.Message = WM_QUIT then Terminate
          else
          begin
            TranslateMessage(Msg); DispatchMessage(Msg);
          end;
    end else // wurde eines der Ereignis-Objekte signalisiert
      if not Terminated then
         // 0 = explizit, -1 = Ereignis-Objekt gelöscht
       if EventIndex < 0 then Beep
         else Synchronize(Update);
  end;
end;

procedure TNotifyThread.Update;
begin
  if Terminated then Exit;
  ResetEvent(FAudio.FNotifyEvents[EventIndex]);
  try
    FAudio.Update(EventIndex);
  except
    on E: Exception do
    begin
      Application.HandleException(E);
    end;
  end;
end;

constructor TIAXAudio.Create(AOwner: TComponent);
var
  res: HRESULT;

  procedure CreateMixers;
  var
    I1,I2: Integer;
    FMixer: tMsMixer;
    FRecLine: tMsMixerLine;
    FMSelect: tMsMixerLine;
  begin
	  FMixers:=TMsMixerSystem.Create(Self);

    for I1:=0 to FMixers.MixerCount-1 do
    begin
      FMixer := FMixers.MixerByIndex[I1];
    end;

    FMixer.EnumLines;
    for I1:=0 to FMixer.LineCount-1 do
    begin
      FRecLine := FMixer.LineByIndex[i1];
      if FRecLine.LineCaps^.Target.dwType=MIXERLINE_TARGETTYPE_WAVEIN then
      begin
        FRecLine.EnumSourceLines;
        for I2:=0 to FRecLine.SourceLineCount-1 do
        begin
	        FRecLine.SourceLineByIndex[i2].LineCaps;
        end;
      end;
    end;



  end;

begin
  inherited Create(AOwner);

  FBlockSize:=320;
  FBufferSize:=4;
  FReadBufferSize:=2;
  FOQueue:=TQueue.Create;
  FIQueue:=TQueue.Create;
  FNotifyEvents[0]:=CreateEvent(nil, False, False, nil);
  FNotifyEvents[1]:=CreateEvent(nil, False, False, nil);
  FNotifyEvents[2]:=CreateEvent(nil, False, False, nil);
  FNotifyEvents[3]:=CreateEvent(nil, False, False, nil);
  FNotifyThread:=TNotifyThread.Create(Self);

  res := DirectSoundCreate(nil, DSound, nil);
  if Failed(res) then
      raise EIAXAudio.Create(DSErrorString(Res));

  res := DirectSoundCaptureCreate8(nil, DSoundC, nil);
  if Failed(res) then
      raise EIAXAudio.Create(DSErrorString(Res));

  DSound.SetCooperativeLevel(Application.Handle, DSSCL_PRIORITY);

  { Try Input Mixer }
  CreateMixers;


//  waveOutMessage(WAVE_MAPPER, DRVM_MAPPER_PREFERRED_GET, Integer(@Pref), Integer(@Fl));
//  waveOutGetDevCaps(Pref, @Cabs, SizeOf(Cabs));
end;

destructor TIAXAudio.Destroy;
var
  Item: Pointer;
begin
  SOBuffer.Stop;
  FNotifyThread.Terminate;
  PulseEvent(FNotifyEvents[0]);

  FFormat:=nil;
  SINotify:=nil;
  SIBuffer:=nil;
  SONotify:=nil;
  SOBuffer:=nil;
  PBuffer:=nil;
  DSoundC:=nil;
  DSound:=nil;

  CloseHandle(FNotifyEvents[0]);
  CloseHandle(FNotifyEvents[1]);
  CloseHandle(FNotifyEvents[2]);
  CloseHandle(FNotifyEvents[3]);

  while FIQueue.Count>0 do
  begin
    FreeMem(FIQueue.Pop, FBlockSize);
  end;

  while FOQueue.Count>0 do
  begin
    FreeMem(FOQueue.Pop, FBlockSize);
  end;
  inherited Destroy;
end;

class function TIAXAudio.OutputDrivers: TDirectXDrivers;
begin
  Result := EnumDirectSoundDrivers;
end;

class function TIAXAudio.InputDrivers: TDirectXDrivers;
begin
  Result := EnumDirectSoundCaptureDrivers;
end;

function TIAXAudio.GetFrequency: Integer;
var
  F: DWORD;
begin
  SOBuffer.GetFrequency(F);
  Result:=F;
end;

procedure TIAXAudio.SetFormat(Value: PWaveFormatEx);
begin
  FFormat := Value;

  RecreateBuffer;
end;

procedure TIAXAudio.RecreateBuffer;
const
  Mult = 2;
type
  PNAr = array of TDSBPositionNotify;
var
  Res: HRESULT;
	BufDesc: TDSBufferDesc;
  PNList: array [0..1] of TDSBPositionNotify;

  I: Integer;

	CBufDesc: TDSCBufferDesc;
  CEffDesc: TDSCEffectDesc;
begin
  if Assigned(PBuffer) then
  begin
    PBuffer:=nil;
  end;
  if Assigned(SOBuffer) then
  begin
    SOBuffer:=nil;
  end;

// Outputbuffer

  FillChar(BufDesc,SizeOf(BufDesc),0);
  with BufDesc do begin
    dwSize := SizeOf(BufDesc);
    dwFlags := DSBCAPS_PRIMARYBUFFER;
  end;
  Res := DSound.CreateSoundBuffer(BufDesc, PBuffer, nil);

  if Failed(Res) then
    raise EIAXAudio.Create(DSErrorString(Res));

  Res:=PBuffer.SetFormat(FFormat^);

  if Failed(Res) then
    raise EIAXAudio.Create(DSErrorString(Res));

  FillChar(BufDesc,SizeOf(BufDesc),0);
  with BufDesc do begin
    dwSize := SizeOf(BufDesc);
    dwFlags := DSBCAPS_GETCURRENTPOSITION2 or DSBCAPS_CTRLFREQUENCY or DSBCAPS_GLOBALFOCUS or DSBCAPS_CTRLPOSITIONNOTIFY;
    dwBufferBytes := FBlockSize * FBufferSize;
    lpwfxFormat := FFormat;
  end;
  Res := DSound.CreateSoundBuffer(BufDesc, SOBuffer, nil);

  if Failed(Res) then
    raise EIAXAudio.Create(DSErrorString(Res));

  Res := SOBuffer.QueryInterface(IID_IDirectSoundNotify8,SONotify);
  if Failed(Res) then
    raise EIAXAudio.Create(DSErrorString(Res));

  PNList[0].dwOffset 			:= (FBufferSize*FBlockSize) div 2;
  PNList[0].hEventNotify 	:= FNotifyEvents[0];
  PNList[1].dwOffset 			:= (FBufferSize*FBlockSize)-1;
  PNList[1].hEventNotify 	:= FNotifyEvents[1];

  Res := SONotify.SetNotificationPositions(2,@PNList);
  if Failed(Res) then
    raise EIAXAudio.Create(DSErrorString(Res));

// Inputbuffer
  FillChar(CEffDesc,SizeOf(CEffDesc),0);
  with CEffDesc do begin
    dwSize := SizeOf(CEffDesc);
    guidDSCFXClass := GUID_DSCFX_CLASS_AEC;
    guidDSCFXInstance := GUID_DSCFX_SYSTEM_AEC;
  end;

  FillChar(CBufDesc,SizeOf(CBufDesc),0);
  with CBufDesc do begin
    dwSize := SizeOf(CBufDesc);
//    dwFlags := DSCBCAPS_CTRLFX;
    dwBufferBytes := FBlockSize*FReadBufferSize;
    lpwfxFormat := FFormat;
//    dwFXCount := 0;
//    lpDSCFXDesc := @CEffDesc;
  end;
  Res := DSoundC.CreateCaptureBuffer(CBufDesc, SIBuffer, nil);
  if Failed(Res) then
    raise EIAXAudio.Create(DSErrorString(Res));


  Res := SIBuffer.QueryInterface(IID_IDirectSoundNotify8,SINotify);
  if Failed(Res) then
    raise EIAXAudio.Create(DSErrorString(Res));

  PNList[0].dwOffset 			:= (FReadBufferSize*FBlockSize) div 2;
  PNList[0].hEventNotify 	:= FNotifyEvents[2];
  PNList[1].dwOffset 			:= (FReadBufferSize*FBlockSize)-1;
  PNList[1].hEventNotify 	:= FNotifyEvents[3];

  Res := SINotify.SetNotificationPositions(2,@PNList);
  if Failed(Res) then
    raise EIAXAudio.Create(DSErrorString(Res));
end;

function TIAXAudio.Space(Value1, Value2: DWORD): DWORD;
begin
  if Value2 < Value1 then
  begin
    Result := Value1 - Value2
  end else
  begin
    Result := Value1 + ((FBufferSize * FBlockSize) - Value2);
  end;
end;

procedure TIAXAudio.Update(Index: Integer);
begin
  if Index<2 then
  begin
	  FillBuffer(Index);
    SOBlocksLoad := FOQueue.Count;
//    if FOQueue.Count<=4 then
//      SOBuffer.SetFrequency(7949);

    if FOQueue.Count>4 then
    begin
			FreeMem(FOQueue.Pop);
			FreeMem(FOQueue.Pop);
    end;
//      SOBuffer.SetFrequency(7970);
  end else
  begin
    ReadBuffer(Index);
  end;

  if Assigned(OnUpdate) then
    FOnUpdate(Self);
end;

procedure TIAXAudio.Start;
var
  res: HRESULT;
begin
  res:=SIBuffer.Start(DSCBSTART_LOOPING);
  if Failed(res) then
  	raise EIAXAudio.Create(DSErrorString(Res));
end;

procedure TIAXAudio.Stop;
var
  res: HRESULT;
begin

  res:=SIBuffer.Stop;
  if Failed(res) then
  	raise EIAXAudio.Create(DSErrorString(Res));
  res:=SOBuffer.Stop;
  if Failed(res) then
  	raise EIAXAudio.Create(DSErrorString(Res));

  FMuting := False;
  FPlaying := False;


  while FIQueue.Count>0 do
  begin
    FreeMem(FIQueue.Pop, FBlockSize);
  end;

  while FOQueue.Count>0 do
  begin
    FreeMem(FOQueue.Pop, FBlockSize);
  end;
end;

procedure TIAXAudio.Play;
var
  res: HRESULT;
  stat: DWORD;
begin
  FMuting := False;

  FillBuffer(0);
  FillBuffer(1);

  res:=SOBuffer.SetCurrentPosition(0);
  if Failed(res) then
  	raise EIAXAudio.Create(DSErrorString(Res));

  res:=SOBuffer.Play(0,0,DSBPLAY_LOOPING);
  if Failed(res) then
  	raise EIAXAudio.Create(DSErrorString(Res));
  FPlaying := True;
end;

procedure TIAXAudio.FillBuffer(Index: Integer);
var
  WritePos: DWORD;
  WriteSize: DWORD;

  procedure FillBlock;
  var
    Res: HRESULT;
	  Data1, Data2: Pointer;
	  Data1Size, Data2Size: DWORD;
    C: Byte;

    procedure FillSmallBlock(Block: Pointer; BlockSize: Integer);
    var
      Item: Pointer;
    begin
      if not FMuting then
        while (BlockSize>0) do
        begin
          if FOQueue.Count>0 then
          begin
            Item:=FOQueue.Pop;
            CopyMemory(Block,Item,FBlockSize);
            Inc(Integer(Block),FBlockSize);
            Dec(BlockSize, FBlockSize);
            FreeMem(Item, FBlockSize);
          end else
          begin
            FMuting:=True;
            Break;
          end;
        end;

      if FMuting then
      begin
        FillChar(Block^, BlockSize, C);
      end;
    end;


  begin
    if Format.wBitsPerSample=8 then C := $80 else C := 0;

    Res:=SOBuffer.Lock(WritePos, WriteSize, Data1, Data1Size, Data2, Data2Size,0);
    if Succeeded(Res) then
    begin
      try
        FillSmallBlock(Data1,Data1Size);
        if Assigned(Data2) then
	        FillSmallBlock(Data2,Data2Size);
      finally
        SOBuffer.Unlock(Data1, Data1Size, Data2, Data2Size);
      end;
    end else
      raise EIAXAudio.Create(DSErrorString(Res));
  end;

begin
	WriteSize := (FBufferSize*FBlockSize) div 2;
  case Index of
    0: WritePos := 0;
    1: WritePos := WriteSize;
  end;
  FillBlock;
end;

procedure TIAXAudio.ReadBuffer(Index: Integer);
var
  ReadPos: DWORD;
  ReadSize: DWORD;

  procedure ReadBlock;
  var
    Res: HRESULT;
	  Data1, Data2: Pointer;
	  Data1Size, Data2Size: DWORD;
    C: Byte;

    procedure ReadSmallBlock(Block: Pointer; BlockSize: Integer);
    var
      Item: Pointer;
    begin
      while (BlockSize>0) do
      begin
          GetMem(Item,FBlockSize);
          CopyMemory(Item,Block,FBlockSize);
          Inc(Integer(Block),FBlockSize);
          Dec(BlockSize, FBlockSize);
          if FIQueue.Count<10 then
          	FIQueue.Push(Item)
          else
          	FreeMem(Item);
      end;
    end;


  begin

    Res:=SIBuffer.Lock(ReadPos, ReadSize, Data1, Data1Size, Data2, Data2Size,0);
    if Succeeded(Res) then
    begin
      try
        ReadSmallBlock(Data1,Data1Size);
        if Assigned(Data2) then
	        ReadSmallBlock(Data2,Data2Size);
      finally
        SIBuffer.Unlock(Data1, Data1Size, Data2, Data2Size);
      end;
    end else
      raise EIAXAudio.Create(DSErrorString(Res));
  end;

begin
	ReadSize := (FReadBufferSize*FBlockSize) div 2;
  case Index of
    2: ReadPos := 0;
    3: ReadPos := ReadSize;
  end;
  ReadBlock;
end;

function TIAXAudio.Calc_level(Data: PChar; Samples: Integer; var History: Double): Double;
var
  d: ^Smallint;
  i: Integer;
  r: Integer;
begin
  // Level
  R := 0;
  i := 0;
  while (i<Samples) do
  begin
    d := Pointer(Integer(Data)+(I*2));
    Inc(R,abs(d^));
    Inc(i);
  end;

  R := Round(R / Samples);

  // Loudness
  Result := R / 32768;

  if Result > history then
    History := Result
  else
    History := Result/4 + 3.0 * history/4.0;

  if History > 1 then
    History := 1;

  Result := History * 3;
  if Result > 1.0 then
    Result := 1.0;
end;


procedure TIAXAudio.WriteBlock(Data: Pointer);
var
  Item: Pointer;
begin
  GetMem(Item,FBlockSize);
  CopyMemory(Item,Data,FBlockSize);
  FOQueue.Push(Item);
  FOLevel:=Round(Calc_Level(Item,160,FOHistory)*10);;

  if FMuting then
    if FOQueue.Count>2 then
      FMuting := False;

  if not FPlaying then
	  if FOQueue.Count>2 then
			Play;
end;
(*
function TIAXAudio.ReadBlock(var Size: Integer): Pointer;
var
	I: Integer;
  Count: Integer;
  Block: Pointer;
begin
  Result := nil;
  Count := FIQueue.Count;
  if (Count>0) then
  begin
		Size:=FBlockSize*Count;
		GetMem(Result, Size);

    for I:=0 to Count-1 do
    begin
			Block := FIQueue.Pop;
		  FILevel:=Round(Calc_Level(Block,160,FIHistory)*10);
	    CopyMemory(Ptr(Integer(Result)+(FBlockSize*I)), Block, FBlockSize);
    end;
  end;
end;
*)
function TIAXAudio.ReadBlock(var Size: Integer): Pointer;
var
	I: Integer;
  Count: Integer;
  Block: Pointer;
begin
  Result := nil;
  Count := FIQueue.Count;
  if (Count>0) then
  begin
		Size:=FBlockSize;

		Result := FIQueue.Pop;
	  FILevel:=Round(Calc_Level(Result,160,FIHistory)*10);
  end;
end;


end.