home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 September / Simtel20_Sept92.cdr / msdos / music / krecord1.arc / KRECORD1.PAS < prev   
Pascal/Delphi Source File  |  1987-04-23  |  10KB  |  354 lines
  1. Program Krecord1;  { Written by Kenneth Manos 04/14/87 - Cambridge, Ma.  }
  2. {$C+}              { Play a 3 octave keyboard and record the notes.      }
  3.                    { Replay forward or reversed.                         }
  4.                    { Save to a file. Load/Replay from a file.            }
  5.                    { Generate random notes.                              }
  6.  
  7. Type
  8.  noterec = record
  9.              nroctave,nrduration,nrsub: integer;
  10.              nrnotetbl: array[1..500] of integer;
  11.              nrintvtbl: array[1..500] of integer;
  12.            end;
  13. Var
  14.   notefile: file of noterec;
  15.   nrec: noterec;
  16.   lim1,lim2,hh,mm,ss,ff,svhh,svmm,svss,svff: real;
  17.   notex: char;
  18.   note,octave,duration,sub1,sub2,sub3,lnth: integer;
  19.   notetbl: array[1..500] of integer;
  20.   intvtbl: array[1..500] of integer;
  21.   filnam1,filnam2: string[30];
  22. Const
  23.   chartbl: string[36] = 'ASDFGHJKL;''/QWERTYUIOP[]1234567890-=';
  24. Label
  25.   ExitMainLine;
  26.  
  27. Procedure DisplayMenu;
  28. { Display the menu }
  29. begin
  30.   Writeln('Enter Note: (Top Three Rows On Keyboard)');
  31.   Writeln(' (Enter "x" To Exit Program)');
  32.   Writeln(' (Enter ">" To Replay - Forward)');
  33.   Writeln(' (Enter "<" To Replay - Reverse)');
  34.   Writeln(' (Enter "?" To Display This Menu)');
  35.   Writeln(' (Enter "c" To Generate Random Notes)');
  36.   Writeln(' (Enter "z" To Reset Options/Clear Memory)');
  37.   Writeln(' (Enter "v" To Save Recording To A Disk File)');
  38.   Writeln(' (Enter "b" To Play Recording From A Disk File)');
  39.   Writeln(' (Enter "n" To Load Recording From A Disk File Into Memory)');
  40. end;
  41.  
  42. Procedure PlayNote(octave,note,duration: integer);
  43. { Play note in octave for duration (in ms).   }
  44. { Frequency computed by first computing C in  }
  45. { octave and then increasing it by note-1     }
  46. { times the twelfth root of 2. (1.059463994). }
  47. Var
  48.   frequency: real;
  49. begin
  50.   frequency := 32.625;
  51.   for sub3 := 1 to octave do       { Compute C in octave }
  52.     frequency := frequency * 2;
  53.   for sub3 := 1 to (note - 1) do   { Increase frequency note-1 times }
  54.     frequency := frequency * 1.059463094;
  55.   Sound(Round(frequency));
  56.   Delay(duration);
  57.   NoSound;
  58. end;
  59.  
  60. Procedure GetTime;
  61. { Get the system time from DOS }
  62. Type
  63.   regpack = record
  64.              ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  65.            end;
  66. Var
  67.   regs: regpack;
  68. begin
  69.   svhh := hh;  svmm := mm;  svss := ss;  svff := ff;
  70.   with regs do
  71.   begin
  72.     ax := $2C00;
  73.     MsDos(regs);                   { Get system time from DOS }
  74.     hh := Int(Hi(cx));             { Hour }
  75.     mm := Int(Lo(cx));             { Minute }
  76.     ss := Int(Hi(dx));             { Second }
  77.     ff := Int(Lo(dx));             { Fraction of second }
  78.   end;
  79. end;
  80.  
  81. Function Interval: integer;
  82. { Return the time interval between two notes }
  83. Var
  84.   tt: real;
  85. begin
  86.   GetTime;
  87.   if (sub1 > 0) then
  88.   begin
  89.     tt := (hh - svhh)*3600 + (mm - svmm)*60 + (ss - svss) + (ff - svff)/100;
  90.     tt := Abs(tt * 1000 - 100);
  91.     if (tt > 30000) then           { Protect against fixed point overflow }
  92.       tt := 1000;
  93.     Interval := Round(tt);
  94.   end;
  95. end;
  96.  
  97. Function Rand(var testlim: real): integer;
  98. { Return a random number between 1 and testlim based on system time }
  99. Var
  100.   rr: real;
  101. begin
  102.   GetTime;
  103.   rr := (hh + 1) * (mm + 1) * (ss + 1) * (ff + 1) * pi;
  104.   rr := Frac(rr / (testlim + 1)) * (testlim +1);
  105.   Rand := Round(rr + 0.5);
  106. end;
  107.  
  108. Procedure Siren;
  109. { Sound a siren }
  110. Var
  111.   frequency: integer;
  112. begin
  113.   for frequency := 300 to 3000 do
  114.   begin
  115.     Delay(1);
  116.     Sound(frequency);
  117.   end;
  118.   Delay(1000);
  119.   for frequency := 3000 downto 300 do
  120.   begin
  121.     Delay(1);
  122.     Sound(frequency);
  123.   end;
  124.   NoSound;
  125. end;
  126.  
  127. Procedure GetFileName;
  128. { Get a file name from the console. }
  129. { Default file name is in filnam2.  }
  130. { Default file extension is "NOT".  }
  131. begin
  132.   Readln(filnam1);
  133.   lnth := Length(filnam1);
  134.   if (lnth = 0) then
  135.   begin
  136.     filnam1 := filnam2;
  137.     exit;
  138.   end;
  139.   for sub2 := 1 to lnth do
  140.     filnam1[sub2] := UpCase(filnam1[sub2]);
  141.   if (Pos('.',filnam1) = 0) then
  142.     filnam1 := Concat(filnam1,'.NOT');
  143.   filnam2 := filnam1;
  144. end;
  145.  
  146. Procedure SaveToFile;
  147. { Save this recording to a disk file. }
  148. begin
  149.   Writeln('Enter File Name Of Recording To Be Saved (',filnam2,')');
  150.   GetFileName;
  151.   with nrec do
  152.   begin
  153.     Assign(notefile,filnam1);
  154.     Rewrite(notefile);
  155.     Flush(notefile);
  156.     nrsub := sub1;
  157.     nroctave := octave;
  158.     nrduration := duration;
  159.     for sub2 := 1 to nrsub do
  160.     begin
  161.       nrnotetbl[sub2] := notetbl[sub2];
  162.       nrintvtbl[sub2] := intvtbl[sub2];
  163.     end;
  164.     Write(notefile,nrec);
  165.     Close(notefile);
  166.   end;
  167. end;
  168.  
  169. Procedure PlayFromFile;
  170. { Play a recording from a disk file. }
  171. begin
  172.   Writeln('Enter File Name Of Recording To Be Played (',filnam2,')');
  173.   GetFileName;
  174.   with nrec do
  175.   begin
  176.     Assign(notefile,filnam1);
  177.     {$I-}
  178.     Reset(notefile);
  179.     {$I+}
  180.     if (IOresult <> 0) then
  181.     begin
  182.       Writeln(' ** Note File Not Found **');
  183.       exit;
  184.     end;
  185.     Read(notefile,nrec);
  186.     Writeln('** ',filnam2,': Octave=',nroctave,' Duration=',nrduration,
  187.             ' #Notes=',nrsub);
  188.     for sub2 := 1 to nrsub do
  189.     begin
  190.       Delay(nrintvtbl[sub2]);
  191.       PlayNote(nroctave,nrnotetbl[sub2],nrduration);
  192.     end;
  193.     Flush(notefile);
  194.     Close(notefile);
  195.   end;
  196. end;
  197.  
  198. Procedure LoadFromFile;
  199. { Load a recording from a disk file into memory. }
  200. begin
  201.   Writeln('Enter File Name Of Recording To Be Loaded (',filnam2,')');
  202.   GetFileName;
  203.   with nrec do
  204.   begin
  205.     Assign(notefile,filnam1);
  206.     {$I-}
  207.     Reset(notefile);
  208.     {$I+}
  209.     if (IOresult <> 0) then
  210.     begin
  211.       Writeln(' ** Note File Not Found **');
  212.       exit;
  213.     end;
  214.     Read(notefile,nrec);
  215.     Writeln('** ',filnam2,': Octave=',nroctave,' Duration=',nrduration,
  216.             ' #Notes=',nrsub);
  217.     for sub1 := 1 to nrsub do
  218.     begin
  219.       notetbl[sub1] := nrnotetbl[sub1];
  220.       intvtbl[sub1] := nrintvtbl[sub1];
  221.     end;
  222.     Flush(notefile);
  223.     Close(notefile);
  224.   end;
  225. end;
  226.  
  227. Procedure PlayRandom;
  228. { Play Random notes }
  229. begin
  230.   lim1 := 5;
  231.   lim2 := 222;
  232.   Writeln('    Enter High Octave (1-8) And High Note Duration (ms)');
  233.   Readln(lim1,lim2);
  234.   lim1 := (lim1 - octave + 1) * 12;
  235.   Writeln('    Hit Any Note To Stop');
  236.   while (not KeyPressed)
  237.   begin
  238.     note := Rand(lim1);
  239.     duration := Rand(lim2);
  240.     Delay(Rand(lim2));
  241.     PlayNote(octave,note,duration);
  242.   end;
  243. end;
  244.  
  245. Procedure ResetOptions;
  246. { Reset options/clear memory }
  247. begin
  248.   sub1 := 0;
  249.   Writeln('Enter Octave (1-8) And Note Duration (ms)');
  250.   Readln(octave,duration);
  251.   if (octave < 1) or (octave > 8) then
  252.   begin
  253.     Writeln('** Invalid Octave: ',octave);
  254.     octave := 3;
  255.     Siren;
  256.   end;
  257.   DisplayMenu;                     { Display menu }
  258. end;
  259.  
  260.  
  261. Begin                              { Mainline logic }
  262.   filnam2 := 'K1.NOT';
  263.   octave := 3;
  264.   duration := 100;
  265.   notex := 'Z';
  266.   while (notex <> 'X')
  267.   begin
  268.     if (notex = 'Z') then
  269.     begin                          { Reset options/clear memory }
  270.       ResetOptions;
  271.       GetTime;                     { Reset interval timer }
  272.       goto ExitMainLine;
  273.     end;
  274.  
  275.     if (notex = 'V') then
  276.     begin                          { Save recording to disk file }
  277.       SaveToFile;
  278.       GetTime;                     { Reset interval timer }
  279.       goto ExitMainLine;
  280.     end;
  281.  
  282.     if (notex = 'B') then
  283.     begin                          { Play recording from disk file }
  284.       PlayFromFile;
  285.       GetTime;                     { Reset interval timer }
  286.       goto ExitMainLine;
  287.     end;
  288.  
  289.     if (notex = 'N') then
  290.     begin                          { Load recording from disk file into memory }
  291.       LoadFromFile;
  292.       GetTime;                     { Reset interval timer }
  293.       goto ExitMainLine;
  294.     end;
  295.  
  296.     if (notex = '?') then
  297.     begin                          { Display menu }
  298.       DisplayMenu;
  299.       GetTime;                     { Reset interval timer }
  300.       goto ExitMainLine;
  301.     end;
  302.  
  303.     if (notex = 'C') then
  304.     begin                          { Generate random notes }
  305.       PlayRandom;
  306.       GetTime;                     { Reset interval timer }
  307.       goto ExitMainLine;
  308.     end;
  309.  
  310.     if (notex = '>') then
  311.     begin                          { Replay from memory - forward }
  312.       for sub2 := 1 to sub1 do
  313.       begin
  314.         Delay(intvtbl[sub2]);
  315.         PlayNote(octave,notetbl[sub2],duration);
  316.       end;
  317.       GetTime;                     { Reset interval timer }
  318.       goto ExitMainLine;
  319.     end;
  320.  
  321.     if (notex = '<') then
  322.     begin                          { Replay from memory - reverse }
  323.       for sub2 := sub1 downto 1 do
  324.       begin
  325.         PlayNote(octave,notetbl[sub2],duration);
  326.         Delay(intvtbl[sub2]);
  327.       end;
  328.       GetTime;                     { Reset interval timer }
  329.       goto ExitMainLine;
  330.     end;
  331.  
  332.     note := 0;
  333.     for sub2 := 1 to 36 do
  334.     begin                          { Determine numeric value of note }
  335.       if chartbl[sub2] = notex then
  336.         note := sub2;
  337.     end;
  338.     if (note = 0) then
  339.     begin
  340.       Writeln('** Invalid Note: ',notex);
  341.       Siren;
  342.       GetTime;                     { Reset interval timer }
  343.       goto ExitMainLine;
  344.     end;
  345.     sub1 := sub1 + 1;               { Increment note subscript }
  346.     notetbl[sub1] := note;          { Save this note }
  347.     intvtbl[sub1] := Interval;      { Save time interval from last note }
  348.     PlayNote(octave,note,duration); { Play this note }
  349.   ExitMainLine:
  350.     Read(kbd,notex);               { Get next note }
  351.     notex := UpCase(notex);        { Convert to upper case }
  352.   end;
  353. End.
  354.