Category : Modula II Source Code
Archive   : VWINDOW2.ZIP
Filename : VWINDOWS.MOD

 
Output of file : VWINDOWS.MOD contained in archive : VWINDOW2.ZIP
IMPLEMENTATION MODULE VWindows;
(*---------------------------------------------------------------------------
Copyright *c* 1986 by Donald Dumitru.
All rights reserved.
Permission is hereby given by the author for inclusion of this module
in other applications without any royalty requirement. Further, this
source code may be distributed free of royalty, so long as this notice
is not removed.
---------------------------------------------------------------------------*)
(*---- VirtualWindows ------------------------------------------------------
| |
| See VWindows.DOC for a description of this module. |
| |
| Version 1.0 Donald Dumitru 21 Mar 86 |
| Version 1.1 Woody Aichner 13 May 88 FST Version 1.2 |
--------------------------------------------------------------------------*)
FROM SYSTEM IMPORT ADDRESS, WORD, ADR, ASSEMBLER;
FROM ASCII IMPORT bel, bs, lf, cr, EOL;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;


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


CONST
space = ' ';
ULCorner = 0D5H;
URCorner = 0B8H;
LLCorner = 0D4H;
LRCorner = 0BEH;
VertLine = 0B3H;
HoriLine = 0CDH;
VerSpace = 1;
HorSpace = 2;
MonoDispSeg = 0B000H;
ColorDispSeg = 0B800H;
MonoDispReg = 03BAH;
ColorDispReg = 03DAH;


TYPE
WinHandle = POINTER TO WinRecord;
WinRecord = RECORD
PosX : XPos;
PosY : YPos;
X1,
X2 : XPos;
Y1,
Y2 : YPos;
Attr : Color;
Bord : BOOLEAN;
BordA : Color;
Text : ADDRESS;
Above : WinHandle;
Below : WinHandle;
END;
ChrRecord = RECORD
CASE : BOOLEAN OF
FALSE : w : WORD;
| TRUE : c : CHAR;
a : CHAR;
END;
END;
ModeType = (direct, wait, bios);
ScreenType = ARRAY YPos, XPos OF ChrRecord;


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


VAR
Top : WinHandle;
Full : WinRecord;
FullText : ScreenType;
Screen : POINTER TO ScreenType;
Mode : ModeType;
DispSeg : CARDINAL;
DispReg : CARDINAL;


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


PROCEDURE CopyBytesLH(source, dest: ADDRESS; count: CARDINAL; wait: BOOLEAN);

VAR
LocDispSeg: CARDINAL;

BEGIN
LocDispSeg:=DispSeg;
ASM
PUSH DS
MOV CX,count
JCXZ M1

LES DI,dest
LDS SI,source
CMP SI,DI
JB M2
JMP M3

M2: STD
PUSH CX
DEC CX
ADD DI,CX
ADD SI,CX
POP CX
JMP M4

M3: CLD

M4: CMP wait,FALSE
JE MA

MOV BX,ES
CMP BX,LocDispSeg
JZ M5
MOV BX,DS
CMP BX,LocDispSeg
JNZ MA
M5: MOV DX,03DAH

M6: CLI
M7: IN AL,DX
TEST AL,8
JNZ M9

TEST AL,1
JNZ M7

M8: IN AL,DX
TEST AL,9
JZ M8

M9: MOVSB
STI
LOOP M6

JMP M1

MA: REPZ
MOVSB
CLD

M1: POP DS
END;
END CopyBytesLH;


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


(* The following are exported procedures. *)


PROCEDURE Write(win : WinHandle; c : CHAR);
BEGIN
IF win <> NIL THEN
CASE c OF
bel : ASM
MOV AX,0E07H
INT 10H
END;
| bs : IF win^.PosX > win^.X1 THEN
GotoXY(win,WhereX(win)-1,WhereY(win));
END;
| lf : IF win^.PosY < win^.Y2 THEN
GotoXY(win,WhereX(win),WhereY(win)+1);
ELSE
Scroll(win);
END;
| cr : GotoXY(win,MinX,WhereY(win));
| EOL : GotoXY(win,MinX,WhereY(win));
IF win^.PosY < win^.Y2 THEN
GotoXY(win,WhereX(win),WhereY(win)+1);
ELSE
Scroll(win);
END;
ELSE
TextWriteCh(win,win^.PosX,win^.PosY,ORD(c)+256*win^.Attr);
IF win^.PosX >= win^.X2 THEN
GotoXY(win,MinX,WhereY(win));
IF win^.PosY < win^.Y2 THEN
GotoXY(win,WhereX(win),WhereY(win)+1);
ELSE
Scroll(win);
END;
ELSE
GotoXY(win,WhereX(win)+1,WhereY(win));
END;
END;
END;
END Write;


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


