Copyright (C) 1994, Digital Equipment Corp.
by Steve Glassman, Mark Manasse and Greg Nelson
<*PRAGMA LL*>
MODULE AnchorBtnVBT;
IMPORT VBT, Filter, ZSplit, Point, Rect, ButtonVBT, Trestle, Axis,
HighlightVBT, Split, VBTClass, TrestleComm;
FROM VBT IMPORT ClickType;
REVEAL
T = Public BRANDED OBJECT
n: CARDINAL;
anchorParent: VBT.T := NIL;
hfudge, vfudge: REAL
OVERRIDES
mouse := Mouse;
position := Position;
init := Be
END;
TYPE
AnchorRef = REF RECORD activeAnchor: T END;
PROCEDURE Be(
v: T;
ch: VBT.T;
menu: VBT.T;
n: CARDINAL := 0;
anchorParent: VBT.T := NIL;
hfudge, vfudge := 0.0;
ref: REFANY := NIL): T RAISES {} =
BEGIN
v.menu := menu;
v.n := n;
v.anchorParent := anchorParent;
v.hfudge := hfudge;
v.vfudge := vfudge;
EVAL ButtonVBT.T.init(v, ch, NIL, ref);
RETURN v
END Be;
PROCEDURE New(
ch: VBT.T;
menu: VBT.T;
n: CARDINAL := 0;
anchorParent: VBT.T := NIL;
hfudge, vfudge := 0.0;
ref: REFANY := NIL): T RAISES {} =
VAR res := NEW(T);
BEGIN
RETURN Be(res, ch, menu, n, anchorParent, hfudge, vfudge, ref)
END New;
PROCEDURE Mouse(v: T; READONLY cd: VBT.MouseRec) RAISES {} =
BEGIN
Filter.T.mouse(v, cd);
IF cd.clickType = ClickType.FirstDown THEN
WITH ref = GetAnchorRef(v) DO
ref.activeAnchor := v;
Activate(v, ref)
END
ELSE
WITH ref = GetAnchorRef(v) DO
IF ref.activeAnchor # NIL THEN
Deactivate(ref.activeAnchor);
ref.activeAnchor := NIL
END
END
END
END Mouse;
PROCEDURE GetAnchorRef(v: T): AnchorRef =
VAR
ref: AnchorRef;
parent: VBT.T;
BEGIN
IF v.anchorParent = NIL THEN
parent := VBT.Parent(v)
ELSE
parent := v.anchorParent
END;
ref := VBT.GetProp(parent, TYPECODE(AnchorRef));
IF ref = NIL THEN
ref := NEW(AnchorRef);
VBT.PutProp(parent, ref)
END;
RETURN ref
END GetAnchorRef;
PROCEDURE Position(v: T; READONLY cd: VBT.PositionRec) RAISES {} =
BEGIN
Filter.T.position(v, cd);
IF cd.cp.gone THEN VBT.SetCage(v, VBT.GoneCage); RETURN END;
VBT.SetCage(v, VBT.InsideCage);
WITH ref = GetAnchorRef(v) DO
IF (ref.activeAnchor # NIL)
AND (ref.activeAnchor # v) THEN
Deactivate(ref.activeAnchor);
ref.activeAnchor := v;
Activate(v, ref)
END
END
END Position;
PROCEDURE GetZSplit(v: T): ZSplit.T =
VAR m := v.n; z := v.parent; BEGIN
LOOP
IF z = NIL THEN RETURN NIL END;
IF ISTYPE(z, ZSplit.T) THEN
IF m = 0 THEN RETURN z ELSE DEC(m) END
END;
z := z.parent
END
END GetZSplit;
PROCEDURE Activate(v: T; ref: AnchorRef) =
VAR
pt := Point.MoveHV(Rect.SouthWest(VBT.Domain(v)),
ROUND(VBT.MMToPixels(v, v.hfudge, Axis.T.Hor)),
ROUND(VBT.MMToPixels(v, v.vfudge, Axis.T.Ver)));
z := GetZSplit(v);
dom: Rect.T;
BEGIN
v.pre();
IF v.menu.st # v.st THEN VBTClass.Rescreen(v.menu, v.st) END;
IF z = NIL THEN
(* insert menu as top-level window *)
WITH srec = Trestle.ScreenOf(v, pt) DO
IF srec.trsl # NIL THEN
dom := Shift(MinRect(v.menu, srec.q), srec.dom);
TRY
Trestle.Attach(v.menu, srec.trsl);
Trestle.Overlap(v.menu, srec.id, Rect.NorthWest(dom))
EXCEPT
TrestleComm.Failure => v.cancel(); ref.activeAnchor := NIL
END
END
END
ELSE
(* insert menu in z *)
dom := Shift(MinRect(v.menu, pt), VBT.Domain(z));
ZSplit.Insert(z, HighlightVBT.New(v.menu), dom)
END
END Activate;
PROCEDURE Shift(READONLY menu, parent: Rect.T): Rect.T =
(* Shift the menu left until it is entirely contained in parent or until its
left edge coincides with the left edge of parent, unless it needs
shifting to the right, in which shift until the left edge of menu is
visible. Do the same thing vertically. *)
VAR dh, dv: INTEGER;
BEGIN
dh := MAX(MIN(0, parent.east - menu.east), parent.west - menu.west);
dv := MAX(MIN(0, parent.south - menu.south), parent.north - menu.north);
RETURN Rect.MoveHV(menu, dh, dv);
END Shift;
PROCEDURE MinRect(v: VBT.T; READONLY pt: Point.T): Rect.T =
BEGIN
RETURN
Rect.FromCorner(pt,
VBTClass.GetShape(v, Axis.T.Hor, 0).lo,
VBTClass.GetShape(v, Axis.T.Ver, 0).lo)
END MinRect;
PROCEDURE Deactivate(v: T) =
<* FATAL Split.NotAChild *>
BEGIN
v.cancel();
WITH z = GetZSplit(v) DO
IF z = NIL THEN
Trestle.Delete(v.menu)
ELSE
WITH highlighter = VBT.Parent(v.menu) DO
Split.Delete(z, highlighter);
Split.Delete(highlighter, v.menu);
VBT.Discard(highlighter)
END
END
END
END Deactivate;
PROCEDURE IsActive(v: T): BOOLEAN =
BEGIN
IF VBT.Parent(v) = NIL THEN RETURN FALSE END;
WITH ref = GetAnchorRef(v) DO
RETURN v = ref.activeAnchor
END
END IsActive;
PROCEDURE SetParent(v: T; p: VBT.T) =
BEGIN
IF IsActive(v) THEN Crash() END;
v.anchorParent := p
END SetParent;
PROCEDURE GetParent(v: T): VBT.T =
BEGIN RETURN v.anchorParent END GetParent;
PROCEDURE Set(v: T; n: CARDINAL;
hfudge, vfudge: REAL) =
BEGIN
IF IsActive(v) THEN Crash() END;
v.n := n; v.hfudge := hfudge; v.vfudge := vfudge
END Set;
PROCEDURE Get(v: T; VAR n: CARDINAL; VAR hfudge, vfudge: REAL) =
BEGIN
n := v.n; hfudge := v.hfudge; vfudge := v.vfudge
END Get;
EXCEPTION FatalError;
PROCEDURE Crash () =
<* FATAL FatalError *>
BEGIN
RAISE FatalError;
END Crash;
BEGIN END AnchorBtnVBT.