<*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.