Category : Modula II Source Code
Archive   : STDLIB.ZIP
Filename : TERMIO.MOD

IMPLEMENTATION MODULE TermIO;

FROM SYSTEM IMPORT
Registers,Seg,Ofs;
FROM AsmLib IMPORT
Intr,Dos;
FROM Bytes IMPORT
Move,Fill;
FROM Words IMPORT
FillWord;
FROM Keyboard IMPORT
ControlKeys,ControlKeyTyped;
IMPORT Keyboard;

TYPE switch=(off,on);

PIXEL=RECORD
ch:CHAR;
attr:CHAR;
END;

LINE=RECORD
line:ARRAY[0..79] OF PIXEL;
END;

VAR curscount:CARDINAL;
SnowCheck:BOOLEAN;
Regs:Registers;
screen:POINTER TO ARRAY[0..24] OF LINE;
blankpixel:PIXEL;
blankline:LINE;

(*................................................*)

PROCEDURE GotoXY(x,y:CARDINAL);
BEGIN
IF x>=scrwidth THEN x:=scrwidth-1 END;
IF y>=scrheight THEN y:=scrheight-1 END;
curx:=x; cury:=y;
INC(x,origx); INC(y,origy);
Regs.DL := SHORTCARD(x);
Regs.DH := SHORTCARD(y);
Regs.BX := 0;
Regs.AH := 2;
Intr(Regs,10H); (* BIOS call to position cursor *)
END GotoXY;

(*................................................*)

PROCEDURE SetAttribute(chattr:AttrSet); (* for mono displays *)

VAR i:CARDINAL;
mask:BITSET;
ma:MonoAttributes;

BEGIN
CurrentAttribute := chattr;
mask:={};
FOR ma:=Bold TO Blink DO
IF ma IN chattr THEN INCL(mask,ORD(ma)) END;
END;
CASE CARDINAL(mask) OF

0:AttrByte:=CHR(7); (* normal *)
| 1:AttrByte:=CHR(0FH); (* bold *)
| 2:AttrByte:=CHR(1); (* underline *)
| 3:AttrByte:=CHR(9); (* bold,underline *)
| 4:AttrByte:=CHR(70H); (* reverse *)
| 5:AttrByte:=CHR(70H); (* bold, reverse *)
| 6:AttrByte:=CHR(70H); (* reverse, underline - wont work on IBM *)
| 7:AttrByte:=CHR(70H); (* reverse, underline, bold - wont work *)
| 8:AttrByte:=CHR(87H); (* blink *)
| 9:AttrByte:=CHR(8FH); (* bold, blink *)
| 10:AttrByte:=CHR(81H); (* blink, underline *)
| 11:AttrByte:=CHR(89H); (* blink, underline, bold *)
| 12:AttrByte:=CHR(0F0H);(* blinking, reverse video *)
| 13:AttrByte:=CHR(0F0H);(* blink, reverse, bold *)
| 14:AttrByte:=CHR(0F0H);(* same as 12 - IBM restriction *)
| 15:AttrByte:=CHR(0F0H) (* same as 13 - IBM restriction *)

END; (* CASES *)
blankpixel.attr:=AttrByte;
FillWord(ADR(blankline),80,blankpixel);
END SetAttribute;

(*....................................................*)

PROCEDURE SetColour(bgnd,fgnd:Colours);

VAR i:CARDINAL;

BEGIN
AttrByte := CHR(ORD(bgnd)*16+ORD(fgnd));
CurrentFgnd := fgnd;
CurrentBgnd := bgnd;
blankpixel.attr:=AttrByte;
WITH blankline DO
FOR i:=0 TO 79 DO line[i].attr:=AttrByte END;
END;
END SetColour;

(*....................................................*)

PROCEDURE SetCursor(onoff:switch);
BEGIN
(* turn cursor on or off *)
IF onoff=on THEN
IF DisplayType=ColourDisplay THEN Regs.CL:=7 ELSE Regs.CL:=13 END;
Regs.CH := Regs.CL-1
ELSE
Regs.CH := 32;
Regs.CL := 32;
END;
Regs.AH := 1; (* BIOS call to change cursor *)
Intr(Regs,10H);
END SetCursor;


(*.......................................*)

PROCEDURE EraseToEol(x,y:CARDINAL);

VAR chrs,attr:CARDINAL;

BEGIN
GotoXY(x,y);
x := curx;
chrs:=(scrwidth-x)-1; attr:=ORD(AttrByte);
IF chrs>0 THEN
Regs.AX := 0920H;
Regs.CX := chrs;
Regs.BX := attr;
Intr(Regs,10H); (* Write blanks to the display *)
END;
END EraseToEol;

(*.......................................*)

