{    (c) 1984 by Neil J. Rubenking  }
program IBMPiano;
type
  NoteRecord = record
                  C,CS,D,DS,E,F,FS,G,GS,A,AS,B: integer;
               end;
  Locations  = array[39..122] of byte;
  FiledNote  = record
                 Octave, Note, Duration : integer;
               end;
  Score      = ^item;
  item       = record
                 Note : FiledNote;
                 next : Score;
               end;
Const
  Notes: NoteRecord =
          (C:1;CS:2;D:3;DS:4;E:5;F:6;FS:7;G:8;GS:9;A:10;AS:11;B:12);
var
  ToggleByte       : byte absolute $0040:$0017;
  done, recording,
  VeryFirst        : boolean;
  octave, duration,
  NoteNum          : integer;
  XLoci, YLoci     : Locations;
  ScreenSeg        : integer;
  LastKey          : char;
  style            : byte;
  MusicFile        : file of FiledNote;
  List, Pointer,
  EndPointer       : Score;
  LastTime         : real;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure DisposeAll(var List : Score);
  begin
    if List <> nil then
      begin
        DisposeAll(List^.next);
        dispose(List);
      end;
  List := nil;
  LastTime := 0;
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure Attribute(row,startx,endx,att:byte);
var
  LocationCode : integer;
  N            : byte;
begin
  for N := startx to endx do
    begin
      LocationCode := (N-1)*2 + (row-1)*160;
      Mem[ScreenSeg:locationCode+1] := att;
    end;
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
function time: real;
type
  regpack = record
              ax,bx,cx,dx,bp,di,si,ds,es,flags: integer;
            end;

var
  recpack:          regpack;             {assign record}
  ah,al,ch,cl,dh:   byte;
  hour,min,sec,hund :     byte;

begin
  ah := $2c;                             {initialize correct registers}
  with recpack do
  begin
    ax := ah shl 8 + al;
  end;
  intr($21,recpack);                     {call interrupt}
  with recpack do
  begin
    hour := cx shr 8;
    min  := cx mod 256;
    sec  := dx shr 8;
    hund := dx mod 256;
  end;
  time := hund/100 + sec + 60*min;
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure recorder(AnOctave,ANote : integer);
var
  ThisDur, ThisTime : real;
  NoteToAdd         : FiledNote;
  {----------------------------------------------------}
   procedure AddNote(ItemToAdd:FiledNote);
     begin
       if VeryFirst then
         begin
           new(List);
           List^.Note := ItemToAdd;
           List^.next := nil;
           EndPointer := List;
           VeryFirst      := false;
         end
       else
         begin
           new(EndPointer^.next);
           EndPointer       := EndPointer^.next;
           EndPointer^.Note := ItemToAdd;
           EndPointer^.next := nil;
         end;
     end;
  {----------------------------------------------------}
  begin
    ThisTime := time;
    ThisDur := ThisTime - LastTime;
    ThisDur := ThisDur * 500;
    if NoteNum > 1 then
      begin
        with NoteToAdd do
          begin
            Octave   := AnOctave;
            note     := ANote;
            Duration := trunc(ThisDur);
          end;
        AddNote(NoteToAdd);
      end;
    NoteNum := NoteNum + 1;
    Attribute(4,60,62,112);
    LastTime := ThisTime;
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure Play(Octave,Note,Duration: integer);
var
  Frequency: real;
  I: integer;
