Old Pascal Unit for Ad Lib, depends on SOUND.COM

adlibfm.pas

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

                                ADLIB
                       FM AdLib Sound Utilitys

                            Date: 4/4/91
                             Version: 1

***************************************************************************

                   Copyright (c) 1991, Zackzon Labs.

                       Author: Anthony Rumble

==========
Addresses:
==========
InterNet: [email protected]
SIGNet: 28:2200/108

Snail Mail:
 32 Woolwich Rd.
 Hunters Hill, NSW, 2110
 Australia

=========================================================================
                              NOTE!
=========================================================================

Many of these functions are incomplete, due to lack of information.
Especially the ROL player. If you can fill the gaps, please get into
contact with me about it. Thankyou.

-------------------------------------------------------------------------
                              HISTORY
-------------------------------------------------------------------------
1.0 - ROL Player still dosent work. Direct playing seems to work.
*************************************************************************}
unit adlib;

interface

uses dos, misc, bnktb;

type
 Signature_Block = record
  Version:word;
  Block:array[0..18] of char;
  Tst1:byte;
  Tst2:byte;
  Tst3:byte;
 end;

 rol_header = record
  Maj_Vers:word;
  Min_Vers:word;
  filler1:array[1..40] of char;
  TickBeats:word;
  BeatMeasure:word;
  yscale:word;
  xscale:word;
  filler2:byte;
  mode:byte;
  filler3:array[1..90] of char;
  filler4:array[1..38] of char;
  filler5:array[1..15] of char;
 end;

 Instrument = bnktb.Instrument;

 addr_type = array[0..1] of word;

const

   TestString = 'SOUND-DRIVER-AD-LIB';

      ALLDONE = $00;
 STILLPLAYING = $01;

     DISABLED = $00;
      ENABLED = $01;

      MELODIC = $00;
   PERCUSSIVE = $01;

       VOICE1 = $00;
       VOICE2 = $01;
       VOICE3 = $02;
       VOICE4 = $03;
       VOICE5 = $04;
       VOICE6 = $05;
       VOICE7 = $06;
       VOICE8 = $07;
       VOICE9 = $08;

       LibInt = $65;

          Init = $00;
  RelTimeStart = $02;
      SetState = $03;
      GetState = $04;
         Flush = $05;
       SetMode = $06;
       GetMode = $07;
  SetRelVolume = $08;
      SetTempo = $09;
  SetTranspose = $0A;
  GetTranspose = $0B;
   SetActVoice = $0C;
   GetActVoice = $0D;
   PlayNoteDel = $0E;
      PlayNote = $0F;
     SetTimbre = $10;
      SetPitch = $11;
   SetTickBeat = $12;
        NoteOn = $13;
       NoteOff = $14;
       _Timbre = $15;
  SetPitchBend = $16;
      WaveForm = $17;

Var
      Regs : Registers;
      intp : pointer;
         p : ^signature_block;
  SigBlock : Signature_Block;
 GActVoice : word; {Active Voice}
        GT : array[0..10] of Instrument; {use global variable to keep array valid}

function initialize:boolean;
procedure rel_timestart(TimeNum, TimeDen : integer);
procedure set_state(state:word);
function get_state:byte;
procedure flush_buffer;
procedure set_mode(mde:byte);
function get_mode:byte;
function Set_RelVolume(VolNum,VolDen,TimeNum,TimeDen :integer) :boolean;
function Set_Tempo(Tempo,TimeNum,TimeDen :integer) :boolean;
procedure set_transpose;
procedure get_transpose;
procedure set_active_voice(vse:byte);
function get_active_voice:byte;
function Play_NoteDel(Pitch :integer; LengthNum,LengthDen,DelayNum,DelayDen :word) :boolean;
function Play_Note(Pitch :integer; LengthNum,LengthDen :word) :boolean;
function Set_Timbre(TimeNum,TimeDen :word) :boolean;
function Set_Pitch(DeltaOctave,DeltaNum,DeltaDen :integer; TimeNum,TimeDen :word) :boolean;
procedure Set_TickBeat(TickBeat :integer);
procedure Note_On(Voice :word; Pitch :integer);
procedure Note_Off(Voice :word);
procedure timbre;
procedure set_pitchbend;
procedure wave_form;
procedure Load_Instrument(FileSpec :string);
function Load_Song(FileSpec :string) :boolean;