PROCEDURE WriteString(win : WinHandle; s : ARRAY OF CHAR);
VAR
I : CARDINAL;
BEGIN
IF win <> NIL THEN
I:=0;
WHILE (I <= HIGH(s)) AND (s[I] <> 0C) DO
Write(win,s[I]);
INC(I);
END;
END;
END WriteString;


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


PROCEDURE WriteLn(win : WinHandle);
BEGIN
IF win <> NIL THEN
Write(win,EOL);
END;
END WriteLn;


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


PROCEDURE ClrEol(win : WinHandle);
VAR
X : XPos;
BEGIN
IF win <> NIL THEN
FOR X := win^.PosX TO win^.X2 DO
TextWriteCh(win,X,win^.PosY,ORD(space)+256*win^.Attr);
END;
END;
END ClrEol;


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


PROCEDURE ClrScr(win : WinHandle);
VAR
X : XPos;
Y : YPos;
BEGIN
IF win <> NIL THEN
FOR Y := win^.Y1 TO win^.Y2 DO
FOR X := win^.X1 TO win^.X2 DO
TextWriteCh(win,X,Y,ORD(space)+256*win^.Attr);
END;
END;
GotoXY(win,MinX,MinY);
END;
END ClrScr;


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


PROCEDURE GotoXY(win : WinHandle; x : XPos; y : YPos);
BEGIN
IF win <> NIL THEN
IF (x > win^.X2-win^.X1+1) OR (y > win^.Y2-win^.Y1+1) THEN
RETURN;
ELSE
win^.PosX := x + win^.X1;
win^.PosY := y + win^.Y1;
IF win = Top THEN
BiosSetPos(win^.PosX,win^.PosY);
END;
END;
END;
END GotoXY;


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


PROCEDURE WhereX(win : WinHandle) : XPos;
BEGIN
IF win <> NIL THEN
RETURN win^.PosX-win^.X1;
ELSE
RETURN MinX;
END;
END WhereX;


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


PROCEDURE WhereY(win : WinHandle) : YPos;
BEGIN
IF win <> NIL THEN
RETURN win^.PosY-win^.Y1;
ELSE
RETURN MinY;
END;
END WhereY;


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


PROCEDURE SetColor(win : WinHandle; attr : Color);
BEGIN
IF win <> NIL THEN
win^.Attr := attr;
END;
END SetColor;


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


PROCEDURE GetColor(win : WinHandle) : Color;
BEGIN
IF win <> NIL THEN
RETURN win^.Attr;
ELSE
RETURN Blank;
END;
END GetColor;


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


PROCEDURE OpenWindow(X1, X2 : XPos; Y1, Y2 : YPos; attr : Color; border : BOOLEAN) : WinHandle;
VAR
NewWin : WinHandle;
X : XPos;
Y : YPos;
t : ADDRESS;
BEGIN
IF (X1 >= X2) OR (Y1 >= Y2) THEN
RETURN NIL;
END;
IF border AND ((X1 < MinX+HorSpace) OR (X2 > MaxX-HorSpace) OR
(Y1 < MinY+VerSpace) OR (Y2 > MaxY-VerSpace)) THEN
RETURN NIL;
END;
NEW(NewWin);
NewWin^.Below := Top;
Top^.Above := NewWin;
Top := NewWin;
Top^.PosX := X1;
Top^.PosY := Y1;
Top^.X1 := X1;
Top^.X2 := X2;
Top^.Y1 := Y1;
Top^.Y2 := Y2;
Top^.Attr := attr;
Top^.Bord := border;
Top^.BordA := attr;
ALLOCATE(Top^.Text,2*(X2-X1+1)*(Y2-Y1+1));
Top^.Above := NIL;
t := Top^.Text;
FOR Y := 0 TO Y2-Y1 DO
FOR X := 0 TO X2-X1 DO
t^ := WORD(ORD(space)+256*Top^.Attr);
t := t + 2;
END;
END;
ReDraw(Top);
RETURN Top;
END OpenWindow;


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


