Program Krecord1;  { Written by Kenneth Manos 04/14/87 - Cambridge, Ma.  }
{$C+}              { Play a 3 octave keyboard and record the notes.      }
                   { Replay forward or reversed.                         }
                   { Save to a file. Load/Replay from a file.            }
                   { Generate random notes.                              }

Type
 noterec = record
             nroctave,nrduration,nrsub: integer;
             nrnotetbl: array[1..500] of integer;
             nrintvtbl: array[1..500] of integer;
           end;
Var
  notefile: file of noterec;
  nrec: noterec;
  lim1,lim2,hh,mm,ss,ff,svhh,svmm,svss,svff: real;
  notex: char;
  note,octave,duration,sub1,sub2,sub3,lnth: integer;
  notetbl: array[1..500] of integer;
  intvtbl: array[1..500] of integer;
  filnam1,filnam2: string[30];
Const
  chartbl: string[36] = 'ASDFGHJKL;''/QWERTYUIOP[]1234567890-=';
Label
  ExitMainLine;

Procedure DisplayMenu;
{ Display the menu }
begin
  Writeln('Enter Note: (Top Three Rows On Keyboard)');
  Writeln(' (Enter "x" To Exit Program)');
  Writeln(' (Enter ">" To Replay - Forward)');
  Writeln(' (Enter "<" To Replay - Reverse)');
  Writeln(' (Enter "?" To Display This Menu)');
  Writeln(' (Enter "c" To Generate Random Notes)');
  Writeln(' (Enter "z" To Reset Options/Clear Memory)');
  Writeln(' (Enter "v" To Save Recording To A Disk File)');
  Writeln(' (Enter "b" To Play Recording From A Disk File)');
  Writeln(' (Enter "n" To Load Recording From A Disk File Into Memory)');
end;

Procedure PlayNote(octave,note,duration: integer);
{ Play note in octave for duration (in ms).   }
{ Frequency computed by first computing C in  }
{ octave and then increasing it by note-1     }
{ times the twelfth root of 2. (1.059463994). }
Var
  frequency: real;
begin
  frequency := 32.625;
  for sub3 := 1 to octave do       { Compute C in octave }
    frequency := frequency * 2;
  for sub3 := 1 to (note - 1) do   { Increase frequency note-1 times }
    frequency := frequency * 1.059463094;
  Sound(Round(frequency));
  Delay(duration);
  NoSound;
end;

Procedure GetTime;
{ Get the system time from DOS }
Type
  regpack = record
             ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
           end;
Var
  regs: regpack;
begin
  svhh := hh;  svmm := mm;  svss := ss;  svff := ff;
  with regs do
  begin
    ax := $2C00;
    MsDos(regs);                   { Get system time from DOS }
    hh := Int(Hi(cx));             { Hour }
    mm := Int(Lo(cx));             { Minute }
    ss := Int(Hi(dx));             { Second }
    ff := Int(Lo(dx));             { Fraction of second }
  end;
end;

Function Interval: integer;
{ Return the time interval between two notes }
Var
  tt: real;
begin
  GetTime;
  if (sub1 > 0) then
  begin
    tt := (hh - svhh)*3600 + (mm - svmm)*60 + (ss - svss) + (ff - svff)/100;
    tt := Abs(tt * 1000 - 100);
    if (tt > 30000) then           { Protect against fixed point overflow }
      tt := 1000;
    Interval := Round(tt);
  end;
end;

Function Rand(var testlim: real): integer;
{ Return a random number between 1 and testlim based on system time }
Var
  rr: real;
begin
  GetTime;
  rr := (hh + 1) * (mm + 1) * (ss + 1) * (ff + 1) * pi;
  rr := Frac(rr / (testlim + 1)) * (testlim +1);
  Rand := Round(rr + 0.5);
end;

Procedure Siren;
{ Sound a siren }
Var
  frequency: integer;
begin
  for frequency := 300 to 3000 do
  begin
    Delay(1);
    Sound(frequency);
  end;
  Delay(1000);
  for frequency := 3000 downto 300 do
  begin
    Delay(1);
    Sound(frequency);
  end;
  NoSound;
end;

Procedure GetFileName;
{ Get a file name from the console. }
{ Default file name is in filnam2.  }
{ Default file extension is "NOT".  }
begin
  Readln(filnam1);
  lnth := Length(filnam1);
  if (lnth = 0) then
  begin
    filnam1 := filnam2;
    exit;
  end;
  for sub2 := 1 to lnth do
    filnam1[sub2] := UpCase(filnam1[sub2]);
  if (Pos('.',filnam1) = 0) then
    filnam1 := Concat(filnam1,'.NOT');
  filnam2 := filnam1;
end;

Procedure SaveToFile;
{ Save this recording to a disk file. }
begin
  Writeln('Enter File Name Of Recording To Be Saved (',filnam2,')');
  GetFileName;
  with nrec do
  begin
    Assign(notefile,filnam1);
    Rewrite(notefile);
    Flush(notefile);
    nrsub := sub1;
    nroctave := octave;
    nrduration := duration;
    for sub2 := 1 to nrsub do
    begin
      nrnotetbl[sub2] := notetbl[sub2];
      nrintvtbl[sub2] := intvtbl[sub2];
    end;
    Write(notefile,nrec);
    Close(notefile);
  end;