implementation

{****************************************************************************
                               INITIALIZE
----------------------------------------------------------------------------
   Checks for the driver. If present will initialise it, and return TRUE
                        else will return FALSE
****************************************************************************}
function initialize:boolean;
var
 Signature:string[19];
 x:word;
begin

 getintvec($65,intp);

 p := ptr(seg(intp^), ofs(intp^) - sizeof(Signature_block));

 SigBlock := p^;
 for x:= 1 to 19 do
 begin
  Signature[x] := SigBlock.block[x-1];
 end;
 Signature[0] := #19;
 if Signature = TestString then
 begin
  regs.SI := Init;
  Intr(LibInt, Regs);
  initialize := TRUE;
 end
 else initialize := FALSE;
end;
{****************************************************************************
                               REL_TIMESTART
----------------------------------------------------------------------------
????
****************************************************************************}
procedure rel_timestart(TimeNum, TimeDen : integer);
var
 TD,TN :integer;
begin
 TD:=TimeDen;
 TN:=TimeNum;
 Regs.SI := RelTimeStart;
 Regs.ES:=Seg(TN);
 Regs.BX:=Ofs(TN);
 Intr(LibInt, Regs);
end;
{****************************************************************************
                               SET_STATE
----------------------------------------------------------------------------
Starts or stops a song..
Either
 DISABLED or
 ENABLED
****************************************************************************}
procedure set_state(state:word);
var
 st:word;
begin
 st := state;
 Regs.SI := SetState;
 Regs.ES := seg(st);
 Regs.BX := ofs(st);
 Intr(LibInt, Regs);
end;
{****************************************************************************
                               GET_STATE
----------------------------------------------------------------------------
Returns either
 ALLDONE  or
 STILLPLAYING
****************************************************************************}
function get_state:byte;
begin
 Regs.SI := GetState;
 Intr(LibInt, Regs);
 if (regs.ax = $00) then get_state := ALLDONE
 else get_state := STILLPLAYING;
end;
{****************************************************************************
                                FLUSH
----------------------------------------------------------------------------
                       Flushes the Song Buffer
****************************************************************************}
procedure flush_buffer;
begin
 Regs.SI := Flush;
 Intr(LibInt, Regs);
end;
{****************************************************************************
                               SET_MODE
----------------------------------------------------------------------------
Either
 MELODIC  or
 PERCUSSIVE
****************************************************************************}
procedure set_mode(mde:byte);
var
 mode:integer;
begin
 mode := mde;
 Regs.SI := SetMode;
 Regs.ES := seg(mode);
 Regs.BX := ofs(mode);
 Intr(LibInt, Regs);
end;
{****************************************************************************
                               GET_MODE
----------------------------------------------------------------------------
Returns either
 MELODIC or
 PERCUSSIVE
****************************************************************************}
function get_mode:byte;
begin
 Regs.SI := GetMode;
 Intr(LibInt, Regs);
 get_mode := Regs.AX;
end;
{****************************************************************************
                               SET_RELVOLUME
----------------------------------------------------------------------------
VolNum: ?
VolDen: ?
TimeNum: ?
TimeDen: ?
****************************************************************************}
function Set_RelVolume(VolNum,VolDen,TimeNum,TimeDen :integer) :boolean;
var
 TD,TN,VD,VN :word; {To put variables values in proper order in memory}
begin
 TD:=TimeDen;
 TN:=TimeNum;
 VD:=VolDen;
 VN:=VolNum;
 Regs.SI := SetRelVolume;
 Regs.ES:=Seg(VN);
 Regs.BX:=Ofs(VN);
 Intr(LibInt, Regs);
 Set_RelVolume:=(Regs.BP=1);
end;
{****************************************************************************
                               SET_TEMPO
----------------------------------------------------------------------------
Tempo: Tempo
TimeNum: ?
TimeDen: ?
****************************************************************************}
function Set_Tempo(Tempo,TimeNum,TimeDen :integer) :boolean;
var
 TD,TN,TP :integer; {To put variables values in proper order in memory}
