unit DXSounds;

interface

{$INCLUDE DelphiXcfg.inc}

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, ExtCtrls, MMSystem,
  DirectX, DXClass, Wave;

type

  {  EDirectSoundError  }

  EDirectSoundError = class(EDirectXError);
  EDirectSoundBufferError = class(EDirectSoundError);

  {  TDirectSound  }

  TDirectSoundBuffer = class;

  TDirectSound = class(TDirectX)
  private
    FBufferList: TList;
    FGlobalFocus: Boolean;
    FIDSound: IDirectSound;
    FInRestoreBuffer: Boolean;
    FStickyFocus: Boolean;
    function GetBuffer(Index: Integer): TDirectSoundBuffer;
    function GetBufferCount: Integer;
    function GetIDSound: IDirectSound;
    function GetISound: IDirectSound;
  protected          
    procedure CheckBuffer(Buffer: TDirectSoundBuffer);
    procedure DoRestoreBuffer; virtual;
  public
    constructor Create(GUID: PGUID);
    destructor Destroy; override;
    class function Drivers: TDirectXDrivers;
    property BufferCount: Integer read GetBufferCount;
    property Buffers[Index: Integer]: TDirectSoundBuffer read GetBuffer;
    property IDSound: IDirectSound read GetIDSound;
    property ISound: IDirectSound read GetISound;
  end;

  {  TDirectSoundBuffer  }

  TDirectSoundBuffer = class(TDirectX)
  private
    FDSound: TDirectSound;
    FIDSBuffer: IDirectSoundBuffer;
    FCaps: TDSBCaps;
    FFormat: PWaveFormatEx;
    FFormatSize: Integer;
    FLockAudioPtr1, FLockAudioPtr2: array[0..0] of Pointer;
    FLockAudioSize1, FLockAudioSize2: array[0..0] of DWORD;
    FLockCount: Integer;
    function GetBitCount: Longint;
    function GetFormat: PWaveFormatEx;
    function GetFrequency: Integer;
    function GetIDSBuffer: IDirectSoundBuffer;
    function GetIBuffer: IDirectSoundBuffer;
    function GetPlaying: Boolean;
    function GetPan: Integer;
    function GetPosition: Longint;
    function GetSize: Integer;
    function GetStatus: Integer;
    function GetVolume: Integer;
    procedure SetFrequency(Value: Integer);
    procedure SetIDSBuffer(Value: IDirectSoundBuffer);
    procedure SetPan(Value: Integer);
    procedure SetPosition(Value: Longint);
    procedure SetVolume(Value: Integer);
  protected
    procedure Check; override;
  public
    constructor Create(ADirectSound: TDirectSound);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function CreateBuffer(const BufferDesc: TDSBufferDesc): Boolean;
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromMemory(const Format: TWaveFormatEx;
      Data: Pointer; Size: Integer);
    procedure LoadFromStream(Stream: TStream);
    procedure LoadFromWave(Wave: TWave);
    function Lock(LockPosition, LockSize: Longint;
      var AudioPtr1: Pointer; var AudioSize1: Longint;
      var AudioPtr2: Pointer; var AudioSize2: Longint): Boolean;
    function Play(Loop: Boolean{$IFNDEF VER100}=False{$ENDIF}): Boolean;
    function Restore: Boolean;
    function SetFormat(const Format: TWaveFormatEx): Boolean;
    procedure SetSize(const Format: TWaveFormatEx; Size: Integer);
    procedure Stop;
    procedure UnLock;
    property BitCount: Longint read GetBitCount;
    property DSound: TDirectSound read FDSound;
    property Format: PWaveFormatEx read GetFormat;
    property FormatSize: Integer read FFormatSize;
    property Frequency: Integer read GetFrequency write SetFrequency;
    property IBuffer: IDirectSoundBuffer read GetIBuffer;
    property IDSBuffer: IDirectSoundBuffer read GetIDSBuffer write SetIDSBuffer;
    property Playing: Boolean read GetPlaying;
    property Pan: Integer read GetPan write SetPan;
    property Position: Longint read GetPosition write SetPosition;
    property Size: Integer read GetSize;
    property Volume: Integer read GetVolume write SetVolume;
  end;

  {  EAudioStreamError  }

  EAudioStreamError = class(Exception);

  {  TAudioStream  }

  TAudioStream = class
  private
    FAutoUpdate: Boolean;
    FBuffer: TDirectSoundBuffer;
    FBufferLength: Integer;
    FBufferPos: DWORD;
    FPlayBufferPos: DWORD;
    FBufferSize: DWORD;
    FDSound: TDirectSound;
    FLooped: Boolean;
    FPlayedSize: Integer;
    FPlaying: Boolean;
    FPosition: Integer;
    FWaveStream: TCustomWaveStream;
    FWritePosition: Integer;
    FNotifyEvent: THandle;
    FNotifyThread: TThread;
    function GetFormat: PWaveFormatEX;
    function GetFormatSize: Integer;
    function GetFrequency: Integer;
    function GetPan: Integer;
    function GetPlayedSize: Integer;
    function GetSize: Integer;
    function GetVolume: Integer;
    function GetWriteSize: Integer;
    procedure SetAutoUpdate(Value: Boolean);
    procedure SetBufferLength(Value: Integer);
    procedure SetFrequency(Value: Integer);
    procedure SetLooped(Value: Boolean);
    procedure SetPan(Value: Integer);
    procedure SetPlayedSize(Value: Integer);
    procedure SetPosition(Value: Integer);
    procedure SetVolume(Value: Integer);
    procedure SetWaveStream(Value: TCustomWaveStream);
    procedure Update2(InThread: Boolean);
    procedure UpdatePlayedSize;
    function WriteWave(WriteSize: Integer): Integer;
  public
    constructor Create(ADirectSound: TDirectSound);
    destructor Destroy; override;
    procedure Play;
    procedure RecreateBuf;
    procedure Stop;
    procedure Update;
    property AutoUpdate: Boolean read FAutoUpdate write SetAutoUpdate;
    property BufferLength: Integer read FBufferLength write SetBufferLength;
    property Format: PWaveFormatEx read GetFormat;
    property FormatSize: Integer read GetFormatSize;
    property Frequency: Integer read GetFrequency write SetFrequency;
    property Pan: Integer read GetPan write SetPan;
    property PlayedSize: Integer read GetPlayedSize write SetPlayedSize;
    property Playing: Boolean read FPlaying;
    property Position: Integer read FPosition write SetPosition;
    property Looped: Boolean read FLooped write SetLooped;
    property Size: Integer read GetSize;
    property Volume: Integer read GetVolume write SetVolume;
    property WaveStream: TCustomWaveStream read FWaveStream write SetWaveStream;
  end;
   
  {  TAudioFileStream  }

  TAudioFileStream = class(TAudioStream)
  private
    FFileName: string;
    FWaveFileStream: TWaveFileStream;
    procedure SetFileName(const Value: string);
  public
    destructor Destroy; override;
    property FileName: string read FFileName write SetFileName;
  end;

  {  TSoundCaptureFormat  }

  TSoundCaptureFormat = class(TCollectionItem)
  private
    FBitsPerSample: Integer;
    FChannels: Integer;
    FSamplesPerSec: Integer;
  public
    property BitsPerSample: Integer read FBitsPerSample;
    property Channels: Integer read FChannels;
    property SamplesPerSec: Integer read FSamplesPerSec;
  end;

  {  TSoundCaptureFormats  }

  TSoundCaptureFormats = class(TCollection)
  private
    function GetItem(Index: Integer): TSoundCaptureFormat;
  public
    constructor Create;
    function IndexOf(ASamplesPerSec, ABitsPerSample, AChannels: Integer): Integer;
    property Items[Index: Integer]: TSoundCaptureFormat read GetItem; default;
  end;

  {  TSoundCaptureStream  }

  ESoundCaptureStreamError = class(EWaveStreamError);

  TSoundCaptureStream = class(TCustomWaveStream2)
  private
    FBuffer: IDirectSoundCaptureBuffer;
    FBufferLength: Integer;
    FBufferPos: DWORD;
    FBufferSize: DWORD;
    FCapture: IDirectSoundCapture;
    FCaptureFormat: Integer;
    FCapturing: Boolean;
    FNotifyEvent: THandle;
    FNotifyThread: TThread;
    FOnFilledBuffer: TNotifyEvent;
    FSupportedFormats: TSoundCaptureFormats;
    function GetReadSize: Integer;
    procedure SetBufferLength(Value: Integer);
    procedure SetOnFilledBuffer(Value: TNotifyEvent);
  protected
    procedure DoFilledBuffer; virtual;
    function GetFilledSize: Integer; override;
    function ReadWave(var Buffer; Count: Integer): Integer; override;
  public
    constructor Create(GUID: PGUID);
    destructor Destroy; override;
    class function Drivers: TDirectXDrivers;
    procedure Start;
    procedure Stop;
    property BufferLength: Integer read FBufferLength write SetBufferLength;
    property CaptureFormat: Integer read FCaptureFormat write FCaptureFormat;
    property Capturing: Boolean read FCapturing;
    property OnFilledBuffer: TNotifyEvent read FOnFilledBuffer write SetOnFilledBuffer;
    property SupportedFormats: TSoundCaptureFormats read FSupportedFormats;
  end;

  {  TSoundEngine  }

  TSoundEngine = class
  private
    FDSound: TDirectSound;
    FEffectList: TList;
    FEnabled: Boolean;
    FTimer: TTimer;
    function GetEffect(Index: Integer): TDirectSoundBuffer;
    function GetEffectCount: Integer;
    procedure SetEnabled(Value: Boolean);
    procedure TimerEvent(Sender: TObject);
  public
    constructor Create(ADSound: TDirectSound);
    destructor Destroy; override;
    procedure Clear;
    procedure EffectFile(const Filename: string; Loop, Wait: Boolean);
    procedure EffectStream(Stream: TStream; Loop, Wait: Boolean);
    procedure EffectWave(Wave: TWave; Loop, Wait: Boolean);
    property EffectCount: Integer read GetEffectCount;
    property Effects[Index: Integer]: TDirectSoundBuffer read GetEffect;
    property Enabled: Boolean read FEnabled write SetEnabled;
  end;

  {  EDXSoundError  }

  EDXSoundError = class(Exception);

  {  TCustomDXSound  }

  TCustomDXSound = class;

  TDXSoundOption = (soGlobalFocus, soStickyFocus, soExclusive);
  TDXSoundOptions = set of TDXSoundOption;

  TDXSoundNotifyType = (dsntDestroying, dsntInitializing, dsntInitialize, dsntFinalize, dsntRestore);
  TDXSoundNotifyEvent = procedure(Sender: TCustomDXSound; NotifyType: TDXSoundNotifyType) of object;

  TCustomDXSound = class(TComponent)
  private
    FAutoInitialize: Boolean;
    FCalledDoInitialize: Boolean;
    FDriver: PGUID;
    FDriverGUID: TGUID;
    FDSound: TDirectSound;
    FForm: TCustomForm;
    FInitialized: Boolean;
    FInternalInitialized: Boolean;
    FNotifyEventList: TList;
    FNowOptions: TDXSoundOptions;
    FOnFinalize: TNotifyEvent;
    FOnInitialize: TNotifyEvent;
    FOnInitializing: TNotifyEvent;
    FOnRestore: TNotifyEvent;
    FOptions: TDXSoundOptions;
    FPrimary: TDirectSoundBuffer;
    FSubClass: TControlSubClass;
    procedure FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
    procedure NotifyEventList(NotifyType: TDXSoundNotifyType);
    procedure SetDriver(Value: PGUID);
    procedure SetForm(Value: TCustomForm);
    procedure SetOptions(Value: TDXSoundOptions);
  protected
    procedure DoFinalize; virtual;
    procedure DoInitialize; virtual;
    procedure DoInitializing; virtual;
    procedure DoRestore; virtual;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    class function Drivers: TDirectXDrivers;
    procedure Finalize;
    procedure Initialize;
    procedure Restore;
    procedure RegisterNotifyEvent(NotifyEvent: TDXSoundNotifyEvent);
    procedure UnRegisterNotifyEvent(NotifyEvent: TDXSoundNotifyEvent);

    property AutoInitialize: Boolean read FAutoInitialize write FAutoInitialize;
    property Driver: PGUID read FDriver write SetDriver;
    property DSound: TDirectSound read FDSound;
    property Initialized: Boolean read FInitialized;
    property NowOptions: TDXSoundOptions read FNowOptions;
    property Primary: TDirectSoundBuffer read FPrimary;
    property OnFinalize: TNotifyEvent read FOnFinalize write FOnFinalize;
    property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
    property OnInitializing: TNotifyEvent read FOnInitializing write FOnInitializing;
    property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
    property Options: TDXSoundOptions read FOptions write SetOptions;
  end;

  {  TDXSound  }

  TDXSound = class(TCustomDXSound)
  published
    property AutoInitialize;
    property Options;
    property OnFinalize;
    property OnInitialize;
    property OnInitializing;
    property OnRestore;
  end;

  {  EWaveCollectionError  }

  EWaveCollectionError = class(Exception);

  {  TWaveCollectionItem  }

  TWaveCollection = class;

  TWaveCollectionItem = class(THashCollectionItem)
  private
    FBuffer: TDirectSoundBuffer;
    FBufferList: TList;
    FFrequency: Integer;
    FInitialized: Boolean;
    FLooped: Boolean;
    FMaxPlayingCount: Integer;
    FPan: Integer;
    FVolume: Integer;
    FWave: TWave;
    function CreateBuffer: TDirectSoundBuffer;
    procedure Finalize;
    procedure Initialize;
    function GetBuffer: TDirectSoundBuffer;
    function GetWaveCollection: TWaveCollection;
    procedure SetFrequency(Value: Integer);
    procedure SetLooped(Value: Boolean);
    procedure SetMaxPlayingCount(Value: Integer);
    procedure SetPan(Value: Integer);
    procedure SetVolume(Value: Integer);
    procedure SetWave(Value: TWave);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Play(Wait: Boolean);
    procedure Restore;
    procedure Stop;
    property Frequency: Integer read FFrequency write SetFrequency;
    property Initialized: Boolean read FInitialized;
    property Pan: Integer read FPan write SetPan;
    property Volume: Integer read FVolume write SetVolume;
    property WaveCollection: TWaveCollection read GetWaveCollection;
  published
    property Looped: Boolean read FLooped write SetLooped;
    property MaxPlayingCount: Integer read FMaxPlayingCount write SetMaxPlayingCount;
    property Wave: TWave read FWave write SetWave;
  end;

  {  TWaveCollection  }

  TWaveCollection = class(THashCollection)
  private
    FDXSound: TCustomDXSound;
    FOwner: TPersistent;
    function GetItem(Index: Integer): TWaveCollectionItem;
    function Initialized: Boolean;
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(AOwner: TPersistent);
    function Find(const Name: string): TWaveCollectionItem;
    procedure Finalize;
    procedure Initialize(DXSound: TCustomDXSound);
    procedure Restore;
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(Stream: TStream);
    property DXSound: TCustomDXSound read FDXSound;
    property Items[Index: Integer]: TWaveCollectionItem read GetItem; default;
  end;

  {  TCustomDXWaveList  }

  TCustomDXWaveList = class(TComponent)
  private
    FDXSound: TCustomDXSound;
    FItems: TWaveCollection;
    procedure DXSoundNotifyEvent(Sender: TCustomDXSound; NotifyType: TDXSoundNotifyType);
    procedure SetDXSound(Value: TCustomDXSound);
    procedure SetItems(Value: TWaveCollection);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property DXSound: TCustomDXSound read FDXSound write SetDXSound;
    property Items: TWaveCollection read FItems write SetItems;
  end;

  {  TDXWaveList  }

  TDXWaveList = class(TCustomDXWaveList)
  published
    property DXSound;
    property Items;
  end;