PROCEDURE Scroll(ulx,uly,lrx,lry:CARDINAL; lines:INTEGER);
BEGIN
IF lines>=0 THEN
Regs.AX := 0600H+CARDINAL(lines)
ELSE
Regs.AX := 0700H+CARDINAL(ABS(lines));
END;
Regs.BX := ORD(AttrByte)*256;
Regs.CX := uly*256+ulx;
Regs.DX := lry*256+lrx;
Intr(Regs,10H);
END Scroll;


(*.......................................*)

PROCEDURE EraseToEos(x,y:CARDINAL);
BEGIN
EraseToEol(x,y);
IF scrheight > y+1 THEN
Scroll(origx,origy+y+1,origx+scrwidth-1,origy+scrheight-1,0);
END;
END EraseToEos;

(*.......................................*)

PROCEDURE Crt(action:CrtCommands);

VAR y:CARDINAL;

BEGIN
CASE action OF

EraseEOS:EraseToEos(curx,cury);
| EraseEOL:EraseToEol(curx,cury);
| ClearCurrLine:GotoXY(0,cury);
EraseToEol(curx,cury);
| ClearScreen:Scroll(origx,origy,origx+scrwidth-1,
origy+scrheight-1,0);
GotoXY(0,0);
| UpCursor:IF cury>0 THEN GotoXY(curx,cury-1); END;
| DownCursor:IF cury | LeftCursor:IF curx>0 THEN GotoXY(curx-1,cury); END;
| RightCursor:IF curx | HomeCursor:GotoXY(0,0);
| EnableCursor:IF curscount>0 THEN
DEC(curscount);
IF curscount=0 THEN SetCursor(on) END;
END
| DisableCursor:IF curscount=0 THEN SetCursor(off) END;
INC(curscount);
| InsertLine:Scroll(origx,origy+cury,origx+scrwidth-1,
origy+scrheight-1,-1);
| DeleteLine:Scroll(origx,origy+cury,origx+scrwidth-1,
origy+scrheight-1,1)

END; (* cases *)
END Crt;

(*....................................................*)

TYPE CODE = ARRAY[0..42] OF SHORTCARD;
WordArray = ARRAY[0..0FFFH] OF WORD;

CONST PokeCode = CODE(01EH, (* PUSH DS *)
056H, (* PUSH SI *)
006H, (* PUSH ES *)
057H, (* PUSH DI *)
0FCH,
0B8H,000H,000H, (* MOV AX,0 *)
08EH,0D8H, (* MOV DS,AX *)
0FCH,
0BEH,000H,000H, (* MOV SI,0 *)
0FCH,
0B8H,000H,000H, (* MOV AX,0 *)
08EH,0C0H, (* MOV ES,AX *)
0FCH,
0BFH,000H,000H, (* MOV DI,0 *)
0BAH,0DAH,003H, (* MOV DX,03DAH *)
0ECH, (* $1 IN AL,DX *)
0A8H,001H, (* TEST AL,1 *)
075H,0FBH, (* JNZ $1 *)
0ECH, (* $2 IN AL,DX *)
0A8H,001H, (* TEST AL,1 *)
074H,0FBH, (* JZ $2 *)
0A5H, (* MOVSW *)
05FH, (* POP DI *)
007H, (* POP ES *)
05EH, (* POP SI *)
01FH, (* POP DS *)
0CBH); (* RETL *)

PROCEDURE MoveChar(VAR source,dest:PIXEL);

VAR wp:POINTER TO WordArray;
p:PROC;

BEGIN
p := PROC(ADR(PokeCode));
wp := ADR(PokeCode);
wp^[3] := Seg(source);
wp^[6] := Ofs(source);
wp^[8] := Seg(dest);
wp^[11] := Ofs(dest);
p();
END MoveChar;

(*....................................................*)

PROCEDURE Write(c:CHAR);

VAR loc:PIXEL;
addr:ADDRESS;

BEGIN
IF c=CHR(13) THEN
GotoXY(0,cury)
ELSIF c=CHR(10) THEN
WriteLn
ELSIF c=CHR(8) THEN
IF curx>0 THEN GotoXY(curx-1,cury) END
ELSIF c=CHR(7) THEN
Regs.AH:=06H;
Regs.DL:=07H;
Dos(Regs)
ELSE
IF SnowCheck THEN
loc.ch:=c;
loc.attr:=AttrByte;
MoveChar(loc,screen^[origy+cury].line[origx+curx])
ELSE
WITH screen^[origy+cury].line[origx+curx] DO
ch:=c; attr:=AttrByte;
END
END;
GotoXY(curx+1,cury);
END;
END Write;

(*....................................................*)

PROCEDURE WriteString(s:ARRAY OF CHAR);