begin
 TD:=TimeDen;
 TN:=TimeNum;
 TP:=Tempo;
 Regs.SI := SetTempo;
 Regs.ES := seg(TP);
 Regs.BX := ofs(TP);
 Intr(LibInt, Regs);
 Set_Tempo:=(Regs.BP=1);
end;
{****************************************************************************
                               SET_TRANSPOSE
----------------------------------------------------------------------------
              Unknown how to program this function. Dont use
****************************************************************************}
procedure set_transpose;
begin
 Regs.SI := SetTranspose;
 Intr(LibInt, Regs);
end;
{****************************************************************************
                               GET_TRANSPOSE
----------------------------------------------------------------------------
               Unknown how to program this funvtion. Dont use.
****************************************************************************}
procedure get_transpose;
begin
 Regs.SI := GetTranspose;
 Intr(LibInt, Regs);
end;
{****************************************************************************
                            SET_ACTIVE_VOICE
-----------------------------------------------------------------------------
Vse can either be a byte between 0 -> 8

Or you can use the constants VOICEx
ie/ VOICE6
****************************************************************************}
procedure set_active_voice(vse:byte);
var
 voice:word;
begin
 GActVoice:=vse;
 voice := vse;
 Regs.SI := SetActVoice;
 Regs.ES := seg(voice);
 Regs.BX := ofs(voice);
 Intr(LibInt, Regs);
end;
{****************************************************************************
                               GET_ACTIVE_VOICE
----------------------------------------------------------------------------
Returns the active voice no. Between 0 -> 8
****************************************************************************}
function get_active_voice:byte;
begin
 Regs.SI := GetActVoice;
 Intr(LibInt, Regs);
 get_active_voice := Regs.AX;
end;
{****************************************************************************
                             PLAY_NOTEDEL
-----------------------------------------------------------------------------
Pitch: Pitch Number
LengthNum: Decay length
LengthDen: Attach Length
DelayNum: Decay Delay?
DelayDen: Attack Delay?
****************************************************************************}
function Play_NoteDel(Pitch :integer; LengthNum,LengthDen,DelayNum,DelayDen :word) :boolean;
var
 DD,DN,LD,LN :word;
 P           :integer;
begin
 P:=Pitch;
 LD:=LengthDen;
 LN:=LengthNum;
 DN:=DelayNum;
 DD:=DelayDen;
 Regs.SI := PlayNoteDel;
 Regs.ES:=Seg(P);
 Regs.BX:=Ofs(P);
 Intr(LibInt, Regs);
 Play_NoteDel:=(Regs.BP=1);
end;
{****************************************************************************
                               PLAY_NOTE
----------------------------------------------------------------------------
Pitch: Pitch Number
LengthNum: Decay length
LengthDen: Attach Length
****************************************************************************}
function Play_Note(Pitch :integer; LengthNum,LengthDen :word) :boolean;
var
 LD,LN :word;
 P     :integer;
begin
 P:=Pitch;
 LD:=LengthDen;
 LN:=LengthNum;
 Regs.ES := seg(P);
 Regs.BX := ofs(P);
 Regs.SI := PlayNote;
 Intr(LibInt, Regs);
 Play_Note:=(Regs.BP=1);
end;
{****************************************************************************
                               SET_TIMBRE
-----------------------------------------------------------------------------
GT[GActVoice] contains the Instrument
TimeNum: ?
TimeDen: ?
****************************************************************************}
function Set_Timbre(TimeNum,TimeDen :word) :boolean;
var
 TD,TN :word;
 T     :^integer;
 c1,c2 :byte;
begin
 T:=Addr(GT[GActVoice]);
 TN:=TimeNum;
 TD:=TimeDen;
 Regs.SI := SetTimbre;
 Regs.ES:=Seg(T);
 Regs.BX:=Ofs(T);
 Intr(LibInt, Regs);
 Set_Timbre:=(Regs.BP=1);
end;
{****************************************************************************
                                SET_PITCH
----------------------------------------------------------------------------
       Unknown how to program this function as yet. Do not use.
****************************************************************************}
function Set_Pitch(DeltaOctave,DeltaNum,DeltaDen :integer; TimeNum,TimeDen :word) :boolean;
var
 TD,TN   :word;
 DD,DN,D :integer;
 c1,c2   :byte;
