<*PRAGMA LL*>

UNSAFE MODULE XScrnCrsr;

IMPORT Cursor, Rect, ScrnCursor, ScrnPixmap, Text, TrestleComm, X, XClient,
       XClientF, XCursors, XScreenType, TrestleOnX, XScrnPxmp, ScreenType;

REVEAL T = T_Pub BRANDED OBJECT cursorGC, cursorGC2: X.GC := NIL;  END;

TYPE
  CursorOracle = ScrnCursor.Oracle OBJECT
                   st: XScreenType.T;
                 OVERRIDES
                   load    := CursorRegister;
                   list    := CursorList;
                   lookup  := CursorLookup;
                   builtIn := CursorBuiltIn
                 END;
  XCursor = ScrnCursor.T OBJECT
            OVERRIDES
              unload   := CursorUnregister;
              localize := CursorLocalize
            END;

PROCEDURE NewOracle (scrn: XScreenType.T): ScrnCursor.Oracle =
  BEGIN
    RETURN NEW(CursorOracle, st := scrn)
  END NewOracle;

PROCEDURE NullCursor (dpy: X.DisplayStar; w: X.Drawable): X.Cursor
  RAISES {TrestleComm.Failure} <* LL.sup = trsl, such that trsl.dpy = dpy *> =
  VAR
    rgb               := X.XColor{0, 0, 0, 0, 0, 0};
    zero: X.Pixmap;
    gc  : X.GC;
    gcv : X.XGCValues;
    res : X.Cursor;
  BEGIN
    TRY
      zero := X.XCreatePixmap(dpy, w, 1, 1, 1);
      gcv.function := X.GXclear;
      gc := X.XCreateGC(dpy, zero, X.GCFunction, ADR(gcv));
      X.XFillRectangle(dpy, zero, gc, 0, 0, 1, 1);
      X.XFreeGC(dpy, gc);
      res :=
        X.XCreatePixmapCursor(dpy, zero, zero, ADR(rgb), ADR(rgb), 0, 0);
      X.XFreePixmap(dpy, zero);
    EXCEPT
      X.Error => RAISE TrestleComm.Failure
    END;
    RETURN res
  END NullCursor;

