Simtel MSDOS - Coast to Coast/simteldosarchivecoasttocoast.iso/pcmag/vol9n21.zip/DGSOUND.PAS

Pascal/Delphi Source File | 1990-09-25 | 18KB | 601 lines

{
 ▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄
 █                                                                         █
 █        TITLE :      DGSOUND.TPU                                         █
 █      PURPOSE :      Sound functions and procedures.                     █
 █       AUTHOR :      David Gerrold, CompuServe ID:  70307,544            █
 █  _____________________________________________________________________  █
 █                                                                         █
 █   Written in Turbo Pascal, Version 5.5,                                 █
 █   with routines from TurboPower, Object Professional.                   █
 █                                                                         █
 █   Turbo Pascal is a product of Borland International.                   █
 █   Object Professional is a product of TurboPower Software.              █
 █  _____________________________________________________________________  █
 █                                                                         █
 █   This is not public domain software.                                   █
 █   This software is copyright 1990, by David Gerrold.                    █
 █   Permission is hereby granted for personal use.                        █
 █                                                                         █
 █        The Brass Cannon Corporation                                     █
 █        9420 Reseda Blvd., #804                                          █
 █        Northridge, CA  91324-2932.                                      █
 █                                                                         █
 ▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀
                                                                            }
{ Compiler Directives ===================================================== }

{$A-}    {Switch word alignment off, necessary for cloning}
{$R-}    {Range checking off}
{$B-}    {Boolean complete evaluation off}
{$S-}    {Stack checking off}
{$I-}    {I/O checking off}
{$N+,E+} {Simulate numeric coprocessor}
{$M 16384,0,327680} {stack and heap}
{$V-}    {Variable range checking off}

{ Name ==================================================================== }

UNIT DgSound;
{
  The purpose of this code is to provide a library of commonly needed
  sounds and sound-managing routines.
}

{ Interface =============================================================== }

INTERFACE

USES
{ Object Professional Units }
  OpCrt,
  OpString,

{ Dg Units }
  DgBit,
  DgCrt;

{ Declarations ============================================================ }

CONST
  SfxCues      =  1;                             { enable beeps and bonks }
  SfxKeyClick  =  2;                             { enable keyclick }
  SfxMusic     =  4;                             { enable music }
  SfxAllSounds =  7;                             { enable all sounds }

  SfxSound    : byte = 7;                        { configurable }
  SfxOptions  : byte = 7;                        { default options }
  BuzzCounter : longint = 1;

TYPE
  BombOb = Object
    Procedure Incoming;                          { falling sound }
    Procedure Boom;                              { explosion }
    Procedure FlashBoom;                         { explosion with flash }
    end;

VAR
  Bomb : BombOb;

{ Sound Managment Routines ================================================ }

FUNCTION Sfx (Option : word) : boolean;
{ returns true if sound effects option is set }

PROCEDURE ToggleSfxCues;
{ Toggle sound cues on and off. }

PROCEDURE ToggleKeyClick;
{ Toggle Key click on and off. }

PROCEDURE ToggleMusic;
{ Toggle music cues on and off. }

PROCEDURE ToggleSound;
{ Toggle all sounds on and off. }

PROCEDURE KeyClick;

PROCEDURE CueClick;

PROCEDURE Beep;

PROCEDURE BeepBeep;

PROCEDURE BeepBoop;

PROCEDURE BoopBeep;

PROCEDURE Bonk;

PROCEDURE Noise (Start,                          { starting frequency }
                 Stop,                           { ending frequency }
                 Step,                           { step size }
                 TmPrStp,                        { time per step }
                 Times,                          { repeats of whole sound }
                 Pause                           { pause between repeats }
                 : Integer);

PROCEDURE BadBuzzer;

PROCEDURE RealBadBuzzer;

PROCEDURE IncBuzzer;

PROCEDURE IndustrialSiren;

{ ========================================================================= }
{ Implementation ========================================================== }

IMPLEMENTATION

{ ========================================================================= }
{ Sfx ===================================================================== }

FUNCTION Sfx (Option : word) : boolean;

BEGIN
  Sfx := SfxOptions and Option = Option;
END;

{ ToggleSfxCues =========================================================== }

{$F+} PROCEDURE ToggleSfxCues; {$F-}
BEGIN
  SfxOptions := ToggleBitMask (SfxOptions, SfxCues);
