Category : Pascal Source Code
Archive   : PIBMUSIC.ZIP
Filename : PIBMUSIC.PAS

 
Output of file : PIBMUSIC.PAS contained in archive : PIBMUSIC.ZIP
(*$R-,V-,C-,U-*)
Program PibMusic;

(* ------------------------------------------------------------------------ *)
(* *)
(* Program: PibMusic *)
(* *)
(* Purpose: Demonstrates the enclosed routine PibPlay, which emulates *)
(* the Microsoft Basic PLAY statement. (See the Basic manual *)
(* for details.) *)
(* *)
(* Author: Philip R. Burns *)
(* Date: January 25, 1985 *)
(* Version: 1.0 *)
(* *)
(* Use: *)
(* *)
(* Call PibPlaySet to initialize global play variables. *)
(* Call PibPlay to play a line of music. *)
(* *)
(* Remarks: You are free to use this routine is your own code. If you *)
(* find any bugs or have suggestions for improvements, please *)
(* leave them for me on one of the following two Chicago BBSs: *)
(* *)
(* Gene Plantz's IBBS (312) 882 4227 *)
(* Ron Fox's RBBS (312) 940 6496 *)
(* *)
(* Thanks. *)
(* *)
(* Note: This code ignores requests for buffered music. *)
(* *)
(* ------------------------------------------------------------------------ *)


(* Global Variable for PibMusic *)
Var
(* String containing music *)
S : String[255];


(* ------------------------------------------------------------------------ *)
(* PibPlaySet --- Set up to play music *)
(* PibPlay --- Play Music through Speaker *)
(* ------------------------------------------------------------------------ *)


(* Global Type for PibPlay Procedure *)
Type
SoundStr = String[255];

(* Global Variables for PibPlay Procedure *)
Var
(* Current Octave for Note *)
Note_Octave : Integer;
(* Fraction of duration given to note *)
Note_Fraction : Real;
(* Duration of note *)
Note_Duration : Integer;
(* Length of note *)
Note_Length : Real;
(* Length of quarter note (principal beat) *)
Note_Quarter : Real;


Procedure PibPlaySet;

(* ------------------------------------------------------------------------ *)
(* *)
(* Procedure: PibPlaySet *)
(* *)
(* Purpose: Sets up to play music though PC's speaker *)
(* *)
(* Calling Sequence: *)
(* *)
(* PibPlaySet; *)
(* *)
(* Calls: None *)
(* *)
(* ------------------------------------------------------------------------ *)

Begin (* PibPlaySet *)

(* Default Octave *)
Note_Octave := 4;
(* Default sustain is semi-legato *)
Note_Fraction := 0.875;
(* Note is quarter note by default *)
Note_Length := 0.25;
(* Moderato pace by default *)
Note_Quarter := 500.0;

End (* PibPlaySet *);


Procedure PibPlay( S : SoundStr );

(* ------------------------------------------------------------------------ *)
(* *)
(* Procedure: PibPlay *)
(* *)
(* Purpose: Play music though PC's speaker *)
(* *)
(* Calling Sequence: *)
(* *)
(* PibPlay( Music_String : SoundStr ); *)
(* *)
(* Music_String --- The string containing the encoded music to be *)
(* played. The format is the same as that of the *)
(* MicroSoft Basic PLAY Statement. The string *)
(* must be <= 254 characters in length. *)
(* *)
(* Calls: Sound *)
(* GetInt (Internal) *)
(* *)
(* Remarks: The characters accepted by this routine are: *)
(* *)
(* A - G Musical Notes *)
(* # or + Following A - G note, indicates sharp *)
(* - Following A - G note, indicates flat *)
(* < Move down one octave *)
(* > Move up one octave *)
(* . Dot previous note (extend note duration by 3/2) *)
(* MN Normal duration (7/8 of interval between notes) *)
(* MS Staccato duration *)
(* ML Legato duration *)
(* Ln Length of note (n=1-64; 1=whole note, *)
(* 4=quarter note, etc.) *)
(* Pn Pause length (same n values as Ln above) *)
(* Tn Tempo, n=notes/minute (n=32-255, default n=120) *)
(* On Octave number (n=0-6, default n=4) *)
(* Nn Play note number n (n=0-84) *)
(* *)
(* The following two commands are IGNORED by PibPlay: *)
(* *)
(* MF Complete note before continuing *)
(* MB Another process may begin before speaker is *)
(* finished playing note *)
(* *)
(* IMPORTANT --- PibPlaySet MUST have been called at least once before *)
(* this routine is called. *)
(* *)
(* ------------------------------------------------------------------------ *)

Const
(* Offsets in octave of natural notes *)

Note_Offset : Array[ 'A'..'G' ] Of Integer
= ( 9, 11, 0, 2, 4, 5, 7 );

(* Frequencies for 7 octaves *)

Note_Freqs: Array[ 0 .. 84 ] Of Integer
=
(*
C C# D D# E F F# G G# A A# B
*)
( 0,
65, 69, 73, 78, 82, 87, 92, 98, 104, 110, 116, 123,
131, 139, 147, 156, 165, 175, 185, 196, 208, 220, 233, 247,
262, 278, 294, 312, 330, 350, 370, 392, 416, 440, 466, 494,
524, 556, 588, 624, 660, 700, 740, 784, 832, 880, 932, 988,
1048, 1112, 1176, 1248, 1320, 1400, 1480, 1568, 1664, 1760, 1864, 1976,
2096, 2224, 2352, 2496, 2640, 2800, 2960, 3136, 3328, 3520, 3728, 3952,
4192, 4448, 4704, 4992, 5280, 5600, 5920, 6272, 6656, 7040, 7456, 7904 );

Quarter_Note = 0.25; (* Length of a quarter note *)


Var
(* Frequency of note to be played *)
Play_Freq : Integer;

(* Duration to sound note *)
Play_Duration : Integer;

(* Duration of rest after a note *)
Rest_Duration : Integer;

(* Offset in Music string *)
I : Integer;
(* Current character in music string *)
C : Char;
(* Note Frequencies *)

Freq : Array[ 0 .. 6 , 0 .. 11 ] Of Integer ABSOLUTE Note_Freqs;

N : Integer;
XN : Real;
K : Integer;

Function GetInt : Integer;

(* --- Get integer from music string --- *)

Var
N : Integer;

Begin (* GetInt *)

N := 0;

While( S[I] In ['0'..'9'] ) Do
Begin
N := N * 10 + ORD( S[I] ) - ORD('0');
I := I + 1;
End;

I := I - 1;

GetInt := N;

End (* GetInt *);


Begin (* PibPlay *)
(* Append blank to end of music string *)
S := S + ' ';
(* Point to first character in music *)
I := 1;
(* Begin loop over music string *)
While( I < LENGTH( S ) ) Do

Begin (* Interpret Music *)
(* Get next character in music string *)
C := Upcase(S[I]);
(* Interpret it *)
Case C Of

'A'..'G' : Begin (* A Note *)

N := Note_Offset[ C ];

Play_Freq := Freq[ Note_Octave , N ];

XN := Note_Quarter * ( Note_Length / Quarter_Note );

Play_Duration := Trunc( XN * Note_Fraction );

Rest_Duration := Trunc( XN * ( 1.0 - Note_Fraction ) );

(* Check for sharp/flat *)

If S[I+1] In ['#','+','-' ] Then
Begin

I := I + 1;

Case S[I] OF
'#' : Play_Freq :=
Freq[ Note_Octave , N + 1 ];
'+' : Play_Freq :=
Freq[ Note_Octave , N + 1 ];
'-' : Play_Freq :=
Freq[ Note_Octave , N - 1 ];
Else ;
End (* Case *);

End;

(* Check for note length *)

If S[I+1] In ['0'..'9'] Then
Begin

I := I + 1;
N := GetInt;
XN := ( 1.0 / N ) / Quarter_Note;

Play_Duration :=
Trunc( Note_Fraction * Note_Quarter * XN );

Rest_Duration :=
Trunc( ( 1.0 - Note_Fraction ) *
Xn * Note_Quarter );

End;
(* Check for dotting *)

If S[I+1] = '.' Then
Begin

XN := 1.0;

While( S[I+1] = '.' ) Do
Begin
XN := XN * 1.5;
I := I + 1;
End;

Play_Duration :=
Trunc( Play_Duration * XN );

End;

(* Play the note *)

Sound( Play_Freq );
Delay( Play_Duration );
NoSound;
Delay( Rest_Duration );

End (* A Note *);

'M' : Begin (* 'M' Commands *)

I := I + 1;
C := S[I];

Case C Of

'F' : ;
'B' : ;
'N' : Note_Fraction := 0.875;
'L' : Note_Fraction := 1.000;
'S' : Note_Fraction := 0.750;
Else ;

End (* Case *);


End (* 'M' Commands *);

'O' : Begin (* Set Octave *)

I := I + 1;
N := ORD( S[I] ) - ORD('0');

If ( N < 0 ) OR ( N > 6 ) Then N := 4;

Note_Octave := N;

End (* Set Octave *);

'<' : Begin (* Drop an octave *)

If Note_Octave > 0 Then
Note_Octave := Note_Octave - 1;

End (* Drop an octave *);

'>' : Begin (* Ascend an octave *)

If Note_Octave < 6 Then
Note_Octave := Note_Octave + 1;

End (* Ascend an octave *);

'N' : Begin (* Play Note N *)

I := I + 1;

N := GetInt;

If ( N > 0 ) AND ( N <= 84 ) Then
Begin

Play_Freq := Note_Freqs[ N ];

XN := Note_Quarter *
( Note_Length / Quarter_Note );

Play_Duration := Trunc( XN * Note_Fraction );

Rest_Duration := Trunc( XN * ( 1.0 - Note_Fraction ) );

End

Else If ( N = 0 ) Then
Begin

Play_Freq := 0;
Play_Duration := 0;
Rest_Duration :=
Trunc( Note_Fraction * Note_Quarter *
( Note_Length / Quarter_Note ) );

End;

Sound( Play_Freq );
Delay( Play_Duration );
NoSound;
Delay( Rest_Duration );

End (* Play Note N *);

'L' : Begin (* Set Length of Notes *)

I := I + 1;
N := GetInt;

If N > 0 Then Note_Length := 1.0 / N;

End (* Set Length of Notes *);

'T' : Begin (* # of quarter notes in a minute *)

I := I + 1;
N := GetInt;

Note_Quarter := ( 1092.0 / 18.2 / N ) * 1000.0;

End (* # of quarter notes in a minute *);

'P' : Begin (* Pause *)

I := I + 1;
N := GetInt;

If ( N < 1 ) Then N := 1
Else If ( N > 64 ) Then N := 64;

Play_Freq := 0;
Play_Duration := 0;
Rest_Duration :=
Trunc( ( ( 1.0 / N ) / Quarter_Note )
* Note_Quarter );

Sound( Play_Freq );
Delay( Play_Duration );
NoSound;
Delay( Rest_Duration );

End (* Pause *);

Else
(* Ignore other stuff *);

End (* Case *);

I := I + 1;

End (* Interpret Music *);

(* Make sure sound turned off when through *)
NoSound;

End (* PibPlay *);


Begin (* PibMusic *)
(* Play Happy Birthday as example *)

Writeln(' Playing Happy Birthday ... ');

PibPlaySet;
PibPlay('MBT120L4MFMNO4C8C8DCFE2C8C8DCGF2C8C8O5CO4A F E D2T90 B-8 B-8 A F G F2');

Delay( 1000 );
(* And Broadway *)

Writeln(' Playing Broadway ... ');

PibPlaySet;
PibPlay('MSO3L16EL6EL16EL4EL4EL8EL4DL2FP4P16L16DL6DL16DL4DL4DL4DL2CP4P8P16'+
'EL6EL16EL4EL4EL8EL4DL2FP4P16L16DL6DL16DL4DL4DL4DL2CP4P8P16');

Delay( 1000 );

Writeln(' Playing William Tell Overture ... ');

PibPlaySet;
PibPlay('L16T155');
PibPlay('o2mnb4p8msbbmnb4p8msbbb8g#8');
PibPlay('e8g#8b8g#8b8o3e8o2b8g#8e8g#8');
PibPlay('b8g#8b8o3e8o2mnb4p8msbbmnb4');
PibPlay('p8msbbmnb4p8msbbmnb4p8msbb');
PibPlay('b8bbb8b8b8bbb8b8b8bb');
PibPlay('b8b8b8bbb8b8mlb2');
PibPlay('b2b8p8p4p4');
PibPlay('p8mso1bbb8bbb8bbo2e8f#8g#8o1bb');
PibPlay('b8bbo2e8g#g#f#8d#8o1b8bbb8bb');
PibPlay('b8bbo2e8f#8g#8eg#mlb4bmsag#f#');
PibPlay('e8g#8e8o3bbb8bbb8bbo4e8f#8');
PibPlay('g#8o3bbb8bbo4e8g#g#f#8d#8o3b8bb');
PibPlay('b8bbb8bbo4e8f#8g#8mleg#b4');
PibPlay('bag#f#mse8g#8e8o3g#g#g#8g#g#g#8g#g#');
PibPlay('g#8o4c#8o3g#8o4c#8o3g#8o4c#8o3g#8f#8e8d#8');
PibPlay('c#8g#g#g#8g#g#g#8g#g#g#8o4c#8o3g#8o4c#8');
PibPlay('o3g#8o4c#8o3b8a#8b8a#8b8g#g#g#8g#g#');
PibPlay('g#8g#g#g#8o4c#8o3g#8o4c#8o3g#8o4c#8o3g#8f#8');
PibPlay('e8d#8c#8g#g#g#8g#g#g#8g#g#g#8o4c#8');
PibPlay('o3g#8o4c#8o3g#8o4c#8o3b8a#8b8o2bbb8f#f#');
PibPlay('f#8f#f#f#8g#8a8f#4mna8msg#8mne4');
PibPlay('msg#8f#8f#8f#8o3f#f#f#8f#f#f#8g#8');
PibPlay('a8mnf#4msa8g#8mne4msg#8f#8o2bb');
PibPlay('b8o1bbb8bbb8bbo2mne8f#8g#8o1bb');
PibPlay('b8bbo2e8g#g#f#8d#8o1b8bbb8bb');
PibPlay('b8bbo2e8f#8g#8eg#mlb4mnbag#f#');
PibPlay('e8g#8e8o3bbb8bbb8bbo4e8f#8');
PibPlay('g#8o3bbb8bbo4e8g#g#f#8d#8o3b8bb');
PibPlay('b8bbb8bbo4e8f#8g#8mleg#mlb4');
PibPlay('mnbag#f#mne8g#8e8o3mle56f56g56a56b56o4c56d56mne8eee8e8g#4.');
PibPlay('f#8e8d#8e8c#8mso3bo4c#o3bo4c#o3b');
PibPlay('o4c#d#eo3abababo4c#d#o3g#ag#ag#abo4c#o3f#');
PibPlay('g#f#g#f#g#f#g#f#g#f#d#o2bo3mlbo4c#d#e8d#8e8');
PibPlay('c#8o3msbo4c#o3bo4c#o3bo4c#d#eo3abababo4c#d#o3g#');
PibPlay('ag#ag#abo4c#o3f#g#f#g#f#af#emne8p8mlc#4');
PibPlay('mnc#o2cmso3c#o2co3d#c#o2baag#ec#c#c#c#c#e');
PibPlay('d#o1cg#g#g#g#g#g#o2c#eg#o3c#c#c#c#c#o2co3c#o2co3d#');
PibPlay('c#o2baag#ec#c#c#c#c#ed#o1cg#g#g#g#g#mng#');
PibPlay('o2c#eg#o3msc#ed#c#d#o2cg#g#g#o3g#ec#d#o2cg#g#g#');
PibPlay('o3g#ec#d#o2bg#g#a#gd#d#g#gg#gg#ag#f#e');
PibPlay('o1ba#bo2eo1bo2f#o1bo2g#ed#eg#eaf#bo3g#f#ed#');
PibPlay('f#ec#o2bo3c#o2bo3c#d#ef#g#o2ababo3c#d#ef#o2g#');
PibPlay('ag#aco3c#d#eo2f#g#f#g#f#g#f#g#f#g#f#d#o1b');
PibPlay('co2c#d#eo1ba#bo2eo1bo2f#o1bo2g#ed#eg#eaf#b');
PibPlay('o3g#f#ed#f#ec#o2bo3c#o2bo3c#d#ef#g#o2ababo3c#');
PibPlay('d#ef#o2g#ag#abo3c#d#eo2f#o3c#o2co3c#d#c#o2af#mne');
PibPlay('o3mlef#g#abo4c#d#mne8mseee8e8g#4.');
PibPlay('msf8mse8d#8e8c#8o3bo4c#o3bo4c#o3bo4c#d#eo3a');
PibPlay('bababo4c#d#o3g#ag#ag#abo4c#o3f#g#f#g#f#');
PibPlay('g#f#g#f#g#f#d#o2bo3mlbo4c#d#mne8eee8e8g#4.');
PibPlay('msf#8e8d#8e8c#8o3bo4c#o3bo4c#o3b');
PibPlay('o4c#d#eo3abababo4c#d#o3g#ag#ag#abo4c#o3f#');
PibPlay('g#f#g#f#ag#f#e8o2b8o3e8g#g#g#8mng#g#g#8');
PibPlay('g#g#g#8o4c#8o3g#8o4c#8o3g#8o4c#8o3g#8f#8e8');
PibPlay('d#8c#8g#g#g#8g#g#g#8g#g#g#8o4c#8o3g#8');
PibPlay('o4c#8o3g#8o4c#8o3b8a#8b8a#8b8g#g#g#8');
PibPlay('g#g#g#8g#g#g#8o4c#8o3g#8o4c#8o3g#8o4c#8o3g#8');
PibPlay('f#8e8d#8c#8g#g#g#8g#g#g#8g#g#g#8');
PibPlay('o4c#8o3g#8o4c#8o3g#8o4c#8o3b8a#8b8a#8b8');
PibPlay('o2f#f#f#8f#f#f#8g#8a8f#4a8g#8');
PibPlay('e4g#8f#8o0b8o1b8o2f#f#f#8f#f#f#8');
PibPlay('g#8a8f#4a8g#8e4g#8f#8');
PibPlay('bbb8o1bbb8bbb8bbo2e8f#8g#8');
PibPlay('o1bbb8bbo2e8g#g#f#8d#8o1b8bbb8');
PibPlay('bbb8bbo2e8f#8g#8eg#mlb4mnb');
PibPlay('ag#f#e8o1b8o2e8o3bbb8bbb8bbo4e8');
PibPlay('f#8g#8o3bbb8bbo4e8g#g#f#8d#8o3b8');
PibPlay('bbb8bbb8bbo4e8f#8g#8o3eg#mlb4');
PibPlay('mnbag#f#mlef#g#mnamlg#abo4mnc#mlo3bo4c#d#mnemld#');
PibPlay('ef#mng#ao3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bmle');
PibPlay('f#g#mnamlg#abmno4c#mlo3bo4c#d#mnemld#ef#mng#ao3bo4ao3bo4a');
PibPlay('o3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bp16mlg#o4g#o3mng#p16mld#o4d#o3mnd#p16');
PibPlay('mleo4eo3mnep16mlao4ao3mnap16mlg#o4g#o3mng#p16mld#o4d#o3mnd#p16mleo4eo3mnep16');
PibPlay('mlao4ao3mnao4go3go4go3go4go3go4go3go4msg8e8c8e8o4mng#');
PibPlay('o3g#o4g#o3g#o4g#o3g#o4g#o3g#o4msg#8e8o3b8o4e8mng#o3g#o4g#o3g#o4g#');
PibPlay('o3g#o4g#o3g#o4msg#8f8c#8f8mna#o3a#o4a#o3a#o4a#o3a#o4a#o3a#o4msa#8');
PibPlay('g8e8g8b8p16mna#p16ap16g#p16f#p16ep16');
PibPlay('d#p16c#p16o3bp16a#p16ap16g#p16f#p16ep16d#p16f#mle');
PibPlay('f#g#mnamlg#abmno4c#o3mlbo4c#d#mnemld#ef#mng#ao3bo4ao3bo4a');
PibPlay('o3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bmlef#g#mnamlg#abmno4c#o3mlb');
PibPlay('o4c#d#mnemld#ef#mng#ao3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bo4a');
PibPlay('o3bo4ao3bp16mlg#o4g#o3mng#p16mld#o4d#o3mnd#p16mleo4eo3mnep16mlao4ao3mnap16');
PibPlay('mlg#o4g#o3mng#p16mld#o4d#o3mnd#p16mleo4eo3mnep16mlao4ao3mnao4go3go4go3go4g');
PibPlay('o3go4go3go4g8e8c8e8g#o3g#o4g#o3g#o4g#o3g#o4g#o3g#o4g#8');
PibPlay('e8o3b8o4e8g#o3g#o4g#o3g#o4g#o3g#o4g#o3g#o4msg#8mnf8c#8');
PibPlay('f8a#o3a#o4a#o3a#o4a#o3a#o4a#o3a#o4a#8g8e8g8b8');
PibPlay('p16a#p16ap16g#p16f#p16ep16d#p16c#p16o3bp16a#p16');
PibPlay('ap16g#p16f#p16ep16d#p16fmled#ed#mne8bbb8');
PibPlay('bbb8bbo4e8f#8g#8o3bbb8bbb8');
PibPlay('bbo4g#8a8b8p8e8f#8g#8p8o3g#8');
PibPlay('a8b8p8p2o2bco3c#dd#');
PibPlay('eff#gg#aa#bco4c#d#ed#f#d#ed#f#d#e');
PibPlay('d#f#d#ed#f#d#ed#f#d#ed#f#d#ed#f#d#e');
PibPlay('d#f#d#e8eo3eo4eo3eo4eo3eo4e8o3bo2bo3bo2bo3bo2bo3b8');
PibPlay('g#o2g#o3g#o2g#o3g#o2g#o3g8eo2eo3eo2eo3eo2eo3e8eee8');
PibPlay('e8e8o2bbb8b8b8g#g#g#8g#8g#8');
PibPlay('eee8e8e8o1b8o2e8o1b8o2g#8e8b8');
PibPlay('g#8o3e8o2b8o3e8o2b8o3g#8e8b8g#8o4e4');
PibPlay('p8eee8e8e8e8e4p8.');
PibPlay('ee4p8.o2ee2');

End (* PibMusic *).

  3 Responses to “Category : Pascal Source Code
Archive   : PIBMUSIC.ZIP
Filename : PIBMUSIC.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/