home *** CD-ROM | disk | FTP | other *** search
/ Beijing Paradise BBS Backup / PARADISE.ISO / software / BBSDOORW / MKMSG102.ZIP / MKMSGCVT.ZIP / MKMUSIC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-08-15  |  7.3 KB  |  271 lines
  1. Unit MKMusic;
  2.  
  3. {$I MKB.Def}
  4.  
  5. {Base on code written by Gregory Arakelian and later modified
  6.  by Ted Lassagne and E Kosiewicz}
  7.  
  8. Interface
  9.  
  10. Uses
  11. {$IFDEF WINDOWS}
  12.   MKWCrt;
  13. {$ELSE}
  14.   {$IFDEF OPRO}
  15.   OpCrt;
  16.   {$ELSE}
  17.   Crt;
  18.   {$ENDIF}
  19. {$ENDIF}
  20.  
  21. Type KeyProc = Procedure(Var Stop: Boolean);
  22. Type KeyPressProc = Function: Boolean;
  23.  
  24.  
  25. Procedure PlayInit;
  26. Procedure Play (TuneString:string);
  27. Procedure KeyNone(Var Stop: Boolean);
  28.  
  29. Const
  30.   MusicKeyProc: KeyProc = KeyNone;
  31.   MusicKeyPressed: KeyPressProc = KeyPressed;
  32.  
  33.  
  34. Implementation
  35.  
  36.  
  37. {$IFDEF WINDOWS}
  38. Uses WinTypes, WinProcs;
  39. {$ENDIF}
  40.  
  41.  
  42. Const
  43.     SharpOffset = 60;
  44.  
  45.  
  46. Const PitchArray: Array[1..120] of Word = (
  47.   28, 31, 33, 37, 41, 44, 49, 55, 62, 65,
  48.   73, 82, 87, 98, 110, 123, 131, 147, 165, 175,
  49.   196, 220, 247, 262, 294, 330, 349, 392, 440, 494,
  50.   523, 587, 659, 698, 784, 880, 988, 1047, 1175, 1319,
  51.   1397, 1568, 1760, 1976, 2093, 2349, 2637, 2794, 3136, 3520,
  52.   3951, 4186, 4699, 5274, 5588, 6272, 32139, 9738, 1934, 39659,
  53.   29, 33, 35, 39, 44, 46, 52, 58, 65, 69,
  54.   78, 87, 92, 104, 117, 131, 139, 156, 175, 185,
  55.   208, 233, 262, 277, 311, 349, 370, 415, 466, 523,
  56.   554, 622, 698, 740, 831, 932, 1047, 1109, 1245, 1397,
  57.   1480, 1661, 1865, 2093, 2217, 2489, 2794, 2960, 3322, 3729,
  58.   4186, 4435, 4978, 5588, 5920, 6645, 35669, 33772, 1772, 18119);
  59.  
  60.  
  61. Const
  62.   BaseOctave: Integer = 0;
  63.   Octave: Integer = 3;
  64.   GenNoteType: Integer = 4;
  65.   Tempo: Integer = 120;
  66.   PlayFrac: Byte = 7;
  67.  
  68. Var
  69.   vq: LongInt;         {Windows voice queue}
  70.   TmpPitch: LongInt;
  71.  
  72.  
  73. Procedure KeyNone(Var Stop: Boolean);
  74.   Begin
  75.   Stop := False;
  76.   End;
  77.  
  78.  
  79. Procedure PlayInit;
  80.   Begin
  81.   BaseOctave := 0;
  82.   Octave := 3;         {Third octave - starts with middle C}
  83.   GenNoteType := 4;    {Quarter note}
  84.   Tempo := 120;        {120 beats per minute}
  85.   PlayFrac := 7;       {Normal - note plays for 7/8 of time}
  86.   End;
  87.  
  88.  
  89.  
  90.  
  91. Procedure Play (TuneString:string);
  92.   Var
  93.     PlayTime: LongInt;
  94.     IdleTime: LongInt;
  95.     DotTime: LongInt;
  96.     NoteTime  : LongInt;
  97.     NoteType: Integer;
  98.     PitchIndex: Integer;
  99.     Position: Integer;
  100.     Number : Integer;
  101.     Code: Integer;
  102.     TuneStrLen: Integer;
  103.     Character: Char;
  104.     PlayDone: Boolean;
  105.  
  106.  
  107.   Procedure NVal(Pos:integer; var v, code: integer);
  108.   {Extracts a numeric value "v" from the tune string starting at
  109.    the index Pos.  The returned value in "code" is the number of
  110.    digits scanned plus one.}
  111.   Var
  112.     Posn:integer;
  113.  
  114.   Begin
  115.   v := 0;
  116.   posn := Pos;
  117.   while (posn <= TuneStrLen) and
  118.   (TuneString[posn] in ['0'..'9']) do
  119.     Begin
  120.     v := v*10 + ord(TuneString[posn]) - ord ('0');
  121.     Inc(posn);
  122.     End;
  123.   code := posn - Pos + 1;
  124.   End;
  125.  
  126.   {$IFDEF WINDOWS}
  127.   Procedure NoSound;
  128.     Begin
  129.     StopSound;
  130.     End;
  131.   {$ENDIF}
  132.  
  133.  
  134.  
  135.   Procedure CheckDots; {Checks for dots after note or pause}
  136.     Begin
  137.     While (Position <= TuneStrLen) and
  138.     (TuneString[Position] = '.') do
  139.       Begin
  140.       DotTime := DotTime + DotTime div 2;
  141.       inc(Position)
  142.       End;
  143.     End;
  144.  
  145.  
  146.   Begin {Play subroutine}
  147.   {$IFDEF WINDOWS}
  148.   vq := OpenSound;
  149.   {$ENDIF}
  150.   PlayDone := False;
  151.   CheckBreak := false;
  152.   TuneStrLen := length(TuneString);
  153.   Position := 1;
  154.   Repeat
  155.     NoteType := GenNoteType;
  156.     DotTime := 1000;
  157.     Character := upcase(TuneString[Position]);
  158.     Case Character Of
  159.       'A'..'G' : Begin
  160.                  PitchIndex := (ord(Character)-64)+Octave*7;
  161.                  If (Character='A') or (Character='B') Then
  162.                    PitchIndex := PitchIndex + 7;  {next octave}
  163.                  inc(Position);
  164.  
  165.                  {Check for sharp or flat}
  166.                  if Position <= TuneStrLen then
  167.                    case TuneString[Position] of
  168.                      '#','+': begin
  169.                               PitchIndex := PitchIndex+SharpOffset;
  170.                               inc(Position);
  171.                               end;
  172.                      '-': begin
  173.                           PitchIndex := PitchIndex+SharpOffset - 1;
  174.                           inc(Position);
  175.                           end;
  176.                      End;
  177.  
  178.                      {Check for length following note}
  179.                  if (Position <= TuneStrLen) and
  180.                  (TuneString[Position] in ['0'..'9']) then
  181.                    begin
  182.                    NVal(Position,NoteType,Code);
  183.                    inc(Position, Code - 1)
  184.                    end;
  185.  
  186.                    {Check for dots after note}
  187.                  CheckDots;
  188.  
  189.                  {Play the note}
  190.                  NoteTime := Round(DotTime/Tempo/NoteType*240);
  191.                  PlayTime := Round(NoteTime*PlayFrac/8);
  192.                  IdleTime := NoteTime-PlayTime;
  193.                  {$IFDEF WINDOWS}
  194.                  StopSound;
  195.                  TmpPitch := PitchArray[PitchIndex];
  196.                  SetVoiceSound(Vq, TmpPitch shl 16, 10000);
  197.                  StartSound;
  198.                  {$ELSE}
  199.                  Sound(PitchArray[PitchIndex]);
  200.                  {$ENDIF}
  201.                  Delay(PlayTime);
  202.                  if IdleTime <> 0 then
  203.                    begin
  204.                    NoSound;
  205.                    Delay(IdleTime)
  206.                    end;
  207.  
  208.                  if keypressed then
  209.                    MusicKeyProc(PlayDone);
  210.                  End;
  211.       'L' :  {Note length (1 thru 64).  "1" signifies a
  212.                      whole note and "64" a 64th note.}
  213.             Begin
  214.             NVal (Position+1,GenNoteType,Code);
  215.             if (GenNoteType < 1) or (GenNoteType > 64) then
  216.               GenNoteType := 4;
  217.             inc(Position, Code);
  218.             End;
  219.       'M' :  {Note length modifier - "S" for staccato,
  220.              "L" for legato, or "N" for normal.}
  221.             Begin
  222.             if Position < TuneStrLen then
  223.               begin
  224.               Case upcase(TuneString[Position+1]) Of
  225.                 'S' : PlayFrac := 6;
  226.                 'N' : PlayFrac := 7;
  227.                 'L' : PlayFrac := 8;
  228.                 End;
  229.               inc(Position, 2);
  230.               end;
  231.             End;
  232.       'O' :  {Octave specification (0 thru 7)}
  233.             Begin
  234.             NVal (Position+1,Octave,Code);
  235.             Octave := Octave+BaseOctave;
  236.             if Octave > 7 then
  237.               Octave := 3;
  238.             inc(Position, Code);
  239.             End;
  240.       'P' :  {Pause (rest) followed by optional value of
  241.                      1 thru 64, with "1" signifying a whole rest
  242.                      and "64" a 64th rest.}
  243.             Begin
  244.             NoSound;
  245.             NVal (Position+1,NoteType,Code);
  246.             if (NoteType < 1) or (NoteType > 64) then
  247.               NoteType := GenNoteType;
  248.               inc(Position, Code);
  249.               CheckDots;
  250.               IdleTime := DotTime Div Tempo * (240 Div NoteType);
  251.               Delay (IdleTime);
  252.               End;
  253.       'T' :  {Tempo - number of beats per minute (32 - 255)}
  254.             Begin
  255.             NVal (Position+1,Tempo,Code);
  256.             if (Tempo < 32) or (Tempo > 255) then
  257.               Tempo := 120;
  258.             inc(Position, Code);
  259.             End;
  260.       Else
  261.         inc(Position);   {Ignore spurious characters}
  262.       End;
  263.     Until ((Position > TuneStrLen) Or (PlayDone));
  264.     NoSound;
  265.     {$IFDEF WINDOWS}
  266.     CloseSound;
  267.     {$ENDIF}
  268.     End;
  269.  
  270. End.
  271.