END;

{ ToggleClick ============================================================= }

{$F+} PROCEDURE ToggleKeyClick; {$F-}
BEGIN
  SfxOptions := ToggleBitMask (SfxOptions, SfxKeyClick);
END;

{ ToggleMusic ============================================================= }

{$F+} PROCEDURE ToggleMusic; {$F-}
BEGIN
  SfxOptions := ToggleBitMask (SfxOptions, SfxMusic);
END;

{ ToggleSound ============================================================= }

CONST
  StoreSfxOptions : byte = 0;

{$F+} PROCEDURE ToggleSound; {$F-}
BEGIN
  if SfxOptions = 0 then
    SfxOptions := StoreSfxOptions
  else begin
    StoreSfxOptions := SfxOptions;
    SfxOptions := 0;
    end;
END;

{ KeyClick ================================================================ }

PROCEDURE KeyClick;
BEGIN
  if not Sfx (SfxKeyClick) then exit;
  Sound (55);
  Delay (1);
  NoSound;
END;

{ CueClick ================================================================ }

PROCEDURE CueClick;
BEGIN
  if not Sfx (SfxCues) then exit;
  Sound (55);
  Delay (1);
  NoSound;
END;

{ Beep ==================================================================== }

PROCEDURE Beep;
BEGIN
  if not Sfx (SfxCues) then exit;
  Sound (440);
  Delay (25);
  NoSound;
END;

{ BeepBeep ================================================================ }

PROCEDURE BeepBeep;
BEGIN
  if not Sfx (SfxCues) then exit;
  Sound (1760);
  Delay (50);
  NoSound;
  Delay (40);
  Sound (1760);
  Delay (50);
  NoSound;
END;

{ BeepBoop ================================================================ }

PROCEDURE BeepBoop;
BEGIN
  if not Sfx (SfxCues) then exit;
  Sound (440);
  Delay (100);
  Sound (330);
  Delay (100);
  NoSound;
END;

{ BoopBeep ================================================================ }

PROCEDURE BoopBeep;
BEGIN
  if not Sfx (SfxCues) then exit;
  Sound (330);
  Delay (100);
  Sound (440);
  Delay (100);
  NoSound;
END;

{ Bonk ==================================================================== }

PROCEDURE Bonk;
VAR
  Loop : byte;
BEGIN
  if not Sfx (SfxCues) then exit;
  For Loop := 1 to 65 do begin
    Sound (110);
    Delay (1);
    Sound (55);
    Delay (1);
    end;
  NoSound;
END;

{ Noise =================================================================== }

PROCEDURE Noise (Start,                          { starting frequency }
                 Stop,                           { ending frequency }
                 Step,                           { step size }
                 TmPrStp,                        { time per step }
                 Times,                          { repeats of whole sound }
                 Pause                           { pause between repeats }
                 : Integer);
{
  Code adapted from E. Kasey Kasemodel's NOISE.PAS.
  Downloaded from CompuServe BPROGA forum.
}
VAR
  Note, Diff, Loop : Integer;

BEGIN
  Note := Start;
  Diff := 0;
  Loop := 0;
  for Loop := 1 to times do begin
    sound (Note); delay (TmPrStp); NoSound;      { make sound the 1st time }
    repeat
      if start > stop then begin                 { noise goes down }
         Note := Note - Step;     { take step value away from current freq }
         Diff := Note - Stop;     { check difference between freq and stop }
         end
       else begin                                { noise goes up }
         Note := Note + Step;
         Diff := Stop - Note;
         end;
       sound (Note); delay (TmPrStp); NoSound;   { produce updated sound }
    until (Diff < 0);             { keep looping til freq goes past stop }
    Note := Start;                         { start over for another loop }
    delay (Pause);                               { wait between loops }
    end;  {for Loop}                             { do again if necessary }
END;

{ IndustrialSiren ========================================================= }

PROCEDURE IndustrialSiren;
VAR
  Loop : byte;

BEGIN
  if not Sfx (SfxCues) then exit;
  for Loop := 1 to 8 do begin
    Noise (1000, 2000, 15, 2, 1, 0);
    Noise (2000, 1000, 15, 2, 1, 0);
    end;
END;

{ BadBuzzer =============================================================== }

PROCEDURE BadBuzzer;
BEGIN
  if not Sfx (SfxCues) then exit;
  Noise (1000, 2000, 500, 2, 20, 0);