VAR c:CHAR;
loc:PIXEL;
absx,i:CARDINAL;

BEGIN
absx:=curx+origx;
WITH screen^[origy+cury] DO
LOOP
FOR i:=0 TO HIGH(s) DO
c:=s[i];
IF c=0C THEN EXIT END;
IF (c>=' ') AND (c<='~') THEN
IF SnowCheck THEN
loc.ch:=c;
loc.attr:=AttrByte;
MoveChar(loc,line[absx]);
ELSE
WITH line[absx] DO
ch:=c; attr:=AttrByte;
END
END;
IF curx=scrwidth-1 THEN EXIT END;
INC(curx); INC(absx)
ELSE
Write(c);
END;
END;
EXIT;
END;
END;
GotoXY(curx,cury);
END WriteString;

(*....................................................*)

PROCEDURE WriteLn;

VAR i:CARDINAL;

BEGIN
IF cury=scrheight-1 THEN
IF scrheight=1 THEN
EraseToEol(0,0)
ELSE
Scroll(origx,origy,origx+scrwidth-1,origy+scrheight-1,1);
END
ELSE
INC(cury);
END;
GotoXY(0,cury);
END WriteLn;

(*....................................................*)

PROCEDURE Read(VAR ch:CHAR);
BEGIN
Keyboard.Read(ch);
END Read;

(*....................................................*)

PROCEDURE ReadString(VAR s:ARRAY OF CHAR);

VAR Ch:CHAR;
Showit:BOOLEAN;
cx,x,y,Lnth,Max:CARDINAL;

BEGIN
Max:=HIGH(s)+1; x:=curx; y:=cury; Lnth:=0; cx:=0;
Fill(ADR(s),Max,' ');
Showit := FALSE;
REPEAT
IF Showit THEN
GotoXY(x,y); WriteString(s);
Showit := FALSE;
END;
IF cx>Lnth THEN cx:=Lnth END;
GotoXY(x+cx,y);
Keyboard.Read(Ch);
CASE ControlKeyTyped OF

NotRecognised:IF (Ch>=' ') AND (Ch<='~') AND (cx IF cx Showit := TRUE;
Move(ADR(s[cx]),ADR(s[cx+1]),Max-cx-1)
ELSE
Write(Ch)
END;
INC(Lnth);
s[cx] := Ch;
INC(cx);
END;
| CursorLeft:IF cx>0 THEN DEC(cx) END;
| CursorRight:IF cx | HomeKey:cx:=0;
| EndKey:cx:=Lnth;
| Del,
DeleteKey:IF cx Showit := TRUE;
Move(ADR(s[cx+1]),ADR(s[cx]),Max-cx-1);
s[Max-1] := ' ';
DEC(Lnth);
END;
| BackSpace:IF cx>0 THEN
Showit := TRUE;
DEC(cx);
Move(ADR(s[cx+1]),ADR(s[cx]),Max-cx-1);
s[Max-1] := ' ';
DEC(Lnth);
END

ELSE
END; (* cases *)
UNTIL Ch = CHR(13);
s[Lnth] := 0C;
END ReadString;

(*.........................................................*)

PROCEDURE SetScrollRegion(newx,newy,newwidth,newheight:CARDINAL);
BEGIN
IF (newx+newwidth<=80) AND (newy+newheight<=25) THEN
origx:=newx; origy:=newy; scrwidth:=newwidth; scrheight:=newheight;
END;
END SetScrollRegion;

(*....................................................*)

PROCEDURE InitTermIOVars;

VAR mode:CHAR;
i,cpos:CARDINAL;
SnowStr:ARRAY[0..12] OF CHAR;

BEGIN
(* Get display mode and set default attribute *)
Regs.AH := 15;
Intr(Regs,10H);
mode := CHAR(Regs.AL);
IF mode=CHR(7) THEN
DisplayType:=Monochrome;
screen := [0B000H:0];
SetAttribute(AttrSet({}))
ELSE
DisplayType:=ColourDisplay;
screen := [0B800H:0];
SetColour(Black,LightGray);
END;
blankpixel.ch := ' ';
FillWord(ADR(blankline),80,blankpixel);
SnowStr := 'SNOWCHECK=Y'; (* this may be patched by a Config prog. *)
SnowCheck := (SnowStr[10]='Y');

(* get current cursor pos & set curx/cury *)
Regs.BX := 0;
Regs.AH := 3;
Intr(Regs,10H);
cpos := Regs.DX;
cury:=cpos DIV 256;
curx:=cpos MOD 256;

(* set default scrolling region *)
SetScrollRegion(0,0,80,25);

curscount:=0;
END InitTermIOVars;

(*....................................................*)

BEGIN
InitTermIOVars;
END TermIO.