Beijing Paradise BBS Backup/PARADISE.ISO/software/BBSDOORW/RADOOR30.ZIP/ANSIMUS.PAS

Pascal/Delphi Source File | 1994-04-10 | 7.6 KB | 270 lines

{╔═════════════════════════════════════════════════════════════════════════╗
 ║                                                                         ║
 ║                   (c) CopyRight LiveSystems 1990, 1994                  ║
 ║                                                                         ║
 ║ Author    : Gerhard Hoogterp                                            ║
 ║ FidoNet   : 2:282/100.5   2:283/7.33                                    ║
 ║ BitNet    : [e-mail]                                     ║
 ║                                                                         ║
 ║ SnailMail : Kremersmaten 108                                            ║
 ║             7511 LC Enschede                                            ║
 ║             The Netherlands                                             ║
 ║                                                                         ║
 ║        This module is part of the RADoor BBS doorwriters toolbox.       ║
 ║                                                                         ║
 ╚═════════════════════════════════════════════════════════════════════════╝}

{ Current problems/bugs:

- Due to the streamlike nature of this AnsiMusic implementation it's not
  yet possible to play music in the background.. Maybe I get a briljant
  idea someday.. For now EVERYTHING is played in the foreground!
}

Unit AnsiMus;
Interface
Uses Crt;


