Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/BGSOUND.ZIP/BACKSOUN.PAS

Pascal/Delphi Source File | 1986-06-06 | 10.2 KB | 297 lines

{$C-}
{$U-}
{$K-}
{$R-}

{
  BGSND.INC

  Background Sound for Turbo Pascal
  Michael Quinlan
  9/17/85

  The routines are rather primitive, but could easily be extended.

  The sample routines at the end implement something similar to the
  BASIC PLAY statement.

}

type BGSItem   = record
                   cnt  : integer;  { count to load into the 8253-5 timer;
                                      count = 1,193,180 / frequency }
                   tics : integer   { timer tics to maintain the sound;
                                      18.2 tics per second }
                 end;

     _BGSItemP = ^BGSItem;

     _BGSCharP = ^Char;

const BGSPlaying : boolean = FALSE;  { TRUE while music is playing }
      _BGSDSSave : integer = 0;

var _BGSNextItem : _BGSItemP;
    _BGSNumItems : integer;
    _BGSOldInt1C : _BGSCharP;
    _BGSDuration : integer;

function _BGSGetInt(int : integer) : _BGSCharP;
{ call MsDos to get interrupt vector }
  var R : record case integer of
            1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : integer);
            2 : (al, ah, bl, bh, cl, ch, dl, dh            : byte)
          end;
  begin
    with R do begin
      ah := $35;
      al := int;
      MsDos(R);
      _BGSGetInt := Ptr(es, bx)
    end
  end;

procedure _BGSSetInt(int, s, o : integer);
  BEGIN
    Inline($B8/$00/$00/    { mov    ax,0                                      }
           $8E/$C0/        { mov    es,ax       ;es=seg of vector table       }
           $8B/$86/int/    { mov    ax,[bp+int] ;load interrupt num. in al    }
           $B1/$04/        { mov    cl,4        ;multiplier                   }
           $F6/$E1/        { mul    cl          ;ax=ofs of vector in table    }
           $89/$C7/        { mov    di,ax       ;es:di = addr of vector       }
           $8B/$86/o/      { mov    ax,[bp+o]   ;ax=new offset for vector     }
           $FA/            { cli                ;no interruptions please      }
           $AB/            { stosw              ;store offset into vector     }
           $8B/$86/s/      { mov    ax,[bp+s]   ;ax=new segment for vector    }
           $AB/            { stosw              ;store segment into vector    }
           $FB);           { sti                ;interrupts back on           }
  end;

procedure _BGSPlayNextItem;
{ used internally to begin playing the next sound segment }
  begin
    _BGSNumItems := _BGSNumItems - 1;
    Port[$43] := $B6;
    with _BGSNextItem^ do begin
      Port[$42] := Lo(cnt);
      Port[$42] := Hi(cnt);
      _BGSDuration := tics;
      if cnt <> 0 then Port[$61] := Port[$61] or $03
    end;
    _BGSNextItem := Ptr(Seg(_BGSNextItem^), Ofs(_BGSNextItem^) + SizeOf(BGSItem))
  end;

procedure _BGSInt1C;
{ Interrupt procedure invoked 18.2 times a second. Decrements a count and
  when the count equals zero, selects the next sound segment to play. }

  begin
    Inline($50/$53/$51/$52/$56/$57/$1E/$06/$FB);
    Inline($2E/$A1/_BGSDSSave/$8E/$D8);  { move _BGSDSSave to DS reg }
    _BGSDuration := _BGSDuration - 1;
    if _BGSDuration = 0 then begin
      Port[$61] := Port[$61] and $F8;
      if _BGSNumItems = 0 then begin
        _BGSSetInt($1C, Seg(_BGSOldInt1C^), Ofs(_BGSOldInt1C^));
        BGSPlaying := FALSE
      end else begin
        _BGSPlayNextItem
      end
    end;
    Inline($07/$1F/$5F/$5E/$5A/$59/$5B/$58/$8B/$E5/$5D/$CF)
  end;

procedure BGSPlay(n : integer; var items);

{ You call this procedure to play music in the background. You pass the number
  of sound segments, and an array with an element for each sound segment. The
  array elements are two words each; the first word has the count to be loaded
  into the timer (1,193,180 / frequency). The second word has the duration of
  the sound segment, in timer tics (18.2 tics per second). }

  var item_list : array[0..1000] of BGSItem absolute items;
  begin

    while BGSPlaying do  { wait for previous sounds to finish }
      ;

    if n > 0 then begin
      _BGSNumItems := n;
      _BGSNextItem := Addr(item_list[0]);
      BGSPlaying   := TRUE;
      _BGSPlayNextItem;
      _BGSOldInt1C := _BGSGetInt($1C);
      _BGSDSSave := DSeg;
      _BGSSetInt($1C, CSeg, Ofs(_BGSInt1C))
    end
  end;

{**************************************************************************}
{                                                                          }
{   Sample Routines                                                        }
{                                                                          }
{**************************************************************************}

(**)

{$R+}
{$K+}

type s255 = string[255];

var MusicArea : array[1..100] of BGSItem; { contains sound segments }

