Unit Textunit;
Interface
uses dos;
{Procedure TextMode;}
Procedure WaitRetrace;
Procedure Blink(Switch: Boolean);
Procedure ClrScr;
Procedure HideCursor;
Procedure ShowCursor;
Procedure Delay(ms: Word);
Function KeyPressed: Boolean;
Function ReadKey : Char;
Function ScanCode: Word;
Function WhereX: Byte;
Function WhereY: Byte;
Procedure GotoXY(X, Y: byte);
Procedure Pal( Color, Red, Green, Blue : Byte);
Procedure Qwrite(x, y: byte; s: string; f, b: byte);
Procedure TextFlow(Col, Row:Integer;Msg:String;Speed:Integer;Center:Boolean);
Procedure Sound (Hertz : Word);
Procedure NoSound;
Procedure SaveTextScreen(filename: String);
Procedure LoadTextScreen(filename: String);
Procedure saveansi(filename : pathstr);
Implementation
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
PROCEDURE SaveANSI(Filename : PathStr);
CONST
Esc = #27;
MaxCol = 70;
AnsiCols : array [0..7] of char = '04261537';
TYPE
TCell = RECORD
C : Char;
A : byte;
END;
TScreen = array [1..25, 1..80] of TCell;
ANSIATTR = record
Bright : boolean;
Blink : boolean;
FG : byte;
BG : byte;
end;
VAR
Screen : TSCreen ABSOLUTE $B800:$0000;
F : text;
X, Y : byte;
s, s1 : String;
AnsiLast,
AnsiTmp : ANSIATTR;
function WriteAttr(var Old, New : ANSIATTR) : string;
{ Write Attributes (ESC[..m) into a string }
var
s : string;
begin
WriteAttr := '';
s := ESC + '[';
if (not(New.Bright = Old.Bright)) or (not(New.Blink = Old.Blink)) then
begin
if (Not (New.Bright and New.Blink)) then
s := s + '0;'
else
if (not New.Bright) and (New.Blink) then
begin
if Old.Bright then
s := s + '0;5;'
else
s := s + '5;';
end
else
if (New.Bright) and (not New.Blink) then
begin
if Old.Blink then
s := s + '0;1;'
else
s := s + '1;';
end
else
begin
if not Old.Bright then
s := s + '1;';
if not Old.Blink then
s := s + '5;';
end;
end;
if (Old.FG <> New.FG) or ((not New.Bright) and Old.Bright) or
((not New.Blink) and Old.Blink) then
begin
{* I don't have no info why, but obviously backswitching to dark
* colorset, what has to be done via ^[0m, must turn fg/bg colors to
* 37/40. However, we can optimize still then a bit !-. *}
if not ( (New.FG=7) and ((not New.Bright) and Old.Bright) )
then s:=s+'3'+AnsiCols[New.FG]+';';
end;
if (Old.BG<>New.BG) or ((not New.Bright) and Old.Bright) or
((not New.Blink) and Old.Blink) then
begin
if not ( (New.BG=0) and ((not New.Bright) and Old.Bright) )
then s:=s+'4'+AnsiCols[New.BG]+';';
end;
if s[length(s)]=';' then s[length(s)]:='m' else s:=s+'m';
if length(s)>length(ESC+'[m') then WriteAttr:=s;
end;
BEGIN
Assign(F, filename);
Rewrite(F);
AnsiTmp.FG := Screen[1, 1].A and 15;
AnsiTmp.BG := Screen[1, 1].A SHR 4;
AnsiTmp.Blink := (AnsiTmp.BG AND 8) = 8;
AnsiTmp.Bright := (AnsiTmp.FG AND 8) = 8;
AnsiTmp.FG:=AnsiTmp.FG and 7;
AnsiTmp.BG:=AnsiTmp.BG and 7;
s:=Esc+'[2J'+Esc+'[0m'+ESC+'[';
if AnsiTmp.Bright then s:=s+'1;';
if AnsiTmp.Blink then s:=s+'5;';
s:=s+'3'+ansicols[AnsiTmp.FG]+';';
s:=s+'4'+ansicols[AnsiTmp.BG]+'m';
FOR Y := 1 TO 25 DO
BEGIN
FOR X := 1 TO 80 DO
BEGIN
AnsiLast:=AnsiTmp;
AnsiTmp.FG := Screen[Y, X].A AND 15;
AnsiTmp.BG := Screen[Y, X].A SHR 4;
AnsiTmp.Bright := (AnsiTmp.FG AND 8)<>0;
AnsiTmp.Blink := (AnsiTmp.BG AND 8)<>0;
AnsiTmp.FG:=AnsiTmp.FG and 7;
AnsiTmp.BG:=AnsiTmp.BG and 7;
s1:=WriteAttr(AnsiLast, AnsiTmp);
s1:=s1+Screen[Y, X].C;
IF (length(s+s1+ESC+'[s')) <= MaxCol then s:=s+s1 else
begin
Write(F,s+ESC+'[s'+#13#10);
s:=ESC+'[u'+s1;
end;
END;
END;
Write(F, Esc+'[0;37;40m');
Close(F);
END;
Procedure TextMode; ASSEMBLER;
Asm
mov ax, 0003h
int 10h
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure WaitRetrace; ASSEMBLER;
Asm
mov dx,3DAh
@L1: in al,dx; and al,08h; jnz @L1
@L2: in al,dx; and al,08h; jz @L2
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure Blink(Switch : Boolean); Assembler;
Asm
mov ax, 1003h
mov bl, Switch
int 10h
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure ClrScr; Assembler;
Asm
mov ah, 0Fh
int 10h
mov ah, 0
int 10h
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure HideCursor; Assembler;
Asm
mov ax, 0100h
mov cx, 2607h
int 10h
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure ShowCursor; Assembler;
Asm
mov ax, 0100h
mov cx, 0506h
int 10h
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure Delay(ms : Word); Assembler;
Asm
mov ax, 1000;
mul ms;
mov cx, dx;
mov dx, ax;
mov ah, 86h;
int 15h;
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Function KeyPressed : Boolean; Assembler;
asm
mov ah,1
int $16
mov al,0
je @next
mov al,1
@next:
end;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Function ReadKey : Char; Assembler;
asm
@slut:
mov ah,1
xor al,al
int $16
jz @slut
xor ah,ah
int $16
mov ah,al
end;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Function ScanCode : word; assembler;
Asm
mov ah, 08h
int 21h
xor dl, dl
mov dh, al
or al, 0 { extended keystroke? }
jnz @1 { no, get out }
int 21h { yes, read extended scan code, F11, F12 supported }
mov dl, al
@1:
mov ax, dx
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Function WhereX: Byte; Assembler;
Asm
mov ah, 03h (* GET CURSOR POSITION *)
mov bh, 0 (* Page 0 (Mode 03h) *)
int 10h (* Call the int *)
mov al, dl (* Col returned in DL *)
inc al (* Add 1 to X (col) *)
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Function WhereY: Byte; Assembler;
Asm
mov ah, 03h (* GET CURSOR POSITION *)
mov bh, 0 (* Page 0 (Mode 03h) *)
int 10h (* Call the int *)
mov al, dh (* Row returned in DH *)
inc al (* Add 1 to Y (row) *)
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure GotoXY(X, Y: byte); Assembler;
{ Note: if x or y > 127 then it flips over...but you gotta be retarded }
{ if yer in text mode tryin' to do gotoxy(128,128) =) }
{ Also, this one of my first attempts at jumping in ASM }
Asm
cmp x, 1 { If X < 1 Then X := 1 }
jg @j1
mov x, 1
@j1:
cmp y, 1 { If Y < 1 Then Y := 1 }
jg @j2
mov y, 1
@j2:
cmp x, 80 { If X > 80 Then X := 80 }
jl @j3
mov x, 80
@j3:
cmp y, 25 { If Y > 25 Then Y := 25 }
jl @j4
mov y, 25
@j4:
mov ah, 02h { SET CURSOR POSITION }
mov bh, 0 { Page 0 }
mov dl, X { Row }
mov dh, Y { Column }
dec dl { Decrement Row (Y) }
dec dh { Decrement Col (X) }
int 10h
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure Pal( Color, Red, Green, Blue : Byte);
Const TextColors :
array[0..15] of byte = (0,1,2,3,4,5,20,7,56,57,58,59,60,61,62,63);
Begin
Port[$3C8] := TextColors[Color];
Port[$3C9] := Red;
Port[$3C9] := Green;
Port[$3C9] := Blue;
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure Qwrite(x, y: byte; s: string; f, b: byte);
Begin
Asm
mov dh, y { move X and Y into DL and DH }
mov dl, x
xor al, al
mov ah, b { load background into AH }
mov cl, 4 { shift background over to next nibble }
shl ax, cl
add ah, f { add foreground }
push ax { PUSH color combo onto the stack }
mov bx, 0040h { look at 0040h:0049h to get video mode }
mov es, bx
mov bx, 0049h
mov al, es:[bx]
cmp al, 7 { see if mode = 7 (i.e., monochrome) }
je @mono_segment
mov ax, 0b800h { it's color: use segment B800h }
jmp @got_segment
@mono_segment:
mov ax, 0b000h { it's mono: use segment B000h }
@got_segment:
push ax { PUSH video segment onto stack }
mov bx, 004ah { check 0040h:0049h to get number of screen columns }
xor ch, ch
mov cl, es:[bx]
xor ah, ah { move Y into AL; decrement to convert Pascal coords }
mov al, dh
dec al
xor bh, bh { shift X over into BL; decrement again }
mov bl, dl
dec bl
cmp cl, $50 { see if we're in 80-column mode }
je @eighty_column
mul cx { multiply Y by the number of columns }
jmp @multiplied
@eighty_column: { 80-column mode: it may be faster to perform the }
mov cl, 4 { multiplication via shifts and adds: remember }
shl ax, cl { that 80d = 1010000b , so one can SHL 4, copy }
mov dx, ax { the result to DX, SHL 2, and add DX in. }
mov cl, 2
shl ax, cl
add ax, dx
@multiplied:
add ax, bx { add X in }
shl ax, 1 { multiply by 2 to get offset into video segment }
mov di, ax { video pointer is in DI }
lea si, s { string pointer is in SI }
SEGSS lodsb
cmp al, 00h { if zero-length string, jump to end }
je @done
mov cl, al
xor ch, ch { string length is in CX }
pop es { get video segment back from stack; put in ES }
pop ax { get color back from stack; put in AX (AH = color) }
@write_loop:
SEGSS lodsb { get character to write }
mov es:[di], ax { write AX to video memory }
inc di { increment video pointer }
inc di
loop @write_loop { if CX > 0, go back to top of loop }
@done: { end }
End;
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure TextFlow(Col, Row :Integer; Msg: String; Speed: Integer; Center : Boolean);
{Text Fading coded by Mark Larson (Valacar) on 03-23-95 }
{Orginally coded in QuickBasic (yuck!) when I was in SWX }
{Idea from OEW's iLL-demo.exe }
Var TextLen, x, i : Integer;
Colour : Byte;
ac : array[1..80] of char;
Begin {Procedure}
If Center Then Col := 40 - Length(Msg) div 2;
Msg := Msg + ' ';
TextLen := Length(Msg);
For x := 1 to TextLen Do
ac[x] := Msg[x];
i := 0;
Repeat
For x := 1 TO 3 Do Begin
Case x of
1 : Colour := 15;
2 : Colour := 07;
3 : Colour := 08;
End;
Qwrite((x + i) + Col - 1, Row, ac[x + i], Colour, 0);
WaitRetrace;
Delay(Speed);
End;
inc(i);
Until i = TextLen - 2;
End; {Procedure}
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure Sound (Hertz : Word);Assembler;
Asm
Mov Bx,SP
Mov Bx,&Hertz
Mov Ax,34DDh
Mov Dx,0012h
CMP Dx,Bx
JNB @J1
Div Bx
Mov Bx,Ax
In Al,61h
Test Al,03h
JNZ @J2
OR Al,03h
OUT 61h,Al
Mov Al,-4Ah
OUT 43h,Al
@J2:
Mov Al,Bl
OUT 42h,Al
Mov Al,Bh
Out 42h,Al
@J1:
End; {Sound}
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure NoSound; Assembler;
Asm
IN AL,61h
AND AL,0FCh
OUT 61h,AL
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure SaveTextScreen(filename: String);
Type
T_Screen = array[0..3999] of byte;
Var
Screen : T_Screen absolute $B800:0000;
F : File;
Begin
Assign(F, filename);
Rewrite(F,1);
BlockWrite(F,Screen,SizeOf(Screen));
Close(F);
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
Procedure LoadTextScreen(filename: String);
Type
T_Screen = array[0..3999] of byte;
Var
Screen : T_Screen absolute $B800:0000;
F : File;
Begin
Assign(F, filename);
Reset(F,1);
BlockRead(F,Screen,SizeOf(Screen));
Close(F);
End;
(*x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞x∞*)
End.