begin
 D:=DeltaOctave;
 DN:=DeltaNum;
 DD:=DeltaDen;
 TN:=TimeNum;
 TD:=TimeDen;
 Regs.SI := SetPitch;
 Regs.ES:=Seg(D);
 Regs.BX:=Ofs(D);
 Intr(LibInt, Regs);
 Set_Pitch:=(Regs.BP=1);
end;
{****************************************************************************
                              SET_TICKBEAT
----------------------------------------------------------------------------
       Unknown how to program this function as yet. Do not use.
****************************************************************************}
procedure Set_TickBeat(TickBeat :integer);
begin
 Regs.ES:=Seg(TickBeat);
 Regs.BX:=Ofs(TickBeat);
 Regs.SI := SetTickBeat;
 Intr(LibInt, Regs);
end;
{****************************************************************************
                              NOTE_ON
-----------------------------------------------------------------------------
Direct Note On
****************************************************************************}
procedure Note_On(Voice :word; Pitch :integer);
var
 P :integer;
 V :word;
begin
 P:=Pitch;
 V:=Voice;
 Regs.SI := NoteOn;
 Regs.ES:=Seg(V);
 Regs.BX:=Ofs(V);
 Intr(LibInt, Regs);
end;
{****************************************************************************
                              NOTE_OFF
-----------------------------------------------------------------------------
Direct Note Off
****************************************************************************}
procedure Note_Off(Voice :word);
begin
 Regs.SI := NoteOff;
 Regs.ES:=Seg(Voice);
 Regs.BX:=Ofs(Voice);
 Intr(LibInt, Regs);
end;
{****************************************************************************
                                TIMBRE
-----------------------------------------------------------------------------
Direct Timbre
****************************************************************************}
procedure timbre;
var
 T:^integer;
 V:word;
begin
 V:=GActVoice;
 T:=Addr(GT[V]);
 Regs.ES:=Seg(V);
 Regs.BX:=Ofs(V);
 Regs.SI := _Timbre;
 Intr(LibInt, Regs);
end;
{****************************************************************************
                              SET_PITCHBEND
-----------------------------------------------------------------------------
       Unknown how to program this function as yet. Do not use
****************************************************************************}
procedure set_pitchbend;
begin
 Regs.SI := SetPitchBend;
 Intr(LibInt, Regs);
end;
{****************************************************************************
                                WAVE_FORM
-----------------------------------------------------------------------------
       Unknown how to program this function as yet. Do not use
****************************************************************************}
procedure wave_form;
begin
 Regs.SI := Waveform;
 Intr(LibInt, Regs);
end;
{****************************************************************************
                           LOAD_INSTRUMENT
-----------------------------------------------------------------------------
Load an Instument from Disk and Place in Array
****************************************************************************}
procedure Load_Instrument(FileSpec :string);
var
 c1 :byte;
 n  :integer;
 f  :file of integer;
begin
 writeln('Loading Ins from Bnk:',FileSpec);
 if not load_bnk(filespec, GT[GActVoice]) then
 begin
  writeln('Loading Ins from .INS:',FileSpec);
  filespec:=filespec+'.ins';
  if not(Exist(FileSpec)) then
  begin
   writeln('Cant find Instriment file');
   halt(1);
  end;
  Assign(f,FileSpec);
  Reset(f);
  Read(f,n);
  for c1:=1 to 26 do
   Read(f,GT[GActVoice,c1]);
  Close(f);
 end;
end;
{****************************************************************************
                               LOAD_SONG
-----------------------------------------------------------------------------
              Read a .ROL file and place song in Buffer
****************************************************************************}
function Load_Song(FileSpec :string) :boolean;
var
 nb :byte;
 ns :string[255];
 ni,ni2,ni3,ni4,BPM,tempi :integer;
 c1,c2  :word;
 nr,nr2,tempr :real;
 fl :boolean;
 f  :file;
 templi:longint;
{---------------------------------------------------------------------------
                                STRINGREAD
---------------------------------------------------------------------------
uses f,ns
---------------------------------------------------------------------------}
procedure StringRead(len :word); 
var
 nc :char;
 c1 :word;
