home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
BEEHIVE
/
UTILITYS
/
FNTM2-11.ARK
/
SCRH.INC
< prev
next >
Wrap
Text File
|
1989-09-27
|
7KB
|
230 lines
{this module needs to have defined several globals :
TYPES:
str80 = string [80]
VARS:
scrn_x (integer)
scrn_y (integer)
scrn_attr (byte)
scrn_color (byte)
use_pcg (boolean)
colour (boolean)
premium (boolean)
In this module there are the following procedures:
Determine Interrogates hardware to see if the program is running
on a colour/premium or not!
SetPcg(x) selects pcg bank x and sets print routines to
subsequently use that bank.
SetColor(x) sets the text colour to x.
PutCurs(x,y) puts the cursor at row y column x with the origin
being 1,1.
PutCursor puts the cursor at the current print location.
PutAt(x,y) sets the current print location to x,y (origin 1,1)
and places the cursor there.
SetCursor(x) sets the cursor to be (11-x) scan lines high.
adding 64 sets the flash rate to speed 1, 64+32 uses
speed 2. Illegal values (i.e. not in the range 0..10
with(out) attribute bytes) switch the cursor off.
ZapCursor trashes the cursor. Same effect as SetCursor with an
illegal value.
Use(str) Sets text attributes. uppercase sets, lower case
resets. 'F'- flashing. 'P'- use PCG.
PutChar(x,y) Puts character y at address x. Also sets attributes
and colour. Address X should be a proper screen
address (i.e. in[$F000..$F7FF]) if you want the
character to display.
Cls Clears screen in current colour and attribute type.
Print(str) Prints string in current colour and attribute type at
current cursor position. Updates cursor position.
PrintLn(str) Same as print except relocates cursor to the start of
the next line.
Edit(var:str,x) Edits the passed string at the current cursor
position. Has nasty effects on the current cursor
location, but can be fixed with a simple PutCursor.
As a var parameter is used, then string constants
can't be passed as arguments. x is a boolean. If x is
true, then the editing cursor is placed at the end of
the passed string, else at the beginning.
}
procedure determine;
var
old:byte;
begin
colour:=false; premium:=false;
old:=mem[$ffff];
port[8]:=$40;
mem[$ffff]:=0;
port[8]:=0;
if mem[$ffff]<>0 then colour:=true;
mem[$ffff]:=old;
old:=mem[$f000];
mem[$f000]:=$20;
port[$1c]:=$90; {bank in attribute ram}
mem[$f000]:=$0;
port[$1c]:=$80;
if mem[$f000]<>0 then premium:=true;
mem[$f000]:=old;
end;
procedure setpcg (set_p: byte);
{banks in pcg and makes print routines use it}
begin
scrn_attr := (scrn_attr and $0f0) or (set_p and $0f);
port [$1c] := $80 or (set_p and $0f);
end;
procedure setcolor (i:byte);
begin
scrn_color := i;
end;
procedure putcurs (x,y:integer);
var
temp: integer;
begin
temp := $2000+ (y-1)*80 + x -1;
port [$0c] := 14; port [$0d] := (temp div 256);
port [$0c] := 15; port [$0d] := (temp mod 256);
end;
procedure putcursor;
begin
putcurs (scrn_x+1,scrn_y+1);
end;
procedure putat(x,y:integer);
begin
scrn_x:=x-1; scrn_y:=y-1; putcursor;
end;
procedure setcursor (i:byte);
begin
port [$0c] := 10; port [$0d] := i;
end;
procedure zapcursor;
begin
setcursor (18);
end;
procedure use (txt: str80);
var
i:integer;
{send in 'P' to use pcgs, 'F' for flash on, 'p' for normal, 'f' for normal}
begin
for i:=1 to length (txt) do
begin
case txt[i] of
'P': use_pcg := TRUE;
'p': use_pcg := FALSE;
'F': scrn_attr := scrn_attr or $80;
'f': scrn_attr := scrn_attr and $7f;
end; {case}
end; {for}
end;
procedure putchar (i:integer;b:byte);
begin
mem[i] := b; {space}
port [$1c] := port[$1c] or $10; {bank in attribute}
if premium then mem[i] := scrn_attr;
port [$1c] := port[$1c] and $0ef;
port [8] := $40; {colour}
if colour then mem[i+2048] := scrn_color;
port [8] := $0bf;
end;
procedure cls;
var
i: integer;
begin
for i:=$f000 to $f000+80*24-1 do putchar(i,$20);
scrn_x := 0; scrn_y := 0; putcursor;
end;
procedure print (txt:str80);
var
i,j:integer;
b:byte;
begin
j:=$f000+scrn_y*80+scrn_x;
for i:=1 to length(txt) do
begin
b:=ord(txt[i]);
if use_pcg then b:=b xor $80;
putchar(i+j-1,b);
end;
scrn_x:=scrn_x+i;
if scrn_x>80 then
begin
scrn_x:=scrn_x-80; scrn_y:=scrn_y+1;
end;
putcursor;
end;
procedure println (txt:str80);
begin
print (txt);
scrn_y :=scrn_y+1; scrn_x:=0; putcursor;
end;
{this routine assumes that the cursor has already been placed where it
should be}
procedure edit(var text:str80;cursloc:boolean);
var
z: integer;
cursor,i: integer;
ch:char;
alpha: boolean;
begin
z:=$f000+(scrn_y)*80+scrn_x; {starting address}
if cursloc then cursor := length(text)+1 else cursor := 1;
alpha:=true;
setcursor(96);
repeat
begin
if alpha then
begin
if length(text)>0 then
for i:=1 to length(text) do putchar(z+i-1,ord(text[i]));
putchar (z+length(text),32); {blank the last character on the line}
alpha:=FALSE;
end;
putcurs (scrn_x+cursor,scrn_y+1); {put the cursor where it should be}
read (kbd,ch); {now what?}
case ch of
^S,#8 : if cursor>1 then cursor:=cursor-1;
^D : if cursor<length(text)+1 then cursor:=cursor+1;
^G : begin
if cursor<length (text)+1 then
begin
delete (text,cursor,1);
alpha:=true;
end;
end;
#127 : begin
if cursor>1 then
begin
delete (text,cursor-1,1);
cursor:=cursor-1; alpha:=true;
end;
end;
^Y : begin
for i:=1 to length (text) do putchar (z+i-1,32);
cursor :=1;
text:='';
end;
end; {case}
if ch in[' '..#126] then
begin
insert(ch,text,cursor);
alpha:=true; cursor:=cursor+1;
end;
end {repeat}
until ch=^M;
setcursor (11);
end; {procedure}