END;

{ RealBadBuzzer =========================================================== }

PROCEDURE RealBadBuzzer;
BEGIN
  if not Sfx (SfxCues) then exit;
  Noise (1000, 2000, 500, 2, 200, 0);
END;

{ IncBuzzer =============================================================== }

PROCEDURE IncBuzzer;
VAR
  Loop : longint;
BEGIN
  inc (BuzzCounter, BuzzCounter);
  for Loop := 1 to BuzzCounter do
    RealBadBuzzer;
END;

{ ========================================================================= }
{ BombOb.Incoming ========================================================= }

PROCEDURE BombOb.InComing;
VAR Loop : word;
BEGIN
  for Loop := 5000 downto 1000 do begin          { falling note }
    sound (Loop);
    delay (1);
    end;
  nosound;
END;

{ BombOb.Boom ============================================================= }

PROCEDURE BombOb.Boom;
VAR
  Loop, X, Y : word;
BEGIN
  for Y := 1 to 5 do
    for X := 80 to 100 do begin
      sound (random (1000));
      delay (1);
      end;

  for Loop := 1 to 1500 do begin                 { crumbling sound }
    sound (random (1000));
    delay (1);
    end;

  for Loop := 100 to 999 do begin                { the diminishing sound }
    sound (random (1000 - Loop));
    delay (1);
    end;

  for Loop := 950 to 999 do begin                { the echo }
    sound (random (1000 - Loop));
    delay (1);
    end;

  nosound;
END;

{ BombOb.FlashBoom ======================================================== }

PROCEDURE BombOb.FlashBoom;
TYPE
  ScreenRowArray = array [1 .. 66] of string [132];

VAR
  Loop, X    : word;
  ScreenRow  : ^ScreenRowArray;                  { for storing screen }
  AttrStr    : string;                           { new attrs }

  R1, G1, B1 : real;                             { color components }
  R2, G2, B2 : real;
  Factor     : byte;

  StoreRegs  : array [1 .. 2, 1 .. 3] of byte;   { save reg values }
  Bg,                                            { registers }
  Fg         : byte;

