unit ToneGen;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, MMSystem, Math;

//default values
const
     AttDef=10;
     DecDef=20;
     SusDef=50;
     RelDef=30;
     DurDef=100;
     FreDef=440;
     VolDef=100;

type
  TTGWave = (tgSine,tgSquare,tgTriangle,tgSawtooth,tgNoise);
  TTGResolution = (tg16Bit,tg8Bit);
  TTGQuality = (tgHiQ,tgLoQ);
  TToneGen = class(TComponent)

  private
    { Private declarations }
    HasChanged: bool;
    HasADSRChanged: bool;
    HasToneChanged: bool;
    HasStopped: bool;
    Buffer: PChar;
    fFrequency: Smallint;
    fDuration: Smallint;
    fWaveform: TTGWave;
    fAttack: Smallint;
    fDecay: Smallint;
    fSustain: Smallint;
    fRelease: Smallint;
    fAsync: bool;
    fLoop: bool;
    fResolution: TTGResolution;
    fQuality: TTGQuality;
    fLeftVolume: Smallint;
    fRightVolume: Smallint;
    DeviceID: Integer;

    procedure SetFrequency(Freq: Smallint);
    procedure SetDuration(Dur: Smallint);
    procedure SetWaveform(Wave: TTGWave);
    procedure SetAttack(Att: Smallint);
    procedure SetDecay(Decy: Smallint);
    procedure SetSustain(Sus: Smallint);
    procedure SetRelease(Rel: Smallint);
    procedure SetResolution(Res: TTGResolution);
    procedure SetQuality(Qual: TTGQuality);
    function GetVolume: DWORD;
    procedure SetVolume;
    procedure SetLeftVolume(LVol: Smallint);
    procedure SetRightVolume(RVol: Smallint);
    function CreateWaveform(DoADSR: bool): bool;
    procedure ADSRWaveform(Buf: PChar;BufferSize: Integer);
    procedure PlayWave;
    function LimitValue(lower,upper,val: Smallint):Smallint;
    function GetPercentage(PC: Smallint):Smallint;
    class function InstanceCount: Integer;
    class function GetOriginalVolume: DWORD;

  protected
    { Protected declarations }
  public
    { Public declarations }

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Frequency: Smallint read fFrequency write SetFrequency default FreDef;
    property Duration: Smallint read fDuration write SetDuration default DurDef;
    property Waveform: TTGWave read fWaveform write SetWaveform default tgSine;
    property Attack: Smallint read fAttack write SetAttack default AttDef;
    property Decay: Smallint read fDecay write SetDecay default DecDef;
    property Sustain: Smallint read fSustain write SetSustain default SusDef;
    property Release: Smallint read fRelease write SetRelease default RelDef;
    property Async: bool read fAsync write fAsync default true;
    property Loop: bool read fLoop write fLoop default false;
    property Resolution: TTGResolution read fResolution write SetResolution default tg16Bit;
    property Quality: TTGQuality read fQuality write SetQuality default tgHiQ;
    property LeftVolume: Smallint read fLeftVolume write SetLeftVolume default VolDef;
    property RightVolume: Smallint read fRightVolume write SetRightVolume default VolDef;
    procedure Play;
    procedure PlayADSR;
    procedure Stop;
    procedure PresetVolume;
    procedure Prepare;
    procedure PrepareADSR;

  end;

procedure Register;

function TheToneGen: TToneGen;

implementation

