Category : Modula II Source Code
Archive   : MLIFE.ZIP
Filename : IBMSCR.MOD

 
Output of file : IBMSCR.MOD contained in archive : MLIFE.ZIP
IMPLEMENTATION MODULE IBMSCR;
(*
Title : IBMSCR.MOD

Author : Randall A. Maddox
12209 M Peach Crest Drive
Germantown, MD 20874
(301) 428-9581

System : LOGITECH MODULA-2, Rel. 3.00, AUGUST 1987

Description: This module contains several screen-handling procedures for
the IBM PC/XT/AT and compatible computers. These procedures use the
ROM BIOS video driver services, so compatibility to this level is a MUST!
They have been tested on both the IBM ROM BIOS and the Phoenix ROM BIOS.
Results with a ROM BIOS that is less than 100% compatible are unpredictable.
For further reference on ROM BIOS services see "Advanced MSDOS", Ray Duncan,
1986, Microsoft Press, Redmond, WA. This is where I got my information.

The only restriction on use or distribution of this code is the stipulation
that as the original author my name not be removed from the text of
IBMSCR.DEF or IBMSCR.MOD.

The procedures fall into the following categories:
1) Cursor handling -
PosCur - position the cursor to text coordinates
GetCur - return text coordinates and size of cursor
SetCurTyp - set cursor type
CurOff - hide the cursor
CurOn - restore the cursor
CurShown - return TRUE if cursor NOT hidden, FALSE otherwise
2) Read/write -
ReadCh - read character without echo from standard input
RdStr - read string with echo from standard input
ChAtCur - return character and attribute at cursor
GetFromScr - read characters from specified area of screen
WrtStr - write null-terminated string at current cursor position
WrtXY - write null-terminated string with attribute at X,Y
WNWrtXY - write embedded-null string with attribute at X,Y
WrtLst - write string to standard list device (printer)
PutToScr - write array of CHAR to box on screen with attribute
ClrScr - clear entire screen and home cursor (if shown)
Beep - sound a distinctive beep
3) Window handling -
MkBox - put box around window
ClrBox - clear a window
GetScr - save contents of a window
PutScr - restore saved contents of window
ScrUp - scroll window up
ScrDn - scroll windown down
4) Check/set video display mode and page -
GetMode - return current display mode, columns, and video page
SetMode - set current display mode
SetPage - set current video page

Together, these procedures allow a simple window approach to screen
management that is very flexible and fast. All the PC/XT/AT video modes
are supported to some degree with restrictions as noted below.

Update History:
Originally written: 8/16/87
Added CurHid flag, GetScr and PutScr procedures: 8/25/87
Added CurOn procedure: 10/21/87
Moved initialization to module body: 10/21/87
Added CurShown procedure: 10/27/87
Added WNWrtXY procedure: 12/27/87
Added PutToScr procedure: 12/30/87
Added GetFromScr procedure, updated for 3.0 compiler: 1/2/88
Added Beep procedure: 1/6/88
Added RdStr and WrtStr procedures: 11/24/88
Added WrtLst procedure: 11/26/88

*)

FROM Delay IMPORT
Delay;

FROM Sounds IMPORT
Sound,NoSound;

FROM Strings IMPORT
Length,Insert,Delete;

FROM SYSTEM IMPORT
AX,BX,CX,DX,DS,GETREG,SETREG,CODE,
SWI,BYTE,WORD,ADDRESS,ADR;

FROM Utility IMPORT
PushBX,PopBX,PushDX,PopDX,PushFL,PopFL,
PushBP,PopBP,LAHF,Dos,ErrMask,HiMask,LoMask;

TYPE
PAGESET = SET OF [0..7]; (* video display pages *)
ATTRSET = SET OF [0H..0F0H]; (* video display attributes *)
MODESET = SET OF [0..16]; (* video display modes *)

CONST
TxtMode = MODESET{0,1,2,3,7}; (* text display modes *)
GrphMode = MODESET{4,5,6,13,14,15,16}; (* graphics display modes *)
OKAttr = ATTRSET{1H,7H,9H,0FH,70H,87H,81H,89H,8FH,0F0H};
ROMvds = 10H; (* ROM video driver services interrupt *)

VAR
OKPage : PAGESET; (* valid pages in current display mode *)
CurPage : CARDINAL; (* current video page *)
CurCols : CARDINAL; (* current screen column width *)
CurMode : CARDINAL; (* current display mode *)
MaxX : COL; (* max column in current display mode *)
CurHid : BOOLEAN; (* true if cursor hidden *)
AXwd,BXwd,CXwd,DXwd,DSwd : WORD; (* CPU registers used *)


(* Procedure implementations follow *)

(******************************************************************************)

PROCEDURE PosCur(X : COL; Y : ROW;
VAR Err : CARDINAL);

(* Position cursor on current page to text coordinates X,Y.
Error codes returned are:
0 = no error
1 = invalid X coordinate
2 = cursor is hidden
3 = not page 0 in graphics mode
>> All display modes are supported. Must use Page = 0 in graphics
modes.
*)

BEGIN
IF (X > MaxX) THEN Err := 1
ELSIF (CurHid) THEN Err := 2
ELSIF ((NOT(CurMode IN TxtMode)) AND (CurPage <> 0)) THEN Err := 3
ELSE
Err := 0;
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD((Y * 100H) + X);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END PosCur;

(******************************************************************************)

PROCEDURE GetCur(VAR X : COL; VAR Y : ROW;
VAR Start : CARDINAL;
VAR End : CARDINAL;
VAR Err : CARDINAL);

(* Return current text coordinate position of cursor on active page,
and Start and End lines for that cursor.
Error codes returned are:
0 = no error
1 = cursor is currently hidden
>> All display modes are supported.
*)

BEGIN
IF (CurHid) THEN Err := 1
ELSE
Err := 0;
AXwd := WORD(0300H);
BXwd := WORD(CurPage * 100H);
SETREG(AX,AXwd); (* AH = 03H, get cursor position function *)
SETREG(BX,BXwd); (* BH = display page number *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP,PushDX); (* pop BP *)
GETREG(CX,CXwd); (* get the returned results *)
CODE(PopDX);
GETREG(DX,DXwd);
Y := CARDINAL(BITSET(DXwd) * HiMask) DIV 100H; (* DH *)
X := CARDINAL(BITSET(DXwd) * LoMask); (* DL *)
Start := CARDINAL(BITSET(CXwd) * HiMask) DIV 100H; (* CH *)
End := CARDINAL(BITSET(CXwd) * LoMask) (* CL *)
END (* IF *)
END GetCur;

