Category : Pascal Source Code
Archive   : TOOL-USE.ZIP
Filename : MINICRT.PAS

(*
* Copyright 1987, 1989 Samuel H. Smith; All rights reserved
*
* This is a component of the ProDoor System.
* Do not distribute modified versions without my permission.
* Do not remove or alter this notice or any other copyright notice.
* If you use this in your own program you must distribute source code.
* Do not use any of this in a commercial product.
*
*)

(*
* MiniCrt - simplified version of Borland's CRT unit.
* Does not EVER do direct video. The standard crt unit
* locks up multi-taskers with its direct video checking before
* the user program can turn it off.
*
* (3-1-89)
*
*)

{$i prodef.inc}

unit MiniCrt;

interface

uses
Dos;

var
stdout: text; {output through dos for ANSI compatibility}

function KeyPressed: Boolean;
function ReadKey: Char;

procedure Window(X1,Y1,X2,Y2: Byte); {only partial support}
procedure SetScrollPoint(Y2: Byte);
procedure FullScreen;

procedure GotoXY(X,Y: Byte);
function WhereX: Byte;
function WhereY: Byte;

procedure ClrScr;
procedure ClrEol;

procedure NormalVideo;
procedure LowVideo;
procedure ReverseVideo;
procedure BlinkVideo;

procedure push_bp; inline($55);
procedure pop_bp; inline($5D);


(* -------------------------------------------------------- *)
procedure ScrollUp;
{$F+} function ConFlush(var F: TextRec): integer; {$F-}
{$F+} function ConOutput(var F: TextRec): integer; {$F-}
{$F+} function ConOpen(var F: TextRec): Integer; {$F-}


(* -------------------------------------------------------- *)
implementation

const
window_y1 : byte = 1;
window_y2 : byte = 25;
TextAttr : byte = $07;
key_pending: char = #0;


procedure intr10(var reg: registers);
begin
push_bp;
intr($10,reg);
pop_bp;
end;


(* -------------------------------------------------------- *)
function ReadKey: Char;
var
reg: registers;
begin
if key_pending <> #0 then
begin
ReadKey := key_pending;
key_pending := #0;
exit;
end;

reg.ax := $0000; {wait for character}
intr($16,reg);
if reg.al = 0 then
key_pending := chr(reg.ah);

ReadKey := chr(reg.al);
end;


(* -------------------------------------------------------- *)
function KeyPressed: Boolean;
var
reg: registers;
begin
reg.ax := $0100; {check for character}
intr($16,reg);
KeyPressed := ((reg.flags and FZero) = 0) or (key_pending <> #0);
end;


(* -------------------------------------------------------- *)
procedure Window(X1,Y1,X2,Y2: Byte);
begin
window_y1 := y1;
window_y2 := y2;
end;

procedure FullScreen;
begin
window_y1 := 1;
window_y2 := 25;
end;

procedure SetScrollPoint(Y2: Byte);
begin
window_y1 := 1;
window_y2 := Y2;
end;


(* -------------------------------------------------------- *)
procedure GotoXY(X,Y: Byte);
var
reg: registers;
begin
reg.ah := 2; {set cursor position}
reg.bh := 0; {page}
reg.dh := y-1;
reg.dl := x-1;
intr10(reg);
end;


(* -------------------------------------------------------- *)
function WhereX: Byte;
var
reg: registers;
begin
reg.ah := 3;
reg.bh := 0;
intr10(reg);
WhereX := reg.dl+1;
end;

function WhereY: Byte;
var
reg: registers;
begin
reg.ah := 3;
reg.bh := 0;
intr10(reg);
WhereY := reg.dh+1;
end;


(* -------------------------------------------------------- *)
procedure ClrScr;
var
reg: registers;
begin
reg.ax := $0600; {scroll up, blank window}
reg.cx := 0; {upper left}
reg.dx := $194F; {line 24, col 79}
reg.bh := TextAttr;
intr10(reg);
GotoXY(1,1);
end;


(* -------------------------------------------------------- *)
procedure ClrEol;
var
reg: registers;
begin
reg.ax := $0600; {scroll up, blank window}
reg.ch := wherey-1;
reg.cl := wherex-1;
reg.dh := reg.ch;
reg.dl := 79; {lower column}
reg.bh := TextAttr;
intr10(reg);
end;


(* -------------------------------------------------------- *)
procedure NormalVideo;
begin
TextAttr := $0F;
end;

procedure LowVideo;
begin
TextAttr := $07;
end;

procedure ReverseVideo;
begin
TextAttr := $70;
end;

procedure BlinkVideo;
begin
TextAttr := $F0;
end;


(* -------------------------------------------------------- *)
procedure ScrollUp;
var
reg: registers;
begin
reg.ah := 6; {scroll up}
reg.al := 1; {lines}
reg.cx := 0; {upper left}
reg.dh := window_y2-1; {lower line}
reg.dl := 79; {lower column}
reg.bh := TextAttr;
intr10(reg);
end;


(* -------------------------------------------------------- *)
{$F+} function ConFlush(var F: TextRec): integer; {$F-}
var
P: Word;
reg: registers;
x,y: byte;

begin
{get present cursor position}
reg.ah := 3;
reg.bh := 0;
intr10(reg);
y := reg.dh+1;
x := reg.dl+1;

{process each character in the buffer}
P := 0;
while P < F.BufPos do
begin
reg.al := ord(F.BufPtr^[P]);

case reg.al of
7: {$i-} write(stdout,chr(reg.al)); {$i+}

8: if x > 1 then {backspace}
dec(x);

9: x := (x+8) and $F8; {tab}

10: if y {>}= window_y2 then {scroll when needed}
ScrollUp
else
inc(y);

13: x := 1; {c/r}

else
begin
reg.ah := 9; {display character with TextAttr}
reg.bx := 0; {... does not move the cursor}
reg.cx := 1;
reg.bl := TextAttr;
intr10(reg);

if x = 80 then {line wrap?}
begin
x := 1;
if y >= window_y2 then {scroll during wrap?}
ScrollUp
else
inc(y);
end
else
inc(x);
end;
end;

{position physical cursor}
reg.ah := 2; {set cursor position}
reg.bh := 0; {page}
reg.dh := y-1;
reg.dl := x-1;
intr10(reg);

inc(P);
end;

F.BufPos:=0;
ConFlush := 0;
end;


{$F+} function ConOutput(var F: TextRec): integer; {$F-}
begin
ConOutput := ConFlush(F);
end;


{$F+} function ConOpen(var F: TextRec): Integer; {$F-}
begin
F.InOutFunc := @ConOutput;
F.FlushFunc := @ConFlush;
F.CloseFunc := @ConFlush;
F.BufPos := 0;
ConOpen := 0;
end;


(* -------------------------------------------------------- *)
var
e: integer;

begin
with TextRec(output) do
begin
BufPos := 0;
InOutFunc := @ConOutput;
FlushFunc := @ConFlush;
OpenFunc := @ConOpen;
end;

{$i-}
assign(stdout,'');
rewrite(stdout);
{$i+}
end.