(* Copyright (C) 1992, Digital Equipment Corporation                         *)
(* All rights reserved.                                                      *)
(* See the file COPYRIGHT for a full description.                            *)
(*                                                                           *)
(* Last modified on Wed Sep 23 11:16:02 PDT 1992 by steveg  *)
(*      modified on Wed Aug 12 17:12:47 PDT 1992 by guarino *)
(*      modified on Tue Jun 16 13:08:47 PDT 1992 by muller *)
(*      modified on Mon Jan 20 19:50:41 PST 1992 by glassman *)
(*      modified on Fri Sep  7 14:39:38 PDT 1990 by chan *)
(*      modified on Sat Jul 14 14:11:54 PDT 1990 by gnelson *)
(*      modified on Tue May 15 12:19:53 PDT 1990 by mcjones *)
(*      modified on Mon Jul 17 11:05:34 1989 by kalsow *)
(*      modified on Sun Mar 12 23:12:34 PST 1989 by msm *)

UNSAFE MODULE JoinVBT;

(* Unsafe because it needs to translate coordinates in paint batches. *)

(* Since JoinVBT is being used inside Trestle to tee the screen for
   Mirage and JoinScreen, it needs to be efficient in the normal case of
   a single parent. A paint short-circuiting similar to that of ZSplit
   is used *)

IMPORT Axis, Batch, BatchRep, BatchUtil, ETAgent, Filter,
  FilterClass, HighlightVBT, MouseSplit, PaintOp, Pixmap, Point, 
  Rect, Region, ScrnCursor,  ScrnPixmap, ScreenType, Thread,
  Trestle, VBT, VBTClass, VBTRep, Word;

EXCEPTION Failure;
<* FATAL Failure *>

REVEAL
  T = Public BRANDED OBJECT
  OVERRIDES
      paintbatch := PaintBatch;
      capture    := Capture;
      sync       := Sync;
      setcage    := SetCage;
      setcursor  := SetCursor;
      discard    := Discard;
      screenOf   := ScreenOf;
      redisplay  := Redisplay;
      shape      := Shape;
      newShape   := NewShape;
      beChild    := BeChild;
      init       := Be
  END;

TYPE
  Ref = OBJECT
        (* This Rec is the upRef of the joinVBT, hereinafter called the
           child. All fields are protected by the muP of the child. In
           addition, the .child and .parents fields are protected by
           VBT.mu *)
        parents: ParentList := NIL;
        child  : T;             (* The joinVBT *)
        current: ParentT   := NIL;
        (* The parent that contains the cursor, or NIL if none does *)
        badRect: Rect.T := Rect.Empty;
        (* This is the region that will be repainted when Redisplay is
           called *)
        needsRescreen: BOOLEAN := TRUE;
        (* If needsRescreen is true, then the join has changed screen type
           but not been rescreened, and newST is the new screenType. *)
        newST: ScreenType.T;

        shapesCache: ARRAY Axis.T OF VBT.SizeRange;
        needsShape : BOOLEAN           := TRUE;
        (* shapesCache is the result of calling Shapes on the join's child.
           The shape of the join is set to the child's shape. needsShape
           gets TRUE on a newshape, rescreen, beChild. invariant:
           needsShape or (shapesCache is valid) *)

        needsReshape: BOOLEAN := TRUE;
        (* If needsReshape is true, then the join has changed shape, but
           not had its reshape method called. In this case the part of the
           old screen that can be used is child.domain - badRect. *)

        lastButtonTime: VBT.TimeStamp;
        (* The eventtime of the last mouse button transition delivered to
           the join; used in Mouse. *)
        allButtonsUp: BOOLEAN        := TRUE;
        mu          : Thread.Mutex;
        (* lock mu for all down calls that can be made concurrently -
           Redisplay, Repaint, Rescreen, Reshape. LL(VBT.mu) < LL(mu) <
           LL(join) *)
      END;

