unit wave; 
 
interface 
 
uses 
  Windows, Classes, Controls, Forms, Dialogs, StdCtrls, SysUtils; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    Label1: TLabel; 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    function buildwave(Freq: array of double; Dauer: integer): pointer; 
    procedure frei; 
    procedure melodie;  
    procedure setlabel;  
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
uses mmsystem; 
 
const 
  Tonzahl = 6; 
  OrgRegstr = 5; 
 
var 
  toene: array[0..pred(Tonzahl)] of pointer; 
  OrganRegister: integer = 0; 
  maxl: integer = 1000; 
  SamplesPerSec: integer = 22050; 
  wavefmt: string = 'WAVEfmt '; 
  riff: string = 'RIFF'; 
  data: string = 'data'; 
  buf: pointer; 
 
function TForm1.buildwave(Freq: array of double; Dauer: integer): pointer; 
var 
  p: PChar; 
  br: single; 
  b, bs: integer; 
  wfe: tWAVEFORMATEX; 
  f: array of double; 
  i, j, count, grs: cardinal; 
  soc, lwf, sowfe, ldta, lr, h: integer; 
begin 
  wfe.wFormatTag := WAVE_FORMAT_PCM; 
  wfe.nChannels := 1; 
  wfe.nSamplesPerSec := SamplesPerSec; 
  wfe.wBitsPerSample := 8; 
  wfe.nBlockAlign := (wfe.nChannels * wfe.wBitsPerSample) shr 3; 
  wfe.nAvgBytesPerSec := SamplesPerSec * wfe.nBlockAlign; 
  soc := sizeof(cardinal); 
  lwf := length(wavefmt); 
  sowfe := sizeof(wfe); 
  ldta := length(data); 
  lr := length(riff); 
  count := (Dauer * SamplesPerSec) div 1000; 
  grs := soc * 2 + lwf + sowfe + ldta + count; 
  h := length(Freq); 
  setlength(f, h); 
  br := 255 / (h shl 1); 
  bs := round(br * h); 
  dec(h); 
  for i := 0 to h do 
    f[i] := 2 * pi * Freq[i] / SamplesPerSec; 
  getmem(buf, lr + soc + grs); 
  try 
    p := buf; 
    copymemory(p, @riff[1], lr); 
    inc(p, lr); 
    copymemory(p, @grs, soc); 
    inc(p, soc); 
    copymemory(p, @wavefmt[1], lwf); 
    inc(p, lwf); 
    copymemory(p, @sowfe, soc); 
    inc(p, soc); 
    copymemory(p, @wfe, sowfe); 
    inc(p, sowfe); 
    copymemory(p, @data[1], ldta); 
    inc(p, ldta); 
    copymemory(p, @count, soc); 
    inc(p, soc); 
    for i := 0 to pred(count) do begin 
      b := bs; 
      for j := 0 to h do 
        inc(b, trunc(br * sin(i * f[j]))); 
      copymemory(p, @b, 1); 
      inc(p); 
    end; 
  except 
    freemem(buf); 
    buf := nil; 
  end; 
  result := buf; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  setlabel; 
end; 
 
procedure TForm1.frei; 
var x: integer; 
begin 
  for x := 0 to pred(Tonzahl) do 
    if Toene[x] <> nil then begin 
      freemem(Toene[x]); 
      Toene[x] := nil; 
    end; 
  buf := nil; 
end; 
 
procedure TForm1.setlabel; 
begin 
  Label1.caption := 'Orgel-Register ' + inttostr(OrganRegister + 1); 
end; 
 
procedure TForm1.melodie; 
var 
  x: integer; 
  p: cardinal; 
  procedure pause; 
  begin 
    playsound(nil, 0, SND_PURGE); 
    sleep(p); 
  end; 