PROCEDURE CloseWindow(VAR win : WinHandle);
BEGIN
IF (win <> NIL) AND (win <> ADR(Full)) THEN
IF win^.Above <> NIL THEN
win^.Above^.Below := win^.Below;
ELSE
Top := win^.Below;
END;
IF win^.Below <> NIL THEN
win^.Below^.Above := win^.Above;
END;
WHILE win^.Below <> NIL DO
ReDraw(win^.Below);
win^.Below := win^.Below^.Below;
END;
DEALLOCATE(win^.Text,2*(win^.X2-win^.X1+1)*(win^.Y2-win^.Y1+1));
DISPOSE(win);
END;
END CloseWindow;


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


PROCEDURE GetX1(win : WinHandle) : XPos;
BEGIN
IF win <> NIL THEN
RETURN win^.X1;
ELSE
RETURN MinX;
END;
END GetX1;


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


PROCEDURE GetX2(win : WinHandle) : XPos;
BEGIN
IF win <> NIL THEN
RETURN win^.X2;
ELSE
RETURN MaxX;
END;
END GetX2;


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


PROCEDURE GetY1(win : WinHandle) : YPos;
BEGIN
IF win <> NIL THEN
RETURN win^.Y1;
ELSE
RETURN MinY;
END;
END GetY1;


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


PROCEDURE GetY2(win : WinHandle) : YPos;
BEGIN
IF win <> NIL THEN
RETURN win^.Y2;
ELSE
RETURN MaxY;
END;
END GetY2;


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


PROCEDURE IsFore(win : WinHandle) : BOOLEAN;
BEGIN
RETURN win = Top;
END IsFore;


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


PROCEDURE ToFront(win : WinHandle);
VAR
t : WinHandle;
BEGIN
IF (win <> NIL) AND (win <> Top) THEN
Top^.Above := win;
IF win^.Below <> NIL THEN
win^.Below^.Above := win^.Above;
END;
IF win^.Above <> NIL THEN
win^.Above^.Below := win^.Below;
END;
win^.Below := Top;
Top := win;
t := Top^.Below;
WHILE t <> NIL DO
ReDraw(t);
t := t^.Below;
END;
END;
END ToFront;


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


PROCEDURE TopWin() : WinHandle;
BEGIN
RETURN Top;
END TopWin;


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


PROCEDURE Back() : WinHandle;
BEGIN
RETURN ADR(Full);
END Back;


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


PROCEDURE Move(win : WinHandle; XOff, YOff : INTEGER);
VAR
t : WinHandle;
BEGIN
IF win <> NIL THEN
IF XOff < 0 THEN
IF NOT win^.Bord AND (win^.X1 < MinX+CARDINAL(ABS(XOff))) THEN
RETURN;
ELSIF win^.Bord AND (win^.X1 < MinX+CARDINAL(ABS(XOff))+HorSpace) THEN
RETURN;
END;
ELSE
IF NOT win^.Bord AND (win^.X2 > MaxX-CARDINAL(XOff)) THEN
RETURN;
ELSIF win^.Bord AND (win^.X2 > MaxX-CARDINAL(XOff)-HorSpace) THEN
RETURN;
END;
END;
IF YOff < 0 THEN
IF NOT win^.Bord AND (win^.Y1 < MinY+CARDINAL(ABS(YOff))) THEN
RETURN;
ELSIF win^.Bord AND (win^.Y1 < MinY+CARDINAL(ABS(YOff))+VerSpace) THEN
RETURN;
END;
ELSE
IF NOT win^.Bord AND (win^.Y2 > MaxY-CARDINAL(YOff)) THEN
RETURN;
ELSIF win^.Bord AND (win^.Y2 > MaxY-CARDINAL(YOff)-VerSpace) THEN
RETURN;
END;
END;
IF XOff < 0 THEN
DEC(win^.X1,CARDINAL(ABS(XOff)));
DEC(win^.X2,CARDINAL(ABS(XOff)));
ELSIF XOff > 0 THEN
INC(win^.X1,CARDINAL(XOff));
INC(win^.X2,CARDINAL(XOff));
END;
IF YOff < 0 THEN
DEC(win^.Y1,CARDINAL(ABS(YOff)));
DEC(win^.Y2,CARDINAL(ABS(YOff)));
ELSIF YOff > 0 THEN
INC(win^.Y1,CARDINAL(YOff));
INC(win^.Y2,CARDINAL(YOff));
END;
t := win;
WHILE t <> NIL DO
ReDraw(t);
t := t^.Below;
END;
END;
END Move;


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


(* The following are local procedures. *)