{ frequency table from Peter Norton's Programmer's Guide to the IBM PC, p. 147 }
const Frequency : array[0..83] of real =
  {    C        C#       D        D#       E        F        F#       G        G#       A        A#       B }
    (32.70,   34.65,   36.71,   38.89,   41.20,   43.65,   46.25,   49.00,   51.91,   55.00,   58.27,   61.74,
     65.41,   69.30,   73.42,   77.78,   82.41,   87.31,   92.50,   98.00,  103.83,  110.00,  116.54,  123.47,
    130.81,  138.59,  146.83,  155.56,  164.81,  174.61,  185.00,  196.00,  207.65,  220.00,  233.08,  246.94,
    261.63,  277.18,  293.66,  311.13,  329.63,  349.23,  369.99,  392.00,  415.30,  440.00,  466.16,  493.88,
    523.25,  554.37,  587.33,  622.25,  659.26,  698.46,  739.99,  783.99,  830.61,  880.00,  932.33,  987.77,
   1046.50, 1108.73, 1174.66, 1244.51, 1378.51, 1396.91, 1479.98, 1567.98, 1661.22, 1760.00, 1864.66, 1975.53,
   2093.00, 2217.46, 2349.32, 2489.02, 2637.02, 2793.83, 2959.96, 3135.96, 3322.44, 3520.00, 3729.31, 3951.07);

procedure PlayMusic(s : s255);
{ Accept a string similar to the BASIC PLAY statement. The following are
  allowed:
    A to G with optional #
      Plays the indicated note in the current octave. A # following the letter
      indicates sharp. A number following the letter indicates the length of
      the note (4 = quarter note, 16 = sixteenth note, 1 = whole note, etc.).
    On
      Sets the octave to "n". There are 7 octaves, numbered 0 to 6. Each octave
      goes from C to B. Octave 3 starts with middle C.
    Ln
      Sets the default length of following notes. L1 = whole notes, L2 = half
      notes, etc. The length can be overridden for a specific note by follow-
      ing the note letter with a number.
    Pn
      Pause. n specifies the length of the pause, just like a note.
    Tn
      Tempo. Number of quarter notes per minute. Default is 120.

  Spaces are allowed between items, but not within items. }

  var i, n : integer;  { i is the offset in the parameter string;
                         n is the element number in MusicArea }
      cchar : char;

  var NoteLength    : integer;
      Tempo         : integer;
      CurrentOctave : integer;

  function GetNumber : integer;
  { get a number from the parameter string }
  { increments i past the end of the number }
    var n : integer;
    begin
      n := 0;
      while (i <= length(s)) and (s[i] in ['0'..'9']) do begin
        n := n * 10 + (Ord(s[i]) - Ord('0'));
        i := i + 1
      end;
      GetNumber := n
    end;

  procedure GetNote;
  { input is a note letter. convert it to two sound segments --
    one for the sound then a pause following the sound. }
  { increments i past the current item }
    var note : integer;
        len  : integer;
        l    : real;

    function CheckSharp(n : integer) : integer;
    { check for a sharp following the letter. increments i if one found }
      begin
        if (i < length(s)) and (s[i] = '#') then begin
          i := i + 1;
          CheckSharp := n + 1
        end else
          CheckSharp := n
      end;  { CheckSharp }

    function FreqToCount(f : real) : integer;
    { convert a frequency to a timer count }
      begin
        FreqToCount := Round(1193180.0 / f)
      end;  { FreqToCount }

    begin  { GetNote }
      case cchar of
        'A' : note := CheckSharp(9);
        'B' : note := 11;
        'C' : note := CheckSharp(0);
        'D' : note := CheckSharp(2);
        'E' : note := 4;
        'F' : note := CheckSharp(5);
        'G' : note := CheckSharp(7)
      end;
      MusicArea[n].cnt := FreqToCount(Frequency[(CurrentOctave * 12) + note]);
      if (s[i] in ['0'..'9']) and (i <= length(s)) then
        len := GetNumber
      else
        len := NoteLength;
      l := 18.2 * 60.0 * 4.0 / (Tempo * len);
      MusicArea[n].tics := Round(7.0 * l / 8.0);
      if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
      n := n + 1;
      MusicArea[n].cnt := 0;
      MusicArea[n].tics := Round(l / 8.0);
      if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
      n := n + 1
    end;  { GetNote }

  procedure GetPause;
  { input is a pause. convert it to a silent sound segment. }
  { increments i past the current item }
    var len  : integer;
        l    : real;

    begin  { GetPause }
      MusicArea[n].cnt := 0;
      if (s[i] in ['0'..'9']) and (i <= length(s)) then
        len := GetNumber
      else
        len := NoteLength;
      l := 18.2 * 60.0 * 4.0 / (Tempo * len);
      MusicArea[n].tics := Round(l);
      if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
      n := n + 1;
    end;  { GetPause }

  begin
    NoteLength := 4;
    Tempo := 120;
    CurrentOctave := 3;

    n := 1;
    i := 1;
    while i <= length(s) do begin
      cchar := s[i];
      i := i + 1;
      case cchar of
        'A'..'G' : GetNote;
        'O'      : CurrentOctave := GetNumber;
        'L'      : NoteLength    := GetNumber;
        'P'      : GetPause;
        'T'      : Tempo         := Getnumber
      end
    end;
    BGSPlay(n-1, MusicArea)
  end;

begin
  writeln('Building music');
  PlayMusic('T80 O4 L8 GFE-FGGG P8 FFF4 GB-B-4 GFE-FGGG GFFGFE-');
  writeln('Music is playing');
  while BGSPlaying do begin  { wait for music to end }
    if WhereY = 25 then ClrScr;
    writeln('The program can continue processing while the music is playing')
  end;
  writeln('Music is done')
end.

*)