Oberon/ETH Oberon/2.3.7/Display3.Mod
< Oberon | ETH Oberon
(* ETH Oberon, Copyright 1990-2003 Computer Systems Institute, ETH Zurich, CH-8092 Zurich.
Refer to the license.txt file provided with this distribution. *)
MODULE Display3; (** portable *) (** jm 17.1.95 / tk 7.12.95*)
(**Module Display3 implements the clipped graphic primitives used by the Gadget system. It has a twin module called Printer3 that implements the same primitives for the printer.
**)
(*
jm 11.2.93 - mask msg
jm 15.4.93 fixed center string
kr 2.6.93 fixed Poly with patterns
jm 17.09.93 10:46:54 - fixed shift mask
25.3.94 - fixed problem with Subtract (bug surfaces after 2 years only)
29.3.94 - Added Pict and ReplPict
15.11.94 - changed definition of String and CenterString
- added selectpat (from Effects)
- removed MakeMask
12.12.94 - fixed clipping problem with lines (was a stupid mistake from Rege).
6.1.95 - removed all the rubbish from rege
- implemented brushes
Lines (supports width, patterns)
Poly (supports width, patterns, filled)
Circle (supports width, patterns, filled)
Ellipse (supports patterns /no fill & width)
3.1.96 - fixed Open by setting clipping port to a maximum area
29.8.96 - fixed Ellipse & Circle (thanks to eos)
*)
IMPORT
Display, Objects, Fonts, Pictures, Oberon, Texts;
CONST
replace* = Display.replace; paint* = Display.paint; invert* = Display.invert; (** Standard display modes. **)
(** Display styles **)
filled* = 1; (** Filled *)
maxcoord = 8192;
add = 1; subtract = 2;
TYPE
Mask* = POINTER TO MaskDesc; (** Clipping Mask. *)
(** Informs a frame of a new mask. This message is always sent directly. **)
OverlapMsg* = RECORD (Display.FrameMsg)
M*: Mask; (** Use NIL to indicate to a frame that its current mask is invalid. *)
END;
(** Message broadcast by a frame (identified by the F field) to indicate that it has an invalid mask and now requires
its parent, to calculate a new mask for it and to inform it through the OverlapMsg. *)
UpdateMaskMsg* = RECORD (Display.FrameMsg)
END;
Run = POINTER TO RunDesc;
RunDesc = RECORD
x, w, right: INTEGER;
value: INTEGER;
next, prev: Run;
END;
ScanLine = POINTER TO ScanLineDesc;
ScanLineDesc = RECORD
y, h, top: INTEGER;
maymerge: BOOLEAN;
run: Run;
next,prev: ScanLine;
END;
MaskDesc* = RECORD (** Clipping mask descriptor. *)
x*, y*: INTEGER; (** Relative mask origin or offset. *)
X*, Y*, W*, H*: INTEGER; (** Current clipping port in absolute coordinates. *)
sX, sY, sW, sH: INTEGER;
simple: BOOLEAN;
scanline: ScanLine;
END;
(** Enumerate the set of rectangles in a mask. The clipping port is not enumerated. *)
EnumProc* = PROCEDURE (X, Y, W, H: INTEGER);
VAR
selectpat*: Display.Pattern; (** Pattern used to draw gadgets when in a selected state. **)
(** Colors *)
FG*, BG*: INTEGER; (** Foreground (black) and background (white) color indexes. *)
red*, green*, blue*: INTEGER; (** Primary color indexes. *)
black*, white*: INTEGER; (** True black and white. **)
topC*: INTEGER; (** Top shadow color. *)
bottomC*: INTEGER; (** Bottom shadow color. *)
upC*: INTEGER; (** Color of a button. *)
downC*: INTEGER; (** Color of the pushed button *)
groupC*: INTEGER; (** Color of containers, i.e. gadgets that have a grouping function like panels. *)
invertC*: INTEGER; (** Best color for doing inverts.. *)
textC*: INTEGER; (** Default text color. *)
textbackC*: INTEGER; (** Default text background. *)
textmode*: INTEGER; (** Best CopyPattern mode for this display card. *)
typ: INTEGER;
aM, bM: Mask; (* for enums *)
(* tmp variables for picture enumerator *)
tmpP: Pictures.Picture;
tmpM, dX, dY: INTEGER;
compactionflag: BOOLEAN;
(* ========= Brush related ========= *)
CONST BrushSize = 100; (* maximum width of the brush *)
TYPE
Brush = RECORD
brul, brur: ARRAY BrushSize OF INTEGER;
bufl, bufr: ARRAY BrushSize OF INTEGER;
bufh, brushr: INTEGER;
x, y, mode: INTEGER;
col: Display.Color;
M: Mask;
pat: Display.Pattern
END;
VAR
drawingPolygon: BOOLEAN;
brush: Brush; (* global Bursh *)
PROCEDURE Min(x, y: INTEGER): INTEGER;
BEGIN
IF x < y THEN RETURN x ELSE RETURN y END
END Min;
PROCEDURE Max(x, y: INTEGER): INTEGER;
BEGIN IF x > y THEN RETURN x ELSE RETURN y END
END Max;
PROCEDURE ClipAgainst(VAR x, y, w, h: INTEGER; x1, y1, w1, h1: INTEGER);
VAR r, t, r1, t1: INTEGER;
BEGIN
r := x + w - 1; r1 := x1 + w1 - 1; t := y + h - 1; t1 := y1 + h1 - 1;
IF x < x1 THEN x := x1 END;
IF y < y1 THEN y := y1 END;
IF r > r1 THEN r := r1 END;
IF t > t1 THEN t := t1 END;
w := r - x + 1; h := t - y + 1;
END ClipAgainst;
PROCEDURE Clip(M: Mask; VAR x, y, w, h : INTEGER);
VAR l, b, t, r, tmp : INTEGER;
BEGIN
l := x; b := y; r := x+w-1; t := y +h-1;
IF (l < M.sX) THEN l := M.sX; END;
tmp := M.sX + M.sW - 1;
IF (r > tmp) THEN r := tmp; END;
IF (b < M.sY) THEN b := M.sY; END;
tmp := M.sY + M.sH - 1;
IF (t > tmp) THEN t := tmp; END;
x := l; y := b; w := r - l + 1; h := t - b + 1;
END Clip;
PROCEDURE Open0(M: Mask);
VAR r: Run; s: ScanLine;
BEGIN
NEW(s); NEW(r);
M.scanline := s; s.run := r; r.next := NIL;
s.y := -maxcoord; s.h := 2 * maxcoord + 1; s.top := maxcoord;
r.x := -maxcoord; r.w := 2 * maxcoord + 1; r.right := maxcoord;
END Open0;
(** Initialize the Mask to the empty region, i.e. everything will be clipped away. *)
PROCEDURE Open*(M: Mask);
BEGIN M.scanline := NIL;
M.x := 0; M.y := 0;
M.simple := TRUE; M.sX := 0; M.sY := 0; M.sW := 0; M.sH := 0;
M.X := 0; M.Y := 0; M.W := maxcoord; M.H := maxcoord
END Open;
(** Enumerate all the visible areas of a mask. The clipping port is not enumerated. The mask translation vector is taken into account.**)
PROCEDURE Enum*(M: Mask; enum: EnumProc);
VAR s: ScanLine; r: Run;
BEGIN
IF M.simple THEN
IF (M.sW > 0) & (M.sH > 0) THEN enum(M.x + M.sX, M.y + M.sY, M.sW, M.sH) END;
ELSE
s := M.scanline;
WHILE s # NIL DO
r := s.run;
WHILE r # NIL DO
IF r.value # 0 THEN enum(M.x + r.x, M.y + s.y, r.w, s.h) END;
r := r.next
END;
s := s.next
END
END
END Enum;
(** Enumerate all the invisible areas of a mask. The clipping port is not enumerated. Note that you might obtain coordinates outside of the normal screen area, bounded by approximately -/+ 8192. The mask translation vector is taken into account.**)
PROCEDURE EnumInvert*(M: Mask; enum: EnumProc);
VAR s: ScanLine; r: Run; X, Y, W, H: INTEGER;
BEGIN
IF M.simple THEN
X := M.x + M.sX; Y := M.y + M.sY; W := M.sW; H := M.sH;
enum(-maxcoord, -maxcoord, 2*maxcoord + 1, Y + maxcoord);
enum(-maxcoord, Y+H, 2*maxcoord + 1, maxcoord - (Y+H) + 1);
enum(-maxcoord, Y, X + maxcoord, H);
enum(X+W, Y, maxcoord - (X+W) , H)
ELSE
s := M.scanline;
WHILE s # NIL DO
r := s.run;
WHILE r # NIL DO
IF r.value = 0 THEN enum(M.x + r.x, M.y + s.y, r.w, s.h) END;
r := r.next
END;
s := s.next
END
END
END EnumInvert;
(** Enumerate all the visible areas in the given rectangular region. The clipping port is not taken into account. *)
PROCEDURE EnumRect*(M: Mask; X, Y, W, H: INTEGER; enum: EnumProc);
VAR hleft, wleft, nw, nh, x, y, X0: INTEGER; s: ScanLine; r: Run;
BEGIN
IF M.simple THEN
ClipAgainst(X, Y, W, H, M.x + M.sX, M.y + M.sY, M.sW, M.sH); (* enum(M.x + M.sX, M.y + M.sY, M.sW, M.sH); *)
IF (W > 0) & (H > 0) THEN enum(X, Y, W, H) END;
ELSE
x := M.x; y := M.y;
hleft := H;
r := NIL;
s := M.scanline;
WHILE s.top + y < Y DO s := s.next; END;
X0 := X;
WHILE hleft > 0 DO
nh := Min(s.top + y - Y + 1, hleft);
r := s.run;
WHILE r.right + x < X DO r := r.next END;
wleft := W;
WHILE wleft > 0 DO
nw := r.right + x - X + 1;
IF wleft < nw THEN nw := wleft END;
IF r.value > 0 THEN enum(X, Y, nw, nh) END;
INC(X, nw); DEC(wleft, nw);
r := r.next
END;
INC(Y, nh); DEC(hleft, nh);
s := s.next; r := NIL; X := X0
END
END
END EnumRect;
PROCEDURE SplitScan(s: ScanLine; y: INTEGER); (* s.y < y < s.top *)
VAR ns: ScanLine; nr, r, tmp: Run;
BEGIN
NEW(ns); ns.y := y; ns.top := s.top; ns.h := s.top - y + 1;
r := s.run; (* NEWRun(nr); *) NEW(nr);ns.run := nr;
WHILE r # NIL DO
nr.x := r.x; nr.w := r.w; nr.right := r.right; nr.value := r.value;
IF r.next # NIL THEN
(* NEWRun(tmp); *) NEW(tmp); nr.next := tmp; nr := tmp;
ELSE
nr.next := NIL;
END;
r := r.next;
END;
ns.next := s.next; s.next := ns; s.top := y - 1; s.h := s.top - s.y + 1;
END SplitScan;
PROCEDURE MergeScanLine(s : ScanLine);
VAR r, rt: Run; noinc: BOOLEAN;
BEGIN
r := s.run;
WHILE r # NIL DO (* Merge *)
IF r.value > 0 THEN r.value := 1; END;
rt := r.next; noinc := FALSE;
IF (rt # NIL) THEN
IF rt.value > 0 THEN rt.value := 1; END;
IF (rt.value = r.value) & (r.right+1 = rt.x) THEN
INC(r.w, rt.w); r.right := rt.right; r.next := rt.next; (* DisposeRun(rt); *) noinc := TRUE;
END;
END;
IF ~noinc THEN r := r.next; END;
END;
END MergeScanLine;
PROCEDURE Compact(M: Mask);
VAR r, rt, thesinglerect: Run;
bs, st, thesinglescanline: ScanLine;
noofrects: INTEGER; merge, noinc: BOOLEAN;
BEGIN
IF ~compactionflag THEN RETURN END;
bs := M.scanline;
WHILE bs # NIL DO
IF bs.maymerge THEN MergeScanLine(bs); END;
bs := bs.next;
END;
bs := M.scanline;
WHILE bs # NIL DO
st := bs.next; noinc := FALSE;
IF st # NIL THEN
r := bs.run; rt := st.run; merge := TRUE;
WHILE merge & (r # NIL) DO
IF (r.value = rt.value) & (r.x = rt.x) & (r.w = rt.w) THEN ELSE merge := FALSE; END;
r := r.next; rt := rt.next;
END;
IF merge THEN
INC(bs.h, st.h); INC(bs.top, st.h);
bs.next := st.next;
noinc := TRUE;
END;
END;
IF ~noinc THEN bs := bs.next; END;
END;
bs := M.scanline; noofrects := 0;
WHILE (bs # NIL) & (noofrects <= 1) DO
r := bs.run;
WHILE (r # NIL) & (noofrects <= 1) DO
IF (r.value > 0) THEN
INC(noofrects);
thesinglerect := r; thesinglescanline := bs;
END;
r := r.next;
END;
bs := bs.next;
END;
IF noofrects = 1 THEN (* super compact *)
M.scanline := NIL;
M.simple := TRUE;
M.sX := thesinglerect.x; M.sY := thesinglescanline.y;
M.sW := thesinglerect.w; M.sH := thesinglescanline.h;
END
END Compact;
PROCEDURE DoLine(s: ScanLine; x, y, w, h: INTEGER);
VAR splittop, splitbottom: BOOLEAN; r, rt: Run; wleft, nw: INTEGER;
BEGIN
splitbottom := (y > s.y); splittop := (y+h-1) < s.top;
r := s.run;
WHILE r.right < x DO r := r.next; END;
wleft := w;
WHILE (wleft > 0) & (r # NIL) DO
nw := Min(wleft, r.right - x + 1);
(* x, y, nw, h *)
IF r.value = 1 THEN (* draw okay in this run *)
ELSE
IF splittop THEN
SplitScan(s, y + h);
splittop := FALSE;
END;
IF splitbottom THEN
SplitScan(s, y);
rt := s.next.run;
WHILE rt.x # r.x DO rt := rt.next END;
r := rt;
s := s.next;
splitbottom := FALSE
END;
IF x > r.x THEN (* split left *)
NEW(rt);
rt.next := r.next;
rt.x := x; rt.w := r.right - x + 1; rt.right := r.right; rt.value := 2;
r.w := x - r.x; r.right := r.x + r.w - 1; r.value := 0;
r.next := rt; nw:=0; s.maymerge := TRUE
ELSIF x + wleft - 1 < r.right THEN (* split right *)
NEW(rt);
rt.next := r.next;
rt.x := x + wleft ; rt.w := r.right - rt.x + 1; rt.right := r.right; rt.value := 0;
r.w := nw; r.right := r.x + r.w - 1; r.value := 1;
r.next := rt; s.maymerge := TRUE
ELSE
r.value := 1; s.maymerge := TRUE
END
END;
INC(x, nw); DEC(wleft, nw); r := r.next
END
END DoLine;
PROCEDURE ExclLine(s: ScanLine; x, y, w, h: INTEGER);
VAR splittop, splitbottom: BOOLEAN;
r, rt: Run; wleft, nw: INTEGER;
BEGIN
splitbottom := (y > s.y); splittop := (y+h-1) < s.top;
r := s.run;
WHILE r.right < x DO r := r.next END;
wleft := w;
WHILE (wleft > 0) & (r # NIL) DO
nw := Min(wleft, r.right - x + 1);
(* x, y, nw, h *)
IF (r.value = 0) THEN
ELSE
IF splittop THEN
SplitScan(s, y + h);
splittop := FALSE
END;
IF splitbottom THEN
SplitScan(s, y);
rt := s.next.run;
WHILE rt.x # r.x DO rt := rt.next; END;
r := rt;
s := s.next;
splitbottom := FALSE
END;
IF x > r.x THEN (* split left *)
NEW(rt);
rt.next := r.next;
rt.x := x; rt.w := r.right - x + 1; rt.right := r.right;
IF x + wleft - 1 < r.right THEN rt.value := 2; ELSE rt.value := 0; END;
r.w := x - r.x; r.right := r.x + r.w - 1; r.value := 2;
r.next := rt; nw:=0; s.maymerge := TRUE;
ELSIF x + wleft - 1 < r.right THEN (* split right *)
NEW(rt);
rt.next := r.next;
rt.x := x + wleft; rt.w := r.right - rt.x + 1; rt.right := r.right; rt.value := 1;
r.w := nw; r.right := r.x + r.w - 1; r.value := 0; s.maymerge := TRUE;
r.next := rt;
ELSE
r.value := 0; s.maymerge := TRUE;
END;
END;
INC(x, nw); DEC(wleft, nw);r := r.next;
END;
END ExclLine;
(** Make a copy of a mask. *)
PROCEDURE Copy*(from: Mask; VAR to: Mask);
VAR r, Tr, Nr: Run; s, Ns, Ts: ScanLine;
BEGIN
NEW(to);
to^ := from^;
IF from.scanline # NIL THEN
s := from.scanline;
NEW(Ns); to.scanline := Ns;
WHILE s # NIL DO
Ns^ := s^; Ns.prev := NIL;
(* copy run *)
r := s.run;
NEW(Nr); Ns.run := Nr;
WHILE r # NIL DO
Nr^ := r^; Nr.prev := NIL;
IF r.next # NIL THEN NEW(Tr); Nr.next := Tr; Nr := Tr;
ELSE Nr.next := NIL;
END;
r := r.next;
END;
(* end copy run *)
IF s.next # NIL THEN NEW(Ts); Ns.next := Ts; Ns := Ts;
ELSE Ns.next := NIL;
END;
s := s.next;
END
END
END Copy;
(** Add the rectangle X, Y, W, H as a visible/drawable area to the mask. *)
PROCEDURE Add*(M: Mask; X, Y, W, H: INTEGER);
VAR hleft, nh: INTEGER; s: ScanLine;
BEGIN
X := X - M.x; Y := Y - M.y; (* adjust for offset *)
IF M.simple THEN
IF M.sW + M.sH = 0 THEN
M.sX := X; M.sY := Y; M.sW := W; M.sH := H;
RETURN;
ELSE
M.simple := FALSE; Open0(M);
compactionflag := FALSE;
Add(M, M.sX + M.x, M.sY + M.y, M.sW, M.sH);
compactionflag := TRUE;
END;
END;
hleft := H;
s := M.scanline; WHILE s # NIL DO s.maymerge := FALSE; s := s.next; END;
s := M.scanline;
WHILE s.top < Y DO s := s.next; END;
WHILE hleft > 0 DO
nh := Min(s.top - Y + 1, hleft);
DoLine(s, X, Y, W, nh);
INC(Y, nh);
DEC(hleft, nh);
s := s.next;
END;
Compact(M);
END Add;
(** Clip the current clipping port of the mask to the rectangle X, Y, W, H. The result is an updated clipping port. *)
PROCEDURE AdjustMask*(M: Mask; X, Y, W, H: INTEGER);
BEGIN
ClipAgainst(X, Y, W, H, M.X, M.Y, M.W, M.H);
M.X := X; M.Y := Y; M.W := W; M.H := H
END AdjustMask;
(** Remove area X, Y, W, H from the mask i.e. make area undrawable. *)
PROCEDURE Subtract*(M: Mask; X, Y, W, H: INTEGER);
VAR hleft, nh: INTEGER;s: ScanLine;
BEGIN
IF M.simple THEN
M.simple := FALSE; Open0(M);
compactionflag := FALSE;
Add(M, M.x + M.sX, M.y + M.sY, M.sW, M.sH);
compactionflag := TRUE;
END;
X := X - M.x; Y := Y - M.y;
hleft := H;
s := M.scanline; WHILE s # NIL DO s.maymerge := FALSE; s := s.next; END;
s := M.scanline;
WHILE s.top < Y DO s := s.next; END;
WHILE hleft > 0 DO
nh := Min(s.top - Y + 1, hleft);
ExclLine(s, X, Y, W, nh);
INC(Y, nh);
DEC(hleft, nh);
s := s.next;
END;
Compact(M);
END Subtract;
(** Interset the mask with the rectangle X, Y, W, H. The visible areas are restricted to this rectangle. *)
PROCEDURE Intersect*(M: Mask; X, Y, W, H: INTEGER);
BEGIN
IF M.simple THEN
X := X - M.x; Y := Y - M.y;
Clip(M, X, Y, W, H); M.sX := X; M.sY := Y; M.sW := W; M.sH := H
ELSE
Subtract(M, -maxcoord, -maxcoord, 2*maxcoord + 1, Y + maxcoord (*+ 1*));
Subtract(M, -maxcoord, Y+H, 2*maxcoord + 1, maxcoord - (Y+H) + 1);
Subtract(M, -maxcoord, Y, X + maxcoord (*+ 1*), H);
Subtract(M, X+W, Y, maxcoord - (X+W) , H)
END
END Intersect;
PROCEDURE *IntersectMasks1(x, y, w, h: INTEGER);
BEGIN
IF typ = add THEN Add(bM, x, y, w, h) ELSIF typ = subtract THEN Subtract(bM, x, y, w, h) END;
END IntersectMasks1;
PROCEDURE *IntersectMasks0(X, Y, W, H: INTEGER);
BEGIN EnumRect(aM, X, Y, W, H, IntersectMasks1);
END IntersectMasks0;
(** Intersect the masks A and B resulting in R. *)
PROCEDURE IntersectMasks*(A, B: Mask; VAR R: Mask); (** R is an out parameter only *)
BEGIN
IF (A = NIL) OR (B = NIL) THEN R := NIL
ELSE
NEW(R); Open(R); R.x := A.x; R.y := A.y;
aM := B; bM := R; typ := add; Enum(A, IntersectMasks0); aM := NIL; bM := NIL
END;
END IntersectMasks;
(** Subtracts the visible areas of B from A to give mask R. *)
PROCEDURE SubtractMasks*(A, B: Mask; VAR R: Mask);
BEGIN
IF (A = NIL) OR (B = NIL) THEN R := NIL
ELSE
Copy(A, R); aM := A; bM := R; typ := subtract; Enum(B, IntersectMasks0); aM := NIL; bM := NIL
END;
END SubtractMasks;
(** Translate the mask so that the resulting origin/offset is 0, 0. This is done by "adding in" the translation vector. *)
PROCEDURE Shift*(M: Mask);
VAR s, first, last: ScanLine; r, f, l: Run;
BEGIN
IF M # NIL THEN
IF M.simple THEN INC(M.sX, M.x); INC(M.sY, M.y);
ELSIF (M.x # 0) OR (M.y # 0) THEN
s := M.scanline; first := s;
WHILE s # NIL DO
INC(s.y, M.y); INC(s.top, M.y);
r := s.run; f := r;
WHILE r # NIL DO
INC(r.x, M.x); INC(r.right, M.x);
l := r; r := r.next
END;
f.x := -maxcoord; l.right := maxcoord; (* ! *)
f.w := f.right - f.x + 1; l.w := l.right - l.x + 1; (* ! *)
last := s; s := s.next;
END;
first.y := -maxcoord; last.top := maxcoord; (* ! *)
first.h := first.top - first.y + 1; last.h := last.top - last.y + 1; (* ! *)
END;
M.x := 0; M.y := 0;
END;
END Shift;
(** Returns TRUE if the visible areas of the mask form a single rectangle. The result, when TRUE, is returned. The clipping port is not taken into account. *)
PROCEDURE Rectangular*(M: Mask; VAR X, Y, W, H: INTEGER): BOOLEAN;
BEGIN
X := M.x + M.sX; Y := M.y + M.sY; W := M.sW; H := M.sH;
RETURN M.simple
END Rectangular;
(* --------- CopyMask ---- *)
(** Using Display.CopyBlock, copy the area M to position X, Y. The point M.x, M.y is copied to screen coordinates X, Y. *)
PROCEDURE CopyMask*(M: Mask; X, Y: INTEGER; mode: INTEGER);
VAR s, sp: ScanLine; r, rp: Run; rruns, rscans: BOOLEAN;
BEGIN
IF M.simple THEN
Display.CopyBlock(M.x + M.sX, M.y + M.sY, M.sW, M.sH, X + M.sX, Y + M.sY, mode)
ELSE
rruns := X > M.x; rscans := Y > M.y;
IF rscans THEN
s := M.scanline; sp := NIL;
WHILE s # NIL DO
s.prev := sp; sp := s; s := s.next
END;
s := sp
ELSE s := M.scanline
END;
WHILE s # NIL DO
IF rruns THEN
r := s.run; rp := NIL;
WHILE r # NIL DO
r.prev := rp; rp := r; r := r.next;
END;
r := rp;
WHILE r # NIL DO
IF r.value > 0 THEN
Display.CopyBlock(M.x + r.x, M.y + s.y, r.w, s.h, X + r.x, Y + s.y, mode)
END;
r := r.prev;
END;
ELSE
r := s.run;
WHILE r # NIL DO
IF r.value > 0 THEN
Display.CopyBlock(M.x + r.x, M.y + s.y, r.w, s.h, X + r.x, Y + s.y, mode);
END;
r := r.next;
END;
END;
IF ~rscans THEN s := s.next ELSE s := s.prev END;
END
END;
END CopyMask;
(** Display.ReplConst through a mask. *)
PROCEDURE ReplConst*(M: Mask; col: Display.Color; X, Y, W, H, mode: INTEGER);
VAR hleft, wleft, nw, nh, x, y, X0 : INTEGER; s : ScanLine; r : Run;
BEGIN
IF M = NIL THEN Display.ReplConst(col, X, Y, W, H, mode);
ELSIF M.simple THEN
ClipAgainst(X, Y, W, H, M.X, M.Y, M.W, M.H);
ClipAgainst(X, Y, W, H, M.x + M.sX, M.y + M.sY, M.sW, M.sH);
Display.ReplConst(col, X, Y, W, H, mode);
ELSE
ClipAgainst(X, Y, W, H, M.X, M.Y, M.W, M.H);
x := M.x; y := M.y;
hleft := H;
s := M.scanline;
WHILE s.top + y < Y DO s := s.next; END;
X0 := X;
WHILE hleft > 0 DO
nh := Min(s.top + y - Y + 1, hleft);
r := s.run; WHILE r.right + x < X DO r := r.next END;
wleft := W;
WHILE wleft > 0 DO
nw := r.right + x - X + 1;
IF wleft < nw THEN nw := wleft END;
IF r.value > 0 THEN Display.ReplConst(col, X, Y, nw, nh, mode); END;
INC(X, nw); DEC(wleft, nw);
r := r.next;
END;
INC(Y, nh); DEC(hleft, nh);
s := s.next; r := NIL; X := X0;
END
END
END ReplConst;
(** Is this rectangle completely visible? The clipping port is taken into acount. **)
PROCEDURE Visible*(M: Mask; X, Y, W, H : INTEGER) : BOOLEAN;
VAR x, y, X0, hleft, wleft, nh, nw: INTEGER; s: ScanLine; r: Run;
BEGIN
IF M = NIL THEN RETURN TRUE
ELSIF (X < M.X) OR (Y < M.Y) OR (X + W > M.X + M.W) OR (Y + H > M.Y + M.H ) THEN RETURN FALSE
ELSIF M.simple THEN x := M.x; y := M.y;
RETURN (X >= M.sX + x) & (Y >= M.sY + y) & (X + W <= M.sX + M.sW + x) & (Y + H <= M.sY + M.sH + y)
ELSE
(* jm mod *)
DEC(X, M.x); DEC(Y, M.y); (* eos: shift rectangle into local mask coords *)
s := M.scanline;
WHILE s.top < Y DO s := s.next END;
hleft := H;
X0 := X;
WHILE hleft > 0 DO
nh := Min(s.top - Y + 1, hleft);
r := s.run;
WHILE r.right < X DO r := r.next END;
wleft := W;
WHILE wleft > 0 DO
IF r.value = 0 THEN RETURN FALSE END; (*gs*)
nw := r.right - X + 1;
IF wleft < nw THEN nw := wleft END;
INC(X, nw); DEC(wleft, nw);
r := r.next
END;
INC(Y, nh); DEC(hleft, nh);
s := s.next; X := X0
END;
RETURN TRUE
END
END Visible;
(** Display.Dot through a clipping mask. *)
PROCEDURE Dot*(M: Mask; col: Display.Color; X, Y, mode: INTEGER);
VAR x, y: INTEGER; s: ScanLine; r: Run;
BEGIN
IF M = NIL THEN Display.Dot(col, X, Y, mode)
ELSIF M.simple THEN
x := M.x; y := M.y;
IF (X >= M.X) & (Y >= M.Y ) & (X < M.X + M.W ) & (Y < M.Y + M.H) THEN
IF (X >= M.sX + x) & (Y >= M.sY + y) & (X < M.sX + M.sW + x) & (Y < M.sY + M.sH + y) THEN
Display.Dot(col, X, Y, mode)
END
END
ELSE
IF (X >= M.X) & (Y >= M.Y ) & (X < M.X + M.W ) & (Y < M.Y + M.H) THEN
x := M.x; y := M.y;
s := M.scanline;
WHILE s.top + y < Y DO s := s.next; END;
r := s.run;
WHILE r.right + x < X DO r := r.next; END;
IF r.value > 0 THEN Display.Dot(col, X, Y, mode) END
END
END
END Dot;
(** Display.FillPattern through a clipping mask. pX, pY is the pattern pin-point. *)
PROCEDURE FillPattern*(M: Mask; col: Display.Color; pat: Display.Pattern; pX, pY, X, Y, W, H, mode: INTEGER);
VAR hleft, nh, wleft, nw, x, y, X0 : INTEGER; s: ScanLine; r : Run;
BEGIN
IF pat = Display.solid THEN ReplConst(M, col, X, Y, W, H, mode); RETURN END;
IF M = NIL THEN Display.FillPattern(col, pat, pX, pY, X, Y, W, H, mode)
ELSIF M.simple THEN
ClipAgainst(X, Y, W, H, M.X, M.Y, M.W, M.H);
ClipAgainst(X, Y, W, H, M.x + M.sX, M.y + M.sY, M.sW, M.sH);
Display.FillPattern(col, pat, pX, pY, X, Y, W, H, mode);
ELSE
ClipAgainst(X, Y, W, H, M.X, M.Y, M.W, M.H);
x := M.x; y := M.y;
s := M.scanline;
WHILE s.top + y < Y DO s := s.next; END;
hleft := H; X0 := X;
WHILE hleft > 0 DO
nh := s.top + M.y - Y + 1; IF hleft < nh THEN nh := hleft END;
r := s.run; WHILE r.right + x < X DO r := r.next END;
wleft := W;
WHILE wleft > 0 DO
nw := r.right + x - X + 1; IF wleft < nw THEN nw := wleft END;
IF r.value > 0 THEN Display.FillPattern(col, pat, pX, pY, X,Y, nw, nh, mode); END;
INC(X, nw);
DEC(wleft, nw);
r := r.next;
END;
INC(Y, nh);
DEC(hleft, nh);
s := s.next; r := NIL; X := X0;
END;
END;
END FillPattern;
(** Same as Display.CopyPattern, but through a clipping mask. *)
PROCEDURE CopyPattern*(M: Mask; col: Display.Color; pat: Display.Pattern; X, Y, mode: INTEGER);
VAR W, H, X0, hleft, wleft, nw, nh, ax, ay, cx, cy, cw, ch, x, y : INTEGER; s: ScanLine; r: Run;
BEGIN
Display.GetDim(pat,W,H);
IF (M = NIL) OR Visible(M,X,Y,W,H) THEN Display.CopyPattern(col, pat, X, Y, mode)
ELSIF (X >= M.X + M.W) OR (X + W <= M.X) OR (Y >= M.Y + M.H) OR (Y + H <= M.Y) THEN (* skip *)
ELSIF M.simple THEN
Display.SetClip(M.X, M.Y, M.W, M.H);
Display.AdjustClip(M.sX+M.x, M.sY+M.y, M.sW, M.sH);
Display.CopyPattern(col, pat, X, Y, mode);
Display.ResetClip;
ELSE
ax := X; ay := Y;
Display.SetClip(M.X, M.Y, M.W, M.H);
Display.GetClip(cx, cy, cw, ch);
x := M.x; y := M.y;
s := M.scanline;
WHILE s.top + y < Y DO s := s.next; END;
hleft := H; X0 := X;
WHILE hleft > 0 DO
nh := Min(s.top + M.y - Y + 1, hleft);
r := s.run; WHILE r.right + x < X DO r := r.next END;
wleft := W;
WHILE wleft > 0 DO
nw := r.right + x - X + 1; IF wleft < nw THEN nw := wleft END;
IF r.value > 0 THEN
Display.AdjustClip(r.x+x, s.y+y, r.w, s.h);
Display.CopyPattern(col, pat, ax, ay, mode);
Display.SetClip(cx, cy, cw, ch)
END;
INC(X, nw);
DEC(wleft, nw);
r := r.next
END;
INC(Y, nh);
DEC(hleft, nh);
s := s.next; r := NIL; X := X0
END;
Display.ResetClip
END
END CopyPattern;
(* ---------- Extra output primitives -------- *)
(** Draw rectangle outline in the specified size, line width and pattern. *)
PROCEDURE Rect*(M: Mask; col: Display.Color; pat: Display.Pattern; X, Y, W, H, width, mode: INTEGER);
VAR mX,mW : INTEGER;
BEGIN
width := Min(width, Min(H DIV 2, W DIV 2));
FillPattern(M, col, pat, X, Y, X, Y, width, H, mode);
FillPattern(M, col, pat, X, Y, X + W - width, Y, width, H, mode);
IF (X < Display.Width) & (X + W >= Display.Width) & (M # NIL) & (M.X < Display.Width) & (M.X + M.W >= Display.Width) THEN
mX := M.X; mW := M.W;
M.W := Display.Width - M.X;
FillPattern(M, col, pat, X, Y, X + width, Y, W - 2 * width, width, mode);
FillPattern(M, col, pat, X, Y, X + width, Y + H - width, W - 2 * width, width, mode);
M.W := mW - M.W; M.X := Display.Width;
FillPattern(M, col, pat, X, Y, X + width, Y, W - 2 * width, width, mode);
FillPattern(M, col, pat, X, Y, X + width, Y + H - width, W - 2 * width, width, mode);
M.X := mX; M.W := mW
ELSE
FillPattern(M, col, pat, X, Y, X + width, Y, W - 2 * width, width, mode);
FillPattern(M, col, pat, X, Y, X + width, Y + H - width, W - 2 * width, width, mode)
END
END Rect;
(** Draw rectangle outline in width using top and bottom shadow (3D effects ).*)
PROCEDURE Rect3D*(M: Mask; topcol, botcol: Display.Color; X, Y, W, H, width, mode: INTEGER);
BEGIN
width := Min(width, Min(H DIV 2, W DIV 2));
WHILE width > 0 DO
ReplConst(M, botcol, X, Y, W, 1,mode);
ReplConst(M, topcol, X, Y + H - 1, W, 1, mode);
ReplConst(M, topcol, X, Y, 1, H, mode);
ReplConst(M, botcol, X + W - 1, Y, 1, H, mode);
DEC(width); INC(X); INC(Y); DEC(W, 2); DEC(H, 2)
END
END Rect3D;
(** Fill rectangle with 3D shadow effects. incol specifies the "inside" color. *)
PROCEDURE FilledRect3D*(M: Mask; topcol, botcol, incol: Display.Color; X, Y, W, H, width, mode: INTEGER);
BEGIN
width := Min(width, Min(H DIV 2, W DIV 2));
WHILE width > 0 DO
ReplConst(M, botcol, X, Y, W, 1,mode);
ReplConst(M, topcol, X, Y + H - 1, W, 1, mode);
ReplConst(M, topcol, X, Y, 1, H, mode);
ReplConst(M, botcol, X + W - 1, Y, 1, H, mode);
DEC(width); INC(X); INC(Y); DEC(W, 2); DEC(H, 2)
END;
ReplConst(M, incol, X , Y, W, H, mode)
END FilledRect3D;
(* BRUSHES *)
PROCEDURE BrushJump(VAR b: Brush; x, y: INTEGER);
VAR i: INTEGER;
BEGIN
IF (b.x # x) OR (b.y # y) THEN
b.x := x; b.y := y;
FOR i := 0 TO b.bufh - 1 DO b.bufl[i] := b.brul[i] + b.x; b.bufr[i] := b.brur[i] + b.x END
END
END BrushJump;
PROCEDURE BrushWalk(VAR b: Brush; x, y: INTEGER);
VAR i, dx, dy, t: INTEGER;
BEGIN
dx := x - b.x; dy := y - b.y; t := b.bufh - 1;
IF dy = 0 THEN (* horizontal move *)
IF dx < 0 THEN
FOR i := 0 TO t DO b.bufl[i] := Min(b.bufl[i], b.brul[i] + x) END
ELSIF dx > 0 THEN
FOR i := 0 TO t DO b.bufr[i] := Max(b.bufr[i], b.brur[i] + x) END
END
ELSIF dy > 0 THEN (* up *)
FillPattern(b.M, b.col, b.pat, 0, 0, b.bufl[0], b.y - b.brushr, b.bufr[0] - b.bufl[0] + 1, 1, b.mode);
FOR i := 0 TO b.bufh - 2 DO
b.bufl[i] := Min(b.bufl[i+1], b.brul[i] + x); b.bufr[i] := Max(b.bufr[i+1], b.brur[i] + x);
END;
b.bufl[t] := b.brul[t] + x; b.bufr[t] := b.brur[t] + x
ELSE (* dy < 0 *) (* down *)
FillPattern(b.M, b.col, b.pat, 0, 0,
b.bufl[t], b.y - b.brushr + b.bufh-1, b.bufr[t] - b.bufl[t] + 1, 1, b.mode);
FOR i := b.bufh - 1 TO 1 BY -1 DO
b.bufl[i] := Min(b.bufl[i-1], b.brul[i] + x); b.bufr[i] := Max(b.bufr[i-1], b.brur[i] + x);
END;
b.bufl[0] := b.brul[0] + x; b.bufr[0] := b.brur[0] + x;
END;
b.x := x; b.y := y
END BrushWalk;
PROCEDURE BrushFlush(VAR b: Brush);
VAR i: INTEGER;
BEGIN
FOR i := 0 TO b.bufh - 1 DO
FillPattern(b.M, b.col, b.pat, 0, 0,
b.bufl[i], b.y + i - b.brushr, b.bufr[i] - b.bufl[i] + 1, 1, b.mode);
END
END BrushFlush;
PROCEDURE InitBrush(VAR b: Brush; M: Mask; pat: Display.Pattern; col: Display.Color; w, mode: INTEGER);
VAR r, x, y, d, dx, dy: INTEGER;
PROCEDURE Set(x, y: INTEGER);
BEGIN
b.brul[y + r] := -x+1; b.brur[y + r] := x; b.brul[-y + r] := -x+1; b.brur[-y + r] := x;
IF y + r > b.bufh THEN b.bufh := y + r END
END Set;
BEGIN b.bufh := 0;
b.M := M; b.col := col; b.mode := mode; b.pat := pat;
IF w >= BrushSize THEN w := BrushSize - 1 END;
b.x := MIN(INTEGER); b.y := MIN(INTEGER);
r := w DIV 2; (* radius *)
IF r < 0 THEN r := 1 END;
x := r; y := 0; d := 2 * r; dx := 4 * r; dy := 0;
Set(x, y);
WHILE y # r DO
WHILE d <= 1 DO DEC(x); DEC(dx, 4); INC(d, dx) END;
INC(y); Set(x, y); INC(dy, 4); DEC(d, dy);
END;
b.brushr := r; INC(b.bufh)
END InitBrush;
(* --------------------- Scan line based primitives --------------------- *)
(** Draw a line in the specified pattern and width. Round brushes are used to draw thick lines. *)
PROCEDURE Line*(M: Mask; col: Display.Color; pat: Display.Pattern; X, Y, X1, Y1, width, mode: INTEGER);
VAR x, y, dx, dy, inx, iny, d, dy2, dx2: INTEGER;
BEGIN
dx := width DIV 2; dx2 := width + 1;
IF Visible(M, Min(X, X1)-dx, Min(Y, Y1)-dx, ABS(X1-X)+dx2, ABS(Y1-Y)+dx2) THEN M := NIL END;
x := X; y := Y; dx := X1 - X; dy := Y1 - Y;
IF width > 1 THEN
IF drawingPolygon THEN
ELSE InitBrush(brush, M, pat, col, width, mode); BrushJump(brush, x, y)
END;
IF ABS(dy) > ABS(dx) THEN
d := -ABS(dx); dy2 := 2 * ABS(dy); dx2 := 2 * ABS(dx);
IF dx < 0 THEN inx := -1; ELSE inx := 1; END;
IF dy < 0 THEN iny := -1; ELSE iny := 1; END;
WHILE y # Y1 DO
INC(y, iny);
INC(d, dx2);
IF d > 0 THEN INC(x, inx); DEC(d, dy2); END;
BrushWalk(brush, x, y);
END;
ELSE
d := -ABS(dx); dy2 := 2 * ABS(dy); dx2 := 2 * ABS(dx);
IF dx < 0 THEN inx := -1; ELSE inx := 1; END;
IF dy < 0 THEN iny := -1; ELSE iny := 1; END;
WHILE x # X1 DO
INC(x, inx);
INC(d, dy2);
IF d > 0 THEN INC(y, iny); DEC(d, dx2); END;
BrushWalk(brush, x, y);
END;
END;
IF ~drawingPolygon THEN BrushFlush(brush) END;
ELSE
IF ABS(dy) > ABS(dx) THEN
d := -ABS(dx); dy2 := 2 * ABS(dy); dx2 := 2 * ABS(dx);
IF dx < 0 THEN inx := -1; ELSE inx := 1; END;
IF dy < 0 THEN iny := -1; ELSE iny := 1; END;
WHILE y # Y1 DO
INC(y, iny);
INC(d, dx2);
IF d > 0 THEN INC(x, inx); DEC(d, dy2); END;
IF pat = Display.solid THEN Dot(M, col, x, y, mode)
ELSE FillPattern(M, col, pat, 0, 0, x, y, 1, 1, mode)
END
END;
ELSE
d := -ABS(dx); dy2 := 2 * ABS(dy); dx2 := 2 * ABS(dx);
IF dx < 0 THEN inx := -1; ELSE inx := 1; END;
IF dy < 0 THEN iny := -1; ELSE iny := 1; END;
WHILE x # X1 DO
INC(x, inx);
INC(d, dy2);
IF d > 0 THEN INC(y, iny); DEC(d, dx2); END;
IF pat = Display.solid THEN Dot(M, col, x, y, mode)
ELSE FillPattern(M, col, pat, 0, 0, x, y, 1, 1, mode)
END
END
END
END
END Line;
PROCEDURE FilledPoly(M: Mask; col: Display.Color; pat: Display.Pattern; VAR X, Y: ARRAY OF INTEGER; n, mode: INTEGER);
TYPE
Run = POINTER TO RunDesc0;
RunDesc0 = RECORD next: Run; x: INTEGER END;
VAR
scan: ARRAY 2000 OF Run; free, s: Run;
i, miny, maxy, x0, x1: INTEGER;
PROCEDURE New(VAR s: Run);
BEGIN IF free = NIL THEN NEW(s) ELSE s := free; free := free.next; s.next := NIL END
END New;
PROCEDURE Free(VAR s: Run);
VAR s0: Run;
BEGIN
IF s # NIL THEN
s0 := s; WHILE s0.next # NIL DO s0 := s0.next END;
s0.next := free; free := s; s := NIL
END
END Free;
PROCEDURE Insert(VAR s: Run; x: INTEGER);
VAR t, t0: Run;
BEGIN
IF s = NIL THEN New(s); s.x := x
ELSE
New(t); t.x := x;
IF x < s.x THEN t.next := s; s := t
ELSE t0 := s;
WHILE (t0.next # NIL) & (t0.next.x < x) DO t0 := t0.next END;
IF t0.next = NIL THEN t0.next := t
ELSE t.next := t0.next; t0.next := t
END
END
END
END Insert;
PROCEDURE line(x1, y1, x2, y2: INTEGER); (* standard bresenham *)
VAR x, y, d, dx, dy, incx, incy: INTEGER;
BEGIN
(* Seg(x1,y1); *)
x := x1; y := y1; dx := (x2 - x1) * 2; dy := (y2 - y1) * 2;
incx := 0;
IF dx < 0 THEN incx := -1; dx := -dx;
ELSIF dx >0 THEN incx := 1
END;
incy := 0;
IF dy < 0 THEN incy := -1; dy := -dy ELSIF dy > 0 THEN incy := 1 END;
d := incx * (x1 - x2);
WHILE y # y2 DO
INC(y, incy); INC(d, dx);
WHILE d > 0 DO INC(x, incx); DEC(d, dy) END;
IF incy > 0 THEN Insert(scan[y], x) ELSE Insert(scan[y+1], x) END
END
END line;
BEGIN free := NIL;
miny := MAX(INTEGER); maxy := MIN(INTEGER);
i := 0; WHILE i < n DO IF Y[i] < miny THEN miny := Y[i] END; IF Y[i] > maxy THEN maxy := Y[i]; END; INC(i) END;
i := 0; WHILE i <= maxy - miny DO scan[i] := NIL; INC(i) END;
i := 1;
WHILE i < n DO
line(X[i - 1], Y[i - 1] - miny, X[i], Y[i] - miny); INC(i)
END;
line(X[n - 1], Y[n - 1] - miny, X[0], Y[0] - miny);
i := 0;
WHILE i <= maxy - miny DO
s := scan[i];
WHILE s # NIL DO
x0 := s.x; s := s.next;
IF s = NIL THEN x1 := x0 ELSE x1 := s.x; s := s.next END;
FillPattern(M, col, pat, 0, 0, x0, i + miny, x1 - x0 + 1, 1, mode)
END;
Free(scan[i]);
INC(i)
END
END FilledPoly;
(** Draw a polygon in pattern pat. n specifies the number of vertices listed in the arrays X and Y. Style may be {filled}. *)
PROCEDURE Poly*(M: Mask; col: Display.Color; pat: Display.Pattern; VAR X, Y: ARRAY OF INTEGER; n, width: INTEGER; style: SET; mode: INTEGER);
VAR i: INTEGER;
BEGIN
IF filled IN style THEN FilledPoly(M, col, pat, X, Y, n, mode)
ELSE
drawingPolygon := TRUE;
IF width > 1 THEN InitBrush(brush, M, pat, col, width, mode); BrushJump(brush, X[0], Y[0]) END;
i := 0;
WHILE i < n - 1 DO
Line(M, col, pat, X[i], Y[i], X[i+1], Y[i+1], width, mode); INC(i)
END;
drawingPolygon := FALSE;
IF width > 1 THEN BrushFlush(brush) END
END
END Poly;
(** Draw an ellipse. Implementation restriction: cannot fill an ellipse or draw an ellipse with line width > 1 *)
PROCEDURE Ellipse*(M: Mask; col: Display.Color; pat: Display.Pattern; X, Y, a, b, width: INTEGER; style: SET; mode: INTEGER);
VAR x1, y1: INTEGER; d, dx, dy, x2, y2, a1, a2, a8, b1, b2, b8: LONGINT;
PROCEDURE Dot4(x1, x2, y1, y2: INTEGER);
BEGIN
IF pat = Display.solid THEN
Dot(M, col, x1, y1, mode); Dot(M, col, x1, y2, mode);
Dot(M, col, x2, y1, mode); Dot(M, col, x2, y2, mode)
ELSE
FillPattern(M, col, pat, 0, 0, x1, y1, 1, 1, mode); FillPattern(M, col, pat, 0, 0, x1, y2, 1, 1, mode);
FillPattern(M, col, pat, 0, 0, x2, y1, 1, 1, mode); FillPattern(M, col, pat, 0, 0, x2, y2, 1, 1, mode)
END
END Dot4;
BEGIN
IF Visible(M, X - a, Y - b, 2 * a + 1, 2 * b + 1) THEN M := NIL END;
IF (a < 600) & (b < 600) THEN
a1 := a; a2 := a1*a1; a8 := 8*a2; b1 := b; b2 := b1*b1; b8 := 8*b2;
x1 := a; y1 := 0; x2 := a1*b2; y2 := 0; dx := b8*(a1-1); dy := 4*a2; d := b2*(1- 4*a1);
WHILE y2 < x2 DO
Dot4(X-x1(*-1*), X+x1, Y-y1(*-1*), Y+y1);
INC(d, dy); INC(dy, a8); INC(y1); INC(y2, a2);
IF d >= 0 THEN DEC(d, dx); DEC(dx, b8); DEC(x1); DEC(x2, b2) END
END;
INC(d, 4*(x2+y2)-b2+a2);
WHILE x1 >= 0 DO
Dot4(X-x1(*-1*), X+x1, Y-y1(*-1*), Y+y1);
DEC(d, dx); DEC(dx, b8); DEC(x1);
IF d < 0 THEN INC(d, dy); INC(dy, a8); INC(y1) END
END;
END
END Ellipse;
(** Draw a circle in radius r using pattern pat at position X, Y. Thick line widths are allowed. *)
PROCEDURE Circle*(M: Mask; col: Display.Color; pat: Display.Pattern; X, Y, r, width: INTEGER; style: SET; mode: INTEGER);
VAR x, y, dx, dy, d, e: INTEGER;
BEGIN
IF filled IN style THEN
IF Visible(M, X - r, Y - r, 2 * r + 1, 2 * r + 1) THEN M := NIL END;
x := r; y := 0; e := 0; dx := 2; dy := 2;
WHILE y <=x DO
FillPattern(M, col, pat, X, Y, X - x, Y + y, 2 * x + 1, 1, mode);
FillPattern(M, col, pat, X, Y, X - x, Y - y, 2 * x + 1, 1, mode);
INC(y);
INC(e, y * dy - 1);
IF e > x THEN
DEC(x); DEC(e, x * dx + 1);
FillPattern(M, col, pat, X, Y, X - y, Y + x, 2* y + 1, 1, mode);
FillPattern(M, col, pat, X, Y, X - y, Y - x, 2 * y + 1, 1, mode)
END
END
ELSIF width > 1 THEN
d := r + (width + 1) DIV 2;
IF Visible(M, X - d, Y - d, 2*d + 1, 2*d + 1) THEN M := NIL END;
x := X + r; y := Y;
InitBrush(brush, M, pat, col, width, mode); BrushJump(brush, x, y);
d := 2* r; dx := 4* r; dy := 0;
WHILE y # Y + r DO
WHILE d <= 1 DO DEC(x); BrushWalk(brush, x, y); DEC(dx,4); INC(d,dx) END;
INC(y); BrushWalk(brush, x, y); INC(dy,4); DEC(d,dy);
END;
WHILE x # X DO DEC(x); BrushWalk(brush, x, y); DEC(dx,4); INC(d,dx) END;
d := -d;
WHILE x # X - r DO
WHILE d <= 1 DO DEC(y); BrushWalk(brush,x,y); DEC(dy,4); INC(d,dy) END;
DEC(x); BrushWalk(brush,x,y); INC(dx,4); DEC(d,dx);
END;
WHILE y # Y DO DEC(y); BrushWalk(brush,x,y); DEC(dy,4); INC(d,dy) END;
d := -d;
WHILE y # Y - r DO
WHILE d <= 1 DO INC(x); BrushWalk(brush,x,y); DEC(dx,4); INC(d,dx) END;
DEC(y); BrushWalk(brush,x,y); INC(dy,4); DEC(d,dy);
END;
WHILE x # X DO INC(x); BrushWalk(brush,x,y); DEC(dx,4); INC(d,dx) END;
d := -d;
WHILE x # X + r DO
WHILE d <= 1 DO INC(y); BrushWalk(brush,x,y); DEC(dy,4); INC(d,dy) END;
INC(x); BrushWalk(brush,x,y); INC(dx,4); DEC(d,dx);
END;
WHILE y # Y DO INC(y); BrushWalk(brush,x,y); DEC(dy,4); INC(d,dy) END;
BrushFlush(brush)
ELSE
(*IF Visible(M, X - r, Y - r, 2 * r + 1, 2 * r + 1) THEN M := NIL END;*)
Ellipse(M, col, pat, X, Y, r, r, width, style, mode)
END
END Circle;
(* ---- end of scanline primitives ---- *)
(** Draw string s in font fnt and color col at position X, Y. *)
PROCEDURE String*(M: Mask; col: Display.Color; X, Y: INTEGER; fnt: Fonts.Font; s: ARRAY OF CHAR; mode: INTEGER);
VAR r: Objects.Object; p: INTEGER;
BEGIN
p := 0;
WHILE s[p] # 0X DO
fnt.GetObj(fnt,ORD(s[p]),r);
WITH r: Fonts.Char DO
CopyPattern(M, col, r.pat, X + r.x, Y + r.y, mode);
INC(X, r.dx); INC(p)
END
END
END String;
(** Draw a string s in font fnt centered in the rectangle X, Y, W, H. Line breaks will be inserted as needed. *)
PROCEDURE CenterString*(M: Mask; col: Display.Color; X, Y, W, H: INTEGER; fnt: Fonts.Font; s: ARRAY OF CHAR; mode: INTEGER);
VAR len, p, h, lspc, i, y: INTEGER; r: Objects.Object; s0: ARRAY 64 OF CHAR;
BEGIN
len := 0; p := 0;
WHILE (s[p] # 0X) DO
fnt.GetObj(fnt, ORD(s[p]), r);
INC(p); INC(len, r(Fonts.Char).dx)
END;
IF len < W - 4 THEN (* normal print *)
String(M, col, (W - len) DIV 2 + X, Y + H DIV 2 - fnt.height DIV 2 + ABS(fnt.minY), fnt, s, mode)
ELSE (* formatted print *)
p := 0; len := 0; h := 0; lspc := -1;
WHILE s[p] # 0X DO
fnt.GetObj(fnt, ORD(s[p]), r);
IF len + r(Fonts.Char).dx >= W THEN (* too long next line *)
IF s[p] = " " THEN lspc := -1; s[p] := 1X; INC(h, fnt.height); len := 0
ELSIF lspc > 0 THEN (* space exists *) p := lspc; lspc := -1; s[p] := 1X; INC(h, fnt.height); len := 0
ELSE INC(len, r(Fonts.Char).dx)
END
ELSE
INC(len, r(Fonts.Char).dx);
IF s[p] = " " THEN lspc := p END
END;
INC(p)
END; INC(h, fnt.height);
(* print *)
p := 0; i := 0; len := 0; y := Y + H DIV 2 + h DIV 2 + ABS(fnt.minY);
WHILE s[p] # 0X DO
fnt.GetObj(fnt, ORD(s[p]), r);
IF s[p] = 1X THEN (* break *)
s0[i] := 0X; i := 0; DEC(y, fnt.height);
String(M, col, X + W DIV 2 - len DIV 2, y, fnt, s0, mode);
len := 0
ELSE
fnt.GetObj(fnt, ORD(s[p]), r);
INC(len, r(Fonts.Char).dx);
s0[i] := s[p]; INC(i)
END;
INC(p)
END; DEC(y, fnt.height);
IF i > 0 THEN s0[i] := 0X;
String(M, col, X + W DIV 2 - len DIV 2, y, fnt, s0, mode)
END
END
END CenterString;
(** Return the size of a string in width w and height h. dsr returns the baseline offset as a positive value. *)
PROCEDURE StringSize*(s: ARRAY OF CHAR; fnt: Fonts.Font; VAR w, h, dsr: INTEGER);
VAR p: INTEGER; r: Objects.Object;
BEGIN
w := 0; h := fnt.height; dsr := ABS(fnt.minY);
p := 0;
WHILE s[p] # 0X DO
fnt.GetObj(fnt, ORD(s[p]), r); INC(w, r(Fonts.Char).dx);
INC(p)
END
END StringSize;
PROCEDURE *EnumPict(X, Y, W, H: INTEGER);
BEGIN Pictures.DisplayBlock(tmpP, X + dX, Y + dY, W, H, X, Y, tmpM);
END EnumPict;
(** Draw the area X, Y, W, H of picture P at position DX, DY on the display. *)
PROCEDURE Pict*(M: Mask; P: Pictures.Picture; X, Y, W, H, DX, DY, mode: INTEGER);
BEGIN
dX := X - DX; dY :=Y - DY;
ClipAgainst(DX, DY, W, H, M.X, M.Y, M.W, M.H);
tmpP := P; tmpM := mode;
EnumRect(M, DX, DY, W, H, EnumPict);
tmpP := NIL; (* for GC *)
END Pict;
(** Replicate a picture filling area X, Y, W, H on the display. px, py is the picture pin-point. *)
PROCEDURE ReplPict*(M: Mask; P: Pictures.Picture; px, py, X, Y, W, H, mode: INTEGER);
VAR x, y, w, h, pw, ph, w0, x0: INTEGER;
BEGIN
pw := P.width; ph := P.height; w0 := W; x0 := X;
WHILE H > 0 DO
y := (Y - py) MOD ph; h := Min(H, ph - y);
W := w0; X := x0;
WHILE W > 0 DO
x := (X - px) MOD pw; w := Min(W, pw - x);
Pict(M, P, x, y, w, h, X, Y, mode);
INC(X, w); DEC(W, w);
END;
INC(Y, h); DEC(H, h)
END
END ReplPict;
PROCEDURE Init;
VAR s: Texts.Scanner;
BEGIN
Oberon.OpenScanner(s, "Gadgets.Hardlook");
IF ((s.class = Texts.Name) OR (s.class = Texts.String)) & (CAP(s.s[0]) = "Y") THEN
bottomC := Display.FG (* hardlook *)
ELSE
bottomC := 12 (* softlook *)
END
END Init;
BEGIN drawingPolygon := FALSE; selectpat := Display.grey1;
FG := 15; BG := 0;
red := 1; green := 2; blue := 3;
black := Display.FG; white := Display.BG;
IF Display.Depth(0) = 1 THEN
topC := Display.FG;
upC := Display.BG;
downC := Display.BG;
groupC := Display.BG;
invertC := Display.FG;
textC := Display.FG;
textbackC := Display.BG;
bottomC := Display.FG
ELSE
topC := Display.BG;
upC := 13;
downC := 12;
groupC := 13;
IF Display.TrueColor(0) THEN invertC := white ELSE invertC := 3 END;
textC := Display.FG;
textbackC := 14;
Init
END;
textmode := Display.paint
END Display3.
(** Remarks:
1. Clipping Masks
Built on top of the Display module, the Display3 module is the basis of the gadgets imaging model. It extends the Display module with more advanced clipped drawing primitives like lines, polygonal lines, ellipses, circles etc. A clipping mask indicates which areas on the display can be drawn in. You can imagine the mask to be a sheet of paper, possibly full of holes, and a display primitive being a spray can. The holes are all rectangular, and may overlap (i.e. only rectangular holes can be cut out of the paper). Just as you can move the piece of paper to spray an image at a new location, the mask can be translated by a translation vector (also refered to as the mask origin). By default, the holes of a mask are always defined relative to the origin (0, 0). The origin can be translated, efficiently moving the mask to a different position. In the MaskDesc, the fields x, y specify the mask origin/translation vector. It can be changed directly as needed. Internally masks are sets of non-overlapping rectangles, where each rectangle has a flag to indicate if drawing is allowed in that area or not. After each operation that changes the mask, the mask is checked to see if it might be optimal, i.e. if it is a single rectangular visible area. The latter case is handled separately, allowing more efficient drawing and masking operations. The construction of a mask is more heavyweight in comparison to drawing through a mask, mainly due to the latter checks. Masks should be generated once, and then left unchanged for as long as possible.
2. Clipping Ports
Clipping ports are used to optimize masks operations. A clipping port is an absolutely positioned rectangular area through which all display operations are clipped (a clipping rectangle). The mask and clipping port form together the clipped region, where drawing primitives are first clipped to the mask, and then to the clipping port. This is an implementation of the following idea. Each gadget on the display can be overlapped by other visual objects, and potentially need to clip itself when displayed. Each gadget is thus allocated a static clipping mask. In some cases however, only parts of a gadget need to be redisplayed, for example when a gadget lying partially in front is removed. Rather than creating a new clipping mask just for this simple case, the clipping port can manipulated to indicate which "sub-area" of a gadget must be drawn. The key idea is thus to restrict the clipping mask of a gadget without actually changing the mask (a potentially expensive operation). The clipping port is set by the rectangle X, Y, W, H in the MaskDesc. These are absolute display coordinates. Programmers are allowed to manipulate the clipping port directly or use Display3.AdjustMask.
3. OverlapMsg and UpdateMaskMsg
Each gadget has a (cached) display mask associated with it, even if it is completely visible. This mask is used when a gadget wants to draw on the display. Each parent visual gadget (container) has to manage the display masks of its children. The Display3 module provides messages for requesting a mask and for setting a mask. The OverlapMsg informs a gadget of its display mask. It is sent directly to a visual gadget by its parent. After some editing operations it may happen that a gadgets' mask has become invalid, in which case it is set to nothing (NIL). Should the gadget notice that it has no mask when it wants to draw itself, it may broadcast an UpdateMaskMsg to indicate that the parent must create a mask for it (the gadget itself is identified by the F field in the frame message). The latter should then calculate the mask, and inform the gadget using the OverlapMsg. In some cases, a parent can indicate to a child that its mask is not valid any more, by sending an OverlapMsg with no mask (M.M = NIL).
*)