home *** CD-ROM | disk | FTP | other *** search
/ SDN¹ Plus / SDN1_.cdr / program / bgsnd.pas < prev    next >
Pascal/Delphi Source File  |  1991-06-26  |  10KB  |  300 lines
  1. {$C-}
  2. {$U-}
  3. {$K-}
  4. {$R-}
  5.  
  6. {
  7.   BGSND.INC
  8.  
  9.   Background Sound for Turbo Pascal
  10.   Michael Quinlan
  11.   9/17/85
  12.  
  13.   The routines are rather primitive, but could easily be extended.
  14.  
  15.   The sample routines at the end implement something similar to the
  16.   BASIC PLAY statement.
  17.  
  18. }
  19.  
  20. type BGSItem   = record
  21.                    cnt  : integer;  { count to load into the 8253-5 timer;
  22.                                       count = 1,193,180 / frequency }
  23.                    tics : integer   { timer tics to maintain the sound;
  24.                                       18.2 tics per second }
  25.                  end;
  26.  
  27.      _BGSItemP = ^BGSItem;
  28.  
  29.      _BGSCharP = ^Char;
  30.  
  31. const BGSPlaying : boolean = FALSE;  { TRUE while music is playing }
  32.       _BGSDSSave : integer = 0;
  33.  
  34. var _BGSNextItem : _BGSItemP;
  35.     _BGSNumItems : integer;
  36.     _BGSOldInt1C : _BGSCharP;
  37.     _BGSDuration : integer;
  38.  
  39. function _BGSGetInt(int : integer) : _BGSCharP;
  40. { call MsDos to get interrupt vector }
  41.   var R : record case integer of
  42.             1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : integer);
  43.             2 : (al, ah, bl, bh, cl, ch, dl, dh            : byte)
  44.           end;
  45.   begin
  46.     with R do begin
  47.       ah := $35;
  48.       al := int;
  49.       MsDos(R);
  50.       _BGSGetInt := Ptr(es, bx)
  51.     end
  52.   end;
  53.  
  54. procedure _BGSSetInt(int, s, o : integer);
  55. { call MsDos to set an interrupt vector }
  56.   var R : record case integer of
  57.             1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : integer);
  58.             2 : (al, ah, bl, bh, cl, ch, dl, dh            : byte)
  59.           end;
  60.   begin
  61.     with R do begin
  62.       ah := $25;
  63.       al := int;
  64.       ds := s;
  65.       dx := o;
  66.       MsDos(R)
  67.     end
  68.   end;
  69.  
  70. procedure _BGSPlayNextItem;
  71. { used internally to begin playing the next sound segment }
  72.   begin
  73.     _BGSNumItems := _BGSNumItems - 1;
  74.     Port[$43] := $B6;
  75.     with _BGSNextItem^ do begin
  76.       Port[$42] := Lo(cnt);
  77.       Port[$42] := Hi(cnt);
  78.       _BGSDuration := tics;
  79.       if cnt <> 0 then Port[$61] := Port[$61] or $03  { turn on sound }
  80.     end;
  81.     _BGSNextItem := Ptr(Seg(_BGSNextItem^), Ofs(_BGSNextItem^) + SizeOf(BGSItem))
  82.   end;
  83.  
  84. procedure _BGSInt1C;
  85. { Interrupt procedure invoked 18.2 times a second. Decrements a count and
  86.   when the count equals zero, selects the next sound segment to play. }
  87.  
  88.   begin
  89.     Inline($50/$53/$51/$52/$56/$57/$1E/$06/$FB);
  90.     Inline($2E/$A1/_BGSDSSave/$8E/$D8);  { move _BGSDSSave to DS reg }
  91.     _BGSDuration := _BGSDuration - 1;
  92.     if _BGSDuration = 0 then begin
  93.       Port[$61] := Port[$61] and $FC; { turn off sound }
  94.       if _BGSNumItems = 0 then begin
  95.         _BGSSetInt($1C, Seg(_BGSOldInt1C^), Ofs(_BGSOldInt1C^));
  96.         BGSPlaying := FALSE
  97.       end else begin
  98.         _BGSPlayNextItem
  99.       end
  100.     end;
  101.     Inline($07/$1F/$5F/$5E/$5A/$59/$5B/$58/$8B/$E5/$5D/$CF)
  102.   end;
  103.  
  104. procedure BGSPlay(n : integer; var items);
  105.  
  106. { You call this procedure to play music in the background. You pass the number
  107.   of sound segments, and an array with an element for each sound segment. The
  108.   array elements are two words each; the first word has the count to be loaded
  109.   into the timer (1,193,180 / frequency). The second word has the duration of
  110.   the sound segment, in timer tics (18.2 tics per second). }
  111.  
  112.   var item_list : array[0..1000] of BGSItem absolute items;
  113.   begin
  114.  
  115.     while BGSPlaying do  { wait for previous sounds to finish }
  116.       ;
  117.  
  118.     if n > 0 then begin
  119.       _BGSNumItems := n;
  120.       _BGSNextItem := Addr(item_list[0]);
  121.       BGSPlaying   := TRUE;
  122.       _BGSPlayNextItem;
  123.       _BGSOldInt1C := _BGSGetInt($1C);
  124.       _BGSDSSave := DSeg;
  125.       _BGSSetInt($1C, CSeg, Ofs(_BGSInt1C))
  126.     end
  127.   end;
  128.  
  129. {**************************************************************************}
  130. {                                                                          }
  131. {   Sample Routines                                                        }
  132. {                                                                          }
  133. {**************************************************************************}
  134.  
  135. (**)
  136.  
  137. {$R+}
  138. {$K+}
  139.  
  140. type s255 = string[255];
  141.  
  142. var MusicArea : array[1..100] of BGSItem; { contains sound segments }
  143.  
  144. { frequency table from Peter Norton's Programmer's Guide to the IBM PC, p. 147 }
  145. const Frequency : array[0..83] of real =
  146.   {    C        C#       D        D#       E        F        F#       G        G#       A        A#       B }
  147.     (32.70,   34.65,   36.71,   38.89,   41.20,   43.65,   46.25,   49.00,   51.91,   55.00,   58.27,   61.74,
  148.      65.41,   69.30,   73.42,   77.78,   82.41,   87.31,   92.50,   98.00,  103.83,  110.00,  116.54,  123.47,
  149.     130.81,  138.59,  146.83,  155.56,  164.81,  174.61,  185.00,  196.00,  207.65,  220.00,  233.08,  246.94,
  150.     261.63,  277.18,  293.66,  311.13,  329.63,  349.23,  369.99,  392.00,  415.30,  440.00,  466.16,  493.88,
  151.     523.25,  554.37,  587.33,  622.25,  659.26,  698.46,  739.99,  783.99,  830.61,  880.00,  932.33,  987.77,
  152.    1046.50, 1108.73, 1174.66, 1244.51, 1378.51, 1396.91, 1479.98, 1567.98, 1661.22, 1760.00, 1864.66, 1975.53,
  153.    2093.00, 2217.46, 2349.32, 2489.02, 2637.02, 2793.83, 2959.96, 3135.96, 3322.44, 3520.00, 3729.31, 3951.07);
  154.  
  155. procedure PlayMusic(s : s255);
  156. { Accept a string similar to the BASIC PLAY statement. The following are  allowed:
  157.     A to G with optional #
  158.       Plays the indicated note in the current octave. A # following the letter
  159.       indicates sharp. A number following the letter indicates the length of
  160.       the note (4 = quarter note, 16 = sixteenth note, 1 = whole note, etc.).
  161.     On
  162.       Sets the octave to "n". There are 7 octaves, numbered 0 to 6. Each octave
  163.       goes from C to B. Octave 3 starts with middle C.
  164.     Ln
  165.       Sets the default length of following notes. L1 = whole notes, L2 = half
  166.       notes, etc. The length can be overridden for a specific note by follow-
  167.       ing the note letter with a number.
  168.     Pn
  169.       Pause. n specifies the length of the pause, just like a note.
  170.     Tn
  171.       Tempo. Number of quarter notes per minute. Default is 120.
  172.  
  173.   Spaces are allowed between items, but not within items. }
  174.  
  175.   var i, n : integer;  { i is the offset in the parameter string;
  176.                          n is the element number in MusicArea }
  177.       cchar : char;
  178.  
  179.   var NoteLength    : integer;
  180.       Tempo         : integer;
  181.       CurrentOctave : integer;
  182.  
  183.   function GetNumber : integer;
  184.   { get a number from the parameter string }
  185.   { increments i past the end of the number }
  186.     var n : integer;
  187.     begin
  188.       n := 0;
  189.       while (i <= length(s)) and (s[i] in ['0'..'9']) do begin
  190.         n := n * 10 + (Ord(s[i]) - Ord('0'));
  191.         i := i + 1
  192.       end;
  193.       GetNumber := n
  194.     end;
  195.  
  196.   procedure GetNote;
  197.   { input is a note letter. convert it to two sound segments --
  198.     one for the sound then a pause following the sound. }
  199.   { increments i past the current item }
  200.     var note : integer;
  201.         len  : integer;
  202.         l    : real;
  203.  
  204.     function CheckSharp(n : integer) : integer;
  205.     { check for a sharp following the letter. increments i if one found }
  206.       begin
  207.         if (i < length(s)) and (s[i] = '#') then begin
  208.           i := i + 1;
  209.           CheckSharp := n + 1
  210.         end else
  211.           CheckSharp := n
  212.       end;  { CheckSharp }
  213.  
  214.     function FreqToCount(f : real) : integer;
  215.     { convert a frequency to a timer count }
  216.       begin
  217.         FreqToCount := Round(1193180.0 / f)
  218.       end;  { FreqToCount }
  219.  
  220.     begin  { GetNote }
  221.       case cchar of
  222.         'A' : note := CheckSharp(9);
  223.         'B' : note := 11;
  224.         'C' : note := CheckSharp(0);
  225.         'D' : note := CheckSharp(2);
  226.         'E' : note := 4;
  227.         'F' : note := CheckSharp(5);
  228.         'G' : note := CheckSharp(7)
  229.       end;
  230.       MusicArea[n].cnt := FreqToCount(Frequency[(CurrentOctave * 12) + note]);
  231.       if (s[i] in ['0'..'9']) and (i <= length(s)) then
  232.         len := GetNumber
  233.       else
  234.         len := NoteLength;
  235.       l := 18.2 * 60.0 * 4.0 / (Tempo * len);
  236.       MusicArea[n].tics := Round(7.0 * l / 8.0);
  237.       if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
  238.       n := n + 1;
  239.       MusicArea[n].cnt := 0;
  240.       MusicArea[n].tics := Round(l / 8.0);
  241.       if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
  242.       n := n + 1
  243.     end;  { GetNote }
  244.  
  245.   procedure GetPause;
  246.   { input is a pause. convert it to a silent sound segment. }
  247.   { increments i past the current item }
  248.     var len  : integer;
  249.         l    : real;
  250.  
  251.     begin  { GetPause }
  252.       MusicArea[n].cnt := 0;
  253.       if (s[i] in ['0'..'9']) and (i <= length(s)) then
  254.         len := GetNumber
  255.       else
  256.         len := NoteLength;
  257.       l := 18.2 * 60.0 * 4.0 / (Tempo * len);
  258.       MusicArea[n].tics := Round(l);
  259.       if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
  260.       n := n + 1;
  261.     end;  { GetPause }
  262.  
  263.   begin
  264.     NoteLength := 4;
  265.     Tempo := 120;
  266.     CurrentOctave := 3;
  267.  
  268.     n := 1;
  269.     i := 1;
  270.     while i <= length(s) do begin
  271.       cchar := s[i];
  272.       i := i + 1;
  273.       case cchar of
  274.         'A'..'G' : GetNote;
  275.         'O'      : CurrentOctave := GetNumber;
  276.         'L'      : NoteLength    := GetNumber;
  277.         'P'      : GetPause;
  278.         'T'      : Tempo         := GetNumber;
  279.       end
  280.     end;
  281.     BGSPlay(n-1, MusicArea)
  282.   end;
  283.  
  284. begin
  285.   writeln('Building music');
  286.   PlayMusic('T100 O3 L8 GFE-FGGG P8 FFF4 GB-B-4 P8 GFE-FGGG GFFGFE-');
  287.   writeln('Music is playing');
  288.   while BGSPlaying do begin  { wait for music to end }
  289.     if WhereY = 25 then ClrScr;
  290.     writeln('The program can continue processing while the MUSIC is playing!')
  291.   end;
  292.   writeln('Music is done')
  293. end.
  294.  
  295.  
  296.  
  297.  
  298. File Area #18: \PAS\
  299. File Command:
  300.