type
{ format of WAV file header }
  TWavHeader = record         { parameter description }
    rId             : longint; { 'RIFF'  4 characters }
    rLen            : longint; { length of DATA + FORMAT chunk }
    { FORMAT CHUNK }
    wId             : longint; { 'WAVE' }
    fId             : longint; { 'fmt ' }
    fLen            : longint; { length of FORMAT DATA = 16 }
    { format data }
    wFormatTag      : word;    { $01 = PCM }
    nChannels       : word;    { 1 = mono, 2 = stereo }
    nSamplesPerSec  : longint; { Sample frequency ie 11025}
    nAvgBytesPerSec : longint; { = nChannels * nSamplesPerSec *
                              (nBitsPerSample/8) }
    nBlockAlign     : word;    { = nChannels * (nBitsPerSAmple / 8 }
    wBitsPerSample  : word;    { 8 or 16 }
    { DATA CHUNK }
    dId             : longint; { 'data' }
    wSampleLength   : longint; { length of SAMPLE DATA }
    { sample data : offset 44 }
    { for 8 bit mono = s[0],s[1]... :byte}
    { for 8 bit stereo = sleft[0],sright[0],sleft[1],sright[1]... :byte}
    { for 16 bit mono = s[0],s[1]... :word}
    { for 16 bit stereo = sleft[0],sright[0],sleft[1],sright[1]... :word}
  end;

var
   TTGCount: Integer=0;
   OriginalVolume: DWORD=0;

procedure Register;
begin
  RegisterComponents('Samples', [TToneGen]);
end;


//limit value
function TToneGen.LimitValue(lower,upper,val: Smallint):Smallint;
var
   msg:String;

begin
if (val>=lower) and (val<=upper) then
   begin
   Result:=val;
   Exit;
   end;

//error message?
if csDesigning in ComponentState then
   begin
   msg:='Value must be between '+IntToStr(lower)+' and '+IntToStr(upper);
   MessageBox(0,PChar(msg),'Error',MB_OK or MB_ICONERROR);
   end;

if val>upper then
   Result:=upper
else
    Result:=lower;


end;


//limit values  0 to 100 **********************************************
//if designing give warning
//force to limits
function TToneGen.GetPercentage(PC: Smallint):Smallint;
begin

Result:=LimitValue(0,100,PC);
end;

//preset tone and volume settings **********************************************
procedure TToneGen.Prepare;
begin

//setup volume
SetVolume;

//create wave
CreateWaveform(false);

end;

//preset ADSR and volume settings **********************************************
procedure TToneGen.PrepareADSR;
begin

//setup volume
SetVolume;

//create wave
CreateWaveform(true);

end;

//preset volume levels **********************************************
procedure TToneGen.PresetVolume;
begin

//setup volume
SetVolume;

end;

//play sound **********************************************
procedure TToneGen.PlayWave;
var
   Flags: DWORD;

begin

//stop any sounds first
Stop;

//setup volume
SetVolume;

Flags:=SND_SYNC;

if fAsync then Flags:=SND_ASYNC;

if fLoop then Flags:=SND_ASYNC or SND_LOOP;

Flags:=Flags or SND_MEMORY;


//play data in buffer
if Buffer<>nil then
   PlaySound(Buffer, 0, Flags);

end;

//play simple tone **********************************************
procedure TToneGen.Play;
begin

if HasChanged or HasToneChanged then
   CreateWaveform(false);

HasStopped:=false;

PlayWave;

//flag as having finished?
HasStopped:=not(Async or Loop);

end;

//play enveloped tone **********************************************
procedure TToneGen.PlayADSR;
begin

if HasChanged or HasADSRChanged then
   CreateWaveform(true);

HasStopped:=false;

PlayWave;

//flag as having finished?
HasStopped:=not(Async or Loop);

end;

//stop sound **********************************************
procedure TToneGen.Stop;
begin

//stop any sounds
PlaySound(nil, 0, 0);

//flag as having finished
HasStopped:=true;
end;


//get waveform volume **********************************************
function TToneGen.GetVolume: DWORD;
var
   vol: DWORD;
   wocs: WAVEOUTCAPS;
   CanDoLR: bool;

begin
vol:=0;

//can do left & right?
waveOutGetDevCaps(DeviceID,@wocs,sizeof(WAVEOUTCAPS));
if(wocs.dwFormats and WAVECAPS_LRVOLUME)>0 then
    CanDoLR:=true
else
    CanDoLR:=false;

//get volume?
waveOutGetVolume(DeviceID,@vol);

//copy mono level to right channel?
if not CanDoLR then
   vol:=vol+(vol shl $10);

Result:=vol;
end;

//set waveform volume **********************************************
procedure TToneGen.SetVolume;
var
   newvol: DWORD;
begin
//combine percentages
  newvol:=(($ffff * DWORD(fLeftVolume)) div 100)+((($ffff * DWORD(fRightVolume)) div 100) shl $10);

  //set volume
  waveOutSetVolume(DeviceID,newvol);
end;

//return original volume setting **********************************************
class function TToneGen.GetOriginalVolume: DWORD;
begin
Result:=OriginalVolume;
end;

//constructor **********************************************
constructor TToneGen.Create(AOwner: TComponent);
begin
  Inherited Create(AOwner);

  HasChanged:=true;
  HasADSRChanged:=true;
  HasToneChanged:=true;
  HasStopped:=true;

  Buffer:=nil;

  fFrequency:=FreDef;
  fDuration:=DurDef;
  fWaveform:=tgSine;
  fAttack:=AttDef;
  fDecay:=DecDef;
  fSustain:=SusDef;
  fRelease:=RelDef;
  fAsync:=true;
  fLoop:=false;
  fResolution:=tg16Bit;
  fQuality:=tgHiQ;
  fLeftVolume:=VolDef;
  fRightVolume:=VolDef;

  DeviceID:=0;

  //store volume settings
  if (InstanceCount=0) and not(csDesigning in ComponentState)then
     begin
     //store original settings
     OriginalVolume:=GetVolume;

     //initialise volume
     SetVolume;

     end;

  //increment instance count
  Inc(TTGCount);


end;

//destructor **********************************************
destructor TToneGen.Destroy;
var
   OV: DWORD;

begin

//stop playing
Stop;

//de-allocate memory
If Buffer<>nil then
   begin
   FreeMem(Buffer);
   Buffer:=nil;
   end;

//decrement instance count
Dec(TTGCount);

//restore volume settings
if (TTGCount=0)  and not(csDesigning in ComponentState) then
   begin
   OV:=GetOriginalVolume;
   waveOutSetVolume(DeviceID,OV);
   end;


inherited Destroy;
end;

//instance count **********************************************
class function TToneGen.InstanceCount: Integer;
begin
Result:=TTGCount;
end;

//set left volume **********************************************
procedure TToneGen.SetLeftVolume(LVol: Smallint);
begin
fLeftVolume:=GetPercentage(LVol);

//initialise volume
if (csLoading in ComponentState) or HasStopped then
   SetVolume;

end;

//set right volume **********************************************
procedure TToneGen.SetRightVolume(RVol: Smallint);
begin
fRightVolume:=GetPercentage(RVol);

//initialise volume
if (csLoading in ComponentState) or HasStopped then
   SetVolume;

end;

//set frequency **********************************************
procedure TToneGen.SetFrequency(Freq: Smallint);
begin
HasChanged:=true;
fFrequency:=LimitValue(20,20000,Freq);
end;

//duration **********************************************
procedure TToneGen.SetDuration(Dur: Smallint);
begin
HasChanged:=true;
fDuration:=LimitValue(10,$7FFF,Dur);
end;

//wave type **********************************************
procedure TToneGen.SetWaveform(Wave: TTGWave);
begin
HasChanged:=true;
fWaveform:=Wave;
end;

//attack **********************************************
procedure TToneGen.SetAttack(Att: Smallint);
begin
HasADSRChanged:=true;
fAttack:=GetPercentage(Att);
end;

//decay **********************************************
procedure TToneGen.SetDecay(Decy: Smallint);
begin
HasADSRChanged:=true;
fDecay:=GetPercentage(Decy);
end;

//sustain **********************************************
procedure TToneGen.SetSustain(Sus: Smallint);
begin
HasADSRChanged:=true;
fSustain:=GetPercentage(Sus);
end;

//release **********************************************
procedure TToneGen.SetRelease(Rel: Smallint);
begin
HasADSRChanged:=true;
fRelease:=GetPercentage(Rel);
end;

//8 or 16 bit **********************************************
procedure TToneGen.SetResolution(Res: TTGResolution);
begin
HasChanged:=true;
fResolution:=Res;
end;

//quality **********************************************
procedure TToneGen.SetQuality(Qual: TTGQuality);
begin
HasChanged:=true;
fQuality:=Qual;
end;


//create wave header ****************************************
procedure CreateWavHeader( stereo: bool;{ t=stereo  f=mono }
                     hires : bool;    { t=16bits, f=8 }
                     hirate       : bool; { sample rate t=44100 f=22050}
                     datasize: longint; {date block size}
                     var wh: TWavHeader { Wavheader ref } );
var
   resolution,channels: word;
   rate: longint;

begin

//stereo/mono?
if stereo=true then
   channels:=2
else
    channels:=1;

//16bit/8bit?
if hires=true then
   resolution:=16
else
    resolution:=8;

//44100/22050 bps?
if hirate=true then
   rate:=96000
else
    rate:=44100;

 wh.rId            := $46464952; { 'RIFF' }
 wh.rLen           := datasize+36;        { length of sample + format }
 wh.wId            := $45564157; { 'WAVE' }
 wh.fId            := $20746d66; { 'fmt ' }
 wh.fLen           := 16;        { length of format chunk }
 wh.wFormatTag     := 1;         { PCM data }
 wh.nChannels      := channels;  { mono/stereo }
 wh.nSamplesPerSec := rate;      { sample rate }
 wh.nAvgBytesPerSec := channels*rate*(resolution div 8);
 wh.nBlockAlign    := channels*(resolution div 8);
 wh.wBitsPerSample := resolution;{ resolution 8/16 }
 wh.dId            := $61746164; { 'data' }
 wh.wSampleLength  := datasize;         { sample size }

end;

//**********************************************************************
//modify data to ADSR settings
procedure TToneGen.ADSRWaveform(Buf: PChar;BufferSize: Integer);
var
   Total,i: Cardinal;
   Start,Samples,Cnt: Cardinal;
   BufValue: Integer;
   SampleFactor,SusFactor: Real;
   Env,EnvDur: Cardinal;
   SusDuration: Cardinal;
   iBuffer: ^SmallInt;
   ResFactor: Integer;
   AttackV, DecayV, SustainV, ReleaseV: Integer;
   HiRes: bool;
begin
  if fResolution=tg16Bit then begin
    HiRes:=true;
  end else begin
    HiRes:=false;
  end;

  AttackV:=fAttack;
  DecayV:=fDecay;
  SustainV:=fSustain;
  ReleaseV:=fRelease;

//1/2 no of samples for 16bit
if HiRes then
   ResFactor:=2
else
   ResFactor:=1;

Total:=AttackV+DecayV+ReleaseV;

//normalise percentages
  if Total>100 then begin
    AttackV := AttackV * 100 div Total;
    DecayV := DecayV * 100 div Total;
    ReleaseV := 100-(AttackV+DecayV);
    SusDuration := 0;
  end;

  SusDuration:=100-(AttackV+DecayV+ReleaseV);
  Samples:=SusDuration * BufferSize div (100 * ResFactor);
  if Samples<1 then begin
    SustainV:=0;
  end;

  //sustain level
  SusFactor:=SustainV/100;

  Start:=0;

  if HiRes then begin
    //create 16bit pointer
    iBuffer:=Pointer(Buf);
  end;


for Env:=0 to 3 do
 begin

 //envelope entry
 case Env of
      0://Attack
        begin
        EnvDur:=AttackV;
        Samples:=EnvDur * BufferSize div (100 * ResFactor);
        if Samples>0 then
           SampleFactor:=1/Samples
        else
            EnvDur:=0;
        end;
      1://Decay
        begin
        EnvDur:=DecayV;
        Samples:=EnvDur * BufferSize div (100 * ResFactor);
        if Samples>0 then
           SampleFactor:=(100-SustainV)/Samples/100
        else
            EnvDur:=0;
         end;
      2://Sustain
        begin
        EnvDur:=SusDuration;
        if ReleaseV=0 then
           Samples:=max(0,((BufferSize div ResFactor)-Start))
        else
           Samples:=EnvDur * BufferSize div (100 * ResFactor);

        SampleFactor:=SusFactor;
        end;
      else//Release
          begin
          EnvDur:=ReleaseV;
          Samples:=max(0,((BufferSize div ResFactor)-Start));
          if Samples>0 then
             SampleFactor:=SusFactor/Samples
          else
             EnvDur:=0;
          end;
 end;

 //process envelope entry
 if EnvDur >0 then
    begin
    Cnt:=0;
    for i:=min(Start,BufferSize) to min(BufferSize,Start+Samples) do
        begin

        if HiRes then //16bit
           begin
           BufValue:=((iBuffer)^);
           end
        else//8bit
           begin
           BufValue:=Integer((Buf+i)^);
           BufValue:=BufValue-$80;
           end;

        case Env of
             0://Attack
               begin
               BufValue:=Trunc(Cnt * BufValue * SampleFactor);
               end;

             1://Decay
               begin
               BufValue:=BufValue-Trunc(Cnt * BufValue * SampleFactor);
               end;

             2://Sustain
               begin
               BufValue:=Trunc(BufValue * SampleFactor);
               end;

             3://Release
               begin
               BufValue:=Trunc((Samples-Cnt) * BufValue * SampleFactor);
               end;

        end;

        if HiRes then //16bit
           begin
           (iBuffer)^:=SmallInt(BufValue);
           Inc(iBuffer);
           end
        else//8bit
            begin
            (Buf+i)^:=Char($80+BufValue);
            end;

        Cnt:=Cnt+1;

        end;

    Start:=Start+Samples+1;

    end;
 end;

HasADSRChanged:=false;
HasChanged:=false;
HasToneChanged:=true;

end;


//**********************************************************************
//create waveform
function TToneGen.CreateWaveform(DoADSR: bool): bool;
var
   wh: TWavHeader;
   SineAdd,BufSize,HdrSize,i: Integer;
   DataBuf: PChar;
   MaxVal,MinVal,CalcVal: Real;
   BytesPerSample,SampsPerInterval: Cardinal;
   DoStereo: bool;
   CycleCount,cnt,CycleMidPoint,SamplesPerCycle: Cardinal;
   FPSamplesPerCycle,FPVerticalStep,FPVerticalAdd :Real;
   HiRes,HiQ: bool;
//   wfh: Integer;
begin

//only mono for now
dostereo:=false;

//size of header record
HdrSize:=sizeof(TWavHeader);

//no of bytes per sample
if fResolution=tg16Bit then
   begin
   BytesPerSample:=2;
   MaxVal:=65534;
   MinVal:=-32767;
   SineAdd:=0;
   HiRes:=true;
   end
else
    begin
    BytesPerSample:=1;
    MaxVal:=255;
    MinVal:=0;
    SineAdd:=1;
    HiRes:=false;
    end;

//no of samples per S/100
if fQuality=tgHiQ then
   begin
   SampsPerInterval:=960;
   HiQ:=true;
   end
else
   begin
   SampsPerInterval:=441;
   HiQ:=false;
   end;


//buffer size
BufSize:=(BytesPerSample * Duration * SampsPerInterval) div 10;//*2 for stereo

//create header
CreateWavHeader(dostereo,HiRes,HiQ,BufSize,wh);

//allocate memory for data buffer
if Buffer<>nil then
   begin
   FreeMem(Buffer);
   Buffer:=nil;
   end;

//stop any sounds
PlaySound(nil, 0, 0);

try
   Buffer:=AllocMem(BufSize+HdrSize+4);
except
   Result:=false;
   Exit;
end;

if Buffer=nil then
   begin
   result:=false;
   Exit;
   end;

//copy header data to start of buffer
CopyMemory(Buffer,@wh,HdrSize);

//floating point samples per cycle
FPSamplesPerCycle:=(SampsPerInterval*100)/Frequency;

//samples per cycle
SamplesPerCycle:=Trunc(FPSamplesPerCycle);

//CycleMidPoint of cycle
CycleMidPoint:=SamplesPerCycle div 2;

//offset to data area
DataBuf:=Buffer+HdrSize;

//counter to step through cycles
CycleCount:=1;


FPVerticalStep:=0;
FPVerticalAdd:=0;

//write wav data to buffer

//sine step values
if fWaveform=tgSine then
   begin
   FPVerticalStep:=(pi*2)/SamplesPerCycle;

   end;

//sq step values
if fWaveform=tgSquare then
   begin
   if Hires then MaxVal:=32767;
   end;

//triangle vertical step size
if fWaveform=tgTriangle then
   begin
   FPVerticalStep:=MinVal;
   FPVerticalAdd:=MaxVal/CycleMidPoint;

   end;

//sawtooth vertical step size
if fWaveform=tgSawtooth then
   begin
   FPVerticalStep:=MinVal;
   FPVerticalAdd:=(MaxVal/SamplesPerCycle);

   end;


cnt:=0;
i:=0;
while i<BufSize  do
      begin

      //select wave type
      case fWaveform of
          //sine
              tgSine:
              begin
              CalcVal:=Trunc((sin(cnt * FPVerticalStep)+SineAdd)/2*MaxVal);

              end;

              //square
              tgSquare:
              begin
              if cnt<CycleMidPoint then
                 CalcVal:=MinVal
              else
                  CalcVal:=MaxVal;

              end;

              //triangle
              tgTriangle:
              begin
              if cnt<CycleMidPoint then
                 begin
                 CalcVal:=Trunc(FPVerticalStep);
                 FPVerticalStep:=FPVerticalStep+FPVerticalAdd;
                 end
              else
                  begin
                  CalcVal:=Trunc(FPVerticalStep);
                  FPVerticalStep:=FPVerticalStep-FPVerticalAdd;
                  end;
              end;

              //sawtooth
              tgSawtooth:
              begin

              CalcVal:=Trunc(FPVerticalStep);
              FPVerticalStep:=FPVerticalStep+FPVerticalAdd;

              end;

              //noise
              else
                  CalcVal:=random(Trunc(MaxVal+1));
              end;


              //8bit or 16?
              if HiRes then
                 begin
                 (DataBuf+i)^:=Char(Trunc(CalcVal) and $ff);
                 (DataBuf+i+1)^:=Char(Trunc(CalcVal) div $100);
                 i:=i+2;
                 end
              else
                  begin
                  (DataBuf+i)^:=Char(Trunc(CalcVal));
                  i:=i+1;
                  end;

              cnt:=cnt+1;

              if cnt=SamplesPerCycle then
                 begin
                 cnt:=0;
                 if fWaveform<>tgSine then
                 begin
                 FPVerticalStep:=MinVal;
                 end;

              CycleCount:=CycleCount+1;

              //update samples per cycle
              SamplesPerCycle:=Trunc((FPSamplesPerCycle*CycleCount)-(Trunc(FPSamplesPerCycle*(CycleCount-1))));

              //CycleMidPoint of cycle
              CycleMidPoint:=SamplesPerCycle div 2;
          end;
      end;

HasADSRChanged:=true;
HasChanged:=false;
HasToneChanged:=false;

//pass to ADSR routine
if DoADSR then
   begin

   ADSRWaveform(DataBuf,BufSize);

   end;

//temporary
{wfh:=FileCreate('c:\test.wav');
if wfh<>-1 then
   begin
   FileWrite(wfh,Buffer^,BufSize+HdrSize);
   FileClose(wfh);
   end;}
//******

Result:=true;

end;

var
  FToneGen: TToneGen = nil;

function TheToneGen: TToneGen;
begin
  if FToneGen = nil then
    FToneGen := TToneGen.Create(nil);
  Result := FToneGen;
end;

initialization
  TheToneGen;
finalization
 FreeAndNil(FToneGen);
end.