PROCEDURE ReDraw(win : WinHandle);
VAR
X : XPos;
Y : YPos;
t : ADDRESS;
BEGIN
IF win^.Bord THEN
ScreenWriteCh(win,win^.X1-HorSpace,win^.Y1-VerSpace,ULCorner+256*win^.BordA);
ScreenWriteCh(win,win^.X2+HorSpace,win^.Y1-VerSpace,URCorner+256*win^.BordA);
ScreenWriteCh(win,win^.X1-HorSpace,win^.Y2+VerSpace,LLCorner+256*win^.BordA);
ScreenWriteCh(win,win^.X2+HorSpace,win^.Y2+VerSpace,LRCorner+256*win^.BordA);
FOR Y := win^.Y1-VerSpace+1 TO win^.Y2+VerSpace-1 DO
ScreenWriteCh(win,win^.X1-HorSpace,Y,VertLine+256*win^.BordA);
FOR X := win^.X1-HorSpace+1 TO win^.X1-1 DO
ScreenWriteCh(win,X,Y,ORD(space)+256*win^.BordA);
END;
ScreenWriteCh(win,win^.X2+HorSpace,Y,VertLine+256*win^.BordA);
FOR X := win^.X2+1 TO win^.X2+HorSpace-1 DO
ScreenWriteCh(win,X,Y,ORD(space)+256*win^.BordA);
END;
END;
FOR X := win^.X1-HorSpace+1 TO win^.X2+HorSpace-1 DO
ScreenWriteCh(win,X,win^.Y1-VerSpace,HoriLine+256*win^.BordA);
FOR Y := win^.Y1-VerSpace+1 TO win^.Y1-1 DO
ScreenWriteCh(win,X,Y,ORD(space)+256*win^.BordA);
END;
ScreenWriteCh(win,X,win^.Y2+VerSpace,HoriLine+256*win^.BordA);
FOR Y := win^.Y2+1 TO win^.Y2+VerSpace-1 DO
ScreenWriteCh(win,X,Y,ORD(space)+256*win^.BordA);
END;
END;
END;
t := win^.Text;
FOR Y := win^.Y1 TO win^.Y2 DO
FOR X := win^.X1 TO win^.X2 DO
ScreenWriteCh(win,X,Y,t^);
t := t + 2;
END;
END;
IF win = Top THEN
BiosSetPos(win^.PosX,win^.PosY);
END;
END ReDraw;


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


PROCEDURE Scroll(win : WinHandle);
VAR
X : XPos;
Y : YPos;
t : ADDRESS;
BEGIN
CopyBytesLH(win^.Text+2*(win^.X2-win^.X1+1),win^.Text,2*(win^.X2-win^.X1+1)*(win^.Y2-win^.Y1),FALSE);
t := win^.Text;
FOR Y := win^.Y1 TO win^.Y2-1 DO
FOR X := win^.X1 TO win^.X2 DO
ScreenWriteCh(win,X,Y,t^);
t := t + 2;
END;
END;
FOR X := win^.X1 TO win^.X2 DO
TextWriteCh(win,X,win^.Y2,ORD(space)+256*win^.Attr);
END;
END Scroll;


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


PROCEDURE TextWriteCh(win : WinHandle; x : XPos; y : YPos; w : WORD);
VAR
t : ADDRESS;
BEGIN
t := win^.Text+2*((x-win^.X1)+(win^.X2-win^.X1+1)*(y-win^.Y1));
t^ := w;
ScreenWriteCh(win,x,y,w);
END TextWriteCh;


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


PROCEDURE ScreenWriteCh(win : WinHandle; x : XPos; y : YPos; w : WORD);

PROCEDURE Uncovered(win : WinHandle; x : XPos; y : YPos) : BOOLEAN;
VAR
t : WinHandle;
BEGIN
t := win^.Above;
WHILE t <> NIL DO
IF t^.Bord THEN
IF (x >= t^.X1-HorSpace) AND (x <= t^.X2+HorSpace) AND
(y >= t^.Y1-VerSpace) AND (y <= t^.Y2+VerSpace) THEN
RETURN FALSE;
END;
ELSE
IF (x >= t^.X1) AND (x <= t^.X2) AND
(y >= t^.Y1) AND (y <= t^.Y2) THEN
RETURN FALSE;
END;
END;
t := t^.Above;
END;
RETURN TRUE;
END Uncovered;

VAR
X : XPos;
Y : YPos;
offset: CARDINAL;