begin
  if ToggleByte and 16 = 16 then duration := 0;
  Frequency:=32.625;
  for I:=1 to Octave do Frequency:=Frequency*2;
  for I:=1 to Note-1 do Frequency:=Frequency*1.059463094;
  if Duration<>0 then
  begin
    Sound(Round(Frequency));
    Delay(Duration);
    NoSound;
  end else Sound(Round(Frequency));
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure PlayBack;
begin
  Pointer := List;
  while Pointer <> nil do
    begin
      with Pointer^.Note do
            play(Octave,Note,Duration);
      Pointer := Pointer^.next;
    end;
  NoSound;
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure  convert(Letter : char;var note, AnOctave : integer);
begin
  note       := 0;
  AnOctave   := octave;
  with notes do
  begin
  case Letter of
    'q': note := Notes.C;
    'w': note := Notes.D;
    'e': note := Notes.E;
    'r': note := Notes.F;
    't': note := Notes.G;
    'y': note := Notes.A;
    'u': note := Notes.B;
    'i': begin
           note := Notes.C;
           AnOctave := AnOctave + 1;
         end;
    'o': begin
           note := Notes.D;
           AnOctave := AnOctave + 1;
         end;
    'p': begin
           note := Notes.E;
           AnOctave := AnOctave + 1;
         end;
    '[': begin
           note := Notes.F;
           AnOctave := AnOctave + 1;
         end;
    ']': begin
           note := Notes.G;
           AnOctave := AnOctave + 1;
         end;
    '2': note := Notes.CS;
    '3': note := Notes.DS;
    '5': note := Notes.FS;
    '6': note := Notes.GS;
    '7': note := Notes.AS;
    '9': begin
           note := Notes.CS;
           AnOctave := AnOctave + 1;
         end;
    '0': begin
           note := Notes.DS;
           AnOctave := AnOctave + 1;
         end;
    '=': begin
           note := Notes.FS;
           AnOctave := AnOctave + 1;
         end;
    '\': begin
           note := Notes.F;
           AnOctave := AnOctave - 2
         end;
    'z': begin
           note := Notes.G;
           AnOctave := AnOctave - 2
         end;
    'x': begin
           note := Notes.A;
           AnOctave := AnOctave - 2
         end;
    'c': begin
           note := Notes.B;
           AnOctave := AnOctave - 2
         end;
    'v': begin
           note := Notes.C;
           AnOctave := AnOctave - 1;
         end;
    'b': begin
           note := Notes.D;
           AnOctave := AnOctave - 1;
         end;
    'n': begin
           note := Notes.E;
           AnOctave := AnOctave - 1;
         end;
    'm': begin
           note := Notes.F;
           AnOctave := AnOctave - 1;
         end;
    ',': begin
           note := Notes.G;
           AnOctave := AnOctave - 1;
         end;
    '.': begin
           note := Notes.A;
           AnOctave := AnOctave - 1;
         end;
    '/': begin
           note := Notes.B;
           AnOctave := AnOctave - 1;
         end;
    'a': begin
           note := Notes.FS;
           AnOctave := AnOctave - 2;
         end;
    's': begin
           note := Notes.GS;
           AnOctave := AnOctave - 2;
         end;
    'd': begin
           note := Notes.AS;
           AnOctave := AnOctave - 2;
         end;
    'g': begin
           note := Notes.CS;
           AnOctave := AnOctave - 1;
         end;
    'h': begin
           note := Notes.DS;
           AnOctave := AnOctave - 1;
         end;
    'k': begin
           note := Notes.FS;
           AnOctave := AnOctave - 1;
         end;
    'l': begin
           note := Notes.GS;
           AnOctave := AnOctave - 1;
         end;
    ';': begin
           note := Notes.AS;
           AnOctave := AnOctave - 1;
         end;
  end;  {case}
  end;  {with notes}
end;   {procedure}
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure LightUp(Letter:char);
var
  LocationCode : integer;
begin
  if (Xloci[Ord(Letter)] > 1)  then
    begin
      LocationCode := (Xloci[ord(Letter)]-1)*2 + (Yloci[Ord(Letter)]-1)*160;
      Mem[ScreenSeg:locationCode+1] := 112;
    end;
    LocationCode := (Xloci[ord(LastKey)]-1)*2 + (Yloci[Ord(LastKey)]-1)*160;
    Mem[ScreenSeg:locationCode+1] := 15;
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure ShowLegato(On: boolean);
var
  col, row, M : byte;
  LocationCode : integer;
  word : string[6];
