Skip to content

Instantly share code, notes, and snippets.

@thirtysixthspan

thirtysixthspan/DDANSI.PAS

Created July 28, 2012 17:48
Show Gist options
  • Save thirtysixthspan/3194158 to your computer and use it in GitHub Desktop.
Save thirtysixthspan/3194158 to your computer and use it in GitHub Desktop.
Download ZIP
What I believe is my first open source code contribution..... from DoorDriver 4.0
Raw
DDANSI.PAS
{--- Circa 1989 ---}
unit ddansi;
interface
uses dos, crt;
{----------------------------------------------------------------------------}
{ Ansi screen emulation routines }
{ By Scott Baker }
{ Revised By Derrick Parkhurst
{----------------------------------------------------------------------------}
{ }
{ Purpose: to execute ansi escape sequences locally. This includes changing }
{ color, moving the cursor, setting high/low intensity, setting }
{ blinking, and playing music. }
{ }
{ Remarks: These routines use a few global variables which are defined }
{ below. So far, only ESC m, J, f, C, and ^N are supported by these }
{ routines. I hope to include more in the future. }
{ }
{ Routines: Here is a listing of the subroutines: }
{ }
{ change_color(x): Change to ansi color code X. }
{ Eval_string(s): Evaluate/execute ansi string }
{ ansi_write(ch): Write a character with ansi checking }
{ }
{----------------------------------------------------------------------------}
var
escape,blink,high,norm,any,any2,fflag,gflag: boolean;
ansi_string: string;
const
ddansibanner: boolean = true;
procedure ansi_write(ch: char);
procedure ansi_write_str(var s: string);
procedure initddansi;
implementation
const
scale: array[0..7] of integer = (0,4,2,6,1,5,3,7);
scaleh: array[0..7] of integer = (8,12,10,14,9,13,11,15);
var
bbb: boolean;
t: char;
restx,resty,curcolor: integer;
Note_Octave: integer;
Note_Fraction, Note_Length, 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 : String );
(* ------------------------------------------------------------------------ *)
(* *)
(* Procedure: PibPlay *)
(* *)
(* Purpose: Play music though PC's speaker *)
(* *)
(* Calling Sequence: *)
(* *)
(* PibPlay( Music_String : AnyStr ); *)
(* *)
(* 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 ];
if quarter_note<>0 then 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;
if quarter_note<>0 then 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;
if quarter_note<>0 then 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 *);
procedure change_color(c: integer);
begin;
case c of
00: begin;any:=true;blink:=false;high:=false;norm:=true;end;
01: begin;high:=true;end;
02: begin;clrscr;any:=true;end;
05: begin;blink:=true;any:=true;end;
end;
if (c>29) and (c<38) then begin;
any:=true;
any2:=true;
c:=c-30;
curcolor:=c;
if (high=true) and (blink=true) then textcolor(scaleh[c]+128);
if (high=true) and (blink=false) then textcolor(scaleh[c]);
if (high=false) and (blink=true) then textcolor(scale[c]+128);
if (high=false) and (blink=false) then textcolor(scale[c]);
fflag:=true;
end;
if (c>39) and (c<48) then begin;
any:=true;
c:=c-40;
textbackground(scale[c]);
gflag:=true;
end;
end;
procedure eval_string(var s: string);
var
cp: integer;
T: CHAR;
jj,tt,ttt,tttt: integer;
flag1:boolean;
begin;
t:=s[length(s)];
cp:=2;
case t of
'k','K': clreol;
'u': gotoxy(restx,resty);
's': begin;
restx:=wherex;
resty:=wherey;
end;
'm','J':begin;
repeat;
tt:=-1;
val(s[cp],tt,tttt);
if tttt=0 then begin;
cp:=cp+1;
val(s[cp],ttt,tttt);
if tttt=0 then begin;
tt:=tt*10;
tt:=tt+ttt;
end;
change_color(tt);
end;
cp:=cp+1;
until cp>=length(s);
if norm=true then begin;
if (fflag=false) and (gflag=false) then begin;textcolor(7);textbackground(0);curcolor:=7;end;
if (fflag=false) and (gflag=true) then begin;textcolor(7);curcolor:=7;end;
if (high=true) and (fflag=false) then textcolor(scaleh[curcolor]);
if (blink=true) and (fflag=false) then textcolor(scale[curcolor]+128);
if (blink=true) and (high=true) and (fflag=false) then textcolor(scaleh[curcolor]+128);
if (fflag=true) and (gflag=false) then begin;textbackground(0);end;
end;
if any=false then textcolor(scaleh[curcolor]);
if (high=true) and (any2=false) then textcolor(scaleh[curcolor]);
any2:=false;any:=false;fflag:=false;gflag:=false;norm:=false;
end;
^N: begin;
delete(s,1,2);
delete(s,length(s),1);
pibplay(s);
end;
'C': begin;
tt:=1;
val(s[cp],tt,tttt);
if tttt=0 then begin;
cp:=cp+1;
val(s[cp],ttt,tttt);
if tttt=0 then begin;
tt:=tt*10;
tt:=tt+ttt;
end;
end else tt:=1;
ttt:=wherex;
if tt+ttt<=80 then gotoxy(tt+ttt,wherey);
end;
'D': begin;
tt:=1;
val(s[cp],tt,tttt);
if tttt=0 then begin;
cp:=cp+1;
val(s[cp],ttt,tttt);
if tttt=0 then begin;
tt:=tt*10;
tt:=tt+ttt;
end;
end else tt:=1;
ttt:=wherex;
if ttt-tt>=1 then gotoxy(ttt-tt,wherey);
end;
'A': begin;
tt:=1;
val(s[cp],tt,tttt);
if tttt=0 then begin;
cp:=cp+1;
val(s[cp],ttt,tttt);
if tttt=0 then begin;
tt:=tt*10;
tt:=tt+ttt;
end;
end else tt:=1;
ttt:=wherey;
if ttt-tt>=1 then gotoxy(wherex,ttt-tt);
end;
'B': begin;
tt:=1;
val(s[cp],tt,tttt);
if tttt=0 then begin;
cp:=cp+1;
val(s[cp],ttt,tttt);
if tttt=0 then begin;
tt:=tt*10;
tt:=tt+ttt;
end;
end else tt:=1;
ttt:=wherey;
if ttt+tt<=25 then gotoxy(wherex,ttt+tt);
end;
'f','H': begin;
flag1:=false;
tt:=1;
val(s[cp],tt,tttt);
if tttt=0 then begin;
cp:=cp+1;
val(s[cp],ttt,tttt);
if tttt=0 then begin;
tt:=tt*10;
tt:=tt+ttt;
flag1:=true;
end;
end else tt:=1;
jj:=tt;
if flag1=false then cp:=cp+1;
if flag1=true then cp:=cp+2;
if cp<length(s) then begin;
tt:=1;
val(s[cp],tt,tttt);
if tttt=0 then begin;
cp:=cp+1;
val(s[cp],ttt,tttt);
if tttt=0 then begin;
tt:=tt*10;
tt:=tt+ttt;
end;
end else tt:=1;
end else tt:=1;
gotoxy(tt,jj);
end;
else writeln(s);
end;
end;
Procedure ansi_write(ch: char);
begin;
case ch of
#12: clrscr;
#09: repeat; write(' '); until wherex/8 = wherex div 8;
#27: begin; escape:=true; bbb:=true; end;
else begin;
if escape then begin;
if (bbb=true) and (ch<>'[') then begin;
blink:=false;
high:=false;
escape:=false;
ansi_string:='';
write(#27);
end else bbb:=false;
if escape then begin;
ansi_string:=ansi_string+ch;
if ch=#13 then escape:=false;
if (ch in ['u','s','A','B','C','D','H','m','J','f','K','k',#14]) then begin;
escape:=false;
eval_string(ansi_string);
ansi_string:='';
end;
end;
end else write(ch);
end;
end;
end;
Procedure ansi_write_str(var s: string);
var
a: integer;
begin;
for a:=1 to length(s) do begin;
case s[a] of
#12: clrscr;
#09: repeat; write(' '); until wherex/8 = wherex div 8;
#27: begin; escape:=true; bbb:=true; end;
else begin;
if escape then begin;
if (bbb=true) and (s[a]<>'[') then begin;
blink:=false;
high:=false;
escape:=false;
ansi_string:='';
write(#27);
end else bbb:=false;
if escape then begin;
ansi_string:=ansi_string+s[a];
if s[a]=#13 then escape:=false;
if (s[a] in ['u','s','A','B','C','D','H','m','J','f','K','k',#14]) then begin;
escape:=false;
eval_string(ansi_string);
ansi_string:='';
end;
end;
end else write(s[a]);
end;
end;
end;
end;
procedure InitDDAnsi;
begin;
{ if ddansibanner then writeln(' ANSI-BBS driver routines installed. (C) 1988 by Scott Baker.');
}
pibplayset;
escape:=false;
ansi_string:='';
blink:=false;
high:=false;
end;
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment