home *** CD-ROM | disk | FTP | other *** search
/ The Mother of All Windows Books / CD-MOM.iso / cd_mom / newsletr / vbz / vbz1-3 / dll_src.exe / WINPLAY.PAS < prev    next >
Pascal/Delphi Source File  |  1993-02-25  |  4KB  |  167 lines
  1. library WINPLAY;
  2. {This is a Windows implementation of the BASIC PLAY}
  3. {command. To use it, you must first open the sound}
  4. {queue with OpenSound}
  5. {by Jonathan Zuck}
  6. {Copyright 1991-3 Jonathan Zuck & User Friendly, Inc.}
  7.  
  8. {$R WINPLAY}
  9.  
  10. uses WinProcs, WinTypes, Strings;
  11.  
  12. Const
  13. A = 65; P = 80;
  14.  
  15. NoteArr: Array[A..P] OF Integer =
  16.     (10,12,1,3,5,6,8,0,0,0,0,0,0,0,0,0);
  17.  
  18. Var  {These are values that should remain between calls}
  19.     hLastCall:Integer;
  20.     Tempo:Integer;
  21.   Music:Integer;
  22.   Octave:Integer;
  23.   Length:Integer;
  24.  
  25. Var {These are temporary values for the SendNote Proc}
  26.     NewNote, NewAccent,
  27.   ForeGround:Bool;
  28.   Pitch, NoteLength, Dots:Integer;
  29.   El: Integer;
  30.  
  31. procedure SendNote;forward;
  32. function GetNumber (Song:PChar):Integer;forward;
  33.  
  34. procedure Play (Song:PChar);export;
  35. Var
  36.     hCaller:Integer;
  37. Begin
  38.   hCaller := GetCurrentTask;
  39.   if hCaller <> hLastCall then
  40.       begin
  41.         hLastCall := hCaller;
  42.         Tempo := 120;
  43.         Music := 0;
  44.         Octave := 3;
  45.       Length := 4;
  46.              ForeGround := TRUE;
  47.     end;
  48.   Dots := 0;
  49.     NewNote := FALSE;
  50.   NewAccent := TRUE;
  51.   NoteLength := 0;
  52.     AnsiUpper (Song);
  53.   El := 0;
  54.   While Song[El] <> #0 do
  55.       Begin
  56.       case Song[El] of
  57.           'A'..'G', 'P':
  58.             begin
  59.                 SendNote;
  60.               Pitch := NoteArr[Ord(Song[El])];
  61.               NewNote := TRUE;
  62.             end;
  63.         '+', '#':
  64.             Inc (Pitch);
  65.         '-':
  66.             Dec (Pitch);
  67.         '.':
  68.             Inc (Dots);
  69.         '1'..'9':
  70.             NoteLength := GetNumber (Song);
  71.         '>':
  72.             begin
  73.               SendNote;
  74.             Inc (Octave);
  75.           end;
  76.         '<':
  77.             begin
  78.               SendNote;
  79.             Dec (Octave);
  80.           end;
  81.         'M':
  82.             begin
  83.               SendNote;
  84.             Inc (El);
  85.             case Song[El] of
  86.                 'N':
  87.                   Music := S_NORMAL;
  88.               'S':
  89.                   Music := S_STACCATO;
  90.               'L':
  91.                   Music := S_LEGATO;
  92.               'F':
  93.                   ForeGround := TRUE;
  94.               'B':
  95.                   ForeGround := FALSE;
  96.             end;
  97.             NewAccent := TRUE;
  98.           end;
  99.         'N':
  100.             begin
  101.               SendNote;
  102.             Inc (El);
  103.             Pitch := GetNumber (Song);
  104.             NewNote := TRUE;
  105.           end;
  106.         'O':
  107.             begin
  108.               SendNote;
  109.             Inc (El);
  110.             Octave := GetNumber (Song);
  111.           end;
  112.         'T':
  113.             begin
  114.               SendNote;
  115.             Inc (El);
  116.             Tempo := GetNumber (Song);
  117.             NewAccent := TRUE;
  118.           end;
  119.         'L':
  120.             begin
  121.               SendNote;
  122.             Inc (El);
  123.             Length := GetNumber (Song);
  124.           end;
  125.       end;
  126.       Inc (El);
  127.     end;
  128.   SendNote;
  129.   if ForeGround then WaitSoundState (0);
  130. End;
  131.  
  132. procedure SendNote;
  133. Begin
  134.     If NewAccent then SetVoiceAccent (1, Tempo, 1, Music, 0);
  135.   If NewNote then
  136.       begin
  137.         If Pitch > 0 then Pitch := (Pitch + (Octave * 12)) - 1;
  138.       If NoteLength = 0 then NoteLength := Length;
  139.       While SetVoiceNote (1, Pitch, NoteLength, Dots) <> 0 Do;
  140.       StartSound;
  141.       NoteLength := 0;
  142.       Dots := 0;
  143.     end;
  144.   NewNote := FALSE;
  145.   NewAccent := FALSE;
  146. End;
  147.  
  148. function GetNumber (Song:PChar):Integer;
  149. Var
  150.     Temp:Integer;
  151. Begin
  152.   Temp := Ord(Song[El]) - 48;   {Convert to number}
  153.   While (Song[El+1] >= '0') and (Song[El+1] <= '9') do
  154.       begin
  155.           Temp := (Temp * 10) + (Ord(Song[El+1]) - 48);
  156.         Inc (El);
  157.     end;
  158.   GetNumber := Temp;
  159. End;
  160.  
  161. Exports
  162.     Play    resident;
  163.  
  164. Begin
  165.   hLastCall := 0;
  166. End.
  167.