BEGIN
  Bg := GetEgaRegister (Black);                  { get registers }
  Fg := GetEgaRegister (White);
  GetVgaRegister (Fg, StoreRegs [1, 1], StoreRegs [1, 2],StoreRegs [1, 3]);
  GetVgaRegister (Bg, StoreRegs [2, 1], StoreRegs [2, 2],StoreRegs [2, 3]);

  new (ScreenRow);                               { allocate memory }
  for Loop := 1 to ScreenHeight do
    ReadAttribute                                { read screen attrs }
      (ScreenWidth, Loop, 1, ScreenRow^ [Loop]);
  AttrStr := CharStr (chr (LightGray), ScreenWidth);
  for Loop := 1 to ScreenHeight do               { write White text }
    WriteAttribute (AttrStr, Loop, 1);

  SetVgaRegister (Fg, 63, 63, 63);               { fg turns white }
  Delay (150);                                   { pause }
  R1 := 63;  G1 := 63;  B1 := 63;
  SetVgaRegister
    (Bg, round (R1), round (G1), round(B1));     { bg turns white }
  delay (150);                                   { a bright white flash }

  for Loop := 1 to 400 do begin                  { first shock wave }
    sound (random (1000));
    delay (1);
    end;
  nosound;
  delay (50);

  Factor := 15;
  R2 := 63;  G2 := 55;  B2 := 30;
  for Loop := 1 to Factor do begin               { second shock wave }
    for X := 1 to 20 do begin
      sound (random (1000));
      delay (1);
      end;
    if R1 > R2 then R1 := R1 - R1/Factor;
    if G1 > G2 then G1 := G1 - G1/Factor;
    if B1 > B2 then B1 := B1 - B1/Factor;
    SetVgaRegister
      (Bg, round (R1), round (G1), round(B1));  { black bg is white }
    end;

  Factor := 5;
  R2 := 63;  G2 := 50;  B2 := 0;
  for Loop := 1 to Factor do begin               { second shock wave }
    for X := 1 to 20 do begin
      sound (random (1000));
      delay (1);
      end;
    if R1 > R2 then R1 := R1 - R1/Factor;
    if G1 > G2 then G1 := G1 - G1/Factor;
    if B1 > B2 then B1 := B1 - B1/Factor;
    SetVgaRegister
      (Bg, round (R1), round (G1), round(B1));  { black bg is white }
    end;

  Factor := 10;
  R2 := 63;  G2 := 0;  B2 := 0;
  for Loop := 1 to Factor do begin               { second shock wave }
    for X := 1 to 20 do begin
      sound (random (1000));
      delay (1);
      end;
    if R1 > R2 then R1 := R1 - R1/Factor;
    if G1 > G2 then G1 := G1 - G1/Factor;
    if B1 > B2 then B1 := B1 - B1/Factor;
    SetVgaRegister
      (Bg, round (R1), round (G1), round(B1));  { black bg is white }
    end;

  for Loop := 100 to 999 do begin                { the diminishing sound }
    for x := 1 to 2 do begin
      sound (random (1000 - Loop));
      delay (1);
      if Loop mod 30 = 0 then begin
        R1 := 45 + Random (9);  G1 := 20 + Random (15);  B1 := Random (10);
        SetVgaRegister (Bg, round (R1), round (G1), round (B1));
        SetVgaRegister (Fg, 30 + Random (33), Random (33), Random (10));
        end;
      end;
    end;

  Factor := 7;
  R2 := 0;  G2 := 0;  B2 := 0;
  for Loop := 925 to 999 do begin                { the echo }
    sound (random (1000 - Loop));
    delay (1);
    if Loop mod 5 = 0 then begin
      if R1 > R2 then R1 := R1 - R1/Factor;
      if G1 > G2 then G1 := G1 - G1/Factor;
      if B1 > B2 then B1 := B1 - B1/Factor;
      SetVgaRegister
        (Bg, round (R1), round (G1), round (B1));     { random Bg colors }
      end;
    end;

  SetVgaRegister (Fg, StoreRegs [1, 1], StoreRegs [1, 2],StoreRegs [1, 3]);
  SetVgaRegister (Bg, StoreRegs [2, 1], StoreRegs [2, 2],StoreRegs [2, 3]);
  for Loop := 1 to ScreenHeight do
    WriteAttribute (ScreenRow^ [Loop], Loop, 1);
  nosound;
  dispose (ScreenRow);
END;

{ ========================================================================= }
{ ========================================================================= }
{ Initialization ========================================================== }

{ No initialization needed. }
END.

{ ========================================================================= }
{ ========================================================================= }

VERSION HISTORY:
  9005.05
    Completely restructured for consistency with Object Professional.

  9005.07
    Added sound toggles for use with DgKbd unit.  Allows procedures to
    be stored in AltProcArray.

  9006.01
    Added Bomb object.

{ ========================================================================= }

NEED:
  Chimes for hourly clock instead of beep-boop.


{ ========================================================================= }



(*

EXTRA NOISES
  Not yet included.

{ IndustrialGrindNoise ==================================================== }

PROCEDURE IndustrialGrindNoise;
BEGIN
  Noise (100, 50, 1, 15, 5, 100);
END;

{ RisingTones ============================================================= }

PROCEDURE RisingTones;
BEGIN
  Noise (100, 250, 10, 50, 3, 100);
END;

{ Boink Boink ============================================================= }

PROCEDURE BoinkBoink;
BEGIN
  Noise (2000, 250, 50, 5, 2, 100);
END;

{ BouncyNoise ============================================================= }

PROCEDURE BouncyNoise;
BEGIN
  Noise (50, 2500, 50, 5, 4, 50);
END;

{ LaserChirp ============================================================== }

PROCEDURE LaserChirp;
BEGIN
  Noise (4000, 1000, 150, 3, 3, 50);
  Noise (1000, 4000, 150, 3, 3, 50);
END;

{ ChirpChirpFlammadiddle ================================================== }

PROCEDURE ChirpChirpFlammadiddle;
BEGIN
  Noise (1000, 6000, 100, 3, 3, 50);
  Noise (4000, 250, 80, 3, 2, 75);
  Noise (50, 5500, 133, 4, 2, 25);
  Noise (2000, 1000, 60, 3, 3, 50);
END;

{ IndustrialAlarm ========================================================= }

PROCEDURE IndustrialAlarm;
BEGIN
  Noise (2000, 2400, 2, 2, 2, 50);
END;

{ ========================================================================= }

*)