begin 
  p := 76; 
  for x := 0 to 3 do begin 
    playsound(toene[x], 0, SND_MEMORY or SND_ASYNC); 
    sleep(400); 
    pause; 
  end; 
  for x := 0 to 1 do begin 
    playsound(toene[4], 0, SND_MEMORY or SND_ASYNC); 
    sleep(800); 
    pause; 
  end; 
  for x := 0 to 3 do begin 
    playsound(toene[5], 0, SND_MEMORY or SND_ASYNC); 
    sleep(400); 
    pause; 
  end; 
  playsound(toene[4], 0, SND_MEMORY or SND_ASYNC); 
  sleep(800); 
  pause; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
  function ok: boolean; 
  var x: integer; 
  begin 
    for x := 0 to pred(Tonzahl) do 
      if toene[x] = nil then begin 
        showmessage('Fehler bei Wave-Erstellung'); 
        result := false; 
        exit; 
      end; 
    result := true; 
  end; 
begin 
  screen.cursor := crHourGlass; 
  button1.enabled := false; 
  button2.enabled := false; 
  case OrganRegister of 
    0: begin 
        toene[0] := buildwave([261.626], maxl); 
        toene[1] := buildwave([293.665], maxl); 
        toene[2] := buildwave([329.628], maxl); 
        toene[3] := buildwave([349.228], maxl); 
        toene[4] := buildwave([391.995], maxl); 
        toene[5] := buildwave([440.000], maxl); 
      end; 
    1: begin 
        toene[0] := buildwave([261.626, 523.251], maxl); 
        toene[1] := buildwave([293.665, 587.330], maxl); 
        toene[2] := buildwave([329.628, 659.255], maxl); 
        toene[3] := buildwave([349.228, 698.456], maxl); 
        toene[4] := buildwave([391.995, 783.991], maxl); 
        toene[5] := buildwave([440.000, 880.000], maxl); 
      end; 
    2: begin 
        toene[0] := buildwave([261.626, 130.813, 523.251], maxl); 
        toene[1] := buildwave([293.665, 146.832, 587.330], maxl); 
        toene[2] := buildwave([329.628, 164.814, 659.255], maxl); 
        toene[3] := buildwave([349.228, 174.614, 698.456], maxl); 
        toene[4] := buildwave([391.995, 195.998, 783.991], maxl); 
        toene[5] := buildwave([440.000, 220.000, 880.000], maxl); 
      end; 
    3: begin 
        toene[0] := buildwave([261.626, 130.813, 523.251, 65.406], maxl); 
        toene[1] := buildwave([293.665, 146.832, 587.330, 73.416], maxl); 
        toene[2] := buildwave([329.628, 164.814, 659.255, 82.407], maxl); 
        toene[3] := buildwave([349.228, 174.614, 698.456, 87.307], maxl); 
        toene[4] := buildwave([391.995, 195.998, 783.991, 97.999], maxl); 
        toene[5] := buildwave([440.000, 220.000, 880.000, 110.000], maxl); 
      end; 
  else begin 
      toene[0] := buildwave([261.626, 130.813, 523.251, 65.406, 1046.502], maxl); 
      toene[1] := buildwave([293.665, 146.832, 587.330, 73.416, 1174.659], maxl); 
      toene[2] := buildwave([329.628, 164.814, 659.255, 82.407, 1318.510], maxl); 
      toene[3] := buildwave([349.228, 174.614, 698.456, 87.307, 1396.913], maxl); 
      toene[4] := buildwave([391.995, 195.998, 783.991, 97.999, 1567.982], maxl); 
      toene[5] := buildwave([440.000, 220.000, 880.000, 110.000, 1760.000], maxl); 
    end; 
  end; 
  if ok then melodie; 
  frei; 
  button1.enabled := true; 
  button2.enabled := true; 
  screen.cursor := crDefault; 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  inc(OrganRegister); 
  if OrganRegister = OrgRegstr then OrganRegister := 0; 
  setlabel; 
end; 
 
end.