home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
PASCAL
/
ANSIPAS.ZIP
/
ANSIIO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-08-14
|
23KB
|
556 lines
UNIT AnsiIO;
INTERFACE
USES
CRT,
Graph3;
FUNCTION ANSIClrScr : string;
FUNCTION ANSIClrEol : string;
FUNCTION ANSIGotoXY(X, Y : word) : string;
FUNCTION ANSIUp(Lines : word) : string;
FUNCTION ANSIDown(Lines : word) : string;
FUNCTION ANSIRight(Cols : word) : string;
FUNCTION ANSILeft(Cols : word) : string;
FUNCTION ANSIColor(Fg, Bg : integer) : string;
FUNCTION ANSIMusic(s : string) : string;
PROCEDURE ANSIWrite(s : string);
PROCEDURE ANSIWriteLn(s : string);
IMPLEMENTATION
CONST
ColorArray : array[0..7] of integer = (0,4,2,6,1,5,3,7);
VAR
Bold, TruncateLines : boolean;
Vari, Octave, Numb : integer;
Test, Dly, Intern, DlyKeep : longInt;
Flager, ChartoPlay : char;
Typom, Min1, Adder : real;
{****************************************************************************}
{*** ***}
{*** Function that returns the ANSI code for a Clear Screen. ***}
{*** ***}
{****************************************************************************}
FUNCTION ANSIClrScr : string;
BEGIN
ANSIClrScr := #27+'[2J';
END;
{****************************************************************************}
{*** ***}
{*** Function that returns the ANSI code for a Clear to End of Line. ***}
{*** ***}
{****************************************************************************}
FUNCTION ANSIClrEol : string;
BEGIN
ANSIClrEol := #27+'[K';
END;
{****************************************************************************}
{*** ***}
{*** Function that returns the ANSI code to move the cursor to (X,Y). ***}
{*** ***}
{****************************************************************************}
FUNCTION ANSIGotoXY(X, Y : word) : string;
VAR
XStr, YStr : string;
BEGIN
str(X,XStr);
str(Y,YStr);
ANSIGotoXY := #27+'['+YStr+';'+XStr+'H';
END;
{****************************************************************************}
{*** ***}
{*** Function that returns the ANSI code to move the cursor up "Lines" ***}
{*** number of lines. ***}
{*** ***}
{****************************************************************************}
FUNCTION ANSIUp(Lines : word) : string;
VAR
LinesStr : string;
BEGIN
str(Lines,LinesStr);
ANSIUp := #27+'['+LinesStr+'A';
END;
{****************************************************************************}
{*** ***}
{*** Function that returns the ANSI code to move the cursor down "Lines" ***}
{*** number of lines. ***}
{*** ***}
{****************************************************************************}
FUNCTION ANSIDown(Lines : word) : string;
VAR
LinesStr : string;
BEGIN
str(Lines,LinesStr);
ANSIDown := #27+'['+LinesStr+'B';
END;
{****************************************************************************}
{*** ***}
{*** Function that returns the ANSI code to move the cursor "Cols" ***}
{*** positions forward. ***}
{*** ***}
{****************************************************************************}
FUNCTION ANSIRight(Cols : word) : string;
VAR
ColsStr : string;
BEGIN
str(Cols,ColsStr);
ANSIRight := #27+'['+ColsStr+'C';
END;
{****************************************************************************}
{*** ***}
{*** Function that returns the ANSI code to move the cursor "Cols" ***}
{*** positions backward. ***}
{*** ***}
{****************************************************************************}
FUNCTION ANSILeft(Cols : word) : string;
VAR
ColsStr : string;
BEGIN
str(Cols,ColsStr);
ANSILeft := #27+'['+ColsStr+'D';
END;
{****************************************************************************}
{*** ***}
{*** Function that returns the ANSI code to change the screen color ***}
{*** to an "Fg" foreground and a "Bg" background. ***}
{*** ***}
{****************************************************************************}
FUNCTION ANSIColor(Fg, Bg : integer) : string;
VAR
FgStr, BgStr, Temp : string;
BEGIN
str(ColorArray[Fg mod 8] + 30, FgStr);
str(ColorArray[Bg mod 8] + 40, BgStr);
Temp := #27+'[';
if Bg > 7 then
Temp := Temp+'5;'
else
Temp := Temp+'0;';
if Fg > 7 then
Temp := Temp+'1;'
else
Temp := Temp+'2;';
ANSIColor := Temp+FgStr+';'+BgStr+'m';
END;
{****************************************************************************}
{*** ***}
{*** Function that returns an ANSI code representing a music string ("s") ***}
{*** ***}
{****************************************************************************}
FUNCTION ANSIMusic(s : string) : string;
BEGIN
ANSIMusic := #27+'[MF'+s+#14;
END;
{****************************************************************************}
{*** ***}
{*** Procedure that simulates BASIC's "PLAY" procedure. Will also work ***}
{*** with ANSI codes. Taken from PC Magazine Volume 9 Number 3 ***}
{*** ***}
{****************************************************************************}
PROCEDURE Play(SoundC : string);
FUNCTION IsNumber(ch : char) : boolean;
BEGIN
IsNumber := (CH >= '0') AND (CH <= '9');
END;
{Converts a string to an integer}
FUNCTION value(s : string) : integer;
VAR
ss, sss : integer;
BEGIN
Val(s, ss, sss);
value := ss;
END;
{Plays the selected note}
PROCEDURE sounder(key : char; flag : char);
VAR
old, New, new2 : Real;
BEGIN
adder := 1;
old := dly;
New := dly;
intern := Pos(key, 'C D EF G A B')-1;
IF (flag = '+') AND (key <> 'E') AND (key <> 'B') {See if note}
THEN Inc(intern); {is sharped }
IF (flag = '-') AND (key <> 'F') AND (key <> 'C')
THEN Dec(intern); {or a flat. }
WHILE SoundC[vari+1] = '.' DO
BEGIN
Inc(vari);
adder := adder/2;
New := New+(old*adder);
END;
new2 := (New/typom)*(1-typom);
sound(Round(Exp((octave+intern/12)*Ln(2)))); {Play the note}
Delay(Trunc(New));
Nosound;
Delay(Trunc(new2));
END;
{Calculate delay for a specified note length}
FUNCTION delayer1 : integer;
BEGIN
numb := value(SoundC[vari+1]);
delayer1 := Trunc((60000/(numb*min1))*typom);
END;
{Used as above, except reads a number >10}
FUNCTION delayer2 : Integer;
BEGIN
numb := value(SoundC[vari+1]+SoundC[vari+2]);
delayer2 := Trunc((60000/(numb*min1))*typom);
END;
BEGIN {Play}
SoundC := SoundC+' ';
FOR vari := 1 TO Length(SoundC) DO
BEGIN {Go through entire string}
SoundC[vari] := Upcase(SoundC[vari]);
CASE SoundC[vari] OF
{Check to see} 'C','D','E',
{if char is a} 'F','G','A',
{note} 'B' : BEGIN
flager := ' ';
dlykeep := dly;
chartoplay := SoundC[vari];
IF (SoundC[vari+1] = '-') OR
(SoundC[vari+1] = '+') THEN
{Check for flats & sharps} BEGIN
flager := SoundC[vari+1];
Inc(vari);
END;
IF IsNumber(SoundC[vari+1]) THEN
BEGIN
IF IsNumber(SoundC[vari+2]) THEN
BEGIN
test := delayer2;
{Make sure # is legal} IF numb < 65 THEN
dly := test;
Inc(vari, 2);
END
ELSE
BEGIN
test := delayer1;
{Make sure # is legal} IF numb > 0 THEN
dly := test;
Inc(vari);
END;
END;
sounder(chartoplay, flager);
dly := dlykeep;
END;
{Check for} 'O' : BEGIN
{octave change} Inc(vari);
CASE SoundC[vari] OF
'-' : IF octave > 1 THEN Dec(octave);
'+' : IF octave < 7 THEN Inc(octave);
'1','2','3',
'4','5','6',
'7' : octave := value(SoundC[vari])+4;
ELSE Dec(vari);
END;
END;
{Check for a} 'L' : IF IsNumber(SoundC[vari+1]) THEN
{change in length} BEGIN
{for notes} IF IsNumber(SoundC[vari+2]) THEN
BEGIN
test := delayer2;
IF numb < 65 THEN
{Make sure # is legal} dly := test;
Inc(vari, 2);
END
ELSE
BEGIN
test := delayer1;
IF numb > 0 THEN
{Make sure # is legal} dly := test;
Inc(vari);
END;
END;
{Check for pause} 'P' : IF IsNumber(SoundC[vari+1]) THEN
{and it's length} BEGIN
IF IsNumber(SoundC[vari+2]) THEN
BEGIN
test := delayer2;
IF numb < 65 THEN
{Make sure # is legal} Delay(test);
Inc(vari, 2);
END
ELSE
BEGIN
test := delayer1;
IF numb > 0 THEN
{Make sure # is legal} Delay(test);
Inc(vari);
END;
END;
{Check for} 'T' : IF IsNumber(SoundC[vari+1]) AND
{tempo change} IsNumber(SoundC[vari+2]) THEN
BEGIN
IF IsNumber(SoundC[vari+3]) THEN
BEGIN
min1 := value(SoundC[vari+1]+
SoundC[vari+2]+SoundC[vari+3]);
Inc(vari, 3);
IF min1 > 255 THEN
{Make sure # isn't too big} min1 := 255;
END
ELSE
BEGIN
min1 := value(SoundC[vari+1]+
SoundC[vari+2]);
IF min1 < 32 THEN
{Make sure # isn't too small} min1 := 32;
END;
min1 := min1/4;
END;
{Check for music} 'M' : BEGIN
{type} Inc(vari);
CASE Upcase(SoundC[vari]) OF
{Normal} 'N' : typom := 7/8;
{Legato} 'L' : typom := 1;
{Staccato} 'S' : typom := 3/4;
END;
END;
END;
END;
END;
{****************************************************************************}
{*** ***}
{*** Procedure to process string "s" and write its contents to the ***}
{*** screen, interpreting ANSI codes as it goes along. ***}
{*** ***}
{****************************************************************************}
PROCEDURE ANSIWrite(s : string);
VAR
SaveX, SaveY : byte;
MusicStr : string;
MusicPos : integer;
{*** Procedure to process the actual ANSI sequence ***}
PROCEDURE ProcessEsc;
VAR
DeleteNum : integer;
ts : string[5];
Num : array[0..10] of shortint;
Color : integer;
LABEL
loop;
{*** Procedure to extract a parameter from the ANSI sequence and ***}
{*** place it in "Num" ***}
PROCEDURE GetNum(cx : byte);
VAR
code : integer;
BEGIN
ts := '';
WHILE (s[1] in ['0'..'9']) and (length(s) > 0) DO
BEGIN
ts := ts + s[1];
Delete(s,1,1);
END;
val(ts,Num[cx],code)
END;
BEGIN
IF s[2] <> '[' THEN exit;
Delete(s,1,2);
IF (UpCase(s[1]) = 'M') and (UpCase(s[2]) in ['F','B']) THEN
{play music} BEGIN
Delete(s,1,2);
MusicPos := pos(#14,s);
Play(copy(s,1,MusicPos-1));
DeleteNum := MusicPos;
Goto Loop;
END;
fillchar(Num,sizeof(Num),#0);
GetNum(0);
DeleteNum := 1;
WHILE (s[1] = ';') and (DeleteNum < 11) DO
BEGIN
Delete(s,1,1);
GetNum(DeleteNum);
DeleteNum := DeleteNum + 1;
END;
CASE UpCase(s[1]) of
{move up} 'A' : BEGIN
if Num[0] = 0 THEN
Num[0] := 1;
WHILE Num[0] > 0 DO
BEGIN
GotoXY(wherex,wherey - 1);
Num[0] := Num[0] - 1;
END;
DeleteNum := 1;
END;
{move down} 'B' : BEGIN
if Num[0] = 0 THEN
Num[0] := 1;
WHILE Num[0] > 0 DO
BEGIN
GotoXY(wherex,wherey + 1);
Num[0] := Num[0] - 1;
END;
DeleteNum := 1;
END;
{move right} 'C' : BEGIN
if Num[0] = 0 THEN
Num[0] := 1;
WHILE Num[0] > 0 DO
BEGIN
GotoXY(wherex + 1,wherey);
Num[0] := Num[0] - 1;
END;
DeleteNum := 1;
END;
{move left} 'D' : BEGIN
if Num[0] = 0 THEN
Num[0] := 1;
WHILE Num[0] > 0 DO
BEGIN
GotoXY(wherex - 1,wherey);
Num[0] := Num[0] - 1;
END;
DeleteNum := 1;
END;
{goto x,y} 'H',
'F' : BEGIN
if (Num[0] = 0) THEN
Num[0] := 1;
if (Num[1] = 0) THEN
Num[1] := 1;
GotoXY(Num[1],Num[0]);
DeleteNum := 1;
END;
{save current} 'S' : BEGIN
{position} SaveX := wherex;
SaveY := wherey;
DeleteNum := 1;
END;
{restore} 'U' : BEGIN
{saved position} GotoXY(SaveX,SaveY);
DeleteNum := 1;
END;
{clear screen} 'J' : BEGIN
if Num[0] = 2 THEN
ClrScr;
DeleteNum := 1;
END;
{clear from} 'K' : BEGIN
{cursor position} ClrEOL;
{to end of line} DeleteNum := 1;
END;
{change} 'M' : BEGIN
{colors and} DeleteNum := 0;
{attributes} WHILE (Num[DeleteNum] <> 0) or (DeleteNum = 0) DO
BEGIN
CASE Num[DeleteNum] of
{all attributes off} 0 : BEGIN
NormVideo;
Bold := false;
END;
{bold on} 1 : Bold := true;
{blink on} 5 : textattr := textattr + blink;
{reverse on} 7 : textattr := ((textattr and $07) shl 4) +
((textattr and $70) shr 4);
{invisible on} 8 : textattr := 0;
{general foregrounds} 30..
37 : BEGIN
color := ColorArray[Num[DeleteNum]
- 30];
IF Bold THEN
color := color + 8;
textcolor(color);
END;
{general backgrounds} 40..
47 : textbackground(
ColorArray[Num[DeleteNum] - 40]);
END;
DeleteNum := DeleteNum + 1;
END;
DeleteNum := 1;
END;
{change text} '=',
{modes} '?' : BEGIN
Delete(s,1,1);
GetNum(0);
if UpCase(s[1]) = 'H' THEN
BEGIN
CASE Num[0] of
0 : TextMode(bw40);
1 : TextMode(co40);
2 : TextMode(bw80);
3 : TextMode(co80);
4 : GraphColorMode;
5 : GraphMode;
6 : HiRes;
7 : TruncateLines := false;
END;
END;
if UpCase(s[1]) = 'L' THEN
if Num[0] = 7 THEN
TruncateLines := true;
DeleteNum := 1;
END;
END;
loop: Delete(s,1,DeleteNum);
END;
BEGIN
WHILE length(s) > 0 DO
BEGIN
if s[1] = #27 THEN
ProcessEsc
else
BEGIN
Write(s[1]);
Delete(s,1,1);
END;
END;
END;
{****************************************************************************}
{*** ***}
{*** Procedure that calls ANSIWrite, then line feeds. ***}
{*** ***}
{****************************************************************************}
PROCEDURE ANSIWriteLn(s : string);
BEGIN
ANSIWrite(s);
WriteLn;
END;
BEGIN
Octave := 4;
ChartoPlay := 'N';
Typom := 7/8;
Min1 := 120;
TruncateLines := false;
END.