begin
  row := 2;
  if On then M := 112 else M := 15;
  if On then word := 'legato' else word := '      ';
  for col := 1 to 6 do
    begin
      LocationCode := (col + 66)*2 + (row-1)*160;
      Mem[ScreenSeg:LocationCode] := ord(word[col]);
      Mem[ScreenSeg:LocationCode+1] := M;
    end;
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure GetKeys;
var
  C, D                 : char;
  legato               : boolean;
  oldToggle            : byte;
  ThisNote, ThisOctave : integer;
begin
  OldToggle := ToggleByte;
  repeat until keypressed;
  read(Kbd,C);
  if C = chr(27) then
    begin
      read(Kbd,D);
        case D of
            'H': Octave := Octave + 1;{up arrow}
            'P': Octave := Octave - 1;{down arrow}
            'M': duration := duration + 10; {left arrow}
            'K': if duration > 10 then duration := duration - 10; {right}
            'O': done := true; {end}
            'G': begin
                   if recording then
                     begin
                       convert(LastKey,ThisNote,ThisOctave);
                       recorder(ThisOctave,ThisNote);
                       LastTime := 0;
                       NoteNum  := 0;
                     end;
                   recording := recording xor true;
                 end;
            'R': begin
                   Attribute(10,57,60,112);
                   PlayBack;
                   Attribute(10,57,60,15);
                 end;
            'S': begin
                   disposeAll(List);
                   VeryFirst := true;
                 end;
         end;
    end
  else
    begin
      LightUp(C);
      convert(C,ThisNote,ThisOctave);
      if ThisNote <> 0 then
      play(ThisOctave,ThisNote,duration);
      if recording then convert(LastKey,ThisNote,ThisOctave);
      LastKey := C;
    end;
  if ToggleByte and 16 = 16 then legato := true else legato := false;
  if recording then
    begin
      recorder(ThisOctave,ThisNote);
    end
  else
    begin
      Attribute(4,60,62,15);
    end;
  ShowLegato(legato);
  gotoXY(1,26);
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure SetLocations;
var
  N : byte;
