unit Title;

interface

uses Graph,Crt,Globals;

var
  Octave, Tempo :byte;
  AllLength,Music : real;
  Step : boolean;

  procedure ShowTitle;
  procedure InitPlay;
  procedure Play(ComLin : string);

implementation

procedure InitPlay;
begin
  Octave := 2;
  AllLength := 1/4;
  Tempo := 120;
  Music := 7/8;
  Step := True;
end;

procedure Play(ComLin : string);
type
  ChrSet = set of char;
const
  Comms : ChrSet = ['L','M','N','<','>','O','P','S','T'];
  Notes : ChrSet = ['A'..'G'];
  Appix : ChrSet = ['#','+','-','.'];
  Numbers : ChrSet = ['0'..'9'];
var
  Ctr : integer;
  ComLinPos : byte;
  Command : string;

  procedure NoSpaces (var Lin : string);
  var Tmp : string;
      Ctr : byte;
  begin
    Tmp := '';
    for Ctr := 1 to Length (Lin) do
      if not (Lin[Ctr] in [' ',',']) then Tmp := Tmp + UpCase(Lin[Ctr]);
    Lin := Tmp;
  end;
  function GetSymbol (Lin : string; LinPos : byte; TrmSet : ChrSet) : string;
  var ComLen : byte;
  begin
    GetSymbol := '';
    if Lin [LinPos] in TrmSet then begin
      ComLen := 1;
      while not (Lin [LinPos+ComLen] in TrmSet) and
            not (LinPos+ComLen>255) do Inc (ComLen);
      GetSymbol := Copy (Lin,LinPos,ComLen);
    end;
  end;
  function GetNumber (Lin : string; var LinPos : byte) : integer;
  var ComLen : byte;
      Code,Tmp : integer;
  begin
    Tmp := 0;
    ComLen := 1;
    while Lin [LinPos+ComLen] in Numbers do
      Inc (ComLen);
    Val (Copy (Lin,LinPos,ComLen),Tmp,Code);
    Inc (LinPos,ComLen-1);
    GetNumber := Tmp;
  end;

  procedure ProcessCommand (Com : string);
  var ThisLen : real;
      p : byte;
  begin
    p := 2;
    case Com[1] of
      'L' : AllLength := 1/GetNumber (Com,p);
      '<' : if Octave > 0 then Dec (Octave);
      '>' : if Octave < 9 then Inc (Octave);
      'O' : Octave := GetNumber (Com,p);
      'P' : begin
              NoSound;
              ThisLen := AllLength;
              if Length(Com)>1 then ThisLen := 1/GetNumber (Com,p);
              Delay (Round(ThisLen*(256-Tempo)*15));
            end;
      'T' : Tempo := GetNumber (Com,p);
      'M' : case Com[2] of
              '7' : Music := 7/8;
              '1' : Music := 1;
              '3' : Music := 3/4;
            end;
      'S' : Step := Boolean (Ord(Com[2])-48);
    end;
  end;
  procedure PlayNote (Com : string);
  var Ctr,ThisOct : byte;
      Frequency,ThisLen : real;
      Note,Dummy : integer;
  begin
    ThisOct := Octave;
    ThisLen := AllLength;
    Note := Pos (Com[1], 'C D EF G A B');
    Ctr := 2;
    while Ctr <= Length(Com) do begin
      case Com[Ctr] of
        '#','+' : Inc (Note);
            '-' : Dec (Note);
            '.' : ThisLen := ThisLen * 3/2;
       '0'..'9' : ThisLen := 1/GetNumber (Com,Ctr);
      end;
      Inc (Ctr);
    end;
    if Note<1 then begin
      Dec (ThisOct);
      Note := 12;
    end else
    if Note>12 then begin
      Inc (ThisOct);
      Note := 1;
    end;
    Frequency := 32.625;
    for Ctr := 1 to ThisOct do
      Frequency := Frequency * 2;
    for Ctr := 1 to Note - 1 do
      Frequency := Frequency * 1.059463094;
    if ThisLen <> 0.0 then
    begin
      if Step then NoSound;
      Sound(Round(Frequency));
      Delay(Round(ThisLen*(256-Tempo)*15*Music));
    end
    else Sound(Round(Frequency));
  end;

begin
  NoSound;
  NoSpaces (ComLin);
  ComLinPos := 1; Command := '';
  repeat
    Command := GetSymbol (ComLin,ComLinPos,Comms+Notes);
    if KeyPressed and ShwTitle then begin
      K1 := ReadKey; Inc (Page);
      if Page = 2 then Move (Tit2,Scr,16240);
    end;
    if (Command <> '') then begin
      if Command [1] in Comms then ProcessCommand (Command)
        else if Command [1] in Notes then PlayNote (Command);
    end;
    Inc (ComLinPos, Length (Command));
  until (ComLinPos > Length (ComLin)) or ((Page > 2) and ShwTitle);
  NoSound;
end;

                                            (***** SHOW TITLE PAGES ****)
procedure ShowTitle;
var PauseTemp : shortint;
begin
  PauseTemp := Pause;
  Pause := 0;
  ShwTitle:=True;
  ClearDevice;
  Delay (400);
  Move (Tit1,Scr,16240); Page := 1;
  Play ('t160 l8');
  if Page<=2 then repeat
    Ctr := 1;
    repeat
      case Ctr of             { Play tune in different octaves }
        1 : Octave := 4;
        2 : Octave := 6;
        3 : Octave := 2;
      end;
      Play ('d4<gab>cd4<gpgp>e4cdef#g4<gpgp'+
           +'>c4dc<bab4>c<bagf#4gabgb4a2>'+
           +'d4<gab>cd4<gpgp>e4cdef#g4<gpgp'+
           +'>c4dc<bab4>c<baga4bagf#g2<g4p4');
      Inc (Ctr);
    until (Ctr>3) or (Page>2);
  until Page >2;
  ShwTitle:=False;
  Pause := PauseTemp;
end;

begin
  InitPlay;
end.