BEGIN
IF Uncovered(win,x,y) THEN
CASE Mode OF
direct : Screen^[y,x].w := w;
| wait : offset := 2*((x-MinX)+(MaxX-MinX+1)*(y-MinY));
ASM
MOV BX,offset
MOV DX,DispReg
MOV CX,w
PUSH AX
PUSH DS
MOV DS,DispSeg
l1:
IN AL,DX
TEST AL,01
JNZ l1
CLI
l2:
IN AL,DX
TEST AL,01
JZ l2
MOV [BX],CX
STI
POP DS
POP AX
END;

| bios : BiosGetPos(X,Y);
BiosSetPos(x,y);
BiosWrite(w);
BiosSetPos(X,Y);
END;
END;
END ScreenWriteCh;


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


PROCEDURE BiosSetPos(x : XPos; y : YPos);
VAR
dx : CARDINAL;
BEGIN
dx := (y-MinY) * 256 + (x-MinX);
ASM
MOV AX,0F00H
INT 10H
MOV AX,0200H
MOV DX,dx
INT 10H
END;
END BiosSetPos;


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


PROCEDURE BiosGetPos(VAR x : XPos; VAR y : YPos);
VAR
dx : CARDINAL;
BEGIN
ASM
MOV AX,0F00H
INT 10H
MOV AX,0300H
INT 10H
MOV dx,DX
END;
y := dx DIV 256 + MinY;
x := dx MOD 256 + MinX;
END BiosGetPos;


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


PROCEDURE BiosWrite(w : WORD);
VAR
ax : CARDINAL;
bx : CARDINAL;
BEGIN
ax := 0900H + CARDINAL(w) MOD 256;
ASM
MOV AX,0F00H
INT 10H
MOV bx,BX
END;

bx := bx - bx MOD 256 + CARDINAL(w) DIV 256;

ASM
MOV AX,ax
MOV BX,bx
MOV CX,1
INT 10H
END;
END BiosWrite;


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


PROCEDURE BiosGetMode() : CARDINAL;
VAR
ax : CARDINAL;
BEGIN
ASM
MOV AX,0F00H
INT 10H
MOV ax,AX
END;
RETURN ax MOD 256;
END BiosGetMode;


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


PROCEDURE BiosReadScreen(a : ADDRESS);
VAR
SavedX,
X : XPos;
SavedY,
Y : YPos;
t : ADDRESS;
ax : CARDINAL;
bx : CARDINAL;
BEGIN
BiosGetPos(SavedX,SavedY);
ASM
MOV AX,0F00H
INT 10H
MOV bx,BX
END;
t := a;
FOR Y := MinY TO MaxY DO
FOR X := MinX TO MaxX DO
BiosSetPos(X,Y);
ASM
MOV AX,0800H
MOV BX,bx
INT 10H
MOV ax,AX
END;
t^ := WORD(ax);
t := t + 2;
END;
END;
BiosSetPos(SavedX,SavedY);
END BiosReadScreen;


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


PROCEDURE Ptr(seg, off : CARDINAL) : ADDRESS;
VAR
res : RECORD
CASE : BOOLEAN OF
FALSE : adr : ADDRESS;
| TRUE : off,
seg : CARDINAL;
END;
END;
BEGIN
res.off := off;
res.seg := seg;
RETURN res.adr;
END Ptr;


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


BEGIN
CASE BiosGetMode() OF
0..1 : DispReg := ColorDispReg;
DispSeg := ColorDispSeg;
Mode := wait;
HALT;
| 2..3 : DispReg := ColorDispReg;
DispSeg := ColorDispSeg;
Mode := wait;
| 4..5 : Mode := bios;
HALT;
| 6 : Mode := bios;
| 7 : DispReg := MonoDispReg;
DispSeg := MonoDispSeg;
Mode := direct;
ELSE
Mode := bios;
HALT;
END;
IF Mode <> bios THEN
Screen := Ptr(DispSeg,0H);
ELSE
Screen := NIL;
END;
Top := ADR(Full);
WITH Full DO
BiosGetPos(PosX,PosY);
X1 := MinX;
X2 := MaxX;
Y1 := MinY;
Y2 := MaxY;
Attr := Normal;
Bord := FALSE;
BordA := Normal;
Text := ADR(FullText);
CASE Mode OF
direct : FullText := Screen^;
| wait : CopyBytesLH(Screen,Text,2*(MaxX-MinX+1)*(MaxY-MinY+1),TRUE);
| bios : BiosReadScreen(Text);
END;
Above := NIL;
Below := NIL;
END;
END VWindows.


  3 Responses to “Category : Modula II Source Code
Archive   : VWINDOW2.ZIP
Filename : VWINDOWS.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/