program shepard;
{$N+}
uses crt;
const f=1600;
type real=single;
var  asdat:string;
     wahl:char;

procedure wavw(wahl:char);
{8-Bit-Mono Daten}
const ftstart=44;traillen=24;blockl=22050;
const header:array[0..ftstart-1] of Byte=
($52,$49,$46,$46,                      {"RIFF"}
$F6,$5F,4,0,                           {Dateil„nge-8}
$57,$41,$56,$45,$66,$6D,$74,$20,       {"WAVEfmt "}
$10,0,0,0,
1,0,1,0,                               {mono}
$22,$56,0,0,$22,$56,0,0,               {Sample-Frequenz,Bytes pro s}
1,0,                                   {Bytes pro Sample}
8,0,                                   {Bits pro Sample}
$64,$61,$74,$61,                       {"data"}
$BA,$5F,4,0);                          {L„nge des Datenblocks}

const trail:array[0..traillen-1] of byte=
($4C,$49,$53,$54,
$10,0,0,0,
$49,$4E,$46,$4F,$49,$53,$46,$54,
4,0,0,0,
$47,$59,$4B,$4F);
const zwz=1.059463094;
type Tbbuff=array[0..blockl-1] of byte;
     Tpz=^Tbbuff;

var wavdat:file;
    m,y:longint;
    a,t,mm,fv:real;
    pz:Tpz;
    pot:array[0..12] of real;

begin
  pot[0]:=1;
  assign(wavdat,asdat+'.wav');
  rewrite(wavdat,1);
  blockwrite(wavdat,header,ftstart);
  new(pz);
  for m:=0 to 12 do
  begin
    if m>0 then pot[m]:=pot[m-1]*zwz;
    for y:=0 to blockl-1 do
    begin
      t:=y/blockl;
      case wahl of
      'd':begin
            mm:=m;
            fv:=pot[m];
          end;
      'k':begin
            mm:=(m*blockl+y)/blockl;
            fv:=exp(mm*ln(2)/12);
          end;
      end;
      a:=0.5*(0.5-mm/24)*sin(2*pi*f*fv*t)+
         0.5*(1.0-mm/24)*sin(2*pi*f/2*fv*t)+
         0.5*(0.5+mm/24)*sin(2*pi*f/4*fv*t)+
         0.5*mm/24*sin(2*pi*f/8*fv*t);
      pz^[y]:=128+trunc(127*a);
    end;
    blockwrite(wavdat,pz^,blockl);
    writeln(m+1:2,'.Sekunde');
  end;
  blockwrite(wavdat,trail,traillen);
  dispose(pz);
  close(wavdat);
end;

begin
  clrscr;
  repeat
  write('Shepard Tonfolge mit diskretem(d) oder kontinuierlichem(k) Anstieg? ');
  readln(wahl);
  until wahl in ['d','k'];
  write('Name fr die zu erzeugende WAV-Datei eingeben (ohne wav) : ');
  readln(asdat);
  writeln('Die Berechnung der 13 T”ne kann ein biáchen dauern.');
  wavw(wahl);
  writeln('fertig');
end.