Category : Modula II Source Code
Archive   : LINEDRAW.ZIP
Filename : LINEDRAW.MOD
(* Adapted from the code listings in the April 1988 issue of Dr. Dobbs
Journal of Software Tools. The article was the Structed Programming
Column by Kent Porter in which he developed an implementation of Dr.
Writh's line drawing module. This FST adaptation of the module by
Larry Maturo, 12209 Arrowwood Drive, Austin, Texas 78727.
This module provides primitive graphics capabilities. It assumes EGA
640 x 350 color mode (procedure Clear puts the system in this mode).
It uses a virtual screen that is 800 wide by 600 high with the origin
in the lower left hand corner.
TYPE
PaintMode = (replace, add, invert, erase);
VAR
Px, Py : INTEGER; (* Current coordinates od drawing pen *)
mode : PaintMode; (* Current mode for paint and copy *)
width : INTEGER; (* Width of picture area, read-only *)
height : INTEGER; (* Height of picture area, read-only *)
CharWidth : INTEGER; (* Witdh of a Character *)
CharHeight : INTEGER; (* Height of a Character *) *)
FROM System IMPORT
AX, BX, CX, DX, SI, DI, BP, DS, ES, FLAGS, carryFlag, zeroFlag, Trap, XTrap;
FROM Strings IMPORT
Length;
CONST
VW = 800.0; (* Virtual width of screen *)
VH = 600.0; (* Virtual height of screen *)
RW = 640.0; (* Real device width, EGA screen *)
RH = 350.0; (* Real device height, EGA screen *)
EGA = 16; (* EGA 640 x 35 color mode *)
VAR
xf, yf : REAL;
color : INTEGER;
(* ------------------------ Local Procedures -----------------------------*)
PROCEDURE MakeWord( a, b :CARDINAL ) :CARDINAL;
BEGIN
RETURN 100H * a + b
END MakeWord;
PROCEDURE GetLowByte( w :CARDINAL ) :CARDINAL;
BEGIN
RETURN w MOD 100H;
END GetLowByte;
PROCEDURE entier( r :REAL ) :INTEGER;
BEGIN
RETURN INTEGER(TRUNC(r))
END entier;
PROCEDURE writePixel(c, x, y : INTEGER);
(* Write pixel of color c at device x, y *)
BEGIN
CASE c OF (* Map color indicator to EGA palette *)
0 : AX := MakeWord(12,63); | (* White *)
1 : AX := MakeWord(12,7); | (* light gray *)
2 : AX := MakeWord(12,56); | (* dark gray *)
3 : AX := MakeWord(12,0); (* black *)
(* 0 : AX := MakeWord(12,15); | (* White *)
1 : AX := MakeWord(12,7); | (* light gray *)
2 : AX := MakeWord(12,8); | (* dark gray *)
3 : AX := MakeWord(12,0); (* black *) *)
END;
BX := 0;
CX := x;
DX := y;
Trap(16);
color := c; (* Set prevailing color *)
END writePixel;
PROCEDURE devX(x : INTEGER) : INTEGER; (* translate x to device x *)
VAR
X : CARDINAL;
f,F : REAL;
BEGIN
X := CARDINAL(x);
f := FLOAT(X);
F := xf * f;
RETURN TRUNC(F);
END devX;
PROCEDURE devY(y : INTEGER) : INTEGER; (* translate y to device y *)
VAR
Y : CARDINAL;
f,F : REAL;
BEGIN
Y := CARDINAL(y);
f := FLOAT(Y);
F := RH - (yf * f);
RETURN TRUNC(F);
END devY;
(*------------------------- Visible Procedures ---------------------------*)
PROCEDURE dot(c : CARDINAL; x,y : INTEGER);
(* Place a dot at coordinate x,y in color c *)
BEGIN
writePixel(c, devX(x), devY(y));
END dot;
PROCEDURE line(d, n : CARDINAL);
(* Draw a line of length n, in direction d
(angle = 45 * d (in degrees)) *)
VAR
xdir, ydir : INTEGER; (* x and y directions given d *)
distance : CARDINAL;
BEGIN
CASE d OF
0 : xdir := 1; ydir := 0; | (* right - east *)
1 : xdir := 1; ydir := 1; | (* - north east *)
2 : xdir := 0; ydir := 1; | (* up - north *)
3 : xdir := -1; ydir := 1; | (* - north west *)
4 : xdir := -1; ydir := 0; | (* left - west *)
5 : xdir := -1; ydir := -1; | (* - south west *)
6 : xdir := 0; ydir := -1; | (* down - south *)
7 : xdir := 1; ydir := -1; (* - south east *)
END;
FOR distance := 1 TO n DO
Px := Px + xdir; (* advance the pen *)
Py := Py + ydir;
dot(color, Px, Py); (* draw in prevailing color *)
END;
END line;
PROCEDURE paint(c : CARDINAL; x,y,w,h : INTEGER);
(* Paint the rectangular area at x,y of width w and height h in
color c, where :
0 = white
1 = light gray
2 = dark gray
3 = black
*)
VAR
cy, prevY, dy : INTEGER;
BEGIN
prevY := 0;
color := c; (* set new prevailing color *)
FOR cy := y TO y+h DO
dy := devY(cy); (* get current device y *)
IF (dy <> prevY) THEN (* if new scan line draw *)
Px := x;
Py := cy;
line(0,w);
prevY := dy; (* remember where last line drawn *)
END;
END;
END paint;
PROCEDURE copyArea(sx, sy, dx, dy, dw, dh : INTEGER);
(* Copy rectangular area at sx, sy into rectangle at ds, dy
of width dw, and height dh *)
VAR
c, x, y, ix, iy, nx, ny, tx, ty : INTEGER;
BEGIN
ix := devX(sx); iy := devY(sy); (* Source dev coordinates *)
nx := devX(sx+dw); ny := devY(sy+dh); (* Ending coordinates *)
tx := devX(dx); ty := devY(dy); (* Target coordinates *)
FOR y := ny TO iy DO (* Go top to bottom *)
FOR x := ix TO nx DO
AX := MakeWord(13,0); (* Read pixel *)
BX := 0;
CX := x;
DX := y;
Trap(16); (* get pixel color into al *)
AX := MakeWord(12,GetLowByte(AX)); (* write pixel to destination *)
CX := tx + x - ix;
DX := ty + y - iy;
Trap(16);
END;
END;
END copyArea;
PROCEDURE clear; (* Clear the Screen *)
(* Note, also palces display into EGA 640 X 50 color mode. *)
BEGIN
AX := MakeWord(0,EGA);
Trap(16); (* EGA 640 x 350 mode *)
color := 0; (* Reset default color to white *)
END clear;
PROCEDURE Write(ch : CHAR); (* Write ch at pen's position. *)
VAR
cc, cr : INTEGER; (* Char column and row *)
BEGIN
cc := devX(Px) DIV 8; (* Derive char position from pen *)
cr := devY(Py) DIV 14;
AX := MakeWord(2,0);
BX := 0;
DX := (cr * 256) + cc;
Trap(16);
AX := 2560 + ORD(ch); (* Write char via ROM BIOS *)
BX := 7;
CX := 1;
Trap(16);
Px := Px + CharWidth; (* advance by char virtual width *)
END Write;
PROCEDURE WriteString(s : ARRAY OF CHAR);
VAR
i : CARDINAL;
BEGIN
FOR i := 0 TO (Length(s) - 1) DO
Write(s[i]);
END;
END WriteString;
PROCEDURE text;
BEGIN
AX := MakeWord(0,3);
Trap(16);
END text;
(*------------------------- Initialization -------------------------------*)
BEGIN
Px := entier(VW / 2.0); (* Virtual screen center *)
Py := entier(VH / 2.0);
mode := replace;
width := entier(VW); (* Virtual screen size *)
height := entier(VH);
CharWidth := 10; (* Char sizes in virtual units *)
CharHeight := 24;
xf := RW/VW; (* x translation factor *)
yf := RH/VH; (* y translation factor *)
color := 0; (* white is default color *)
END LineDraw.
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
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/