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

Pascal/Delphi Source File | 1991-01-30 | 8.1 KB | 256 lines

UNIT BGSOUND;

{$S-,R-,F+}

{
 UNIT BGSOUND;
  Version for Turbo Pascal 6.0 by Francesco Duranti (30 january 1991)
  From BGSOUND adapted for TP5.5 by Francesco Duranti (9 january 1991)

 From :
  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.

}

INTERFACE

uses crt,dos;

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;


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

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). }

procedure PlayMusic(s : string);
{ 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 a 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. }

IMPLEMENTATION

var _BGSNextItem : _BGSItemP;
    _BGSNumItems : integer;
    _BGSOldInt1C : procedure;
    _BGSDuration : integer;
    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 _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;
{ 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
    asm
      pushf
      cli
    end;
    _BGSOldInt1C;
    _BGSDuration := _BGSDuration - 1;
    if _BGSDuration = 0 then begin
      Port[$61] := Port[$61] and $F8;
      if _BGSNumItems = 0 then begin
        SetIntvec($1C, addr(_BGSOldInt1C));
        BGSPlaying := FALSE
      end else begin
        _BGSPlayNextItem
      end
    end;
    asm
      sti
    end;
  end;

procedure BGSPlay(n : integer; var items);

  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;
      GetIntvec($1C,addr(_BGSOldInt1C));
      SetIntvec($1C,addr(_BGSInt1C))
    end
  end;

procedure PlayMusic(s : string);
  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;

end.