unit tttwave;
{Ausgerichtete Recordfelder aus!}
{$A-}

interface

uses forms, //für application
     sysutils, //fileexists
     Classes, mmsystem, WinProcs;
const sampl441 = 441; //für eine 1/100-Sekunde
      sampl22050 = 50*sampl441; //22050
      TonDauer = 3;

type
  TRiffHeader = record
    riff: Array[0..3] OF Char;
    filesize: LongInt;
    typeStr: Array[0..3] OF Char;
  end;
  TChunkRec = record
    id: Array[0..3] OF Char;
    size: LongInt;
  end;
  TWaveFormatRec = record
    tag: Word;
    channels: Word;
    samplesPerSec: LongInt;
    bytesPerSec: LongInt;
    blockAlign: Word;
  end;
  TPCMWaveFormatRec = record
    wf: TWaveFormatRec;
    bitsPerSample: Word;
  end;
  TWAVHeader = record { WAV Format }
    riffHdr: TRiffHeader;
    fmtChunk: TChunkRec;
    fmt: TPCMWaveFormatRec;
    dataChunk: TChunkRec;
    { data follows here }
  end;

var lautstaerke: integer = 3200;
    Tonauswav: Boolean = false;
procedure spiele(fr1, fr2, fr3, fr4, fr5, fr6, fr7, fr8: double; tondauer: integer);
procedure spieleton(fr: double; tondauer: integer);
procedure spieleAngeklicktenPunkt(const k:integer);
procedure spieleRechtsAngeklicktenPunkt(const k:integer);

implementation

uses FileCtrl;


procedure HeadInit(var Header: TWAVHeader);
begin
  with Header do
  begin
    with riffHdr do
    begin
        //Schreibe 'RIFF' in die ersten 4 bytes
      riff[0] := char($52); riff[1] := char($49); riff[2] := char($46); riff[3] := char($46);
        // wird spaeter gesetzt;
      filesize := 0;
        //Schreibe 'WAVE' in die naechsten 4 bytes
      typeStr[0] := char($57); typeStr[1] := char($41); typeStr[2] := char($56); typeStr[3] := char($45);
    end;
    with fmtChunk do
    begin
        //Schreibe 'fmt' + char($20) in die naechsten 4 bytes
      id[0] := char($66); id[1] := char($6D); id[2] := char($74); id[3] := char($20);
      size := $10;
    end;
    with fmt.wf do
    begin
        //its 16 bit, 44kHz Stereo
      tag := 1; channels := 2;
      samplesPerSec := $AC44;
      bytesPerSec := MakeLong($B110, $2);
      blockAlign := 4;
      fmt.bitsPerSample := $10;
    end;
    with dataChunk do
    begin
        //Schreibe 'data' in die naechsten 4 bytes
      id[0] := char($64); id[1] := char($61); id[2] := char($74); id[3] := char($61);
      size := 0;
    end;
  end;
end;

function f0(const k: double): SmallInt;
begin
  //result := Round(sin(k*Pi/sampl22050)*lautstaerke); //reiner sinus
  result := Round(sin((k * Pi) / sampl22050) * lautstaerke) div 2 +
      Round(sin((2 * k * Pi) / sampl22050) * lautstaerke) div 4 + //1.Oberton
      Round(sin((3 * k * Pi) / sampl22050) * lautstaerke) div 6; //2.Oberton}
end;


function Abtastwert(const k1,k2,k3,k4,k5,k6,k7,k8: double): SmallInt; //
  var f:Smallint;
begin //z.B. k=i*frw1 (für i=441*500(5Sek) frw1=100)=max=sampl220500000
                                           //Longword=0..4294967295
  if k1=0 then Begin result:=0; exit End else f:=f0(k1);
  result:=f;
  if k2=0 then exit;
  if k2<>k1 then f:=f0(k2); //else f=f0(k1)
  result:=result+f;
  if k3=0 then exit;
  if k3<>k2 then f:=f0(k3); //else f=f0(k2)
  result:=result+f;
  if k4=0 then exit;
  if k4<>k3 then f:=f0(k4); //else f=f0(k3)
  result:=result+f;
  if k5=0 then exit;
  if k5<>k4 then f:=f0(k5); //else f=f0(k4)
  result:=result+f;
  if k6=0 then exit;
  if k6<>k5 then f:=f0(k6); //else f=f0(k5)
  result:=result+f;
  if k7=0 then exit;
  if k7<>k6 then f:=f0(k7); //else f=f0(k6)
  result:=result+f;
  if k8=0 then exit;
  if k8<>k7 then result:=result+f0(k8) else result:=result+f;
end;

procedure spiele(fr1, fr2, fr3, fr4, fr5, fr6, fr7, fr8: double; tondauer: integer);

var ms: TMemoryStream;
  Header: TWavHeader;
  i: integer; //z.B. i=0 to 441*500=441500 (5 Sekunden)
  s: SmallInt;
begin
  HeadInit(Header);
  Header.Datachunk.size := sampl441 * tondauer * 2 * 2; //441*cs Samples pro sekunde,
                                                  //2 Channels, 2Bytes (16bit)
  //FileSize = DataSize + HeaderSize
  Header.riffHdr.FileSize := Header.Datachunk.size + 24;
  ms := TMemoryStream.Create;
  try
    ms.Seek(0, 0);
    //Write Header to Stream
    ms.Write(Header, sizeof(header));
    //form here: just data chunks. in this case (16bit stereo):
    // 16bit LeftValue, 16bit Right Value, 16bit LeftValue, 16bit Right Value ...
    // in the range of a SmallInt
    if tondauer <= 0 then exit; //kein Ton. Sollte nicht vorkommen
    for i := 0 to sampl441 * tondauer - 2 do BEgin
        //Writing left channel

        s := Abtastwert(i * fr1, i * fr2, i * fr3, i * fr4,
                        i * fr5, i * fr6, i * fr7, i * fr8);
        ms.Write(s, 2);
        //Writing to right channel
        ms.Write(s, 2);
    ENd;
  Finally
    if not sndPlaySound(ms.Memory, SND_MEMORY or SND_SYNC) then;
    ms.Free;
  End;
    { sndPlaySound(ms.Memory, SND_MEMORY or SND_ASYNC or SND_LOOP)
       führt bei WinNT zu Fehler. Deshalb dort nur snd_sync
       sndPlaySound(ms.Memory, SND_MEMORY or SND_SYNC or SND_LOOP) }
end;

procedure spieleton(fr: double; tondauer: integer);
begin
  spiele(fr, 0, 0, 0, fr, 0, 0, 0, tondauer);
end;

procedure spieleAngeklicktenPunkt(const k:integer);
  const aa: array[1..3] of double = (440/2,550/2,660/2);
begin
  if TonausWav then exit;
  if k <= 3 then spieleton(aa[k], TonDauer) else spieleton(440/2,TonDauer);
end;

procedure spieleRechtsAngeklicktenPunkt(const k:integer);
begin
  if TonausWav then exit;
  case k of 1: spiele(220,220,220,220,0,0,0,0,TonDauer*2);
            2: spiele(440/2,550/2,0,0,0,0,0,0,TonDauer*2);
            3: spiele(440/2,550/2,660/2,0,0,0,0,0,TonDauer*2);
           else spieleton(440/2,TonDauer);
  end;
end;

end.