Category : Pascal Source Code
Archive   : ANSI_133.ZIP
Filename : MUSICA.PAS

{ $A+,B-,D-,E-,F+,I-,L-,O+,R-,S-,V-}
(*
Musica v1.01 (c) CopyRight P.H.Rankin Hansen 1990.

This unit implements the Play statement knovn from Basic in Turbo
Pascal versions 5.x and higher. (version 4 does not support
procedural types). The syntax adhers to the Basic syntax with the
exception of the X command, wich has no meaning in a compiled
language.

Released in Denmark on June 3rd, 1990 as part of PingAnsi 1.30.

By using this material You assume FULL responsibility for ANY
consequences - direct or indirect - thereof. Any dispute regarding
this material shall be setteled by Danish law and in a Danish
Court.

(Sigh!)

This source may NOT be used by Lawyers, Politicians or, persons
engaged in any other form of terrorism. Otherwise the usage is
free.

This source may be freely distributed as long as no fee is
charged.

Please direct any comments, corrections, modifications via netmail
to:

Ping Hansen - Fido Net 2:231/62.58

*)
Unit Musica;

Interface

Uses Dos, TpCrt;{CRT will do as well}

Const
MaxPlayBuffer = 64;
{ set this to true to disable background processing of sound }
NoBackground : Boolean = False;
{ If this is set stuff will WAIT for room in play buffer before returning }
WaitForSpace : Boolean = True;

Var
BackGroundPlayHook : Procedure(Tone, Duration : Word);
PlayBuffer : Array[0..MaxPlayBuffer] Of
Record
Tone,
Duration : Word;
End;

Procedure Play(St : String);
Procedure PurgePlayBuffer;
Function PlayBufferEmpty : Boolean;
Function PlayBufferFull : Boolean;
{$F+}
Procedure Stuff(Tone, Time : Word);
{$F-}
Function GrabTimer : Boolean;
{$F+}
Procedure ReleaseTimer;
{$F-}

{-----------------------------------------------------------------------}

Implementation

Const
Timer0 = 0;
FirstPlay : Word = 0; { buffer Pointer }
LastPlay : Word = 1; { buffer Pointer }
TimerMode : Byte = 0; { saved mode for the timer }

Var
SaveExitProc : Pointer;
SaveTimerInt : Pointer;

{-----------------------------------------------------------------------}

Procedure Play(St : String);

