home *** CD-ROM | disk | FTP | other *** search
/ Sound Sensations! / sound_sensations.iso / programr / soundbk / backsoun.inc
Text File  |  1985-12-20  |  10KB  |  297 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
  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 $F8;
  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
  157.   allowed:
  158.     A to G with optional #
  159.       Plays the indicated note in the current octave. A # following the letter
  160.       indicates sharp. A number following the letter indicates the length of
  161.       the note (4 = quarter note, 16 = sixteenth note, 1 = whole note, etc.).
  162.     On
  163.       Sets the octave to "n". There are 7 octaves, numbered 0 to 6. Each octave
  164.       goes from C to B. Octave 3 starts with middle C.
  165.     Ln
  166.       Sets the default length of following notes. L1 = whole notes, L2 = half
  167.       notes, etc. The length can be overridden for a specific note by follow-
  168.       ing the note letter with a number.
  169.     Pn
  170.       Pause. n specifies the length of the pause, just like a note.
  171.     Tn
  172.       Tempo. Number of quarter notes per minute. Default is 120.
  173.  
  174.   Spaces are allowed between items, but not within items. }
  175.  
  176.   var i, n : integer;  { i is the offset in the parameter string;
  177.                          n is the element number in MusicArea }
  178.       cchar : char;
  179.  
  180.   var NoteLength    : integer;
  181.       Tempo         : integer;
  182.       CurrentOctave : integer;
  183.  
  184.   function GetNumber : integer;
  185.   { get a number from the parameter string }
  186.   { increments i past the end of the number }
  187.     var n : integer;
  188.     begin
  189.       n := 0;
  190.       while (i <= length(s)) and (s[i] in ['0'..'9']) do begin
  191.         n := n * 10 + (Ord(s[i]) - Ord('0'));
  192.         i := i + 1
  193.       end;
  194.       GetNumber := n
  195.     end;
  196.  
  197.   procedure GetNote;
  198.   { input is a note letter. convert it to two sound segments --
  199.     one for the sound then a pause following the sound. }
  200.   { increments i past the current item }
  201.     var note : integer;
  202.         len  : integer;
  203.         l    : real;
  204.  
  205.     function CheckSharp(n : integer) : integer;
  206.     { check for a sharp following the letter. increments i if one found }
  207.       begin
  208.         if (i < length(s)) and (s[i] = '#') then begin
  209.           i := i + 1;
  210.           CheckSharp := n + 1
  211.         end else
  212.           CheckSharp := n
  213.       end;  { CheckSharp }
  214.  
  215.     function FreqToCount(f : real) : integer;
  216.     { convert a frequency to a timer count }
  217.       begin
  218.         FreqToCount := Round(1193180.0 / f)
  219.       end;  { FreqToCount }
  220.  
  221.     begin  { GetNote }
  222.       case cchar of
  223.         'A' : note := CheckSharp(9);
  224.         'B' : note := 11;
  225.         'C' : note := CheckSharp(0);
  226.         'D' : note := CheckSharp(2);
  227.         'E' : note := 4;
  228.         'F' : note := CheckSharp(5);
  229.         'G' : note := CheckSharp(7)
  230.       end;
  231.       MusicArea[n].cnt := FreqToCount(Frequency[(CurrentOctave * 12) + note]);
  232.       if (s[i] in ['0'..'9']) and (i <= length(s)) then
  233.         len := GetNumber
  234.       else
  235.         len := NoteLength;
  236.       l := 18.2 * 60.0 * 4.0 / (Tempo * len);
  237.       MusicArea[n].tics := Round(7.0 * l / 8.0);
  238.       if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
  239.       n := n + 1;
  240.       MusicArea[n].cnt := 0;
  241.       MusicArea[n].tics := Round(l / 8.0);
  242.       if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
  243.       n := n + 1
  244.     end;  { GetNote }
  245.  
  246.   procedure GetPause;
  247.   { input is a pause. convert it to a silent sound segment. }
  248.   { increments i past the current item }
  249.     var len  : integer;
  250.         l    : real;
  251.  
  252.     begin  { GetPause }
  253.       MusicArea[n].cnt := 0;
  254.       if (s[i] in ['0'..'9']) and (i <= length(s)) then
  255.         len := GetNumber
  256.       else
  257.         len := NoteLength;
  258.       l := 18.2 * 60.0 * 4.0 / (Tempo * len);
  259.       MusicArea[n].tics := Round(l);
  260.       if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
  261.       n := n + 1;
  262.     end;  { GetPause }
  263.  
  264.   begin
  265.     NoteLength := 4;
  266.     Tempo := 120;
  267.     CurrentOctave := 3;
  268.  
  269.     n := 1;
  270.     i := 1;
  271.     while i <= length(s) do begin
  272.       cchar := s[i];
  273.       i := i + 1;
  274.       case cchar of
  275.         'A'..'G' : GetNote;
  276.         'O'      : CurrentOctave := GetNumber;
  277.         'L'      : NoteLength    := GetNumber;
  278.         'P'      : GetPause;
  279.         'T'      : Tempo         := Getnumber
  280.       end
  281.     end;
  282.     BGSPlay(n-1, MusicArea)
  283.   end;
  284.  
  285. begin
  286.   writeln('Building music');
  287.   PlayMusic('T80 O4 L8 GFE-FGGG P8 FFF4 GB-B-4 GFE-FGGG GFFGFE-');
  288.   writeln('Music is playing');
  289.   while BGSPlaying do begin  { wait for music to end }
  290.     if WhereY = 25 then ClrScr;
  291.     writeln('The program can continue processing while the music is playing')
  292.   end;
  293.   writeln('Music is done')
  294. end.
  295.  
  296. *)
  297.