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