home *** CD-ROM | disk | FTP | other *** search
/ Audio 4.94 - Over 11,000 Files / audio-11000.iso / mac / soundutl / unsn070b.hqx / MakePitchTable.p < prev    next >
Encoding:
Text File  |  1992-06-15  |  1.0 KB  |  52 lines
  1. program MakePitchTable;
  2.  
  3.     type
  4.         PitchTable = array[0..127] of longint;
  5.     var
  6.         TheTable: PitchTable;
  7.  
  8.     procedure InitPitchTable (var TheTable: PitchTable);
  9.         const
  10.             SemiTone = 1.0594630943592953;
  11.             HalfSampleRate = 22050.0;
  12.             TwoPower23 = 8388608.0;
  13.             MiddleA = 69;
  14.             MiddleAPitch = 440.0;
  15.         var
  16.             APitch, NextPitch: double;
  17.             i: integer;
  18.     begin
  19.         APitch := (MiddleAPitch / HalfSampleRate) * TwoPower23;
  20.         TheTable[MiddleA] := Round(APitch);
  21.  
  22.         NextPitch := APitch;
  23.         for i := MiddleA - 1 downto 0 do
  24.             begin
  25.                 NextPitch := NextPitch / SemiTone;
  26.                 TheTable[i] := Round(NextPitch);
  27.             end;
  28.  
  29.         NextPitch := APitch;
  30.         for i := MiddleA + 1 to 127 do
  31.             begin
  32.                 NextPitch := NextPitch * SemiTone;
  33.                 TheTable[i] := Round(NextPitch);
  34.             end;
  35.     end; {InitPitchTable}
  36.  
  37.     procedure WritePitchTable (var T: PitchTable);
  38.         var
  39.             F: text;
  40.             i: integer;
  41.     begin
  42.         open(F, Newfilename('junk'));
  43.         write(F, 'table ');
  44.         for i := 0 to 127 do
  45.             write(F, T[i] : 1, ' ');
  46.         close(F);
  47.     end;
  48.  
  49. begin
  50.     InitPitchTable(TheTable);
  51.     WritePitchTable(TheTable);
  52. end.