begin
 ns:='';
 for c1:=1 to len do
 begin
  BlockRead(f,nc,1);
  ns:=ConCat(ns,nc);
 end;
end;
{---------------------------------------------------------------------------
                                TEMPOREAD
---------------------------------------------------------------------------
uses f,nb
---------------------------------------------------------------------------}
procedure TempoRead;
var
 b1,b2,b3,b4 :byte;
begin
 BlockRead(f,b1,1);
 BlockRead(f,b2,1);
 BlockRead(f,b3,1);
 BlockRead(f,b4,1);
{ nb:=51+Round(b3/2.5); }
 nb:=trunc(b4);
end;
{---------------------------------------------------------------------------
                                VOLUMEREAD
---------------------------------------------------------------------------}
procedure VolumeRead;
var
 b1,b2,b3,b4 :byte;
begin
 BlockRead(f,b1,1);
 BlockRead(f,b2,1);
 BlockRead(f,b3,1);
 BlockRead(f,b4,1);
 nb:=51+Round(b3/2.5);
end;

begin
 Load_Song:=true;
 if not(Exist(FileSpec)) then
 begin
  Load_Song:=false;
  Exit;
 end;
 if not initialize then
 begin
  writeln(#7,'Error. SOUND.COM or equilivant not loaded');
  halt(1);
 end;
 Rel_TimeStart(0,1);

 {Open ROL File}

 Assign(f,FileSpec);
 Reset(f,1);
 {Read in Header}
 StringRead(44);
 {Read in Ticks per Beat}
 BlockRead(f,ni,2);
 Set_TickBeat(ni); {Ticks per Beat}
 {Read in Beats per Measure}
 BlockRead(f,ni,2);
 BPM:=ni; {Beats per Measure}

 StringRead(5);
 {Read in Mode}
 BlockRead(f,nb,1);
 Set_Mode(nb);  {Mode}

 StringRead(143);
 {Read in General Tempo}
 TempoRead;
 fl:=Set_Tempo(nb,0,1); {Tempo}
 {Read in Specific Tempos}
 BlockRead(f,ni,2);
 for c1:=1 to ni do
 begin
  BlockRead(f,ni2,2);
  TempoRead;
  fl:=Set_Tempo(nb,ni2,1); {Tempo}
 end;
 {Read in each music pattern}
 for c1:=0 to 10 do {11 Voices}
 begin
  Set_Active_Voice(c1);
  StringRead(15);
  BlockRead(f,ni2,2); {Time in ticks of last Note}
  c2:=0;
  while (c2<ni2) do
  begin
   BlockRead(f,ni3,2); {Note Pitch}
   BlockRead(f,ni4,2); {Note Duration}
   fl:=Play_Note(ni3-60,ni4,BPM); {Note}
   c2:=c2+ni4; {Summation of Durations}
  end;
  StringRead(15);
  BlockRead(f,ni2,2);
  for c2:=1 to ni2 do {Instuments}
  begin
   BlockRead(f,ni3,2);
   StringRead(9);
   nb:=Pos(#0,ns);
   Delete(ns,nb,Length(ns));
   Load_Instrument(ns);
   fl:=Set_Timbre(ni3,1);
   StringRead(1);
   BlockRead(f,ni4,2);
  end;
  StringRead(15);
  BlockRead(f,ni2,2);
  nb:=1;
  for c2:=1 to ni2 do {Volume}
  begin
   BlockRead(f,ni3,2);
   fl:=Set_RelVolume(100,nb,ni3,1);  {Use inverse to disable Relative}
   VolumeRead;
   fl:=Set_RelVolume(nb,100,ni3,1);
  end;
  StringRead(15);
  BlockRead(f,ni2,2);
  for c2:=1 to ni2 do {Pitch -disabled}
  begin
   BlockRead(f,ni3,2);
   BlockRead(f,nr,4);
   if (nr=0) then nr2:=1 else nr2:=nr;
{   tempr:=nr*100.0;
   templi:=trunc(tempr);
   tempi:=abs(templi);
   fl:=Set_Pitch(0,tempi,Trunc((nr/nr2)*100),ni3,1); }
  end;
 end;
 Close(f);
end;

end.