[Back to SOUND SWAG index] [Back to Main SWAG index] [Original]

    {  SEE XX34 modules at end of document !!!}

    {$R-,F+}

    {
      ******************************************************************
      BGSND.PAS

      Background Sound for Turbo Pascal

      Adapted from BGSND.INC for Turbo Pascal 3.0
      by Michael Quinlan
      9/17/85

      This version for Turbo Pascal 6.0
      by Larry Hadley
      3/20/93

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

      The sample routines included implement something similar to the
      BASIC PLAY statement.
      ******************************************************************
    }
    Unit BGSND;

    INTERFACE

    Uses
       DOS;

    CONST
       BGSVer = '2.0';               { Unit version number }

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

    VAR
       _BGSNumItems :integer;

    procedure BGSPlay(n :integer; VAR items);

    procedure _BGSStopPlay;

    procedure PlayMusic(s :string);

    IMPLEMENTATION

    TYPE
       BGSItem = RECORD
                    cnt :word;     { 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;

    VAR
       _BGSNextItem :_BGSItemP;
       _BGSOldInt1C :pointer;
       _BGSDuration :integer;
       ExitSave     :pointer;

    procedure _BGSsaveDS; external;      { saves ds as a CS:CONSTANT for use
                                            within the int 1C vector }
    procedure _BGSPlayNextItem; external; { used by int 1C vector - selects next
                                            note to play }
    procedure _BGSStopPlay; external;

    procedure _BGSInt1C; external;        { int1C vector - hooks timer }
    {$L BGS.OBJ}

    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;
            _BGSsaveDS;
            SetIntVec($1C, @_BGSInt1C);
         END;
      END;

    procedure BGSErrorExit;
    {
     **************************************************************************
     In case there's an "oopsie" ... make sure that Int $1C is clean, and
     music isn't playing.
     **************************************************************************
    }
      BEGIN
         ExitProc := ExitSave;
         if BGSPLaying then
         BEGIN
            _BGSStopPlay;
            SetIntVec($1C, _BGSOldInt1C);
         END;
      END;

    {
     **************************************************************************

        BASIC PLAY Routines

     **************************************************************************
    }

    {$R+}

    VAR
       MusicArea : array[1..255] 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 :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
        (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.

        Period (.) terminates processing.

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

       VAR
          i, n,            { i is the offset in the parameter string;
                             n is the element number in MusicArea }
          NoteLength,
          Tempo,
          CurrentOctave :integer;
          cchar         :char;

       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,
             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; { case }

             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 { PlayMusic }
          NoteLength := 4;
          Tempo := 120;
          CurrentOctave := 3;

          n := 1;
          i := 1;
          while (i <= length(s)) and (s[i]<>'.') 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; { case }
          END;
          BGSPlay(n-1, MusicArea)
       END; { PlayMusic }

    BEGIN { Unit init code }
      ExitSave := ExitProc;
      ExitProc := @BGSErrorExit;

      GetIntVec($1C, _BGSOldInt1C);

      Writeln('BGS v'+BGSVer);
    END.

    (*   DEMO PROGRAM FOR BACKGROUND SOUND *)

    {$M 1024, 0, 0}
    Program PlayBG;

    Uses
       DOS,
       CRT,
       BGSND;

    VAR
       F1              :text;
       play_str, buf,
       fname, progname :string;

    Procedure Usage;
       BEGIN
          Writeln('PLAYBG <playfile>');
          Writeln(#10+#13+'Where:');
          Writeln(' <playfile> is the file containing the music you want played in');
          Writeln('            the background');
          Writeln(#10+#13+'The playfile contains a series of notes in ascii format');
          Writeln;
          Halt(1);
       END;

    {$I-}
    Function Exists(name:string):boolean;
       VAR
          F :file;
       BEGIN
          Assign(f, name);
          Reset(f);
          if IOresult<>0 then
             Exists := FALSE
          ELSE
          BEGIN
             Exists := TRUE;
             Close(f);
          END;
       END;
    {$I+}

    Function AskYN:boolean;
       VAR
          ch :char;
       BEGIN
          repeat
             ch := ReadKey;
             if ch = #0 then
             BEGIN
                ch := ReadKey;
                ch := #0;
             END;
          until ch in ['y','Y','n','N'];
          Write(ch);
          case ch of
            'Y','y' : AskYN := TRUE;
            'N','n' : AskYN := FALSE;
          END;
       END;

    BEGIN
       Writeln('Background Play 1.0');

       if ParamCount<1 then
          Usage;

       fname := ParamStr(1);
       Assign(F1, fname);

       if (fname='') or not(Exists(fname)) then
       BEGIN
          Writeln('Invalid playfile.');
          Halt(2);
       END;

       play_str := '';
       Reset(F1);

       repeat
          ReadLn(F1, buf);
          play_str := play_str+buf;
       until Eof(F1) or (Length(play_str)>=200);

       Close(F1);

       Writeln(play_str);  {debug}
       PlayMusic(play_str);

       Exec(GetEnv('COMSPEC'), '');

       if BGSPlaying then
       BEGIN
           Writeln('Music still playing - wait for it to finish?');
           if Not(AskYN) then
              _BGSStopPlay;
           while BGSPLaying do;
       END;
    END.

    (*

    XX34 Of OBJ CODE FILES.  Extract to separte files and use XX3401 to
    create BGS.OBJ and PLAYFIL.ASC.  Here is how to use :

    1. Copy first block to BGS.XX.
    2. run XX3401 : XX3401 D BGS.XX.  This will create BGS.OBJ.
    3. Copy second block to PLAYFIL.XX.
    4. run XX3401 : XX3401 D PLAYFIL.XX
    5. Write unit code to BGSND.PAS.  Compile.
    6. Write demo code to PLAYSND.PAS Compile and run.

    *XX3401-000674-210393--68--85-48874---------BGS.OBJ--1-OF--1
    U-U+3aIuL4ZWPJlWNrBjRKtYL47bQmt-IooeW0++++-IRL7WPm--QrBZPK7gNL6U63NZ
    QbBdPqsUAWskAMS65U-+uF6-RFcKNHdQOK7hL47bQqxpPaFQMaRn9Y3HHJ46+k-+uImK
    +U++O6U1+20VZ7M9++F2EJF--2F-J22Xa+Q+G++++UA-2tM9++F1HoF3-2BDF2IVa+Q+
    8Bo+-+I-Icl3++lTEYRHHZJBGJF3HJA+13x0FpBCFJVIGJF3HE+ALo75IoxAF2ZCJ131
    ++lTEYRHF3JGEJF7Hos+0Y75Ip-AEJZ7HYQ+ZN+L+++023x0FpBEH23NHYJMJ2ZIFIp3
    +++XY-++++67Lo75IoZCJ131WE++Ad+F+++00Zx0FpBHFJF7HZE6+++tY-A+++6ALo75
    IpBIHp-EH23N8E++Pt+F+++00Zx0FpBHEJN3F3A0++-EW+E+E86-YO1T++60+0uA5U++
    mpK9v9U++6v+WoM8gEHqsMjsWoM4yei9FUWfysjZLQc4+9UQ+30V+U-EcE++I+vcnzzY
    MGHsta54-U+++AhJWymV++-6ck++g9PaEwEy+++aWULaEWO8FE5aEWO9FE8X+++aUno+
    R+PYMEk1ta52DU++XII2XA8X++073U6+WyJRmpK9v3-HIJ7KJls4ymuC5U++cE++G8A+
    +6Ay++++RGbYMGHsta41DU+++5IMi-k+I820+30V++-E1iV1zwM4++++ukKE1iVozkQT
    LptOKJhMWyJRnsmQLU12+pE0l0k4+ED2A+M-+wEz-U23l2Q4+E52GkM-+QFH-U20l4I4
    +EH2REM-+gFx-U20l624+E92ZZE0l7Y4+EH2bEM--AGV-U22l8s4+E52i+M-+wGw-U21
    lAI4+EJrWU6++5E+
    ***** END OF XX-BLOCK *****

    {-------------------------  CUT HERE -------------------------------}

    *XX3401-000047-210393--68--85-51905-----PLAYFIL.ASC--1-OF--1
    J1Uk62wo62ks62R4FIN5FoQUI1UUFYN4B0-5EY6o62R4FIN5FoQUFoN4FoN31Ec+
    ***** END OF XX-BLOCK *****

    *)

[Back to SOUND SWAG index] [Back to Main SWAG index] [Original]