implementation

uses DXConsts;

function DXDirectSoundCreate(lpGUID: PGUID; out lpDS: IDirectSound;
  pUnkOuter: IUnknown): HRESULT;
type
  TDirectSoundCreate = function(lpGUID: PGUID; out lplpDD: IDirectSound;
    pUnkOuter: IUnknown): HRESULT; stdcall;
begin
  Result := TDirectSoundCreate(DXLoadLibrary('DSound.dll', 'DirectSoundCreate'))
    (lpGUID, lpDS, pUnkOuter);
end;

function DXDirectSoundEnumerate(lpCallback: TDSEnumCallbackA;
    lpContext: Pointer): HRESULT;
type
  TDirectSoundEnumerate = function(lpCallback: TDSEnumCallbackA;
    lpContext: Pointer): HRESULT; stdcall;
begin
  Result := TDirectSoundEnumerate(DXLoadLibrary('DSound.dll', 'DirectSoundEnumerateA'))
    (lpCallback, lpContext);
end;

function DXDirectSoundCaptureCreate(lpGUID: PGUID; out lplpDSC: IDirectSoundCapture;
  pUnkOuter: IUnknown): HRESULT;
type
  TDirectSoundCaptureCreate = function(lpGUID: PGUID; out lplpDD: IDirectSoundCapture;
    pUnkOuter: IUnknown): HRESULT; stdcall;
begin
  try
    Result := TDirectSoundCaptureCreate(DXLoadLibrary('DSound.dll', 'DirectSoundCaptureCreate'))
      (lpGUID, lplpDSC, pUnkOuter);
  except
    raise EDirectXError.Create(SSinceDirectX5);
  end;
end;

function DXDirectSoundCaptureEnumerate(lpCallback: TDSEnumCallbackA;
    lpContext: Pointer): HRESULT;
type
  TDirectSoundCaptureEnumerate = function(lpCallback: TDSEnumCallbackA;
    lpContext: Pointer): HRESULT; stdcall;
begin
  try
    Result := TDirectSoundCaptureEnumerate(DXLoadLibrary('DSound.dll', 'DirectSoundCaptureEnumerateA'))
      (lpCallback, lpContext);
  except
    raise EDirectXError.Create(SSinceDirectX5);
  end;
end;

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;