(* Copyright (C) 1992, Digital Equipment Corporation                         *)
(* All rights reserved.                                                      *)
(* See the file COPYRIGHT for a full description.                            *)
(*                                                                           *)
(* by Steve Glassman, Mark Manasse and Greg Nelson           *)
(* Last modified on Wed Mar 18 15:46:44 PST 1992 by msm      *)
(*      modified on Tue Mar 10 19:07:02 1992 by steveg   *)
(*      modified on Mon Feb 24 13:52:20 PST 1992 by muller   *)
(*      modified on Sun Nov 10 21:30:22 PST 1991 by gnelson  *)
<*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;

EXCEPTION FatalError; <*FATAL FatalError*>

PROCEDURE SetParent(v: T; p: VBT.T) =
  BEGIN 
    IF IsActive(v) THEN RAISE FatalError 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 RAISE FatalError 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;

BEGIN END AnchorBtnVBT.