Const
Notes : Array[1..84] Of Word =
{ C C#,D- D D#,E- E F F#,G- G G#,A- A A#,B- B }
(0065, 0070, 0073, 0078, 0082, 0087, 0093, 0098, 0104, 0110, 0117, 0123,
0131, 0139, 0147, 0156, 0165, 0175, 0185, 0196, 0208, 0220, 0233, 0247,
0262, 0277, 0294, 0311, 0330, 0349, 0370, 0392, 0415, 0440, 0466, 0494,
0523, 0554, 0587, 0622, 0659, 0698, 0740, 0784, 0831, 0880, 0932, 0987,
1047, 1109, 1175, 1245, 1329, 1397, 1480, 1568, 1661, 1760, 1865, 1976,
2093, 2217, 2349, 2489, 2637, 2794, 2960, 3136, 3322, 3520, 3729, 3951,
4186, 4435, 4699, 4978, 5274, 5588, 5920, 6272, 6645, 7040, 7459, 7902);
MusicType : Byte = 7; {Normal - note plays for 7/8 of time}
Tempo : Word = 120; {120 beats per minute}
StdNoteLength : Word = 4; {Quarter note}
Octave : Word = 3; {Third octave}
BackGround : Boolean = False; {Mn is default}

Var
PlayTime, IdleTime,
DotTime, TempTime,
NoteLength, Note,
Index : Word;
Ch : Char;

{-------------}

Function Numerical(Var Index : Word) : Word;

Var
n : Word;
Begin
n := 0;
While (Index <= Length(St)) And (St[Index] In ['0'..'9']) Do
Begin
n := n * 10 + Ord(St[Index]) - Ord('0');
Inc(Index)
End;
Numerical := n;
End {Numerical} ;

{-------------}

Procedure CheckDots(Var Index : Word);

Begin
While (Index <= Length(St)) And ((St[Index] = '.') Or (St[Index] = ',')) Do
Begin
DotTime := DotTime + DotTime Div 2;
Inc(Index)
End;
End {CheckDots} ;

{-------------}

Begin {Play subroutine}
Index := 1;
While Index < Length(St) Do
Begin
NoteLength := StdNoteLength;
DotTime := 1000;
Ch := Upcase(St[Index]);
Case Ch Of
'A'..'G' :
Begin {read note}
Note := Pos(Ch, 'CcDdEFfGgAaB');
Inc(Index);

{Check for sharp or flat}
If Index <= Length(St) Then
Case St[Index] Of
'#', '+' :
Begin
Inc(Note);
Inc(Index);
End;
'-' :
Begin
Dec(Note);
Inc(Index);
End;
End;

{Check for length suffix}
If (Index <= Length(St)) And
(St[Index] In ['0'..'9']) Then
Begin
NoteLength := Numerical(Index);
End;
CheckDots(Index);

{calculate periods}
TempTime := Round(DotTime / Tempo / NoteLength * 240);
PlayTime := Round(TempTime * MusicType / 8);
IdleTime := TempTime - PlayTime;

{Play the note}
If BackGround
Then
Begin
BackGroundPlayHook(Notes[Note + Octave * 12], PlayTime);
If IdleTime <> 0 Then BackGroundPlayHook(0, IdleTime);
End
Else
Begin
Sound(Notes[Note + Octave * 12]);
Delay(PlayTime);
If IdleTime <> 0 Then
Begin
NoSound;
Delay(IdleTime)
End;
End;
End;
'<' :
Begin {step octave down}
If Octave > 0 Then Dec(Octave);
Inc(Index);
End;
'>' :
Begin {step octave up}
If Octave < 6 Then Inc(Octave);
Inc(Index);
End;
'L' :
Begin {set notelength}
Inc(Index);
StdNoteLength := Numerical(Index);
If (StdNoteLength < 1) Or (StdNoteLength > 64) Then
StdNoteLength := 4;
End;
'M' :
Begin {determine music type}
Inc(Index);
If (Index <= Length(St)) Then
Begin
Case Upcase(St[Index]) Of
'S' : MusicType := 6; {music staccato}
'N' : MusicType := 7; {music normal}
'L' : MusicType := 8; {music legato}
'B' : BackGround := True; {enable background buffering}
'F' : BackGround := False; {disable do.}
End;
Inc(Index);
End;
End;
'O' :
Begin {set octave}
Inc(Index);
Octave := Numerical(Index);
If Octave > 6 Then Octave := 6;
End;
'P' :
Begin {pause}
NoSound;
Inc(Index);
NoteLength := Numerical(Index);
If (NoteLength < 1) Or (NoteLength > 64) Then
NoteLength := StdNoteLength;
CheckDots(Index);

{calculate pause}
IdleTime := DotTime Div Tempo * (240 Div NoteLength);

{execute pause}
If BackGround
Then BackGroundPlayHook(0, IdleTime)
Else Delay(IdleTime);
End;
'T' :
Begin {set tempo}
Inc(Index);
Tempo := Numerical(Index);
If (Tempo < 32) Or (Tempo > 255) Then
Tempo := 120;
End;
'N' :
Begin {play note #nn}
Inc(Index);
Note := Numerical(Index);
If (Note < 1) Then Note := 1;
If (Note > 84) Then Note := 84;
CheckDots(Index);

{calculate periods}
TempTime := Round(DotTime / Tempo / NoteLength * 240);
PlayTime := Round(TempTime * MusicType / 8);
IdleTime := TempTime - PlayTime;

{Play the note}
If BackGround
Then
Begin
BackGroundPlayHook(Notes[Note + Octave * 12], PlayTime);
If IdleTime <> 0 Then BackGroundPlayHook(0, IdleTime);
End
Else
Begin
Sound(Notes[Note + Octave * 12]);
Delay(PlayTime);
If IdleTime <> 0 Then
Begin
NoSound;
Delay(IdleTime)
End;
End;
End;
Else {garbage collector}
Inc(Index); {pollution, Just dump it}
End;
End {While} ;
NoSound; {we are finished}
End {Play} ;

{-----------------------------------------------------------------------}

{$F+}
Procedure DummyStuff(Tone, Duration : Word);
{$F-}
{dummy background}
Begin
If Tone <> 0
Then Sound(Tone)
Else NoSound;
Delay(Duration);
End {DummyStuff} ;

{-------------------------------------------------------------------------}

Procedure PurgePlayBuffer;

Begin
Inline($FA); {CLI}
FillChar(PlayBuffer, SizeOf(PlayBuffer), 0);
FirstPlay := 0;
LastPlay := 1;
Inline($FB); {STI}
end {PurgePlayBuffer} ;

{-------------------------------------------------------------------------}

Function PlayBufferEmpty : Boolean;

Begin
PlayBufferEmpty := (FirstPlay = LastPlay);
End {PlayBufferEmpty} ;

{-------------------------------------------------------------------------}

Function PlayBufferFull : Boolean;

Begin
PlayBufferFull := (LastPlay = FirstPlay - 1) Or
((LastPlay = MaxPlayBuffer) And (FirstPlay = 1));
End {PlayBufferFull} ;

{-------------------------------------------------------------------------}

{$F+}
Procedure Stuff(Tone, Time : Word);
{$F-}

{ Place a note in background buffer. }

Begin
If NoBackground Then
Begin
If Tone <> 0 Then Sound(Tone);
Delay(Time);
Exit;
End;
While WaitForSpace And PlayBufferFull Do {} ;
If {(LastPlay <> FirstPlay - 1) And
((LastPlay <> MaxPlayBuffer) Or (FirstPlay <> 1))} Not PlayBufferFull Then
Begin
PlayBuffer[LastPlay].Tone := Tone;
PlayBuffer[LastPlay].Duration := Time;
Inc(LastPlay);
If LastPlay > MaxPlayBuffer Then LastPlay := 1;
End;
End {Stuff} ;

{-------------------------------------------------------------------------}

Procedure InitTimer(Timer, Mode : Byte; Count : Word);

Var
Tics : LongInt Absolute $40 : $6C;
t : LongInt;

Begin
t := Tics;
While t = Tics Do {} ; { wait for clock tick }
Inline($FA); {CLI}
Port[$43] := Mode;
Port[$40 + Timer] := Lo(Count);
Port[$40 + Timer] := Hi(Count);
Inline($FB); {STI}
End;

{-------------------------------------------------------------------------}

Procedure NewTimer(BP : Word); Interrupt;

Const
InTune : Boolean = True;
TimerVar : Word = 54; { no delay first time }
Count : Word = 05;
Begin
Inc(TimerVar);
If TimerVar >= 55 Then
Begin
TimerVar := 0;
Inline($9C / $FF / $1E / SaveTimerInt); { Pushf/Call Far SaveTimer }
End
Else
Begin
Port[$20] := $20; { Non speciffic EOI }
End;
Inline($FB); {STI}
If Count > 0 Then Dec(Count);
If Count = 0 Then
Begin
If InTune Then
Begin
InTune := False;
NoSound;
End;
If (LastPlay <> FirstPlay) Then
Begin
If (PlayBuffer[FirstPlay].Tone <> 0) Then
Begin
Sound(PlayBuffer[FirstPlay].Tone);
InTune := True;
End;
If (PlayBuffer[FirstPlay].Duration <> 0)
Then Count := PlayBuffer[FirstPlay].Duration;
Inc(FirstPlay);
If FirstPlay > MaxPlayBuffer Then FirstPlay := 1;
End;
End;
End {NewTimer} ;

{-------------------------------------------------------------------------}

{$F+}
Procedure ReleaseTimer;
{$F-}

{ unload the interrupt handler }

Begin
{ Reprogram the 8253 to a 55 ms period }
InitTimer(Timer0, $36, 0);
SetIntVec($8, SaveTimerInt);
ExitProc := SaveExitProc;
NoSound;
BackgroundPlayHook := DummyStuff;
End {ReleaseTimer} ;

{-------------------------------------------------------------------------}

Function GrabTimer : Boolean;

Begin
GrabTimer := True;
FillChar(PlayBuffer, SizeOf(PlayBuffer), 0);
GetIntVec($8, SaveTimerInt);
(*
Port[$43] := $E2; { readback command. Timer 0, status. }
TimerMode := Port[$40] And $0F + $30;
if (TimerMode <> $36)
then GrabTimer := False
else
*)
Begin
SaveExitProc := ExitProc;
InitTimer(Timer0, $36, $04A8);
SetIntVec($8, @NewTimer);
SaveExitProc := ExitProc;
ExitProc := @ReleaseTimer;
BackgroundPlayHook := Stuff;
(*
Stuff(10, 100); {void attempt to fix problem with first note}
*)
End;
End {GrabTimer} ;

{-----------------------------------------------------------------------}

Begin
BackGroundPlayHook := DummyStuff;
End.