blackbox-linux-console/BlackBox/System/Mod/Properties.txt

MODULE Properties;

	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 System/Mod/Properties.odc *)
	(* DO NOT EDIT *)

	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.