{ Comment: (Mon  02-04-1991, 23:02:45)
|-----------------------------------------------------------------------------|
  PlayAnsi accepts a string containing an ANSIMusic string. The part between
  the <ESC>[M  and the #14 that is.
  Controle is returned to the program as soon as the music is finished
|-----------------------------------------------------------------------------|
}

Procedure PlayAnsi(S : String);


{ Comment: (Mon  02-04-1991, 23:04:10)
|-----------------------------------------------------------------------------|
 The AnsiMusic procedure accepts a stream of characters which should only
 contain legal Ansi-Music symbols.
 It's up the the master-routine to detect the end of the stream..
 Controle is returned after each character. See the Driver.pas file for an
 example of the usage.
|-----------------------------------------------------------------------------|
}

Procedure AnsiMusic(C : Char);

{
|-----------------------------------------------------------------------------|
 Reset the ansi interpreter to it's default values!
|-----------------------------------------------------------------------------|
}

Procedure ResetMusic;


Implementation

Function Str2Nr(S : String):Word;
Var Temp : Word;
    Err  : Word;
Begin
Val(S,Temp,Err);
If Err<>0
   Then Str2Nr:=0
   Else Str2Nr:=Temp;
End;

{---------------- Music routines -------------------------------------------}

Const Scale : Array[1..84] Of Word =

(
 0065, 0070, 0073, 0078, 0082, 0087, 0093, 0098, 0104, 0110, 0117, 0123,
 0131, 0139, 0147, 0156, 0165, 0175, 0185, 0196, 0208, 0220, 0233, 0247,
 0262, 0277, 0294, 0311, 0330, 0349, 0370, 0392, 0415, 0440, 0466, 0494,
 0523, 0554, 0587, 0622, 0659, 0698, 0740, 0784, 0831, 0880, 0932, 0987,
 1047, 1109, 1175, 1245, 1329, 1397, 1480, 1568, 1661, 1760, 1865, 1976,
 2093, 2217, 2349, 2489, 2637, 2794, 2960, 3136, 3322, 3520, 3729, 3951,
 4186, 4435, 4699, 4978, 5274, 5588, 5920, 6272, 6645, 7040, 7459, 7902
);


Type StatusType = (None,Note,NoteLen,Music,Octave,Tempo);
     BufType    = String[10];

Var Status     : StatusType;
    Buf        : BufType;

    DefLength  : Word;
    DefOctave  : Word;
    DefTempo   : Word;
    Timing     : Real;
    Fraktion   : Real;


Procedure DoNote(S : BufType);
Var UseNote : Byte;
    NoteLen : Byte;

    TTime,
    PTime,
    ITime,
    DTime   : LongInt;

    Len     : String[5];
    Count   : Byte;
    Error   : Integer;

Begin
UseNote:=Pos(S[1],'CcDdEFfGgAaB');

DTime:=1000;
If Length(S)>1
   Then Begin
        If S[2] In ['+','#','-']
           Then Begin
                Case S[2] Of
                 '+','#' : Inc(UseNote);
                 '-'     : Dec(UseNote);
                End;
                Count:=3;
                End
           Else Count:=2;
        Len:='';

        While (Count<=Length(S)) And (S[Count] In ['0'..'9']) Do
           Begin
           Len:=Len+S[Count];
           Inc(Count);
           End;
        Val(Len,NoteLen,Error);

        If NoteLen=0
           Then NoteLen:=DefLength;

        If Length(S)>(Count-1)
           Then Begin
                While Count<=Length(S) Do
                 Begin
                 If S[Count]='.'
                    Then DTime:=DTime+DTime Div 2;
                 Inc(Count);
                 End;
                End;
        End
   Else NoteLen:=DefLength;


TTime := Round(DTime/DefTempo/NoteLen*240);
PTime := Round(TTime*Fraktion/8);
ITime := TTime-PTime;


If S[1]<>'P'
   Then Sound(Scale[UseNote + DefOctave * 12 ]);

Delay(PTime);
If ITime<>0
   Then Begin
        NoSound;
        Delay(ITime);
        End;
End;

Procedure AnsiMusic(C : Char);
Var Buffed : Boolean;
    Mem    : Char;
Begin
Buffed:=False;
Repeat
 If Buffed
    Then Begin
         C:=Mem;
         Buffed:=False;
         End;

 Case Status Of
  None      : Begin
              Buf:=C;
              Case C Of
               'A'..'G',
               'P'      : Status:=Note;
               'L'      : Status:=NoteLen;
               'M'      : Status:=Music;
               'O'      : Status:=Octave;
               'T'      : Status:=Tempo;
               '>'      : If DefOctave<8
                             Then Inc(DefOctave);
               '<'      : If DefOctave>0
                             Then Dec(DefOctave);
              End;{Case}
              End;
  Note      : Begin
              If C In ['A'..'G','P','M','L','O','T','P']
                 Then Begin
                      Status:=None;
                      Mem:=C;
                      Buffed:=True;
                      End
                 Else Buf:=Buf+C;
              If Status=None
                 Then DoNote(Buf);
              End;
  NoteLen   : Begin
              If Not (C In ['0'..'9'])
                 Then Begin
                      Status:=None;
                      Mem:=C;
                      Buffed:=True;
                      End
                 Else Buf:=Buf+C;
              If Status=None
                 Then DefLength:=Str2Nr(Copy(Buf,2,Length(Buf)-1));
              End;
  Music     : Begin
              Case C Of
               'B','F' : ;
               'S'     : Fraktion:=6;
               'N'     : Fraktion:=7;
               'L'     : Fraktion:=8;
              End;
              Status:=None;
              End;
  Octave    : Begin
              DefOctave:=Ord(C)-$30;
              Status:=None;
              End;
  Tempo     : Begin
              If Not (C In ['0'..'9'])
                 Then Begin
                      Status:=None;
                      Mem:=C;
                      Buffed:=True;
                      End
                 Else Buf:=Buf+C;
              If Status=None
                 Then DefTempo:=Str2Nr(Copy(Buf,2,Length(Buf)-1));
              End;
 End; {Status}
Until Not Buffed;
End;

Procedure PlayAnsi(S : String);
Var Count : Byte;
Begin
For Count:=1 To Length(S) Do
  AnsiMusic(Upcase(S[Count]));
End;


Procedure ResetMusic;
Begin
DefOctave:=3;
DefTempo:=120;
DefLength:=4;
Status:=None;
End;

Begin
DefOctave:=3;
DefTempo:=120;
DefLength:=4;
Status:=None;
End.