home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PASWIZ14.ZIP / SOURCE.ZIP / MUSIC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-02-28  |  7.2 KB  |  298 lines
  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1993  Thomas G. Hanlin III         |
  4.     |             3544 E. Southern Ave. #104,  Mesa, AZ 85204              |
  5.     |                                                                      |
  6.     |                     The Pascal Wizard's Library                      |
  7.     |                                                                      |
  8.     +----------------------------------------------------------------------+
  9.  
  10.  
  11.  
  12. Music:
  13.  
  14.    This unit provides a music interpreter that works like BASIC's PLAY
  15.    statement.  Currently, only foreground music is supported.  See the
  16.    PASWIZ.DOC manual for information about the command set.
  17.  
  18. }
  19.  
  20.  
  21.  
  22. UNIT Music;
  23.  
  24.  
  25.  
  26. INTERFACE
  27.  
  28.  
  29.  
  30. PROCEDURE PlayMF (Sounds: String);
  31. PROCEDURE ResetMF;
  32.  
  33.  
  34.  
  35. { --------------------------------------------------------------------------- }
  36.  
  37.  
  38.  
  39. IMPLEMENTATION
  40.  
  41.  
  42.  
  43. USES
  44.    CRT;
  45.  
  46.  
  47.  
  48. {$F+}
  49.  
  50. FUNCTION UpperCase (St: String): String; external;
  51. FUNCTION WVal (St: String): Word; external;
  52.  
  53. {$L UPCASE.OBJ}
  54. {$L WVAL.OBJ}
  55.  
  56.  
  57.  
  58. VAR
  59.    Octave, NoteLen, Tempo, SoundLen, TmpNoteLen: Integer;
  60.    BaseOctave: Array[0..11] of Integer;
  61.    BaseTime: LongInt;
  62.    Nr: Integer;
  63.    Error: Boolean;
  64.    NoteConvert: String;
  65.  
  66.  
  67.  
  68. { grab a number from the music string }
  69. PROCEDURE GetNum (VAR St: String; VAR Nr: Integer; VAR Error: Boolean);
  70. VAR
  71.    Acc: String;
  72. BEGIN
  73.    Acc := '';
  74.    WHILE (Length(St) > 0) AND (Pos(St[1], '0123456789') > 0) DO BEGIN
  75.       Acc := Acc + St[1];
  76.       Delete(St, 1, 1);
  77.    END;
  78.    IF (Length(Acc) = 0) OR (Length(Acc) > 3) THEN
  79.       Error := TRUE
  80.    ELSE BEGIN
  81.       Error := FALSE;
  82.       Nr := WVal(Acc);
  83.    END;
  84. END;
  85.  
  86.  
  87.  
  88. { play a note }
  89. PROCEDURE PlayNote (Freq: Word);
  90. VAR
  91.    Time: Word;
  92. BEGIN
  93.    IF TmpNoteLen = 0 THEN
  94.       TmpNoteLen := NoteLen;
  95.    Time := BaseTime DIV (Tempo * TmpNoteLen);
  96.    IF Freq > 0 THEN
  97.       Sound(1193180 DIV Freq);
  98.    Delay(SoundLen * Time);
  99.    IF Freq > 0 THEN
  100.       NoSound;
  101.    Delay((8 - SoundLen) * Time);
  102.    TmpNoteLen := 0;
  103.    BaseTime := 38000;
  104. END;
  105.  
  106.  
  107.  
  108. { ---- procs to handle music commands ------------------------------------- }
  109.  
  110.  
  111.  
  112. PROCEDURE DoLength (VAR Sounds: String);
  113. BEGIN
  114.    GetNum(Sounds, Nr, Error);
  115.    IF NOT Error AND (Nr > 0) AND (Nr < 65) THEN
  116.       NoteLen := Nr;
  117. END;
  118.  
  119.  
  120.  
  121. PROCEDURE DoMiscCmd (VAR Sounds: String);
  122. BEGIN
  123.    IF Length(Sounds) > 0 THEN BEGIN
  124.       CASE Sounds[1] OF
  125.          'L': SoundLen := 8;    { legato }
  126.          'N': SoundLen := 7;    { normal }
  127.          'S': SoundLen := 6;    { staccato }
  128.          ELSE ;                 { either MF (default) or MB (not supported) }
  129.       END;
  130.       Delete(Sounds, 1, 1);
  131.    END;
  132. END;
  133.  
  134.  
  135.  
  136. PROCEDURE DoNoteLetter (VAR Sounds: String; Ch: Char);
  137. VAR
  138.    SpecialLen, NotePos: Integer;
  139.    DotLen: LongInt;
  140.    NoteInfo: String;
  141. BEGIN
  142.    NotePos := ORD(NoteConvert[ORD(Ch) - 64]) - 65;
  143.    IF Length(Sounds) > 0 THEN BEGIN
  144.       NoteInfo := '';
  145.       Ch := Sounds[1];
  146.       Delete(Sounds, 1, 1);
  147.       IF Ch = '-' THEN BEGIN
  148.          IF (NotePos IN [2, 4, 7, 9, 11]) THEN
  149.             DEC(NotePos);
  150.          IF (Length(Sounds) > 0) AND (Sounds[1] IN ['0'..'9', '.']) THEN BEGIN
  151.             Ch := Sounds[1];
  152.             Delete(Sounds, 1, 1);
  153.          END;
  154.       END ELSE IF ((Ch = '+') OR (Ch = '#')) THEN BEGIN
  155.          IF (NotePos IN [0, 2, 5, 7, 9]) THEN
  156.             INC(NotePos);
  157.          IF (Length(Sounds) > 0) AND (Sounds[1] IN ['0'..'9', '.']) THEN BEGIN
  158.             Ch := Sounds[1];
  159.             Delete(Sounds, 1, 1);
  160.          END;
  161.       END
  162.       ELSE IF NOT(Ch IN ['0'..'9', '.']) THEN
  163.          Sounds := Ch + Sounds;
  164.       IF (Ch IN ['0'..'9', '.']) THEN BEGIN
  165.          NoteInfo := NoteInfo + Ch;
  166.          WHILE (Length(Sounds) > 0) AND (Sounds[1] IN ['0'..'9', '.']) DO BEGIN
  167.             NoteInfo := NoteInfo + Sounds[1];
  168.             Delete(Sounds, 1, 1);
  169.          END;
  170.          IF TmpNoteLen = 0 THEN
  171.             TmpNoteLen := NoteLen;
  172.          DotLen := BaseTime;
  173.          WHILE Pos('.', NoteInfo) > 0 DO BEGIN
  174.             DotLen := DotLen SHR 1;
  175.             BaseTime := BaseTime + DotLen;
  176.             Delete(NoteInfo, Pos('.', NoteInfo), 1);
  177.          END;
  178.          IF (Length(NoteInfo) > 0) AND (Length(NoteInfo) < 3) THEN BEGIN
  179.             SpecialLen := WVal(NoteInfo);
  180.             IF (SpecialLen > 0) AND (SpecialLen < 65) THEN
  181.                TmpNoteLen := SpecialLen;
  182.          END;
  183.       END;
  184.    END;
  185.    PlayNote(BaseOctave[NotePos] SHR Octave);
  186. END;
  187.  
  188.  
  189.  
  190. PROCEDURE DoNoteNumber (VAR Sounds: String);
  191. BEGIN
  192.    GetNum(Sounds, Nr, Error);
  193.    IF NOT Error AND (Nr >= 0) AND (Nr <= 84) THEN
  194.       IF Nr = 0 THEN
  195.          PlayNote(Nr)
  196.       ELSE BEGIN
  197.          DEC(Nr);
  198.          PlayNote(BaseOctave[Nr MOD 12] SHR (Nr DIV 12));
  199.       END;
  200. END;
  201.  
  202.  
  203.  
  204. PROCEDURE DoOctave (VAR Sounds: String);
  205. BEGIN
  206.    GetNum(Sounds, Nr, Error);
  207.    IF NOT Error AND (Nr >= 0) AND (Nr <= 6) THEN
  208.       Octave := Nr;
  209. END;
  210.  
  211.  
  212.  
  213. PROCEDURE DoPause (VAR Sounds: String);
  214. BEGIN
  215.    GetNum(Sounds, Nr, Error);
  216.    IF NOT Error AND (Nr > 0) AND (Nr < 65) THEN BEGIN
  217.       TmpNoteLen := Nr;
  218.       PlayNote(0);
  219.    END;
  220. END;
  221.  
  222.  
  223.  
  224. PROCEDURE DoTempo (VAR Sounds: String);
  225. BEGIN
  226.    GetNum(Sounds, Nr, Error);
  227.    IF NOT Error AND (Nr >= 32) AND (Nr <= 255) THEN
  228.       Tempo := Nr;
  229. END;
  230.  
  231.  
  232.  
  233. { ---- public procs ------------------------------------------------------- }
  234.  
  235.  
  236.  
  237. { play music in the foreground }
  238. PROCEDURE PlayMF (Sounds: String);
  239. VAR
  240.    Posn: Integer;
  241.    Ch: Char;
  242. BEGIN
  243.    REPEAT                                        { remove spaces }
  244.       Posn := Pos(' ', Sounds);
  245.       IF Posn > 0 THEN
  246.          Delete(Sounds, Posn, 1);
  247.    UNTIL Posn = 0;
  248.    Sounds := UpperCase(Sounds);                  { convert to uppercase }
  249.    WHILE (Length(Sounds) > 0) DO BEGIN           { process music commands }
  250.       Ch := Sounds[1];
  251.       Delete(Sounds, 1, 1);
  252.       CASE Ch OF
  253.          '<': IF Octave > 1 THEN Dec(Octave);
  254.          '>': IF Octave < 6 THEN Inc(Octave);
  255.          'A'..'G': DoNoteLetter(Sounds, Ch);
  256.          'L': DoLength(Sounds);
  257.          'M': DoMiscCmd(Sounds);
  258.          'N': DoNoteNumber(Sounds);
  259.          'O': DoOctave(Sounds);
  260.          'P': DoPause(Sounds);
  261.          'T': DoTempo(Sounds);
  262.       END;
  263.    END;
  264. END;
  265.  
  266.  
  267.  
  268. { reset defaults to original values }
  269. PROCEDURE ResetMF;
  270. BEGIN
  271.    Octave := 4;
  272.    NoteLen := 4;
  273.    Tempo := 120;
  274.    SoundLen := 7;
  275. END;
  276.  
  277.  
  278.  
  279. { ----------------------- initialization code --------------------------- }
  280. BEGIN
  281.    BaseOctave[0]  := 18357;    { C }
  282.    BaseOctave[1]  := 17292;    { C# or D- }
  283.    BaseOctave[2]  := 16124;    { D }
  284.    BaseOctave[3]  := 15297;    { D# or E- }
  285.    BaseOctave[4]  := 14551;    { E }
  286.    BaseOctave[5]  := 13715;    { F }
  287.    BaseOctave[6]  := 12830;    { F# or G- }
  288.    BaseOctave[7]  := 12175;    { G }
  289.    BaseOctave[8]  := 11473;    { G# }
  290.    BaseOctave[9]  := 10847;    { A }
  291.    BaseOctave[10] := 10286;    { A# or B- }
  292.    BaseOctave[11] := 9623;     { B }
  293.    NoteConvert := 'JLACEFH';
  294.    TmpNoteLen := 0;
  295.    BaseTime := 38000;
  296.    ResetMF;
  297. END.
  298.