REVEAL
  ParentT = ParentPublic BRANDED OBJECT
      (* All fields of this record are protected by the muP of the child.
         In addition, the .cl and .link fields are protected by VBT.mu and
         the .delta field is protected by the child's ref's mu*)
      delta : Point.T   := Point.Origin;
      (* delta + child coordinate = corresponding parent point. If parent
         screen is empty, delta is arbitrary. *)
      cp         : VBT.CursorPosition;
      north, west: REAL;
      nw: Point.T;              (* child coordinates of parent's nw
                                   corner *)
      dom : Rect.T;             (* domain of parent *)
      cl  : Ref;                (* backpointer to child's paint closure *)
      link: ParentT
    OVERRIDES
      init     := BeParent;
      reshape  := Reshape;
      rescreen := Rescreen;
      repaint  := Repaint;
      mouse    := Mouse;
      position := Position;
      setcage  := ParentSetCage;
      setcursor := ParentSetCursor;
      misc     := Misc;
      key      := Key;
      discard  := ParentDiscard;
      translate:= ParentTranslate;
    END;

TYPE
  ParentList = ParentT;
   
PROCEDURE Be(v: T; ch: VBT.T): T  =
  VAR
    cl:= NEW(Ref);
  BEGIN
      cl.child         := v;
      cl.mu := NEW(MUTEX);
      LOCK v DO
        VBTClass.ClearShortCircuit(v);
        v.upRef := cl;
      END;
    RETURN Filter.T.init(v,HighlightVBT.New(ch));
  END Be;

PROCEDURE New(ch: VBT.T): T  =
  BEGIN
    RETURN NEW(T).init(ch);
  END New;

PROCEDURE Unmark(v: VBT.T) =
  BEGIN
    v.props := v.props - VBTRep.Props{VBTRep.Prop.Marked};
  END Unmark;

PROCEDURE BeParent(prntP: ParentT; v: T; north, west: REAL): ParentT  =
  VAR
    cl: Ref;
  BEGIN
    LOCK v DO
      cl := NARROW(v.upRef, Ref);
      prntP.link         := cl.parents;
      cl.parents         := prntP;
      prntP.cl           := cl;
      prntP.dom          := Rect.Empty;
      prntP.north        := north;
      prntP.west         := west;
      prntP.cp    := VBT.CursorPosition{Point.Origin, VBT.AllScreens, TRUE, TRUE};
      VBT.SetCursor(prntP, VBTClass.GetCursor(v));
      IF (v.st = NIL) AND (prntP.st # NIL) THEN
        cl.needsRescreen := TRUE;
        cl.newST         := prntP.st;
        cl.badRect       := Rect.Full;
        (* !!! *) Unmark(v);
      END;
      IF (v.st # NIL) AND 
         (prntP.st # NIL) AND 
         (v.st # prntP.st) THEN RAISE Failure END;
    END;

      (* make parent NIL to make ETAgent.Be happy to set v's parent to prntP
         *)
    v.parent := NIL;
    EVAL ETAgent.T.init(prntP, v);
      (* does the ClearShortCircuit, and VBT.Mark *)
    MoveParent(v, prntP, north, west);
    RETURN prntP;
  END BeParent;

PROCEDURE NewParent(v: T; north, west: REAL): ParentT  =
  BEGIN
    RETURN NEW(ParentT).init(v, north, west);
  END NewParent;

(* LL = muP(child) *)
PROCEDURE ClearParentCages(cl: Ref)  =
  VAR
    pl:         ParentList;
    cg, cgAdj: VBT.Cage;
    cageType:  VBTClass.VBTCageType;
  BEGIN
    cg       := VBTClass.Cage(cl.child);
    cageType := cl.child.cageType;
    IF cageType = VBTClass.VBTCageType.Everywhere THEN cg := VBT.GoneCage; END;
    pl     := cl.parents;
    cgAdj := cg;
    WHILE pl # NIL DO
      IF cageType = VBTClass.VBTCageType.Rectangle THEN
        cgAdj.rect := Rect.Move(cg.rect, pl.delta);
      END;
      VBT.SetCage(pl, cgAdj);
      pl := pl.link;
    END;
  END ClearParentCages;

PROCEDURE RemParent(v: T; prntP: ParentT)  =
  VAR
    cl: Ref;
    pl: ParentList;
  BEGIN (* LL = VBT.mu *)
    cl := NARROW(v.upRef, Ref);
    LOCK v DO
        (* delete prntP from list of parents *)
      pl := cl.parents;
      IF (pl = prntP) THEN
          (* delete first element *)
        cl.parents := pl.link;
      ELSE
          (* find and delete *)
        WHILE (pl # NIL) AND (pl.link # prntP) DO pl := pl.link END;
        IF pl = NIL THEN RAISE Failure END; (* prnt not a parent of v"*)
        pl.link         := pl.link.link;
      END;
        (* If the deleted parent was the parent that was chosen as "the"
           parent of the batchVBT above the join, then choose another, if
           possible. *)
      IF prntP = v.parent THEN
        v.parent := cl.parents;
      END;
      IF prntP = cl.current THEN
        cl.current := NIL;
          (* set cages of all parents to Gone because we need a new value for
             current *)
        ClearParentCages(cl);
      END;
      VBTClass.ClearShortCircuit(v);
    END;

    prntP.cl := NIL;
    prntP.ch := NIL;
    prntP.link := NIL;
    
      (* VBT.Mark(v); not needed when all screen types the same *)
    VBTClass.Reshape(prntP, Rect.Empty, Rect.Empty);
  END RemParent;

PROCEDURE CheckShortCircuit(v: T; cl: Ref) =
  BEGIN (* LL < v *)
    LOCK v DO
      IF (cl.parents = NIL) OR
         ((cl.parents.link = NIL) AND
          Point.Equal(cl.parents.delta, Point.Origin))
      THEN
        VBTClass.SetShortCircuit(v);
      END;
    END;
  END CheckShortCircuit;

PROCEDURE Child(prnt: ParentT): T  =
  BEGIN
    RETURN prnt.cl.child;
  END Child;

PROCEDURE ScreenOf(
         split: T;
         <* UNUSED *> child: VBT.T;
  READONLY pt:    Point.T
  ): Trestle.ScreenOfRec  =
  VAR
    cl:  Ref;
    sor: Trestle.ScreenOfRec;
  BEGIN
(* LL = child *)
    LOCK split DO
      cl := NARROW(split.upRef, Ref);
      IF cl.current # NIL THEN
        RETURN cl.current.screenOf(split, Point.Add(pt, cl.current.delta))
      ELSIF split.parent # NIL THEN
        RETURN split.parent.screenOf(split, 
          Point.Add(pt, NARROW(split.parent, ParentT).delta))
      ELSE
          sor.id   := Trestle.NoScreen;
          sor.trsl := NIL;
        RETURN sor;
      END
    END;
  END ScreenOf;

PROCEDURE Discard(v: T)  =
  VAR
    cl: Ref;
  BEGIN
    cl := NARROW(v.upRef, Ref);
    WHILE cl.parents # NIL DO RemParent(v, cl.parents) END;
    LOCK v DO
      cl.child   := NIL;
      cl.current := NIL;
    END;
    Filter.T.discard(v);
  END Discard;

(* LL = v *)
PROCEDURE MMToPixels(v: T; mm: REAL; ax: Axis.T): REAL  =
  BEGIN
    IF v.st = NIL THEN RETURN 0.0 ELSE RETURN mm * v.st.res[ax]; END;
  END MMToPixels;

PROCEDURE Redisplay (v: T) =
  VAR
    cl                                     : Ref;
    a                                      : Rect.Partition;
    i                                      : INTEGER;
    badRect                                : Rect.T;
    needsShape, needsRescreen, needsReshape: BOOLEAN;
    shapes                                 : ARRAY Axis.T OF VBT.SizeRange;
  BEGIN                         (* LL = VBT.mu *)
    cl := NARROW(v.upRef, Ref);
    LOCK cl.mu DO
      LOCK v DO
        needsRescreen := cl.needsRescreen;
        needsShape := cl.needsShape;
        IF needsRescreen THEN
          cl.needsRescreen := FALSE;
          cl.badRect := Rect.Full;
          cl.needsReshape := TRUE;
        END;
        needsReshape := needsRescreen OR (cl.needsReshape);
      END;

      IF needsRescreen THEN VBTClass.Rescreen(v, cl.newST); END;

      IF needsShape THEN shapes := GetShapes(v, v.ch); END;

      LOCK v DO
        IF needsShape THEN
          cl.badRect := Rect.Full;
          WITH dom = cl.child.domain DO
            needsReshape :=
              needsReshape OR dom.west < shapes[Axis.T.Hor].lo
                OR dom.east >= shapes[Axis.T.Hor].hi
                OR dom.north < shapes[Axis.T.Ver].lo
                OR dom.south >= shapes[Axis.T.Ver].hi;
          END;
          cl.shapesCache := shapes
        END;

        IF needsReshape THEN
          Rect.Factor(cl.child.domain, cl.badRect, a, 0, 0);
          (* if the valid old domain is non-empty, arbitrarily choose a
             rectangle from it to give the client; otherwise give empty. *)
          i := 0;
          WHILE (i = 2) OR (i # 4) AND Rect.IsEmpty(a[i]) DO
            i := i + 1
          END;
          cl.needsReshape := FALSE;
          cl.badRect := Rect.Empty
        ELSE
          badRect := cl.badRect;
          cl.badRect := Rect.Empty
        END;
      END;
      IF needsReshape THEN
        VBTClass.Reshape(
          v, Rect.FromSize(cl.shapesCache[Axis.T.Hor].pref,
                           cl.shapesCache[Axis.T.Ver].pref), a[i])
      ELSE
        VBTClass.Repaint(v, Region.FromRect(badRect))
      END;
      (* after the needsReshape so that the latest parent delta is set *)
      CheckShortCircuit(v, cl);
    END;                        (* LOCK cl.mu *)
  END Redisplay;

PROCEDURE GetShapes(<* UNUSED *> v: T; ch: VBT.T): 
  ARRAY Axis.T OF VBT.SizeRange =
  VAR shapes := VBTClass.GetShapes(ch, TRUE);
  BEGIN
    shapes[Axis.T.Hor].lo := shapes[Axis.T.Hor].pref;
    shapes[Axis.T.Hor].hi := shapes[Axis.T.Hor].pref + 1;
    shapes[Axis.T.Ver].lo := shapes[Axis.T.Ver].pref;
    shapes[Axis.T.Ver].hi := shapes[Axis.T.Ver].pref + 1;
    RETURN shapes;
  END GetShapes;
  
PROCEDURE Shape(v: T; axis: Axis.T;  <* UNUSED *>n: CARDINAL):
  VBT.SizeRange =
  VAR
    cl        : Ref;
    shapes    : ARRAY Axis.T OF VBT.SizeRange;
    needsShape, markParents: BOOLEAN := FALSE;
    pl: ParentList;
  BEGIN
    LOCK v DO
      cl := NARROW(v.upRef, Ref);
      shapes := cl.shapesCache;
      needsShape := cl.needsShape;
    END;
    IF needsShape THEN
      shapes := GetShapes(v, v.ch);
      LOCK v DO
        cl.needsShape := FALSE;
        IF cl.shapesCache # shapes THEN
          cl.needsReshape := TRUE;
          cl.shapesCache := shapes;
          cl.badRect := Rect.Full;
          VBTRep.Mark(v);
          markParents := TRUE;
        END;
      END;
    END;
    IF markParents THEN
      pl := cl.parents;
      WHILE pl # NIL DO
        VBT.Mark(pl);
        pl := pl.link;
      END;
    END;
    RETURN shapes[axis];
  END Shape;

(* some prop munging stolen from VBT.NewShape *)
PROCEDURE NewShape (v: T;  <* UNUSED *>ch: VBT.T) =
  VAR
    cl: Ref;
    pl: ParentList;
  BEGIN
    LOCK v DO
      cl := NARROW(v.upRef, Ref);
      cl.needsShape := TRUE;
      VBTRep.Mark(v);
      v.props := v.props + VBTRep.Props{VBTRep.Prop.HasNewShape,
                                        VBTRep.Prop.BlockNewShape};
      pl := cl.parents;
      WHILE pl # NIL DO pl.newShape(v); pl := pl.link; END;
    END;
  END NewShape;

PROCEDURE BeChild(v: T; ch: VBT.T)  =
  VAR
    cl: Ref;
  BEGIN
    Filter.T.beChild(v, ch);
    cl             := NARROW(v.upRef, Ref);
    cl.needsShape := TRUE;
    VBTRep.Mark(v);
  END BeChild;

PROCEDURE MoveParent (v: T; prntP: ParentT; north, west: REAL) =
  VAR
    cl: Ref;
    pl: ParentList;
    cp: VBT.CursorPosition;
  BEGIN
    cl := NARROW(v.upRef, Ref);
    LOCK cl.mu DO
      LOCK v DO
        IF prntP.north = north AND prntP.west = west THEN RETURN END;
        pl := prntP;
        IF (pl = NIL) THEN RAISE Failure END; (* prnt not a parent of v *)
        prntP.north := north;
        prntP.west := west;
        prntP.nw :=
          Point.FromCoords(TRUNC(0.5 + MMToPixels(v, west, Axis.T.Hor)),
                           TRUNC(0.5 + MMToPixels(v, north, Axis.T.Ver)));
        prntP.dom := prntP.domain;
        IF NOT Rect.IsEmpty(prntP.dom) THEN
          prntP.delta := Point.Sub(Rect.NorthWest(prntP.dom), prntP.nw);
          cl.badRect :=
            Rect.Join(
              cl.badRect, Rect.Move(prntP.dom, Point.Minus(prntP.delta)));
          cp.gone := FALSE;
          cp.screen := VBT.AllScreens;
          VBTClass.SetCage(prntP, VBT.CageFromRect(Rect.Empty, cp))
        END;
        VBTClass.ClearShortCircuit(v);
      END;
    END;
    VBT.Mark(v);
  END MoveParent;

PROCEDURE Capture(
              join: T;
              <* UNUSED *> ch:   VBT.T;
  <* UNUSED *> READONLY      clip: Rect.T;
  <* UNUSED *> VAR (*out*) br:   Region.T
  ): ScrnPixmap.T  =

(* NYI
  PROCEDURE Factor(pl: ParentList; READONLY r: Rect.T): Rect.T =
    VAR
      a, a2: Rect.Partition;
      i:     INTEGER;
      br:    Rect.T;
    BEGIN
      RETURN r;
      WHILE
        (pl # NIL)
        AND NOT Rect.Overlap(Rect.Move(r, prntP.delta),
                  prntP.domain) DO
        pl := prntP.link
      END;
      IF pl = NIL THEN RETURN r END;

      Rect.Factor(r,
        Rect.Move(prntP.domain, Point.Minus(prntP.delta)), a, 0, 0);
      bmP := Bitmap.New(Rect.Move(a[2], prntP.delta));
      br := VBT.GetBits(prntP, bmP.bounds, bmP, VBT.WhiteBlack);
      Rect.Factor(bmP.bounds, br, a2, 0, 0);

      FOR i := 0 TO 4 DO
        TRY
          IF (i # 2) AND NOT Rect.IsEmpty(a2[i]) THEN
            BitBlt.Blt(bmP, a2[i].west, a2[i].north, bm,
              Rect.Move(a2[i], Point.Minus(prntP.delta)), op)
          END;
        EXCEPT
        ELSE RAISE(VBT.Error, "Bad opcode to GetBits")
        END;
      END;

      (* Help the garbage collector reuse our space during the recursion *)
      bmP.bits := NIL;
      br := Factor(prntP.link, Rect.Move(a2[2], Point.Minus(prntP.delta)));

      FOR i := 0 TO 4 DO
        IF (i # 2) AND NOT Rect.IsEmpty(a[i]) THEN
          br := Rect.Join(br, Factor(prntP.link, a[i]))
        END
      END;
      RETURN br
    END Factor;
 *)

  VAR
    cl:      Ref;
    pl: ParentList;
  BEGIN
    cl := NARROW(join.upRef, Ref);
    pl := cl.parents;
    RAISE Failure; (* NYI *)
  END Capture;

PROCEDURE Succ(v: T; prntP: ParentT): ParentT  =
  VAR
    cl: Ref;
    p:  ParentList;
  BEGIN
    LOCK v DO
      cl := NARROW(v.upRef, Ref);
      p  := cl.parents;
      IF prntP # NIL THEN
        WHILE (p # NIL) AND (p # prntP) DO p := p.link END;
        IF p = NIL THEN RAISE Failure END; (* prnt not a parent of v *)
        p := p.link
      END;
      IF p # NIL THEN RETURN p ELSE RETURN NIL END
    END;
  END Succ;

PROCEDURE PaintBatch(v: T; <* UNUSED *> ch: VBT.T; ba: Batch.T)  =
  VAR
    cl:        Ref;
    saved, pl: ParentList;
    btchP:     Batch.T;
    lenb, len: INTEGER;
  BEGIN (* LL = ch *)
    LOCK v DO
      cl := NARROW(v.upRef, Ref);
      pl := cl.parents;
      IF pl = NIL THEN
        Batch.Free(ba);
        RETURN
      END;
          (* Clip batch if it hasn't been done already, since Rect.Fulls
             can't be translated. *)
        BatchUtil.Tighten(ba);
        WHILE (pl # NIL) AND
              NOT Rect.Overlap(Rect.Move(ba.clip, pl.delta), pl.dom)
        DO
          pl := pl.link
        END;
        IF pl = NIL THEN
          Batch.Free(ba);
          RETURN
        END;
        saved := pl;
        pl    := pl.link;
        lenb  := ba.next - ADR(ba.b[0]);
        len   := lenb DIV BYTESIZE(Word.T);
        WHILE pl # NIL DO
            (* copy, translate, and paint batch, if relevant to this parent.
               *)
          IF Rect.Overlap(Rect.Move(ba.clip, pl.delta), pl.dom) THEN
            btchP := Batch.New(len);
            SUBARRAY(btchP.b^, 0, len) := SUBARRAY(ba.b^, 0, len);
            btchP.scrollSource := ba.scrollSource;
            btchP.clip         := ba.clip;
            btchP.clipped      := ba.clipped;
            btchP.next         := ADR(btchP.b[0]) + lenb;
            BatchUtil.Translate(btchP, pl.delta);
            VBTClass.PaintBatch(pl, btchP)
          END;
          pl := pl.link
        END;
        BatchUtil.Translate(ba, saved.delta);
        VBTClass.PaintBatch(saved, ba)
    END;
  END PaintBatch;

PROCEDURE Sync(v: T; <* UNUSED *> ch: VBT.T)  =
  VAR
    cl: Ref;
    pl: ParentList;
  BEGIN
    LOCK v DO
      cl := NARROW(v.upRef, Ref);
      pl := cl.parents;
      WHILE pl # NIL DO
        VBT.Sync(pl);
        pl := pl.link
      END
    END;
  END Sync;

PROCEDURE ParentSetCage(<* UNUSED *> prntP: ParentT; <* UNUSED *> ch: VBT.T)  =
  BEGIN (* LL = ch *)
    (* do nothing *)
  END ParentSetCage;

PROCEDURE ParentSetCursor(prntP: ParentT; ch: VBT.T) =
  VAR cs := ch.getcursor();
  BEGIN
    LOCK prntP DO
      IF prntP.effectiveCursor # cs THEN
        prntP.effectiveCursor := cs;
        IF prntP.parent # NIL THEN prntP.parent.setcursor(prntP) END;
      END;
    END;
  END ParentSetCursor;

PROCEDURE ParentDiscard (prntP: ParentT) =
  BEGIN
    IF prntP.ch # NIL THEN
      IF NARROW(prntP.ch.upRef, Ref).parents = NIL THEN
        VBT.Discard(prntP.ch);
        prntP.ch.upRef := NIL;
        prntP.ch.parent := NIL;
        prntP.ch := NIL;
      END;
    END
  END ParentDiscard;
  
PROCEDURE ParentTranslate (prntP: ParentT; READONLY r: Rect.T): Rect.T =
  BEGIN
    IF prntP.ch = NIL THEN RETURN(r); END;
    LOCK prntP.ch DO
      RETURN(Rect.Add(r, prntP.delta));
    END;
  END ParentTranslate;


PROCEDURE XlateGoneCageToParent(prntP: ParentT; VAR cg: VBT.Cage) =
  VAR
    a:          Rect.Partition;
    cdom, pdom: Rect.T;
  BEGIN
      (* A gone cage on the child might still represent visible areas on the
         parent.  So:

         1) IF last position is gone or child contains parent then return
         gone 2)Factor parent domain by child domain 3) If last position in
         any rectangle, then set cage to that rectangle 4) set cage to gone
         cage. *)
    cdom := Rect.Move(prntP.cl.child.domain, prntP.delta);
    pdom := prntP.cl.current.domain;
    IF (prntP.cp.gone) OR Rect.Subset(pdom, cdom) THEN
      cg := VBT.GoneCage;
    ELSE
      Rect.Factor(pdom, cdom, a, 0, 0);
      FOR i := 0 TO 4 DO
        IF (i # 2) AND (Rect.Member(prntP.cp.pt, a[i])) THEN
          cg.rect := a[i];
          RETURN
        END;
      END;
      cg := VBT.GoneCage;
    END;
  END XlateGoneCageToParent;

PROCEDURE SetCage(v: T; ch: VBT.T)  =
  VAR
    cl: Ref;
    pl: ParentList;
    cg: VBT.Cage;
  BEGIN (* LL = ch *)
    cg := VBTClass.Cage(ch);
      VBTClass.SetCage(v, cg); (* makes VBTClass.Position happy *)
      cl := NARROW(v.upRef, Ref);
      IF cl.current = NIL THEN
          (* Mark sez: Trying to give semantics that don't give out of domain
             tracking, so: if we don't think the cursor is in any one of our
             windows (current = NIL), but the child's cage contains some
             points outside of ch's domain, then we will pretend that the
             cusor is at some such point, otherwise we will pretend it is
             gone *)
        IF NOT (TRUE IN cg.inOut) THEN VBTClass.ForceEscape(v) END
      ELSE
        LOCK cl.current DO
          pl := cl.current;
          IF (cg.screen # VBT.AllScreens) AND
             (pl.cp.screen # VBT.AllScreens) AND (cg.screen # pl.cp.screen)
          THEN
            cg := VBT.GoneCage;
          ELSIF ch.cageType = VBTClass.VBTCageType.Gone THEN
            XlateGoneCageToParent(pl, cg)
          ELSIF NOT Rect.Equal(cg.rect, Rect.Full) AND
                NOT Rect.IsEmpty(cg.rect)
          THEN
            cg.rect := Rect.Move(cg.rect, pl.delta)
          END;
        END;
        VBTClass.SetCage(cl.current, cg)
    END
  END SetCage;

PROCEDURE SetCursor(v: T; ch: VBT.T)  =
  VAR
    cl: Ref;
    pl: ParentList;
    cs: ScrnCursor.T;
  BEGIN (* LL = ch *)
    cs := ch.getcursor();
    LOCK v DO
      v.effectiveCursor := cs;
      cl := NARROW(v.upRef, Ref);
      pl := cl.parents;
      WHILE pl # NIL DO
        pl.setcursor(v);
        pl := pl.link
      END;
    END;
  END SetCursor;

(* If all the parents agree on a new screen type, then return that
   else return the current st *)
PROCEDURE NewST(v: T): VBT.ScreenType =
  VAR
    parentST: VBT.ScreenType := NIL;
    parents := NARROW(v.upRef, Ref).parents;
  BEGIN
    WHILE parents # NIL DO
      IF parentST # parents.st THEN
        IF parentST = NIL THEN
          parentST := parents.st;
        ELSIF parents.st # NIL THEN
          RETURN v.st;
        END;
      END;
      parents := parents.link;
    END;
    RETURN parentST;
  END NewST;

PROCEDURE Rescreen(prntP: ParentT; 
                   <* UNUSED *> READONLY cd: VBT.RescreenRec)  =
  VAR
    pl:            ParentList;
    needsRescreen: BOOLEAN;
    newST: VBT.ScreenType;
  BEGIN
    LOCK muCache DO
      IF prntP = vCache1 THEN vCache1 := NIL END;
      IF prntP = vCache2 THEN vCache2 := NIL END;
    END;

    pl := prntP;
    IF pl = NIL THEN RETURN END;

    LOCK prntP.cl.mu DO
      LOCK prntP.cl.child DO
        newST := NewST(prntP.cl.child);
        IF newST = prntP.cl.child.st THEN RETURN END;
        IF newST # NIL THEN
          prntP.cl.newST         := newST;
          prntP.cl.needsRescreen := TRUE;
          prntP.cl.needsShape    := TRUE;
          prntP.cl.badRect       := Rect.Full;
          (* !!! *) Unmark(prntP.cl.child);
        END;
        needsRescreen := prntP.cl.needsRescreen;
        prntP.delta     := Point.Origin;
        prntP.dom       := Rect.Empty;
        VBTClass.ClearShortCircuit(prntP.cl.child);
        prntP.nw := Point.FromCoords(
                    TRUNC(0.5 + VBT.MMToPixels(prntP, prntP.west, Axis.T.Hor)),
                    TRUNC(0.5 + VBT.MMToPixels(prntP, prntP.north, Axis.T.Ver)));
        IF needsRescreen THEN prntP.cl.badRect := Rect.Empty; END;
      END;
    END;

    IF needsRescreen AND NOT VBT.IsMarked(prntP.cl.child) THEN
      Redisplay(prntP.cl.child)
    END
  END Rescreen;

PROCEDURE Reshape(prntP: ParentT; READONLY cd: VBT.ReshapeRec)  =
  VAR
    a:             Rect.Partition;
    delta:         Point.T;
    needsRescreen: BOOLEAN;
  BEGIN
    IF prntP.cl = NIL THEN RETURN END;
    needsRescreen := FALSE;

    LOCK prntP.cl.mu DO
      LOCK prntP.cl.child DO
        prntP.delta := Point.Sub(Rect.NorthWest(cd.new), prntP.nw);
        prntP.dom   := cd.new;
        VBTClass.ClearShortCircuit(prntP.cl.child);
        IF Rect.IsEmpty(cd.prev) AND NOT Rect.IsEmpty(cd.new) THEN
          needsRescreen := prntP.cl.needsRescreen;
          IF needsRescreen THEN prntP.cl.badRect := Rect.Empty; END;
        END;
      END;

      IF NOT needsRescreen THEN
          (* use old bits if possible; pass repaints to child as necessary *)
        delta := Point.Sub(Rect.NorthWest(cd.new), Rect.NorthWest(cd.prev));
        Rect.Factor(
          cd.new, Rect.Move(Rect.Meet(cd.saved, cd.prev), delta), a, 0, 0);
        FOR i := 0 TO 4 DO
          IF NOT Rect.IsEmpty(a[i]) THEN
            IF i = 2 THEN
              VBT.Scroll(prntP, a[2], delta, PaintOp.Copy)
            ELSIF prntP.cl.parents.link = NIL THEN
              VBTClass.Repaint(
                prntP.cl.child,
                Region.FromRect(Rect.Move(a[i], Point.Minus(prntP.delta))))
            ELSE
              VBT.ForceRepaint(
                prntP.cl.child,
                Region.FromRect(Rect.Move(a[i], Point.Minus(prntP.delta))))
            END
          END
        END;
        Rect.Factor(
          cd.new, Rect.Add(prntP.cl.child.domain, prntP.delta), a, 0, 0);
        FOR i := 0 TO 4 DO
          IF i # 2 THEN
            VBT.PaintTexture(
              prntP, a[i], PaintOp.BgFg, Pixmap.Gray, Point.Origin)
          END
        END
      END;
    END;

    IF needsRescreen AND NOT VBT.IsMarked(prntP.cl.child) THEN
      Redisplay(prntP.cl.child);
    END;
  END Reshape;

PROCEDURE Repaint(prntP: ParentT; READONLY br: Region.T)  =
  VAR
    a:  Rect.Partition;
  BEGIN
    IF prntP.cl # NIL THEN
      LOCK prntP.cl.mu DO
        IF prntP.cl.parents.link = NIL THEN
          VBTClass.Repaint(
            prntP.cl.child,
            Region.FromRect(Rect.Move(br.r, Point.Minus(prntP.delta))))
        ELSE
          VBT.ForceRepaint(
            prntP.cl.child,
            Region.FromRect(Rect.Move(br.r, Point.Minus(prntP.delta))))
        END;
        Rect.Factor(
          br.r, Rect.Move(prntP.cl.child.domain, prntP.delta), a, 0, 0);
        FOR i := 0 TO 4 DO
          IF i # 2 THEN
            VBT.PaintTexture(
              prntP, a[i], PaintOp.BgFg, Pixmap.Gray, Point.Origin)
          END
        END
      END;
    END
  END Repaint;

VAR
  vCache1, vCache2: VBT.T;
  tCache1, tCache2: Trestle.T;
  muCache:          Thread.Mutex;

(* LL = VBT.mu *)
PROCEDURE SameTrestle(v1, v2: VBT.T): BOOLEAN =
  VAR
    sor: Trestle.ScreenOfRec;
  BEGIN
    LOCK muCache DO
      IF v1 = v2 THEN RETURN TRUE END;
      IF v1 # vCache1 THEN
        vCache1 := v1;
        sor     := Trestle.ScreenOf(v1, Point.Origin);
        tCache1 := sor.trsl;
      END;
      IF v2 # vCache2 THEN
        vCache2 := v2;
        sor     := Trestle.ScreenOf(v2, Point.Origin);
        tCache2 := sor.trsl;
      END;
    END;
    RETURN tCache1 = tCache2;
  END SameTrestle;

PROCEDURE Mouse(prntP: ParentT; READONLY cd: VBT.MouseRec)  =
  VAR
    cl:        Ref;
    cdP:       VBT.MouseRec;
    child:     T;
    oldParent: ParentT;
    deliver:   BOOLEAN;
  BEGIN
    IF (prntP.cl # NIL) AND 
       (NOT cd.cp.gone OR 
       (cd.time # prntP.cl.lastButtonTime))
    THEN
        (* If a mouse button goes down in one parent and comes up in another,
           then the second up transition will be followed by an up transition
           with the same event time in the first parent, which should not be
           delivered to the join. This is the purpose of the above test. Note
           that the initial value of the .lastButtonTime is irrelevant, since
           the first transition will be of type FirstDown (at least it will
           be if it's important), and consequently will not have position
           "gone". *)
      cl := prntP.cl;
      cl.lastButtonTime := cd.time;
      cdP := cd;
      IF NOT cd.cp.gone THEN cdP.cp.pt := Point.Sub(cd.cp.pt, prntP.delta) END;
      child     := cl.child;
      oldParent := child.parent;
      deliver   := TRUE;
      IF oldParent = NIL THEN
        child.parent := prntP;
        LOCK child DO ClearParentCages(cl); END;
      ELSIF NOT SameTrestle(oldParent, prntP) THEN
        IF cl.allButtonsUp AND (cd.clickType = VBT.ClickType.FirstDown) THEN
          ETAgent.ReleaseSelections(oldParent);
          child.parent := prntP;
          NARROW(child.upRef, Ref).current := prntP;
          LOCK child DO ClearParentCages(cl); END; 
        ELSE
          deliver := FALSE
        END
      END;
      IF deliver THEN
        VBTClass.Mouse(child, cdP);
        cl.allButtonsUp := cd.clickType = VBT.ClickType.LastUp
      END;
    END
  END Mouse;

PROCEDURE Misc(prntP: ParentT; READONLY cd: VBT.MiscRec)  =
  VAR
    child: T;
  BEGIN
    IF prntP.cl # NIL THEN
      child := prntP.cl.child;
      IF cd.type.typ = VBT.Deleted.typ THEN
        RemParent(child, prntP);
        Redisplay(child);
      ELSE
        ETAgent.T.misc(prntP, cd)
      END;
    END;
  END Misc;

PROCEDURE Key(prntP: ParentT; 
              READONLY cd: VBT.KeyRec)  =
  BEGIN   ETAgent.T.key(prntP, cd);
  END Key;

PROCEDURE Position(prntP: ParentT; READONLY cd: VBT.PositionRec)  =
  VAR
    b:      BOOLEAN;
    cdP:    VBT.PositionRec;
    parent: ParentT;
  BEGIN
    IF prntP.cl # NIL THEN
        parent := prntP.cl.child.parent;
        IF (parent = NIL) OR SameTrestle(parent, prntP) THEN
          LOCK prntP.cl.child DO
              (* lock muP since child SetCage reads cl.current *)
            prntP.cp := cd.cp;
            IF NOT cd.cp.gone THEN
              prntP.cl.current       := prntP;
              prntP.cl.child.parent := prntP; (* for SetCage *)
              b             := TRUE
            ELSIF prntP = prntP.cl.current THEN
              prntP.cl.current := NIL;
              b       := TRUE
            ELSE
              b := FALSE
            END
          END;
          IF cd.cp.gone THEN
            VBT.SetCage(prntP, VBT.GoneCage)
          ELSE
            VBT.SetCage(prntP, VBT.CageFromRect(prntP.domain, cd.cp))
          END;
          IF b THEN
            cdP       := cd;
            cdP.cp.pt := Point.Sub(cdP.cp.pt, prntP.delta);
            VBTClass.Position(prntP.cl.child, cdP)
          END
        END;
    END
  END Position;

BEGIN
  muCache := NEW(MUTEX);
  vCache1 := NIL;
  vCache2 := NIL;
  tCache1 := NIL;
  tCache2 := NIL;
END JoinVBT.