PROCEDURE CursorRegister (                    orc: CursorOracle;
                                     READONLY c  : ScrnCursor.Raw;
                          <*UNUSED*>          nm : TEXT             := NIL):
  ScrnCursor.T RAISES {TrestleComm.Failure} =
  VAR
    gcv   : X.XGCValues;
    res                 := NEW(XCursor);
    fg, bg: X.XColor;
  BEGIN
    TRY
    IF (c.plane1 = NIL) OR (c.plane2 = NIL) OR (c.plane1.depth # 1)
         OR (c.plane2.depth # 1) OR Rect.IsEmpty(c.plane1.bounds)
         OR (c.plane1.bounds # c.plane2.bounds) THEN
      RETURN ScrnCursor.DontCare
    END;
    WITH st   = orc.st,
         trsl = st.trsl,
         dpy  = trsl.dpy DO
      TrestleOnX.Enter(trsl);
      TRY
        WITH mask   = XScrnPxmp.PixmapFromRaw(st.bits, c.plane1),
             source = XScrnPxmp.PixmapFromRaw(st.bits, c.plane2)  DO
          IF st.cursorGC = NIL THEN
            gcv.function := X.GXor;
            gcv.graphics_exposures := X.False;
            st.cursorGC := X.XCreateGC(dpy, mask, X.GCFunction, ADR(gcv))
          END;
          IF st.cursorGC2 = NIL THEN
            gcv.function := X.GXorInverted;
            gcv.graphics_exposures := X.False;
            st.cursorGC2 := X.XCreateGC(dpy, mask, X.GCFunction, ADR(gcv))
          END;
          X.XCopyArea(dpy, source, mask, st.cursorGC, 0, 0,
                      Rect.HorSize(c.plane1.bounds),
                      Rect.VerSize(c.plane1.bounds), 0, 0);
          IF st.color THEN
            fg.red := ROUND(FLOAT(16_ffff) * c.color1.r);
            fg.green := ROUND(FLOAT(16_ffff) * c.color1.g);
            fg.blue := ROUND(FLOAT(16_ffff) * c.color1.b);
            bg.red := ROUND(FLOAT(16_ffff) * c.color2.r);
            bg.green := ROUND(FLOAT(16_ffff) * c.color2.g);
            bg.blue := ROUND(FLOAT(16_ffff) * c.color2.b)
          ELSIF st.depth # 1 THEN
            fg.red := ROUND(FLOAT(16_ffff) * c.color1.gray);
            fg.green := fg.red;
            fg.blue := fg.red;
            bg.red := ROUND(FLOAT(16_ffff) * c.color2.gray);
            bg.green := bg.red;
            bg.blue := bg.red
          ELSE
            IF c.color1.bw = Cursor.BW.UseBg THEN
              fg.red := 16_ffff;
              (* gross hack for broken Macintosh XServer *)
              X.XCopyArea(dpy, mask, source, st.cursorGC2, 0, 0,
                          Rect.HorSize(c.plane1.bounds),
                          Rect.VerSize(c.plane1.bounds), 0, 0);
            ELSE
              fg.red := 0
            END;
            fg.green := fg.red;
            fg.blue := fg.red;
            IF c.color2.bw = Cursor.BW.UseBg THEN
              bg.red := 16_ffff
            ELSE
              bg.red := 0
            END;
            bg.green := bg.red;
            bg.blue := bg.red
          END;
          res.id :=
            X.XCreatePixmapCursor(dpy, source, mask, ADR(fg), ADR(bg),
                                  c.hotspot.h - c.plane1.bounds.west,
                                  c.hotspot.v - c.plane1.bounds.north);
          X.XFreePixmap(dpy, mask);
          X.XFreePixmap(dpy, source)
        END
      FINALLY
        TrestleOnX.Exit(trsl)
      END
    END;
    EXCEPT X.Error => RAISE TrestleComm.Failure END;
    RETURN res
  END CursorRegister;

PROCEDURE CursorList (<*UNUSED*> orc       : CursorOracle;
                      <*UNUSED*> pat       : TEXT;
                      <*UNUSED*> maxResults: CARDINAL       := 1):
  REF ARRAY OF TEXT =
  BEGIN
    RETURN NIL
  END CursorList;

PROCEDURE CursorLookup (orc: CursorOracle; name: TEXT): ScrnCursor.T
  RAISES {TrestleComm.Failure} =
  VAR
    trsl: XClient.T := orc.st.trsl;
    res             := NEW(XCursor);
  BEGIN
    TRY
    FOR i := 0 TO LAST(XCursors.Names) DO
      IF Text.Equal(name, XCursors.Names[i]) THEN
        TrestleOnX.Enter(trsl);
        TRY
          res.id := X.XCreateFontCursor(trsl.dpy, 2 * i);
          RETURN res
        FINALLY
          TrestleOnX.Exit(trsl)
        END
      END
    END;
    EXCEPT X.Error => RAISE TrestleComm.Failure END;
    RETURN NIL
  END CursorLookup;

PROCEDURE CursorBuiltIn (orc: CursorOracle; cs: Cursor.Predefined):
  ScrnCursor.T =
  VAR ret: ScrnCursor.T := ScrnCursor.DontCare;
  BEGIN
    WITH st   = orc.st,
         trsl = st.trsl,
         dpy  = trsl.dpy DO
      TRY
        TrestleOnX.Enter(trsl);
        TRY
          CASE cs OF
          | Cursor.DontCare.cs =>
          | Cursor.TextPointer.cs =>
            ret := NEW(XCursor,
                       id := X.XCreateFontCursor(dpy, 68 (*X.XC_left_ptr*)));
          | Cursor.NotReady.cs =>
            ret := NEW(XCursor,
                       id := X.XCreateFontCursor(dpy, 150 (*X.XC_watch*)));
          ELSE
            ret := NEW(XCursor, id := X.None);
          END
        FINALLY
          TrestleOnX.Exit(trsl)
        END
      EXCEPT
      | X.Error, TrestleComm.Failure =>
      END
    END;
    RETURN ret;
  END CursorBuiltIn;

PROCEDURE CursorLocalize (<*UNUSED*> cs: XCursor): ScrnCursor.Raw
  RAISES {ScrnCursor.Failure} =
  BEGIN
    RAISE ScrnCursor.Failure
  END CursorLocalize;

PROCEDURE CursorUnregister (<*UNUSED*> cs: XCursor) =
  BEGIN
  END CursorUnregister;

BEGIN
END XScrnCrsr.