MODULE Properties;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
changes = ""
issues = ""
**)
IMPORT SYSTEM, Kernel, Math, Services, Fonts, Stores, Views, Controllers, Dialog;
CONST
(** StdProp.known/valid **)
color* = 0; typeface* = 1; size* = 2; style* = 3; weight* = 4;
(** SizeProp.known/valid **)
width* = 0; height* = 1;
(** PollVerbsMsg limitation **)
maxVerbs* = 16;
(** PollPickMsg.mark, PollPick mark **)
noMark* = FALSE; mark* = TRUE;
(** PollPickMsg.show, PollPick show **)
hide* = FALSE; show* = TRUE;
TYPE
Property* = POINTER TO ABSTRACT RECORD
next-: Property; (** property lists are sorted **) (* by TD address *)
known*, readOnly*: SET; (** used for polling, ignored when setting properties **)
valid*: SET
END;
StdProp* = POINTER TO RECORD (Property)
color*: Dialog.Color;
typeface*: Fonts.Typeface;
size*: INTEGER;
style*: RECORD val*, mask*: SET END;
weight*: INTEGER
END;
SizeProp* = POINTER TO RECORD (Property)
width*, height*: INTEGER
END;
(** property messages **)
Message* = Views.PropMessage;
PollMsg* = RECORD (Message)
prop*: Property (** preset to NIL **)
END;
SetMsg* = RECORD (Message)
old*, prop*: Property
END;
(** preferences **)
Preference* = ABSTRACT RECORD (Message) END;
ResizePref* = RECORD (Preference)
fixed*: BOOLEAN; (** OUT, preset to FALSE **)
horFitToPage*: BOOLEAN; (** OUT, preset to FALSE **)
verFitToPage*: BOOLEAN; (** OUT, preset to FALSE **)
horFitToWin*: BOOLEAN; (** OUT, preset to FALSE **)
verFitToWin*: BOOLEAN; (** OUT, preset to FALSE **)
END;
SizePref* = RECORD (Preference)
w*, h*: INTEGER; (** OUT, preset to caller's preference **)
fixedW*, fixedH*: BOOLEAN (** IN **)
END;
BoundsPref* = RECORD (Preference)
w*, h*: INTEGER (** OUT, preset to (Views.undefined, Views.undefined) **)
END;
FocusPref* = RECORD (Preference)
atLocation*: BOOLEAN; (** IN **)
x*, y*: INTEGER; (** IN, valid iff atLocation **)
hotFocus*, setFocus*: BOOLEAN (** OUT, preset to (FALSE, FALSE) **)
END;
ControlPref* = RECORD (Preference)
char*: CHAR; (** IN **)
focus*: Views.View; (** IN **)
getFocus*: BOOLEAN; (** OUT, valid if (v # focus), preset to ((char = [l]tab) & "FocusPref.setFocus") **)
accepts*: BOOLEAN (** OUT, preset to ((v = focus) & (char # [l]tab)) **)
END;
TypePref* = RECORD (Preference)
type*: Stores.TypeName; (** IN **)
view*: Views.View (** OUT, preset to NIL **)
END;
(** verbs **)
PollVerbMsg* = RECORD (Message)
verb*: INTEGER; (** IN **)
label*: ARRAY 64 OF CHAR; (** OUT, preset to "" **)
disabled*, checked*: BOOLEAN (** OUT, preset to FALSE, FALSE **)
END;
DoVerbMsg* = RECORD (Message)
verb*: INTEGER; (** IN **)
frame*: Views.Frame (** IN **)
END;
(** controller messages **)
CollectMsg* = RECORD (Controllers.Message)
poll*: PollMsg (** OUT, preset to NIL **)
END;
EmitMsg* = RECORD (Controllers.RequestMessage)
set*: SetMsg (** IN **)
END;
PollPickMsg* = RECORD (Controllers.TransferMessage)
mark*: BOOLEAN; (** IN, request to mark pick target **)
show*: BOOLEAN; (** IN, if mark then show/hide target mark **)
dest*: Views.Frame (** OUT, preset to NIL, set if PickMsg is acceptable **)
END;
PickMsg* = RECORD (Controllers.TransferMessage)
prop*: Property (** set to picked properties by destination **)
END;
VAR era-: INTEGER; (* estimator to cache standard properties of focus *)
PROCEDURE ^ IntersectSelections* (a, aMask, b, bMask: SET; OUT c, cMask: SET; OUT equal: BOOLEAN);
(** properties **)
PROCEDURE (p: Property) IntersectWith* (q: Property; OUT equal: BOOLEAN), NEW, ABSTRACT;
PROCEDURE (p: StdProp) IntersectWith* (q: Property; OUT equal: BOOLEAN);
VAR valid: SET; c, m: SET; eq: BOOLEAN;
BEGIN
WITH q: StdProp DO
valid := p.valid * q.valid; equal := TRUE;
IF p.color.val # q.color.val THEN EXCL(valid, color) END;
IF p.typeface # q.typeface THEN EXCL(valid, typeface) END;
IF p.size # q.size THEN EXCL(valid, size) END;
IntersectSelections(p.style.val, p.style.mask, q.style.val, q.style.mask, c, m, eq);
IF m = {} THEN EXCL(valid, style)
ELSIF (style IN valid) & ~eq THEN p.style.mask := m; equal := FALSE
END;
IF p.weight # q.weight THEN EXCL(valid, weight) END;
IF p.valid # valid THEN p.valid := valid; equal := FALSE END
END
END IntersectWith;
PROCEDURE (p: SizeProp) IntersectWith* (q: Property; OUT equal: BOOLEAN);
VAR valid: SET;
BEGIN
WITH q: SizeProp DO
valid := p.valid * q.valid; equal := TRUE;
IF p.width # q.width THEN EXCL(valid, width) END;
IF p.height # q.height THEN EXCL(valid, height) END;
IF p.valid # valid THEN p.valid := valid; equal := FALSE END
END
END IntersectWith;
(** property collection and emission **)
PROCEDURE IncEra*;
BEGIN
INC(era)
END IncEra;
PROCEDURE CollectProp* (OUT prop: Property);
VAR msg: CollectMsg;
BEGIN
msg.poll.prop := NIL;
Controllers.Forward(msg);
prop := msg.poll.prop
END CollectProp;
PROCEDURE CollectStdProp* (OUT prop: StdProp);
(** post: prop # NIL, prop.style.val = prop.style.val * prop.style.mask **)
VAR p: Property;
BEGIN
CollectProp(p);
WHILE (p # NIL) & ~(p IS StdProp) DO p := p.next END;
IF p # NIL THEN
prop := p(StdProp); prop.next := NIL
ELSE
NEW(prop); prop.known := {}
END;
prop.valid := prop.valid * prop.known;
prop.style.val := prop.style.val * prop.style.mask
END CollectStdProp;
PROCEDURE EmitProp* (old, prop: Property);
VAR msg: EmitMsg;
BEGIN
IF prop # NIL THEN
msg.set.old := old; msg.set.prop := prop;
Controllers.Forward(msg)
END
END EmitProp;
PROCEDURE PollPick* (x, y: INTEGER;
source: Views.Frame; sourceX, sourceY: INTEGER;
mark, show: BOOLEAN;
OUT dest: Views.Frame; OUT destX, destY: INTEGER);
VAR msg: PollPickMsg;
BEGIN
ASSERT(source # NIL, 20);
msg.mark := mark; msg.show := show; msg.dest := NIL;
Controllers.Transfer(x, y, source, sourceX, sourceY, msg);
dest := msg.dest; destX := msg.x; destY := msg.y
END PollPick;
PROCEDURE Pick* (x, y: INTEGER; source: Views.Frame; sourceX, sourceY: INTEGER;
OUT prop: Property);
VAR msg: PickMsg;
BEGIN
ASSERT(source # NIL, 20);
msg.prop := NIL;
Controllers.Transfer(x, y, source, sourceX, sourceY, msg);
prop := msg.prop
END Pick;
(** property list construction **)
PROCEDURE Insert* (VAR list: Property; x: Property);
VAR p, q: Property; ta: INTEGER;
BEGIN
ASSERT(x # NIL, 20); ASSERT(x.next = NIL, 21); ASSERT(x # list, 22);
ASSERT(x.valid - x.known = {}, 23);
IF list # NIL THEN
ASSERT(list.valid - list.known = {}, 24);
ASSERT(Services.TypeLevel(list) = 1, 25)
END;
ta := SYSTEM.TYP(x^);
ASSERT(Services.TypeLevel(x) = 1, 26);
p := list; q := NIL;
WHILE (p # NIL) & (SYSTEM.TYP(p^) < ta) DO
q := p; p := p.next
END;
IF (p # NIL) & (SYSTEM.TYP(p^) = ta) THEN x.next := p.next ELSE x.next := p END;
IF q # NIL THEN q.next := x ELSE list := x END
END Insert;
PROCEDURE CopyOfList* (p: Property): Property;
VAR q, r, s: Property; t: Kernel.Type;
BEGIN
q := NIL; s := NIL;
WHILE p # NIL DO
ASSERT(Services.TypeLevel(p) = 1, 20);
t := Kernel.TypeOf(p); Kernel.NewObj(r, t); ASSERT(r # NIL, 23);
SYSTEM.MOVE(p, r, t.size);
r.next := NIL;
IF q # NIL THEN q.next := r ELSE s := r END;
q := r; p := p.next
END;
RETURN s
END CopyOfList;
PROCEDURE CopyOf* (p: Property): Property;
VAR r: Property; t: Kernel.Type;
BEGIN
IF p # NIL THEN
ASSERT(Services.TypeLevel(p) = 1, 20);
t := Kernel.TypeOf(p); Kernel.NewObj(r, t); ASSERT(r # NIL, 23);
SYSTEM.MOVE(p, r, t.size);
r.next := NIL;
END;
RETURN r
END CopyOf;
PROCEDURE Merge* (VAR base, override: Property);
VAR p, q, r, s: Property; tp, tr: INTEGER;
BEGIN
ASSERT((base # override) OR (base = NIL), 20);
p := base; q := NIL; r := override; override := NIL;
IF p # NIL THEN
tp := SYSTEM.TYP(p^);
ASSERT(Services.TypeLevel(p) = 1, 21)
END;
IF r # NIL THEN
tr := SYSTEM.TYP(r^);
ASSERT(Services.TypeLevel(r) = 1, 22)
END;
WHILE (p # NIL) & (r # NIL) DO
ASSERT(p # r, 23);
WHILE (p # NIL) & (tp < tr) DO
q := p; p := p.next;
IF p # NIL THEN tp := SYSTEM.TYP(p^) END
END;
IF p # NIL THEN
IF tp = tr THEN
s := p.next; p.next := NIL; p := s;
IF p # NIL THEN tp := SYSTEM.TYP(p^) END
ELSE
END;
s := r.next;
IF q # NIL THEN q.next := r ELSE base := r END;
q := r; r.next := p; r := s;
IF r # NIL THEN tr := SYSTEM.TYP(r^) END
END
END;
IF r # NIL THEN
IF q # NIL THEN q.next := r ELSE base := r END
END
END Merge;
PROCEDURE Intersect* (VAR list: Property; x: Property; OUT equal: BOOLEAN);
VAR l, p, q, r, s: Property; plen, rlen, ta: INTEGER; filtered: BOOLEAN;
BEGIN
ASSERT((x # list) OR (list = NIL), 20);
IF list # NIL THEN ASSERT(Services.TypeLevel(list) = 1, 21) END;
IF x # NIL THEN ASSERT(Services.TypeLevel(x) = 1, 22) END;
p := list; s := NIL; list := NIL; l := NIL; plen := 0;
r := x; rlen := 0; filtered := FALSE;
WHILE (p # NIL) & (r # NIL) DO
q := p.next; p.next := NIL; INC(plen);
ta := SYSTEM.TYP(p^);
WHILE (r # NIL) & (SYSTEM.TYP(r^) < ta) DO
r := r.next; INC(rlen)
END;
IF (r # NIL) & (SYSTEM.TYP(r^) = ta) THEN
ASSERT(r # p, 23);
IF l # NIL THEN s.next := p ELSE l := p END;
s := p;
p.known := p.known + r.known;
p.IntersectWith(r, equal);
filtered := filtered OR ~equal OR (p.valid # r.valid);
r := r.next; INC(rlen)
END;
p := q
END;
list := l;
equal := (p = NIL) & (r = NIL) & (plen = rlen) & ~filtered
END Intersect;
(** support for IntersectWith methods **)
PROCEDURE IntersectSelections* (a, aMask, b, bMask: SET; OUT c, cMask: SET; OUT equal: BOOLEAN);
BEGIN
cMask := aMask * bMask - (a / b);
c := a * cMask;
equal := (aMask = bMask) & (bMask = cMask)
END IntersectSelections;
(** standard preferences protocols **)
PROCEDURE PreferredSize* (v: Views.View; minW, maxW, minH, maxH,
defW, defH: INTEGER;
VAR w, h: INTEGER);
VAR p: SizePref;
BEGIN
ASSERT(Views.undefined < minW, 20); ASSERT(minW < maxW, 21);
ASSERT(Views.undefined < minH, 23); ASSERT(minH < maxH, 24);
ASSERT(Views.undefined <= defW, 26);
ASSERT(Views.undefined <= defH, 28);
IF (w < Views.undefined) OR (w > maxW) THEN w := defW END;
IF (h < Views.undefined) OR (h > maxH) THEN h := defH END;
p.w := w; p.h := h; p.fixedW := FALSE; p.fixedH := FALSE;
Views.HandlePropMsg(v, p); w := p.w; h := p.h;
IF w = Views.undefined THEN w := defW END;
IF h = Views.undefined THEN h := defH END;
IF w < minW THEN w := minW ELSIF w > maxW THEN w := maxW END;
IF h < minH THEN h := minH ELSIF h > maxH THEN h := maxH END
END PreferredSize;
(** common resizing constraints **)
PROCEDURE ProportionalConstraint* (scaleW, scaleH: INTEGER; fixedW, fixedH: BOOLEAN; VAR w, h: INTEGER);
(** pre: w > Views.undefined, h > Views.undefined **)
(** post: (E s: s * scaleW = w, s * scaleH = h), |w * h - w' * h'| min! **)
VAR area: REAL;
BEGIN
ASSERT(scaleW > Views.undefined, 22); ASSERT(scaleH > Views.undefined, 23);
IF fixedH THEN
ASSERT(~fixedW, 24);
ASSERT(h > Views.undefined, 21);
area := h; area := area * scaleW;
w := SHORT(ENTIER(area / scaleH))
ELSIF fixedW THEN
ASSERT(w > Views.undefined, 20);
area := w; area := area * scaleH;
h := SHORT(ENTIER(area / scaleW))
ELSE
ASSERT(w > Views.undefined, 20); ASSERT(h > Views.undefined, 21);
area := w; area := area * h;
w := SHORT(ENTIER(Math.(*L*)Sqrt(area * scaleW / scaleH)));
h := SHORT(ENTIER(Math.(*L*)Sqrt(area * scaleH / scaleW)))
END
END ProportionalConstraint;
PROCEDURE GridConstraint* (gridX, gridY: INTEGER; VAR x, y: INTEGER);
VAR dx, dy: INTEGER;
BEGIN
ASSERT(gridX > Views.undefined, 20);
ASSERT(gridY > Views.undefined, 21);
dx := x MOD gridX;
IF dx < gridX DIV 2 THEN DEC(x, dx) ELSE INC(x, (-x) MOD gridX) END;
dy := y MOD gridY;
IF dy < gridY DIV 2 THEN DEC(y, dy) ELSE INC(y, (-y) MOD gridY) END
END GridConstraint;
PROCEDURE ThisType* (view: Views.View; type: Stores.TypeName): Views.View;
VAR msg: TypePref;
BEGIN
msg.type := type; msg.view := NIL;
Views.HandlePropMsg(view, msg);
RETURN msg.view
END ThisType;
END Properties.