(******************************************************************************)

PROCEDURE SetCurTyp(Start,End : CARDINAL;
VAR Err : CARDINAL);

(* Set cursor Start and End lines. Valid values are:
Start - 0 to 11 in display mode 07H
- 0 to 6 in other modes
End - 1 to 12 in display mode 07H
- 1 to 7 in other modes
Error codes returned are:
0 = no error
1 = invalid Start for current display mode
2 = invalid End for current display mode
3 = Start > End
4 = not in text mode
>> Only text modes can be supported.
*)

BEGIN
Err := 0;
IF (NOT(CurMode IN TxtMode)) THEN Err := 4
ELSIF (Start > End) THEN Err := 3
ELSIF (CurMode = 7) THEN
IF (Start > 11) THEN Err := 1
ELSIF (End > 12) THEN Err := 2 END;
ELSE (* CurMode IN {0,1,2,3} *)
IF (Start > 6) THEN Err := 1
ELSIF (End > 7) THEN Err := 2 END;
END;
IF (Err = 0) THEN
AXwd := WORD(0100H);
CXwd := WORD((Start * 100H) + End);
SETREG(AX,AXwd); (* AH = 01H, set cursor type function *)
SETREG(CX,CXwd); (* CH = start line, CL = end line *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END SetCurTyp;

(******************************************************************************)

PROCEDURE CurOff();

(* Turn off the cursor by moving it to a non-displayable location.
Cursor is restored by calling CurOn.
NOTE: Any other procedures that reposition the cursor during their
operation will restore the cursor to its hidden position when done.
No error codes are returned.
*)

BEGIN
IF ((CurMode IN TxtMode) OR (CurPage = 0)) THEN
(* otherwise, cursor is already not displayed *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(2500H);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END; (* IF *)
CurHid := TRUE; (* in any case, set the flag *)
END CurOff;

(******************************************************************************)

PROCEDURE CurOn();

(* Restore cursor by resetting CurHid flag. Cursor position is NOT
changed by this procedure.
No error codes are returned.
*)

BEGIN
CurHid := FALSE (* reset the flag *)
END CurOn;

(******************************************************************************)

PROCEDURE CurShown() : BOOLEAN;

(* Return TRUE if cursor is shown, and FALSE if cursor is hidden.
No error codes are returned.
*)

BEGIN
RETURN (NOT(CurHid))
END CurShown;

(******************************************************************************)

PROCEDURE ReadCh(VAR Ch : CHAR;
VAR Ascii : BOOLEAN);

(* Read one character from standard input with no echo. If no character
is available, wait until one is. If extended ASCII code is detected
(first char is 0) then the following character is read and returned.
The variable Ascii is FALSE if the value returned in Ch is extended
ASCII. The procedure uses DOS interrupt 21H function 0CH to clear the
input buffer and then function 07H, unfiltered character input without
echo. No special action is taken on Ctrl-C or Ctrl-Break. Input may
be redirected. No error codes are returned.
*)

BEGIN
Ascii := TRUE; (* initialize *)
AXwd := WORD(0C07H); (* AH = 0CH, reset input buffer then do input *)
SETREG(AX,AXwd); (* AL = 07H, unfiltered char input w/o echo *)
CODE(PushBP); (* push BP *)
SWI(Dos); (* call DOS *)
CODE(PopBP); (* pop BP *)
GETREG(AX,AXwd); (* recover result *)
Ch := CHR(CARDINAL(BITSET(AXwd) * LoMask)); (* = AL *)
IF (ORD(Ch) = 0) THEN (* get extended ASCII code *)
Ascii := FALSE;
AXwd := WORD(0700H);
SETREG(AX,AXwd); (* AH = 07H, unfiltered char input w/o echo *)
CODE(PushBP); (* push BP *)
SWI(Dos); (* call DOS *)
CODE(PopBP); (* pop BP *)
GETREG(AX,AXwd); (* recover result *)
Ch := CHR(CARDINAL(BITSET(AXwd) * LoMask)); (* = AL *)
END;
END ReadCh;

(******************************************************************************)

PROCEDURE RdStr(VAR Str : ARRAY OF CHAR);

(* Read string from standard input with echo, starting at current cursor
position. Editing characters during input are: BackSpace - if not on
first character of current input string move cursor one space left and
delete character there, Delete - delete character under cursor and move
any following characters one space left, Insert - insert single space
at current cursor position and move following characters one space
right dropping any characters that are pushed past the end of Str, Left
Arrow - move cursor one space left if not on first character of current
input string, Right Arrow - if not at last character of current input
string move cursor one space right, Enter/Return - terminate current
input. Terminating Enter/Return is not returned as part of string. All
characters past last entered prior to Enter/Return will be set to ASCII
null. Cursor is left at current position when terminating Enter/Return
is detected. The procedure uses DOS interrupt 21H function 0CH to clear
the input buffer and then function 07H, unfiltered character input
without echo to read each character. ROM BIOS Video Service, INT 10H
function 09H is used to echo each character, except for the terminating
Enter/Return, to the screen. No special action is taken on Ctrl-C or
Ctrl-Break. Input may be redirected. No error codes are returned.
*)

CONST
Nul = 000C; (* ASCII, Null character *)
BS = 010C; (* ASCII, BackSpace key *)
Ent = 015C; (* ASCII, Enter/Return key *)
LA = 113C; (* Extended ASCII, Left Arrow key *)
RA = 115C; (* Extended ASCII, Right Arrow key *)
Del = 123C; (* Extended ASCII, Delete key *)
Ins = 122C; (* Extended ASCII, Insert key *)

VAR
FirstX,LastX,CurX,Y,I : CARDINAL;
LastCh : INTEGER;
Ch : CHAR;
Ascii : BOOLEAN;

BEGIN
IF (NOT CurHid) AND (CurMode IN TxtMode) THEN
(* null out our string *)
FOR CurX := 0 TO HIGH(Str) DO
Str[CurX] := Nul
END; (* for *)
(* get current cursor position *)
AXwd := WORD(0300H);
BXwd := WORD(CurPage * 100H);
SETREG(AX,AXwd); (* AH = 03H, get cursor position function *)
SETREG(BX,BXwd); (* BH = display page number *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
GETREG(DX,DXwd);
(* initialize our other variables *)
Y := CARDINAL(BITSET(DXwd) * HiMask) DIV 100H; (* DH *)
FirstX := CARDINAL(BITSET(DXwd) * LoMask); (* DL *)
CurX := FirstX;
LastCh := -1;
LastX := FirstX + HIGH(Str);
IF (LastX > MaxX) THEN LastX := MaxX END; (* don't go past edge *)
(* start read string loop *)
LOOP
(* position the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD((Y * 100H) + CurX);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* read a character *)
Ascii := TRUE; (* initialize *)
AXwd := WORD(0C07H); (* AH = 0CH, reset input buffer then do input *)
SETREG(AX,AXwd); (* AL = 07H, unfiltered char input w/o echo *)
CODE(PushBP); (* push BP *)
SWI(Dos); (* call DOS *)
CODE(PopBP); (* pop BP *)
GETREG(AX,AXwd); (* recover result *)
Ch := CHR(CARDINAL(BITSET(AXwd) * LoMask)); (* = AL *)
IF (ORD(Ch) = 0) THEN (* get extended ASCII code *)
Ascii := FALSE;
AXwd := WORD(0700H);
SETREG(AX,AXwd); (* AH = 07H, unfiltered char input w/o echo *)
CODE(PushBP); (* push BP *)
SWI(Dos); (* call DOS *)
CODE(PopBP); (* pop BP *)
GETREG(AX,AXwd); (* recover result *)
Ch := CHR(CARDINAL(BITSET(AXwd) * LoMask)); (* = AL *)
END;
(* then decide what to do *)
IF (NOT Ascii) THEN (* may be Del, Ins, LA or RA *)
IF (Ch = Del) THEN (* delete current character *)
Delete(Str,CurX - FirstX,1);
IF (LastCh >= 0) THEN
LastCh := LastCh - 1
END;
WNWrtXY(FirstX,Y,Str,Norm,I)
ELSIF (Ch = Ins) THEN
Insert(' ',Str,CurX - FirstX);
IF ((VAL(INTEGER,FirstX) + LastCh) < VAL(INTEGER,LastX)) THEN
LastCh := LastCh + 1
END;
WrtXY(FirstX,Y,Str,Norm,I)
ELSIF (Ch = LA) THEN
IF (CurX > FirstX) THEN (* backup cursor *)
CurX := CurX - 1
END (* if *)
ELSIF (Ch = RA) THEN
IF (VAL(INTEGER,CurX) <= (VAL(INTEGER,FirstX) + LastCh))
AND (CurX < LastX) THEN (* advance cursor *)
CurX := CurX + 1
END (* if *)
ELSE (* append to string and echo to screen *)
Str[CurX - FirstX] := Ch;
IF (VAL(INTEGER,(CurX - FirstX)) > LastCh) THEN
LastCh := CurX - FirstX (* advance last char index *)
END; (* if *)
IF (CurX < LastX) THEN (* advance cursor *)
CurX := CurX + 1
END; (* if *)
AXwd := WORD(0900H + ORD(Ch));
BXwd := WORD((CurPage * 100H) + Norm);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* if *)
ELSE (* may be BS or Ent *)
IF (Ch = BS) THEN
IF (CurX > FirstX) THEN
CurX := CurX - 1;
END; (* if *)
Delete(Str,CurX - FirstX,1);
IF (LastCh >= 0) THEN
LastCh := LastCh - 1
END;
WNWrtXY(FirstX,Y,Str,Norm,I)
ELSIF (Ch = Ent) THEN (* all done *)
EXIT
ELSE (* append to string and echo to screen *)
Str[CurX - FirstX] := Ch;
IF (VAL(INTEGER,(CurX - FirstX)) > LastCh) THEN
LastCh := CurX - FirstX
END; (* if *)
IF (CurX < LastX) THEN (* advance cursor *)
CurX := CurX + 1
END; (* if *)
AXwd := WORD(0900H + ORD(Ch));
BXwd := WORD((CurPage * 100H) + Norm);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* if *)
END (* if *)
END (* loop *)
END (* if *)
END RdStr;

(******************************************************************************)

PROCEDURE ChAtCur(VAR Ch : CHAR;
VAR Attr : CARDINAL;
VAR Err : CARDINAL);

(* Return the character and attribute at current cursor position on
active display page.
Error codes returned are:
0 = no error
1 = cursor is not displayed
2 = not in Text mode
>> Only text modes are supported.
*)

BEGIN
IF CurHid THEN Err := 1
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 2
ELSE
Err := 0;
AXwd := WORD(0800H);
BXwd := WORD(CurPage * 100H);
SETREG(AX,AXwd); (* AH = 08H, read attribute and character function *)
SETREG(BX,BXwd); (* BH = page *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
GETREG(AX,AXwd); (* get returned results *)
Attr := CARDINAL(BITSET(AXwd) * HiMask) DIV 100H; (* AH *)
Ch := CHR(CARDINAL(BITSET(AXwd) * LoMask)); (* AL *)
END; (* IF *)
END ChAtCur;

(******************************************************************************)

PROCEDURE GetFromScr(ULX,LRX : COL; ULY,LRY : ROW;
VAR Scr : ARRAY OF BYTE;
VAR Err : CARDINAL);

(* Put into the Scr array what is the box specified by its upper left
and lower right corners. No attribute data is saved. Data is
from currently active screen page. The smallest box that may be
specified is one character, i.e., LRX = ULX and LRY = ULY.
Calling parameters are:
ULX - X-coordinate of upper left corner (0 to 78)
ULY - Y-coordinate of upper left coordinate (0 to 24)
LRX - X-coordinate of lower right corner (1 to 79)
LRY - Y-coordinate of lower right corner (1 to 25)
Scr - array of char to put screen data into
Error codes returned are:
0 = no error
1 = coordinates do not specify UL and LR corners of rectangle
2 = one or both X-coordinates out of range
3 = invalid display mode
4 = array not large enough to hold specified box
>> Only text display modes are supported.
*)

VAR
Row,Col,Chars,Indx : CARDINAL;


BEGIN
Chars := (ABS(LRX - ULX) + 1) * (ABS(LRY - ULY) + 1) - 1;
IF ((ULX > MaxX) OR (LRX > MaxX)) THEN Err := 2
ELSIF (LRX < ULX) OR (LRY < ULY) THEN Err := 1
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 3
ELSIF (HIGH(Scr) < Chars) THEN Err := 4
ELSE
Err := 0;
Indx := 0;
FOR Row := ULY TO LRY DO
FOR Col := ULX TO LRX DO
(* first position the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD((Row * 100H) + Col);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then read the character *)
AXwd := WORD(0800H);
BXwd := WORD(CurPage * 100H);
SETREG(AX,AXwd); (* AH = 08H, read attribute and char function *)
SETREG(BX,BXwd); (* BH = display page *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
GETREG(AX,AXwd); (* recover result *)
Scr[Indx] := VAL(BYTE,CARDINAL(BITSET(AXwd) * LoMask));(* AL *)
INC(Indx) (* and point to next *)
END (* FOR *)
END; (* FOR *)
IF (CurHid) THEN (* rehide cursor if off *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(2500H);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END (* IF *)
END GetFromScr;

(******************************************************************************)

PROCEDURE WrtStr(Str : ARRAY OF CHAR);

(* Write an arbitrary string of characters; starting at current cursor
position to current video display page. No automatic wraparound at
screen edge and no automatic scroll at screen bottom. Output redirection
is ignored. Special characters such as Carriage Return or Line Feed
are printed as just their character representations and do not perform
any special functions. Cursor is left at position immediately after
that of last character written. This procedure expects a null-
terminated string and will write out Str until the first null or until
the end of the array, whichever comes first.
No error codes are returned.
*)

VAR
Index,Col,X,Y,L : CARDINAL;

BEGIN
IF (NOT CurHid) AND (CurMode IN TxtMode) THEN
L := Length(Str);
IF (L > 0) THEN
(* get current cursor position *)
AXwd := WORD(0300H);
BXwd := WORD(CurPage * 100H);
SETREG(AX,AXwd); (* AH = 03H, get cursor position function *)
SETREG(BX,BXwd); (* BH = display page number *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
GETREG(DX,DXwd);
Y := CARDINAL(BITSET(DXwd) * HiMask) DIV 100H; (* DH *)
X := CARDINAL(BITSET(DXwd) * LoMask); (* DL *)
(* then write out the string *)
FOR Index := 0 TO L DO
(* first position the cursor *)
Col := X + Index;
IF (Col > MaxX) THEN Col := MaxX END; (* don't write past edge *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD((Y * 100H) + Col);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
IF (Index < L) THEN
(* write a character *)
AXwd := WORD(0900H + ORD(Str[Index]));
BXwd := WORD((CurPage * 100H) + Norm);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* if *)
END (* for *)
END (* if *)
END (* IF *)
END WrtStr;


(******************************************************************************)

PROCEDURE WrtXY(X : COL; Y : ROW;
Str : ARRAY OF CHAR;
Attr : ATTRTYP;
VAR Err : CARDINAL);

(* Write an arbitrary string of characters; starting at position X,Y;
with attribute Attr; to current video display page. No automatic
wraparound at screen edge and no automatic scroll at screen bottom.
Output redirection is ignored. Special characters such as Carriage
Return or Line Feed are printed as just their character representations
and do not perform any special functions. Cursor is left at position
of last character written, unless cursor is off. This procedure
expects a null-terminated string and will write out Str until the
first null or until the end of the array, whichever comes first.
Error codes returned are:
0 = no error
1 = invalid start column
2 = invalid attribute
3 = invalid display mode
>> Only text modes are supported.
*)

VAR
Index,Col : CARDINAL;

BEGIN
IF (X > MaxX) THEN Err := 1
ELSIF (NOT(Attr IN OKAttr)) THEN Err := 2
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 3
ELSE
Err := 0;
IF (Length(Str) > 0) THEN
FOR Index := 0 TO (Length(Str) - 1) DO
(* first position the cursor *)
Col := X + Index;
IF (Col > MaxX) THEN Col := MaxX END; (* don't try to write past edge *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD((Y * 100H) + Col);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then write a character *)
AXwd := WORD(0900H + ORD(Str[Index]));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* for *)
END; (* if *)
IF (CurHid) THEN (* rehide cursor if off *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(2500H);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END (* IF *)
END WrtXY;

(******************************************************************************)

PROCEDURE WNWrtXY(X : COL; Y : ROW;
Str : ARRAY OF CHAR;
Attr : ATTRTYP;
VAR Err : CARDINAL);

(* Write an arbitrary string of characters; starting at position X,Y;
with attribute Attr; to current video display page. No automatic
wraparound at screen edge and no automatic scroll at screen bottom.
Output redirection is ignored. Special characters such as Carriage
Return or Line Feed are printed as just their character representations
and do not perform any special functions. Cursor is left at position
of last character written, unless cursor is off. This procedure will
always write out all characters from Str[0] through and including
Str[HIGH(Str)] whether or not any null characters are present in
the string.
Error codes returned are:
0 = no error
1 = invalid start column
2 = invalid attribute
3 = invalid display mode
>> Only text modes are supported.
*)

VAR
Index,Col : CARDINAL;

BEGIN
IF (X > MaxX) THEN Err := 1
ELSIF (NOT(Attr IN OKAttr)) THEN Err := 2
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 3
ELSE
Err := 0;
FOR Index := 0 TO HIGH(Str) DO
(* first position the cursor *)
Col := X + Index;
IF (Col > MaxX) THEN Col := MaxX END; (* don't try to write past edge *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD((Y * 100H) + Col);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then write a character *)
AXwd := WORD(0900H + ORD(Str[Index]));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END; (* for *);
IF (CurHid) THEN (* rehide cursor if off *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(2500H);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END (* IF *)
END WNWrtXY;

(******************************************************************************)

PROCEDURE WrtLst(Str : ARRAY OF CHAR; VAR Err : CARDINAL);

(* This procedure writes out Str to the current DOS standard list device.
Error codes returned are:
0 = no error
1 = incomplete output
2 = Carry Flag set by DOS
*)

VAR
StrAdr : ADDRESS;
Len,Chars : CARDINAL;

BEGIN
Err := 0; (* no error yet *)
StrAdr := ADR(Str);
Len := Length(Str);
AXwd := WORD(4000H); (* AH = 40H = write to device *)
BXwd := WORD(0004H); (* BL = 04H = handle for standard list device *)
CXwd := WORD(Len); (* CX = length of string *)
DSwd := WORD(StrAdr.SEGMENT); (* DS:DX points to string *)
DXwd := WORD(StrAdr.OFFSET);
SETREG(AX,AXwd); (* set our registers *)
SETREG(BX,BXwd);
SETREG(CX,CXwd);
SETREG(DS,DSwd);
SETREG(DX,DXwd);
CODE(PushBP);
SWI(Dos); (* call DOS *)
CODE(PopBP,PushFL); (* save Flags register *)
GETREG(AX,Chars); (* AX = number of characters actually transferred *)
CODE(PopFL,LAHF); (* get flags back and put in AH *)
GETREG(AX,AXwd); (* recover AX register with Flags *)
Err := CARDINAL(BITSET(AXwd) * ErrMask); (* test for Carry Flag set *)
IF (Err > 0) THEN (* Carry Flag set by DOS *)
Err := 2
ELSIF (Chars < Len) THEN (* output incomplete *)
Err := 1
END (* if *)
END WrtLst;

(******************************************************************************)

PROCEDURE PutToScr(ULX,LRX : COL; ULY,LRY : ROW;
VAR Scr : ARRAY OF BYTE;
Attr : ATTRTYP;
VAR Err : CARDINAL);

(* Put what is in the Scr array into the box specified by its upper left
and lower right corners, each character having the display attribute
Attr. Output is to currently active screen page. The smallest box
that may be specified is one character, i.e., LRX = ULX and
LRY = ULY.
Calling parameters are:
ULX - X-coordinate of upper left corner (0 to 78)
ULY - Y-coordinate of upper left coordinate (0 to 24)
LRX - X-coordinate of lower right corner (1 to 79)
LRY - Y-coordinate of lower right corner (1 to 25)
Scr - array of char to put to screen
Attr - one of the exported display attribute values
Error codes returned are:
0 = no error
1 = coordinates do not specify UL and LR corners of rectangle
2 = one or both X-coordinates out of range
3 = invalid display attribute
4 = invalid display mode
5 = array not large enough to fill specified box
>> Only text display modes are supported.
*)

VAR
Row,Col,Chars,Indx : CARDINAL;

BEGIN
Chars := (ABS(LRX - ULX) + 1) * (ABS(LRY - ULY) + 1) - 1;
IF ((ULX > MaxX) OR (LRX > MaxX)) THEN Err := 2
ELSIF (LRX < ULX) OR (LRY < ULY) THEN Err := 1
ELSIF (NOT(Attr IN OKAttr)) THEN Err := 3
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 4
ELSIF (HIGH(Scr) < Chars) THEN Err := 5
ELSE
Err := 0;
Indx := 0;
FOR Row := ULY TO LRY DO
FOR Col := ULX TO LRX DO
(* first position the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD((Row * 100H) + Col);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then write the character and attribute *)
AXwd := WORD(0900H + ORD(Scr[Indx]));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
INC(Indx) (* and point to next *)
END (* FOR *)
END; (* FOR *)
IF (CurHid) THEN (* rehide cursor if off *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(2500H);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END (* IF *)
END PutToScr;

(******************************************************************************)

PROCEDURE ClrScr();

(* Clear the currently active display page and home the cursor. Cursor
can only be homed in text modes or page 0 of graphics modes. Cursor
will not be homed if it is hidden.
No error codes are returned.
>> All display modes are supported.
*)

BEGIN
(* first clear the screen *)
AXwd := WORD(0600H);
BXwd := WORD(Norm * 100H);
CXwd := WORD(0);
DXwd := WORD(2500H + MaxX);
SETREG(AX,AXwd); (* AH = 06H, initialize window or scroll up,
AL = 0 -> blank the entire window *)
SETREG(BX,BXwd); (* BH = attribute of blank area *)
SETREG(CX,CXwd); (* CH = column, CL = row, for upper left corner *)
SETREG(DX,DXwd); (* DH = column, DL = row, for lower right corner *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then home the cursor, if we can *)
IF ((NOT(CurHid)) AND ((CurMode IN TxtMode) OR (CurPage = 0))) THEN
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(0000H);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END
END ClrScr;

(****************************************************************************)

PROCEDURE Beep(Count : CARDINAL);

(* Make distinctive sounding beep Count times.
*)

VAR
I : CARDINAL;

BEGIN
FOR I := 1 TO Count DO
Sound(650);
Delay(55);
Sound(450);
Delay(35);
NoSound
END (* for *)
END Beep; (* procedure *)

(******************************************************************************)

PROCEDURE MkBox(X : COL; Y : ROW;
Attr : ATTRTYP;
BType : BOXTYP;
Width,Height : CARDINAL;
VAR Err : CARDINAL);

(* Draw a box with all four corners on current display page. Output
redirection is ignored. Cursor is left at bottom of right side of box,
unless the cursor is hidden. The smallest box that may be drawn will
have a width and height of 3. This allows for each corner and one
side/top/bottom line per side. One character may be placed into this
smallest box.
The calling parameters are:
X - x-coordinate of upper left corner, 0 to 77
Y - y-coordinate of upper left corner, 0 to 23
Width - width of box in columns, 3 to 80
Height - height of box in rows, 3 to 26
Attr - display attribute to use
BType - type of box to draw. Possibilities are:
0 = use ASCII space for box characters
1 = draw single line box
2 = draw double line box
3 = draw box with single line sides and double
line top and bottom
4 = draw box using +, - and |
Error codes returned are:
0 = no error
1 = invalid X coordinate
2 = invalid Y coordinate
3 = invalid height
4 = invalid width
5 = invalid attribute
6 = not in Text mode
>> Only text display modes are supported.
*)

VAR
ul,ur,ll,lr,bt,sd : CHAR; (* box characters *)
I : CARDINAL;

BEGIN
IF (X > 77) THEN Err := 1
ELSIF (Y > 23) THEN Err := 2
ELSIF (((Y + (Height - 1)) > 25) OR (Height < 3)) THEN Err := 3
ELSIF (((X + (Width - 1)) > MaxX) OR (Width < 3)) THEN Err := 4
ELSIF (NOT(Attr IN OKAttr)) THEN Err := 5
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 6
ELSE
Err := 0;
CASE BType OF
0 : ul := ' '; (* use ASCII space *)
ur := ' ';
ll := ' ';
lr := ' ';
bt := ' ';
sd := ' ' |
1 : ul := 'Ú'; (* single-line box *)
ur := '¿';
ll := 'À';
lr := 'Ù';
bt := 'Ä';
sd := '³' |
2 : ul := 'É'; (* double-line box *)
ur := '»';
ll := 'È';
lr := '¼';
bt := 'Í';
sd := 'º' |
3 : ul := 'Õ'; (* single-line sides, double-line top/bottom *)
ur := '¸';
ll := 'Ô';
lr := '¾';
bt := 'Í';
sd := '³'
ELSE (* +, -, and | *)
ul := '+';
ur := '+';
ll := '+';
lr := '+';
bt := '-';
sd := '|';
END (* CASE *);
(* now, draw top of box *)
(* first position the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD((Y * 100H) + X);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* write upper left corner *)
AXwd := WORD(0900H + ORD(ul));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then reposition the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD((Y * 100H) + (X + 1));
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* do top line *)
AXwd := WORD(0900H + ORD(bt));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(Width - 2);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = Width - 2 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then reposition the cursor again *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD((Y * 100H) + (X + (Width -1)));
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* and write upper right corner *)
AXwd := WORD(0900H + ORD(ur));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)

(* then draw bottom of box *)
(* first position the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(((Y + (Height - 1)) * 100H) + X);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* write lower left corner *)
AXwd := WORD(0900H + ORD(ll));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then reposition the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(((Y + (Height - 1)) * 100H) + (X + 1));
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* do bottom line *)
AXwd := WORD(0900H + ORD(bt));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(Width - 2);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = Width - 2 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then reposition the cursor again *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(((Y + (Height - 1)) * 100H) + (X + (Width -1)));
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* and write lower right corner *)
AXwd := WORD(0900H + ORD(lr));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)

(* draw left side of box *)
FOR I := 1 TO (Height - 2) DO
(* first position the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(((Y + I) * 100H) + X);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then write a character *)
AXwd := WORD(0900H + ORD(sd));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END;

(* finally, draw right side of box *)
FOR I := 1 TO (Height - 2) DO
(* first position the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(((Y + I) * 100H) + (X + (Width - 1)));
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then write a character *)
AXwd := WORD(0900H + ORD(sd));
BXwd := WORD((CurPage * 100H) + Attr);
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END;
IF (CurHid) THEN (* rehide cursor if off *)
AXwd := WORD(0200H);
BXwd := WORD(CurPage * 100H);
DXwd := WORD(2500H);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END (* IF *)
END MkBox;

(******************************************************************************)

PROCEDURE ClrBox(ULX,LRX : COL; ULY,LRY : ROW;
Attr : ATTRTYP;
VAR Err : CARDINAL);

(* Clear box specified by its upper left and lower right corners. Attr is
attribute of cleared area. Box is cleared on currently active display
page. The smallest box that may be cleared is one character space,
i.e., LRX = ULX and LRY = ULY.
Calling parameters are:
ULX - X-coordinate of upper left corner (0 to 78)
ULY - Y-coordinate of upper left coordinate (0 to 24)
LRX - X-coordinate of lower right corner (1 to 79)
LRY - Y-coordinate of lower right corner (1 to 25)
Attr - display attribute of cleared area
Error codes returned are:
0 = no error
1 = coordinates do not specify UL and LR corners of rectangle
2 = one or both X-coordinates out of range
3 = invalid attribute
4 = invalid display mode
>> Only text display modes are supported.
*)

BEGIN
IF ((ULX > MaxX) OR (LRX > MaxX)) THEN Err := 2
ELSIF (LRX < ULX) OR (LRY < ULY) THEN Err := 1
ELSIF (NOT(Attr IN OKAttr)) THEN Err := 3
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 4
ELSE
Err := 0;
AXwd := WORD(0600H);
BXwd := WORD(Attr * 100H);
CXwd := WORD((ULY * 100H) + ULX);
DXwd := WORD((LRY * 100H) + LRX);
SETREG(AX,AXwd); (* AH = 06H, initialize window or scroll up,
AL = 0 -> blank the entire window *)
SETREG(BX,BXwd); (* BH = attribute of blank area *)
SETREG(CX,CXwd); (* CH = column, CL = row, for upper left corner *)
SETREG(DX,DXwd); (* DH = column, DL = row, for lower right corner *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END ClrBox;

(******************************************************************************)

PROCEDURE GetScr(ULX,LRX : COL; ULY,LRY : ROW;
VAR Scr : ARRAY OF WORD;
Page : PAGETYP;
VAR Err : CARDINAL);

(* Get what is on the screen in the box specified by its upper left and
lower right corners. Page is the display page to get from and Scr
is an ARRAY OF WORD[] big enough to hold one WORD for each CHAR in the
specified box, since it gets both the character and attribute at each
location. The smallest box that may be specified is a single character,
i.e., LRX = ULX and LRY = ULY.
Calling parameters are:
ULX - X-coordinate of upper left corner (0 to 78)
ULY - Y-coordinate of upper left coordinate (0 to 24)
LRX - X-coordinate of lower right corner (1 to 79)
LRY - Y-coordinate of lower right corner (1 to 25)
Page - display page to use
Scr - starting address of buffer
Error codes returned are:
0 = no error
1 = coordinates do not specify UL and LR corners of rectangle
2 = one or both X-coordinates out of range
3 = invalid page for current mode
4 = invalid display mode
5 = Scr not large enough to hold data
>> Only text display modes are supported.
*)

VAR
Row,Col,Words,Indx : CARDINAL;

BEGIN
Words := (ABS(LRX - ULX) + 1) * (ABS(LRY - ULY) + 1) - 1; (* words needed *)
IF ((ULX > MaxX) OR (LRX > MaxX)) THEN Err := 2
ELSIF (LRX < ULX) OR (LRY < ULY) THEN Err := 1
ELSIF (NOT(Page IN OKPage)) THEN Err := 3
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 4
ELSIF (HIGH(Scr) < Words) THEN Err := 5
ELSE
Err := 0;
Indx := 0;
FOR Row := ULY TO LRY DO
FOR Col := ULX TO LRX DO
(* first position the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(Page * 100H);
DXwd := WORD((Row * 100H) + Col);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then get the character and attribute *)
AXwd := WORD(0800H);
BXwd := WORD(Page * 100H);
SETREG(AX,AXwd); (* AH = 08H, read attribute and character function *)
SETREG(BX,BXwd); (* BH = page *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
GETREG(AX,Scr[Indx]);(* get returned results *)
INC(Indx) (* point to next word *)
END (* IF *)
END (* FOR *)
END (* FOR *)
END GetScr;

(******************************************************************************)

PROCEDURE PutScr(ULX,LRX : COL; ULY,LRY : ROW;
VAR Scr : ARRAY OF WORD;
Page : PAGETYP;
VAR Err : CARDINAL);

(* Put what is in the buffer into the box specified by its upper left and
lower right corners. Page is the display page to put to and Scr
is an ARRAY OF WORD[] that has one WORD for each CHAR in the box,
since each word represents both the character and attribute at each
location. NOTE WELL, that should Scr contain something other than
screen data, it will still be written to the screen as character/
attribute pairs. Sometimes this may lead to interesting displays.
The smallest box that may be specified is one character, i.e.,
LRX = ULX and LRY = ULY.
Calling parameters are:
ULX - X-coordinate of upper left corner (0 to 78)
ULY - Y-coordinate of upper left coordinate (0 to 24)
LRX - X-coordinate of lower right corner (1 to 79)
LRY - Y-coordinate of lower right corner (1 to 25)
Page - display page to use
Scr - array of data to put to screen
Error codes returned are:
0 = no error
1 = coordinates do not specify UL and LR corners of rectangle
2 = one or both X-coordinates out of range
3 = invalid page for current mode
4 = invalid display mode
5 = Scr not large enough to fill box
>> Only text display modes are supported.
*)

VAR
Row,Col,Words,Indx : CARDINAL;

BEGIN
Words := (ABS(LRX - ULX) + 1) * (ABS(LRY - ULY) + 1) - 1; (* words needed *)
IF ((ULX > MaxX) OR (LRX > MaxX)) THEN Err := 2
ELSIF (LRX < ULX) OR (LRY < ULY) THEN Err := 1
ELSIF (NOT(Page IN OKPage)) THEN Err := 3
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 4
ELSIF (HIGH(Scr) < Words) THEN Err := 5
ELSE
Err := 0;
Indx := 0;
FOR Row := ULY TO LRY DO
FOR Col := ULX TO LRX DO
(* first position the cursor *)
AXwd := WORD(0200H);
BXwd := WORD(Page * 100H);
DXwd := WORD((Row * 100H) + Col);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then write the character and attribute *)
AXwd := WORD(0900H + (CARDINAL(BITSET(Scr[Indx]) * LoMask)));
BXwd := WORD((Page * 100H) +
(CARDINAL(BITSET(Scr[Indx]) * HiMask) DIV 100H));
CXwd := WORD(1);
SETREG(AX,AXwd); (* AH = 09H, write attribute and character function,
AL = character to write *)
SETREG(BX,BXwd); (* BH = display page, BL = display attribute *)
SETREG(CX,CXwd); (* CX = character repeat count = 1 *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
INC(Indx) (* point to next word *)
END (* FOR *)
END; (* FOR *)
IF (CurHid) THEN (* rehide cursor if off *)
AXwd := WORD(0200H);
BXwd := WORD(Page * 100H);
DXwd := WORD(2500H);
SETREG(AX,AXwd); (* AH = 02H, position cursor function *)
SETREG(BX,BXwd); (* BH = display page number *)
SETREG(DX,DXwd); (* DH = row, DL = column *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END (* IF *)
END PutScr;

(******************************************************************************)

PROCEDURE ScrUp(ULX,LRX : COL; ULY,LRY : ROW;
Lines : CARDINAL;
Attr : ATTRTYP;
VAR Err : CARDINAL);

(* Scroll or blank an area of the screen. If Lines = 0 the specified area
is blanked with attribute Attr, otherwise the specified area is scrolled
up Lines lines with text scrolled beyond the top of the window being
lost and new blank lines being scrolled in having the attribute Attr.
The window is on the currently active display page. The smallest box
that may be specified is one character, i.e., LRX = ULX and LRY = ULY.
The calling parameters are:
ULX - X-coordinate of upper left corner (0 to 78)
ULY - Y-coordinate of upper left coordinate (0 to 24)
LRX - X-coordinate of lower right corner (1 to 79)
LRY - Y-coordinate of lower right corner (1 to 25)
Lines - number of lines to scroll
Attr - attribute to use for blank lines scrolled into area
Error codes returned are:
0 = no error
1 = coordinates do not specify UL and LR corners of rectangle
2 = one or both X-coordinates out of range
3 = invalid attribute
4 = invalid display mode
>> Only text display modes are supported.
*)

BEGIN
IF ((ULX > MaxX) OR (LRX > MaxX)) THEN Err := 2
ELSIF (LRX < ULX) OR (LRY < ULY) THEN Err := 1
ELSIF (NOT(Attr IN OKAttr)) THEN Err := 3
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 4
ELSE
Err := 0;
AXwd := WORD(0600H + Lines);
BXwd := WORD(Attr * 100H);
CXwd := WORD((ULY * 100H) + ULX);
DXwd := WORD((LRY * 100H) + LRX);
SETREG(AX,AXwd); (* AH = 06H, initialize window or scroll up,
AL = Lines = how far to scroll *)
SETREG(BX,BXwd); (* BH = attribute of scrolled in lines *)
SETREG(CX,CXwd); (* CH = column, CL = row, for upper left corner *)
SETREG(DX,DXwd); (* DH = column, DL = row, for lower right corner *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END ScrUp;

(******************************************************************************)

PROCEDURE ScrDn(ULX,LRX : COL; ULY,LRY : ROW;
Lines : CARDINAL;
Attr : ATTRTYP;
VAR Err : CARDINAL);

(* Scroll or blank an area of the screen. If Lines = 0 the specified area
is blanked with attribute Attr, otherwise the specified area is scrolled
down Lines lines with text scrolled below the bottom of the window being
lost and new blank lines being scrolled in having the attribute Attr.
The window is on the currently active display page. The smallest box
that may be specified is one character, i.e., LRX = ULX and LRY = ULY.
The calling parameters are:
ULX - X-coordinate of upper left corner (0 to 78)
ULY - Y-coordinate of upper left coordinate (0 to 24)
LRX - X-coordinate of lower right corner (1 to 79)
LRY - Y-coordinate of lower right corner (1 to 25)
Lines - number of lines to scroll
Attr - attribute to use for blank lines scrolled into area

Error codes returned are:
0 = no error
1 = coordinates do not specify UL and LR corners of rectangle
2 = one or both X-coordinates out of range
3 = invalid attribute
4 = invalid display mode
>> Only text display modes are supported.
*)

BEGIN
IF ((ULX > MaxX) OR (LRX > MaxX)) THEN Err := 2
ELSIF (LRX < ULX) OR (LRY < ULY) THEN Err := 1
ELSIF (NOT(Attr IN OKAttr)) THEN Err := 3
ELSIF (NOT(CurMode IN TxtMode)) THEN Err := 4
ELSE
Err := 0;
AXwd := WORD(0700H + Lines);
BXwd := WORD(Attr * 100H);
CXwd := WORD((ULY * 100H) + ULX);
DXwd := WORD((LRY * 100H) + LRX);
SETREG(AX,AXwd); (* AH = 07H, initialize window or scroll down,
AL = number of lines to scroll *)
SETREG(BX,BXwd); (* BH = attribute of scrolled in lines *)
SETREG(CX,CXwd); (* CH = column, CL = row, for upper left corner *)
SETREG(DX,DXwd); (* DH = column, DL = row, for lower right corner *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END ScrDn;

(******************************************************************************)

PROCEDURE GetMode(VAR Cols : CARDINAL;
VAR Mode : CARDINAL;
VAR Page : CARDINAL);

(* Return the number of character columns on the screen, the current
display mode, and the currently active display page. No error codes
are returned. See SetMode below for list of display modes.
*)

BEGIN
AXwd := WORD(0F00H); (* Function 0FH, get current display mode *)
SETREG(AX,AXwd); (* AH = 0FH *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP,PushBX); (* pop BP *)
GETREG(AX,AXwd); (* get the returned values *)
CODE(PopBX);
GETREG(BX,BXwd);
Cols := CARDINAL(BITSET(AXwd) * HiMask) DIV 100H; (* AH *)
Mode := CARDINAL(BITSET(AXwd) * LoMask); (* AL *)
Page := CARDINAL(BITSET(BXwd) * HiMask) DIV 100H (* BH *)
END GetMode;

(******************************************************************************)

PROCEDURE SetMode(Mode : MODETYP;
Clear : BOOLEAN;
VAR NewMode : CARDINAL;
VAR Err : CARDINAL);

(* Set the current display mode as listed below. If Clear = TRUE,
the display buffer will be cleared when the new mode is selected.
If Clear = FALSE, it will not. The procedure may fail if you
select a mode that your hardware does not support. To check this,
the current display mode is tested after the set and the new display
mode is returned in NewMode. If NewMode <> Mode, then you know the
procedure failed. You may also discover this when strange things
happen after calling this procedure. Check the list below and make
sure you only call it with values that your hardware actually supports.
The display modes are:
00H = 40 X 25 B&W text, color adapter
01H = 40 X 25 color text
02H = 80 X 25 B&W text
03H = 80 X 25 color text
04H = 320 X 200 4-color graphics
05H = 320 X 200 4-color graphics, color burst off
06H = 640 X 200 2-color graphics
07H = Monochrome Adapter text display
08H - 0AH = PCjr modes not supported here
0DH = 320 X 200 16-color graphics, EGA
0EH = 640 X 200 16-color graphics, EGA
0FH = 640 X 350 monochrome graphics, EGA
10H = 640 X 350 4- or 16-color graphics, EGA (RAM size dependent)
Error codes returned are:
0 = no error
1 = invalid display mode
*)
BEGIN
IF (NOT(Mode IN TxtMode)) AND (NOT(Mode IN GrphMode)) THEN
Err := 1
ELSE
Err := 0;
AXwd := WORD(Mode);
IF (NOT Clear) THEN (* set high bit of AL on *)
AXwd := WORD(BITSET(AXwd) + BITSET(0080H))
END;
SETREG(AX,AXwd);
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP); (* pop BP *)
(* then redo initialization of our global variables *)
AXwd := WORD(0F00H); (* Function 0FH, get current display mode *)
SETREG(AX,AXwd); (* AH = 0FH *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP,PushBX); (* pop BP *)
GETREG(AX,AXwd); (* get the returned values *)
CODE(PopBX);
GETREG(BX,BXwd);
CurPage := CARDINAL(BITSET(BXwd) * HiMask) DIV 100H; (* BH *)
CurCols := CARDINAL(BITSET(AXwd) * HiMask) DIV 100H; (* AH *)
CurMode := CARDINAL(BITSET(AXwd) * LoMask); (* AL *)
NewMode := CurMode; (* send this back to caller *)
MaxX := CurCols - 1;
IF (CurMode IN MODESET{0,1,13}) THEN
OKPage := PAGESET{0,1,2,3,4,5,6,7}
ELSIF (CurMode IN MODESET{2,3,14}) THEN
OKPage := PAGESET{0,1,2,3}
ELSIF (CurMode IN MODESET{15,16}) THEN
OKPage := PAGESET{0,1}
ELSE
OKPage := PAGESET{0}
END
END (* IF *)
END SetMode;

(******************************************************************************)

PROCEDURE SetPage(Page : PAGETYP;
VAR Err : CARDINAL);

(* Select active display page. Valid Page selections are:
0 thru 7 for modes 00H, 01H and 0DH
0 thru 3 for modes 02H, 03H and 0EH
0 or 1 for modes 0FH and 10H
0 only for modes 04H thru 07H
Error codes returned are:
0 = no error
1 = invalid Page for current display mode
*)

BEGIN
IF (NOT(Page IN OKPage)) THEN Err := 1
ELSE
Err := 0;
AXwd := WORD(0500H + Page);
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP) (* pop BP *)
END (* IF *)
END SetPage;

(******************************************************************************)

BEGIN (* Perform module initialization. *)
AXwd := WORD(0F00H); (* Function 0FH, get current display mode *)
SETREG(AX,AXwd); (* AH = 0FH *)
CODE(PushBP); (* push BP *)
SWI(ROMvds); (* transfer to ROM driver *)
CODE(PopBP,PushBX); (* pop BP *)
GETREG(AX,AXwd); (* get the returned values *)
CODE(PopBX);
GETREG(BX,BXwd);
CurPage := CARDINAL(BITSET(BXwd) * HiMask) DIV 100H; (* BH *)
CurCols := CARDINAL(BITSET(AXwd) * HiMask) DIV 100H; (* AH *)
CurMode := CARDINAL(BITSET(AXwd) * LoMask); (* AL *)
MaxX := CurCols - 1;
IF (CurMode IN MODESET{0,1,13}) THEN
OKPage := PAGESET{0,1,2,3,4,5,6,7}
ELSIF (CurMode IN MODESET{2,3,14}) THEN
OKPage := PAGESET{0,1,2,3}
ELSIF (CurMode IN MODESET{15,16}) THEN
OKPage := PAGESET{0,1}
ELSE
OKPage := PAGESET{0}
END;
CurHid := FALSE (* cursor isn't hidden yet *)
END IBMSCR.

(* end of this file *)


  3 Responses to “Category : Modula II Source Code
Archive   : MLIFE.ZIP
Filename : IBMSCR.MOD

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/