{******************************************************************************

Player example file

Implements a Qbasic compatible "play" statement, and feeds it a sample song.
The theory here is that using an existing music notation will give us lots
of test material.

******************************************************************************}

program player(input, output);

uses trmlib,
     sndlib;

label 99;

const second = 10000;

var 

   ntime: integer; { normal beat time in quarter notes }
   octave: note; { current octave }
   deftim: integer; { default note time }
   i: integer;

procedure wait(t: integer);

var er: evtrec; { event record }

begin

   timer(input, 1, t, false);
   repeat event(input, er) until (er.etype = ettim) or (er.etype = etterm);
   if er.etype = etterm then goto 99

end;

{ Qbasic compatible "play" string command }

procedure play(view ms: string);

var n:  note;
    nt: integer;
    i:  integer;
    x:  integer;

function lcase(c: char): char;

begin

   { convert lower case }
   if c in ['A'..'Z'] then c := chr(ord(c)-ord('A')+ord('a'));
   lcase := c { return result }

end;

function next: char;

var c: char;

begin

   if i <= max(ms) then c := ms[i] else c := ' ';
   next := c

end;

procedure playnote(n: note; nt: integer);

begin

{;writeln('Note: ', n:1, ' Time: ', nt:1);}
   noteon(1, 0, 1, n, maxint); { turn on the note }
   wait(nt); { wait time }
   noteoff(1, 0, 1, n, maxint); { turn off the note }

end;

procedure getnum(var n: integer);

begin

   if not (next in ['0'..'9']) then begin { error }

      writeln('*** Play: number expected');
      goto 99

   end;
   n := 0; { clear result }
   while next in ['0'..'9'] do begin

      n := n*10+ord(next)-ord('0'); 
      i := i+1

   end

end;  

procedure settim(var t: integer);

var ln: integer;

begin

   getnum(ln); { get the length }
   while ln > 4 do begin { process tempo levels }
   
      t := t div 2;
      ln := ln div 2

   end;
   if ln = 1 then t := t*4 { set whole note }
   else if ln = 2 then t := t*2 { 1/2 note }

end;

procedure setoct;

var on: integer;

begin

   getnum(on); { get octave number }
   if (on < 0) or (on > 6) then begin { bad octave }

      writeln('*** Play: bad octave number');
      goto 99

   end;
   { we place Plays' 6 7 octaves in the middle of midis' 11 octaves }
   case on of { octave }

      0: octave := octave_2;
      1: octave := octave_3;
      2: octave := octave_4;
      3: octave := octave_5;
      4: octave := octave_6;
      5: octave := octave_7;
      6: octave := octave_8

   end

end;

begin

   i := 1; { index 1st character of string }
   while i <= max(ms) do begin { interpret commands}

      { process single notes }
      if (lcase(next) >= 'a') and (lcase(next) <= 'g') then begin

         write(next, ' ');
         { its a note }
         case lcase(ms[i]) of { note }

            'c': n := note_c;
            'd': n := note_d;
            'e': n := note_e;
            'f': n := note_f;
            'g': n := note_g;
            'a': n := note_a;
            'b': n := note_b

         end;
         i := i+1; { next character }
         if (next = '+') or (next = '#') then begin

            n := n+1; { sharpen it }
            i := i+1

         end else if next = '-' then begin

            n := n-1; { flatten it }
            i := i+1

         end;
         nt := deftim; { set default whole note }
         { check length follows, and set time from that }
         if next in ['0'..'9'] then begin

            nt := ntime; { reset to main time }
            settim(nt)

         end;
         if next = '.' then begin { dotted length }

            nt := nt+nt div 2; { extend by 1/2 }
            i := i+1

         end;
         { note is fully prepared, send it }
         playnote(n+octave, nt)

      end else if lcase(next) = 'o' then begin { set octave }

         i := i+1; { advance }
         setoct { set octave }

      end else if lcase(next) = 'l' then begin { set note lengths }

         i := i+1; { advance }
         deftim := ntime; { reset default }
         settim(deftim) { set default time }

      end else if next = '>' then begin { up octave }

         if octave < octave_8 then octave := octave+12;         
         i := i+1

      end else if next = '<' then begin { down octave }

         if octave > octave_2 then octave := octave-12;         
         i := i+1

      end else if lcase(next) = 'n' then begin { numbered note }

         i := i+1; { advance }
         getnum(i); { get the note }
         if (i < 0) or (i > 84) then begin

            writeln('*** Play: Invalid note number');
            goto 99

         end;
         if i = 0 then wait(ntime) { rest }
         else playnote(i-1+octave_2, deftim) { play note }

      end else if lcase(next) = 'p' then begin { pause }

         i := i+1; { advance }
         settim(x); { get time }
         wait(x) { wait for that time }
         
      end else if lcase(next) = 't' then begin { tempo }

         { not implemented, just skip }
         i := i+1; { advance }
         getnum(x) { get time }
         
      end else if lcase(next) = 'm' then begin { various commands }

         i := i+1; { advance }
         if not (lcase(next) in ['n', 'l', 's', 'f', 'b']) then begin

            writeln('*** Play: command syntax error');
            goto 99

         end;
         i := i+1 { advance }

      end else if next = ' ' then i := i+1 { skip spaces }
      else begin

         writeln('*** Play: command syntax error');
         goto 99
  
      end

   end

end;

begin

   { set up "play" parameters }
   ntime := second div 2; { set default tempo for quarter notes }
   octave := octave_5; { start in middle octave }
   deftim := ntime; { set whole notes default }

   writeln('Synthesisers: ', synthout);
   opensynthout(1); { open main synthesiser }

   instchange(1, 0, 1, inst_acoustic_grand);

   writeln('Mozart''s Sonata in C');
   play('c2 l4 e g < b. > l16 c d l2 c');
   play('> a l4 g > c < g l16 g f e f l2 e');
   play('< a8 l16 b > c d e f g a g f e d c < b a');
   play('g8 a b > c d e f g f e d c < b a g f8 g a b > c d e');
   play('f e d c < b a g f e8 f g a b > c d e d c < b a g f e');
   play('d8 e f g a b > c# d < a b > c# d e f g');
   play('a b > c < b a g f e f g a g f e d c');
   play('< l8 b ms > g e c ml d g ms e c');
   play('d4 g4 < g2 g2 > c4 e4 g2');
   play('l16 a g f e f e d c e d e d e d e d e d e d e d c d');
   play('c4 c < g > c e g e c e f d < b > d');
   play('c4 < c < g > c e g e c e f d < b > d c4 > c4 c2');
   writeln;

   99:

end.