begin
  for N := 39 to 122 do
    begin
      Xloci[N] := 1;
      Yloci[N] := 1;
    end;
  Yloci[50]  := 2;  Xloci[50]  := 11;
  Yloci[51]  := 2;  Xloci[51]  := 15;
  Yloci[53]  := 2;  Xloci[53]  := 23;
  Yloci[54]  := 2;  Xloci[54]  := 27;
  Yloci[55]  := 2;  Xloci[55]  := 31;
  Yloci[57]  := 2;  Xloci[57]  := 39;
  Yloci[48]  := 2;  Xloci[48]  := 43;
  Yloci[61]  := 2;  Xloci[61]  := 51;
  Yloci[113] := 4;  Xloci[113] := 8;
  Yloci[119] := 4;  Xloci[119] := 12;
  Yloci[101] := 4;  Xloci[101] := 16;
  Yloci[114] := 4;  Xloci[114] := 20;
  Yloci[116] := 4;  Xloci[116] := 24;
  Yloci[121] := 4;  Xloci[121] := 28;
  Yloci[117] := 4;  Xloci[117] := 32;
  Yloci[105] := 4;  Xloci[105] := 36;
  Yloci[111] := 4;  Xloci[111] := 40;
  Yloci[112] := 4;  Xloci[112] := 44;
  Yloci[91]  := 4;  Xloci[91]  := 48;
  Yloci[93]  := 4;  Xloci[93]  := 52;
  Yloci[97]  := 6;  Xloci[97]  := 9;
  Yloci[115] := 6;  Xloci[115] := 13;
  Yloci[100] := 6;  Xloci[100] := 17;
  Yloci[103] := 6;  Xloci[103] := 25;
  Yloci[104] := 6;  Xloci[104] := 29;
  Yloci[107] := 6;  Xloci[107] := 37;
  Yloci[108] := 6;  Xloci[108] := 41;
  Yloci[59]  := 6;  Xloci[59]  := 45;
  Yloci[92]  := 8;  Xloci[92]  := 8;
  Yloci[122] := 8;  Xloci[122] := 12;
  Yloci[120] := 8;  Xloci[120] := 16;
  Yloci[99]  := 8;  Xloci[99]  := 20;
  Yloci[118] := 8;  Xloci[118] := 24;
  Yloci[98]  := 8;  Xloci[98]  := 28;
  Yloci[110] := 8;  Xloci[110] := 32;
  Yloci[109] := 8;  Xloci[109] := 36;
  Yloci[44]  := 8;  Xloci[44]  := 40;
  Yloci[46]  := 8;  Xloci[46]  := 44;
  Yloci[47]  := 8;  Xloci[47]  := 48;
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure DrawKeyboard;
begin
WriteLn('ÉÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÍÍÑÍÍÍÍÍÍÍÑÍÍÍÍÍÍÍ»');
WriteLn('º   ³   ³ C#³ D#³   ³ F#³ G#³ A#³   ³ C#³ D#³   ³ F#³     ³       ³       º');
WriteLn('ÇÄÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÄÂÄÄÄÅÄÄÄÂÄÄÄÅÄÄÄÂÄÄĶ');
WriteLn('º    ³ C ³ D ³ E ³ F ³ G ³ A ³ B ³ C ³ D ³ E ³ F ³ G  ³   ³Rec³ ',chr(24),' ³   ³   º');
WriteLn('ÇÄÄÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÁÂÄÄÄ´   ÃÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ');
WriteLn('º     ³ F#³ G#³ A#³   ³ C#³ D#³   ³ F#³ G#³ A#³   ³   ³   ³ ',chr(27),' ³   ³ ',chr(26),' ³   º');
WriteLn('ÇÄÄÄÄÂÁÄÄÂÁÄÄÂÁÄÄÂÁÄÄÂÁÄÄÂÁÄÄÂÁÄÄÂÁÄÄÂÁÄÄÂÁÄÄÂÁÄÄÂÁÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄ´   º');
WriteLn('º    ³ F ³ G ³ A ³ B ³ C ³ D ³ E ³ F ³ G ³ A ³ B ³    ³   ³End³ ',chr(25),' ³   ³   º');
WriteLn('ÇÄÄÄÄÁÄÄÂÁÄÄÄÁÄÄÄÁÄÄÄÁÄÄÄÁÄÄÄÁÄÄÄÁÄÄÄÁÄÄÄÁÄÄÄÁÄÄÂÁÄÄÄÄÅÄÄÄÁÄÄÄÅÄÄÄÁÄÄÄ´   º');
WriteLn('º       ³                                       ³     ³ Play  ³ Erase ³   º');
WriteLn('ÈÍÍÍÍÍÍÍÏÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÏÍÍÍÍÍÏÍÍÍÍÍÍÍÏÍÍÍÍÍÍÍÏÍÍͼ');
WriteLn;
WriteLn('Up and Down arrows control the octave.');
WriteLn;
WriteLn('Right and Left arrows control note duration--right is shorter.');
WriteLn;
WriteLn('The Scroll Lock turns legato on and off.  The change takes effect');
WriteLn('     on the NEXT note.');
WriteLn;
WriteLn('Home turns recording on and off, Ins plays back, and Del erases.');
WriteLn;
WriteLn('Press <End> to end');
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
procedure initialize;
begin
    IF (Mem[0000:1040] AND 48) <> 48 THEN ScreenSeg := $B800
   ELSE ScreenSeg := $B000;
  Octave := 3;
  LastTime := 0;
  duration := 50;
  done := false;
  recording := false;
  VeryFirst := true;
  NoteNum   := 0;
  style := 0;
  SetLocations;
  DrawKeyboard;
  List := nil;
  LastTime := 0;
end;
{®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®¯®}
begin
  initialize;
  repeat GetKeys until done;
  NoSound;
  ClrScr;
end.