end;

Procedure PlayFromFile;
{ Play a recording from a disk file. }
begin
  Writeln('Enter File Name Of Recording To Be Played (',filnam2,')');
  GetFileName;
  with nrec do
  begin
    Assign(notefile,filnam1);
    {$I-}
    Reset(notefile);
    {$I+}
    if (IOresult <> 0) then
    begin
      Writeln(' ** Note File Not Found **');
      exit;
    end;
    Read(notefile,nrec);
    Writeln('** ',filnam2,': Octave=',nroctave,' Duration=',nrduration,
            ' #Notes=',nrsub);
    for sub2 := 1 to nrsub do
    begin
      Delay(nrintvtbl[sub2]);
      PlayNote(nroctave,nrnotetbl[sub2],nrduration);
    end;
    Flush(notefile);
    Close(notefile);
  end;
end;

Procedure LoadFromFile;
{ Load a recording from a disk file into memory. }
begin
  Writeln('Enter File Name Of Recording To Be Loaded (',filnam2,')');
  GetFileName;
  with nrec do
  begin
    Assign(notefile,filnam1);
    {$I-}
    Reset(notefile);
    {$I+}
    if (IOresult <> 0) then
    begin
      Writeln(' ** Note File Not Found **');
      exit;
    end;
    Read(notefile,nrec);
    Writeln('** ',filnam2,': Octave=',nroctave,' Duration=',nrduration,
            ' #Notes=',nrsub);
    for sub1 := 1 to nrsub do
    begin
      notetbl[sub1] := nrnotetbl[sub1];
      intvtbl[sub1] := nrintvtbl[sub1];
    end;
    Flush(notefile);
    Close(notefile);
  end;
end;

Procedure PlayRandom;
{ Play Random notes }
begin
  lim1 := 5;
  lim2 := 222;
  Writeln('    Enter High Octave (1-8) And High Note Duration (ms)');
  Readln(lim1,lim2);
  lim1 := (lim1 - octave + 1) * 12;
  Writeln('    Hit Any Note To Stop');
  while (not KeyPressed)
  begin
    note := Rand(lim1);
    duration := Rand(lim2);
    Delay(Rand(lim2));
    PlayNote(octave,note,duration);
  end;
end;

Procedure ResetOptions;
{ Reset options/clear memory }
begin
  sub1 := 0;
  Writeln('Enter Octave (1-8) And Note Duration (ms)');
  Readln(octave,duration);
  if (octave < 1) or (octave > 8) then
  begin
    Writeln('** Invalid Octave: ',octave);
    octave := 3;
    Siren;
  end;
  DisplayMenu;                     { Display menu }
end;


Begin                              { Mainline logic }
  filnam2 := 'K1.NOT';
  octave := 3;
  duration := 100;
  notex := 'Z';
  while (notex <> 'X')
  begin
    if (notex = 'Z') then
    begin                          { Reset options/clear memory }
      ResetOptions;
      GetTime;                     { Reset interval timer }
      goto ExitMainLine;
    end;

    if (notex = 'V') then
    begin                          { Save recording to disk file }
      SaveToFile;
      GetTime;                     { Reset interval timer }
      goto ExitMainLine;
    end;

    if (notex = 'B') then
    begin                          { Play recording from disk file }
      PlayFromFile;
      GetTime;                     { Reset interval timer }
      goto ExitMainLine;
    end;

    if (notex = 'N') then
    begin                          { Load recording from disk file into memory }
      LoadFromFile;
      GetTime;                     { Reset interval timer }
      goto ExitMainLine;
    end;

    if (notex = '?') then
    begin                          { Display menu }
      DisplayMenu;
      GetTime;                     { Reset interval timer }
      goto ExitMainLine;
    end;

    if (notex = 'C') then
    begin                          { Generate random notes }
      PlayRandom;
      GetTime;                     { Reset interval timer }
      goto ExitMainLine;
    end;

    if (notex = '>') then
    begin                          { Replay from memory - forward }
      for sub2 := 1 to sub1 do
      begin
        Delay(intvtbl[sub2]);
        PlayNote(octave,notetbl[sub2],duration);
      end;
      GetTime;                     { Reset interval timer }
      goto ExitMainLine;
    end;

    if (notex = '<') then
    begin                          { Replay from memory - reverse }
      for sub2 := sub1 downto 1 do
      begin
        PlayNote(octave,notetbl[sub2],duration);
        Delay(intvtbl[sub2]);
      end;
      GetTime;                     { Reset interval timer }
      goto ExitMainLine;
    end;

    note := 0;
    for sub2 := 1 to 36 do
    begin                          { Determine numeric value of note }
      if chartbl[sub2] = notex then
        note := sub2;
    end;
    if (note = 0) then
    begin
      Writeln('** Invalid Note: ',notex);
      Siren;
      GetTime;                     { Reset interval timer }
      goto ExitMainLine;
    end;
    sub1 := sub1 + 1;               { Increment note subscript }
    notetbl[sub1] := note;          { Save this note }
    intvtbl[sub1] := Interval;      { Save time interval from last note }
    PlayNote(octave,note,duration); { Play this note }
  ExitMainLine:
    Read(kbd,notex);               { Get next note }
    notex := UpCase(notex);        { Convert to upper case }
  end;
End.