dps/src/DPS.m3


Copyright (C) 1994, Digital Equipment Corp.

UNSAFE MODULE DPS;

IMPORT Unix, Fifo, SchedulerPosix, Text, Err, Fmt;
IMPORT TextWr, Thread, Wr, cDPS, wraps, DPS;

<*FATAL Wr.Failure, Thread.Alerted *>

CONST PointsPerPixel = 0.92182;
Get this from X someday. Experimental pMax value.

CONST SendStackBufferSize = 8000;

CONST ClipRepainting = TRUE;

TYPE TalkToXThreadClosure = Thread.Closure OBJECT END;

TYPE TList = RECORD next: REFTList; t: T; END;
TYPE REFTList = REF TList;

VAR cPostScriptMutex: MUTEX;
VAR transformChangeMutex: MUTEX;

VAR tsMonitor: MUTEX; (* Serializes access to X and DPS engine. *)

VAR globalTs: REFTList;
VAR globalMaxXfd: INTEGER;
VAR globalXfds: Unix.FDSet;

CONST millisecond = 0.001d0;

VAR preferredFontName := "Times-Roman";

PROCEDURE GSaveAndClip (box: Box): TEXT =
  BEGIN
  RETURN " gsave " & NewPathBox (box) & " clip newpath ";
  END GSaveAndClip;

PROCEDURE NewPathBox (box: Box): TEXT =
 VAR data: TEXT;
  BEGIN
  data := " newpath "
    & Fmt.Real(box.low.x) & " dup " & Fmt.Real(box.low.y)
    & " moveto "
    & Fmt.Real(box.high.y)
    & " lineto "
    & Fmt.Real(box.high.x) & " dup " & Fmt.Real(box.high.y)
    & " lineto "
    & Fmt.Real(box.low.y)
    & " lineto closepath ";
  RETURN data;
  END NewPathBox;

PROCEDURE GSaveAndClipIf (box, containee: Box): TEXT =
  BEGIN
  IF ContainerContainee (box, containee) THEN RETURN " gsave ";
   ELSE RETURN GSaveAndClip (box);
    END;
  END GSaveAndClipIf;

PROCEDURE GRestore (): TEXT =
  BEGIN
  RETURN " grestore ";
  END GRestore;

PROCEDURE BoxCoordsAsText (box: Box): TEXT =
  BEGIN
  RETURN " " & Fmt.Real(box.low.x) & " " & Fmt.Real(box.low.y)
     & " " & Fmt.Real(box.high.x) & " " & Fmt.Real(box.high.y)
     & " ";
  END BoxCoordsAsText;

PROCEDURE BoxAlter (b: Box; fp: FixedPoint; w, h: REAL := -1.0): Box =
 VAR d: REAL;
  BEGIN
  IF w >= 0.0 THEN
    CASE fp OF
    | FixedPoint.nw, FixedPoint.w, FixedPoint.sw =>
       b.high.x := b.low.x + w;
    | FixedPoint.n, FixedPoint.c, FixedPoint.s =>
      d := w - (b.high.x - b.low.x);
      b.low.x := b.low.x - d / 2.0; b.high.x := b.high.x + d / 2.0;
    | FixedPoint.ne, FixedPoint.e, FixedPoint.se =>
      b.low.x := b.high.x - w;
      END;
    END;
  IF h >= 0.0 THEN
    CASE fp OF
    | FixedPoint.nw, FixedPoint.n, FixedPoint.ne =>
       b.low.y := b.high.y - h;
    | FixedPoint.w, FixedPoint.c, FixedPoint.e =>
      d := h - (b.high.y - b.low.y);
      b.low.y := b.low.y - d / 2.0; b.high.y := b.high.y + d / 2.0;
    | FixedPoint.sw, FixedPoint.s, FixedPoint.se =>
       b.high.y := b.low.y + h;
      END;
    END;
  RETURN b;
  END BoxAlter;

PROCEDURE BoxesIntersect (b1, b2: Box): BOOLEAN =
  BEGIN
  RETURN (b1.high.x > b2.low.x) AND (b1.high.y > b2.low.y)
   AND (b1.low.x < b2.high.x) AND (b1.low.y < b2.high.y);
  END BoxesIntersect;

PROCEDURE ContainerContainee (b1, b2: Box): BOOLEAN =
  BEGIN
  RETURN (b1.high.x >= b2.high.x) AND (b1.high.y >= b2.high.y)
   AND (b1.low.x <= b2.low.x) AND (b1.low.y <= b2.low.y);
  END ContainerContainee;

PROCEDURE PlaceIsInBox (p: Place; b: Box): BOOLEAN =
  BEGIN
  RETURN (p.x > b.low.x) AND (p.y > b.low.y)
   AND (p.x < b.high.x) AND (p.y < b.high.y);
  END PlaceIsInBox;

PROCEDURE BoxUnion (b1, b2: Box): Box =
  BEGIN
  RETURN Box { Place { MIN(b1.low.x,b2.low.x), MIN(b1.low.y,b2.low.y) },
    Place { MAX(b1.high.x,b2.high.x), MAX(b1.high.y,b2.high.y) } };
  END BoxUnion;

CONST grayStrokeWidthText = "4.0"; (* Only 'inside' paints, due to clip. *)
CONST colorStrokeWidthText = "4.0"; (* Only 'inside' paints, due to clip. *)

PROCEDURE EdgedBoxClipAndPaint (box: Box; hue: REAL := -1.0): TEXT = (* Hue < 0.0 => Grays. *)
 VAR path: TEXT := "";
  BEGIN
  IF box = ZeroBox THEN RETURN NIL; END;
  path := " newpath "
     & Fmt.Real(box.low.x) & " " & Fmt.Real(box.low.y) & " moveto "
     & Fmt.Real(box.low.x) & " " & Fmt.Real(box.high.y) & " lineto "
     & Fmt.Real(box.high.x) & " " & Fmt.Real(box.high.y) & " lineto "
     & Fmt.Real(box.high.x) & " " & Fmt.Real(box.low.y) & " lineto "
     & " closepath ";
  IF hue >= 0.0 THEN
    RETURN " " & path & " clip "
     & Fmt.Real(hue) & " 0.5 0.9 sethsbcolor gsave fill grestore "
     & Fmt.Real(hue) & " 1.0 0.3 sethsbcolor "
     & colorStrokeWidthText & " setlinewidth stroke ";
   ELSE
    RETURN " " & path & " clip 0.9 setgray gsave fill grestore "
     & "0.1 setgray " & grayStrokeWidthText & " setlinewidth stroke ";
    END;
  END EdgedBoxClipAndPaint;

PROCEDURE EscapeText (text: TEXT): TEXT = (* Fixes parens etc. for show. *)
 VAR k: INTEGER;
 VAR count: INTEGER;
 VAR a, b: REF ARRAY OF CHAR;
  BEGIN
  k := Text.FindChar (text, ')');
  IF k < 0 THEN k := Text.FindChar (text, '(') END;
  IF k < 0 THEN k := Text.FindChar (text, '\\') END;
  IF k < 0 THEN RETURN text; END;
  (* Do the above first, hoping it's fast. *)
  a := NEW (REF ARRAY OF CHAR, Text.Length(text));
  Text.SetChars (a^, text);
  count := 0;
  FOR m := 0 TO Text.Length(text)-1 DO
    IF (a^[m]='(') OR (a^[m]=')') OR (a^[m]='\\') THEN count := count + 1; END;
    END;
  b := NEW (REF ARRAY OF CHAR, Text.Length(text) + count);
  k := 0;
  FOR m := 0 TO Text.Length(text)-1 DO
    IF (a^[m]='(') OR (a^[m]=')') OR (a^[m]='\\') THEN b^[k] := '\\'; k := k + 1; END;
    b^[k] := a^[m];
    k := k + 1;
    END;
  <* ASSERT k = Text.Length(text) + count *>
  RETURN Text.FromChars (SUBARRAY (b^, 0, Text.Length(text) + count));
  END EscapeText;

VAR unshifted: ARRAY [0..255] OF CHAR;
VAR shifted: ARRAY [0..255] OF CHAR;

PROCEDURE CharFromKey (key: INTEGER; modifiers: Modifiers): CHAR =
 VAR ret: CHAR;
  BEGIN
  IF Modifier.Option IN modifiers THEN RETURN '\000'; END;
  IF Modifier.Shift IN modifiers THEN ret := shifted[key];
   ELSIF Modifier.Lock IN modifiers THEN ret := shifted[key];
   ELSE ret := unshifted[key];
    END;
  IF Modifier.Ctrl IN modifiers THEN ret := VAL(ORD(ret)+128, CHAR); END;
  RETURN ret;
  END CharFromKey;

PROCEDURE InitializeCharArrays() =
 PROCEDURE Letter(i: INTEGER; c: CHAR) =
   BEGIN
   shifted[i] := c;
   unshifted[i] := VAL ( ORD(c) + 32, CHAR );
   END Letter;
 PROCEDURE Other(i: INTEGER; s, c: CHAR) =
   BEGIN
   shifted[i] := s;
   unshifted[i] := c;
   END Other;
  BEGIN
  FOR j := 0 TO 255 DO shifted[j] := '\000'; END;
  FOR j := 0 TO 255 DO unshifted[j] := '\000'; END;
  Letter(194,'A'); Letter(217,'B'); Letter(206,'C'); Letter(205,'D');
  Letter(204,'E'); Letter(210,'F'); Letter(216,'G'); Letter(221,'H');
  Letter(230,'I'); Letter(226,'J'); Letter(231,'K'); Letter(236,'L');
  Letter(227,'M'); Letter(222,'N'); Letter(235,'O'); Letter(240,'P');
  Letter(193,'Q'); Letter(209,'R'); Letter(199,'S'); Letter(215,'T');
  Letter(225,'U'); Letter(211,'V'); Letter(198,'W'); Letter(200,'X');
  Letter(220,'Y'); Letter(195,'Z');
  Other(192,'!','1'); Other(197,'@','2'); Other(203,'#','3'); Other(208,'$','4');
  Other(214,'%','5'); Other(219,'^','6'); Other(224,'&','7'); Other(229,'*','8');
  Other(234,'(','9'); Other(239,')','0'); Other(249,'_','-'); Other(245,'+','=');
  Other(250,'{','['); Other(246,'}',']'); Other(242,':',';'); Other(251,'\"','\'');
  Other(247,'|','\\'); Other(232,',',','); Other(237,'.','.'); Other(243,'?','/');
  Other(212,' ',' '); Other(232,',',','); Other(237,'.','.'); Other(243,'?','/');
  Other(189,'\n','\n'); Other(188,'\010','\010'); Other(190,'\t','\t');
  END InitializeCharArrays;

VAR globalRepainting, globalMouse, globalKey: BOOLEAN;

VAR mouseOrCleanMutex: MUTEX;

PROCEDURE CleanThreadForkee (ctc: CleanThreadClosure): REFANY RAISES {} =
 <*FATAL DPS.BadPostScript*>
 VAR r: T;
 VAR db: DirtyBox;
  BEGIN
  r := ctc.root;
  LOOP
    db := r.dirtyFifo.RemoveOrWait();
    LOCK mouseOrCleanMutex DO
      globalRepainting := TRUE;
      IF ClipRepainting THEN
       r.Send (
          " " & Fmt.Real(db.box.low.x)
        & " " & Fmt.Real(db.box.low.y)
        & " " & Fmt.Real(db.box.high.x-db.box.low.x)
        & " " & Fmt.Real(db.box.high.y-db.box.low.y)
        & " rectviewclip " );
       END;
      r.Paint (db.box, db.only);
      IF ClipRepainting THEN r.Send (" initviewclip "); END;
      globalRepainting := FALSE;
      END;
    END; (* of infinite LOOP *)
  END CleanThreadForkee;

PROCEDURE Create (t: T; width, height: INTEGER := 600; color: BOOLEAN := TRUE; over: T := NIL) =
 VAR tl: REFTList;
  BEGIN
  IF over = NIL THEN IF color THEN t.planes := 256; ELSE t.planes := 255; END;
   ELSIF over = t THEN t.planes := 1;
   ELSE
    t.dpy := over.dpy; t.win := over.win;
    IF over.planes = 1 THEN t.planes := 2;
     ELSIF over.planes = 2 THEN t.planes := 4;
     ELSE t.planes := 1;
      Err.Msg ("Bad usage of -over- in DPS.Create call.");
      END;
    END;
  LOCK cPostScriptMutex DO cDPS.docreatesimplewindow (t, width, height); END;
  tl := NEW (REFTList);
  tl^.t := t;
  t.dirtyFifo := Fifo.New (DirtyBoxMatchProc);
  LOCK tsMonitor DO
    tl^.next := globalTs; globalTs := tl;
    globalMaxXfd := MAX (globalMaxXfd, t.fd);
    globalXfds := globalXfds + Unix.FDSet{t.fd};
    END;
  SendInternal ( t, " /dps-m3-original-matrix matrix currentmatrix def "
   & " /ufill { gsave newpath uappend fill grestore } def ", TRUE );
  (* LOCK transformChangeMutex DO cDPS.stufftransforms (t); END; *)
  (* Should not need this ^^ since SendInternal does it too.  But do. *)
  (* I think its because the first one after a create has problems ... *)
  EVAL Thread.Fork (
   NEW (CleanThreadClosure, apply := CleanThreadForkee, root := t) );
  END Create;

PROCEDURE Send ( t: T; text: TEXT;
 regardlessOfCircumstance: BOOLEAN := FALSE;
 alreadyLocked: BOOLEAN := FALSE ) RAISES {BadPostScript} =
 VAR wr: Wr.T;
 VAR ri: INTEGER;
  BEGIN
  <* ASSERT ( regardlessOfCircumstance
   OR globalRepainting OR globalMouse OR globalKey) *>
  wr := t.specialWriter; IF wr#NIL THEN Wr.PutText (wr, text); END;
  IF t.alwaysNervous THEN
    ri := SendInternalNervously (t, text, FALSE, alreadyLocked);
   ELSE ri := 1; SendInternal (t, text, FALSE, alreadyLocked);
    END;
  IF ri # 0 THEN RETURN; ELSE RAISE BadPostScript(text); END;
 END Send;

 PROCEDURE SendInternalNervously ( t: T; text: TEXT;
  calculateTransforms, alreadyLocked: BOOLEAN ): INTEGER =
   VAR ri: INTEGER;
   PROCEDURE Internal () =
     BEGIN
     SendInternal (t, " { ", FALSE, TRUE);
     SendInternal (t, text, FALSE, TRUE);
     SendInternal ( t,
      " } stopped { 0 } { 1 } ifelse /success exch def ",
      calculateTransforms, TRUE );
     ri := wraps.FetchInteger (t.ctx, "success", TRUE);
     END Internal;
  BEGIN
  IF alreadyLocked THEN Internal();
   ELSE LOCK cPostScriptMutex DO Internal(); END;
    END;
  RETURN ri;
  END SendInternalNervously;

PROCEDURE SendNervously ( t: T; text: TEXT;
 regardlessOfCircumstance: BOOLEAN := FALSE;
 alreadyLocked: BOOLEAN := FALSE ) RAISES {BadPostScript} =
 VAR wr: Wr.T;
 VAR ri: INTEGER;
  BEGIN
  <* ASSERT ( regardlessOfCircumstance
   OR globalRepainting OR globalMouse OR globalKey) *>
  wr := t.specialWriter; IF wr#NIL THEN Wr.PutText (wr, text); END;
  ri := SendInternalNervously (t, text, FALSE, alreadyLocked);
  IF ri # 0 THEN RETURN; ELSE RAISE BadPostScript(text); END;
  END SendNervously;

PROCEDURE AcquireDPSMutex () =
  BEGIN
  Thread.Acquire (cPostScriptMutex);
  END AcquireDPSMutex;

PROCEDURE ReleaseDPSMutex () =
  BEGIN
  Thread.Release (cPostScriptMutex);
  END ReleaseDPSMutex;

PROCEDURE SendInternal ( t: T; text: TEXT;
 calculateTransforms: BOOLEAN := FALSE;
 alreadyLocked: BOOLEAN := FALSE)  =
 VAR chars: ARRAY [0..SendStackBufferSize] OF CHAR;
 VAR point: UNTRACED REF CHAR;
  BEGIN
  IF Text.Length(text) >= SendStackBufferSize THEN
    IF alreadyLocked THEN SimpleSendBig (t, text);
     ELSE LOCK cPostScriptMutex DO SimpleSendBig (t, text); END;
      END;
   ELSE
    Text.SetChars (chars, Text.Cat(text,"\000"));
    point := ADR(chars[0]);
    IF alreadyLocked THEN cDPS.dosendps (t, point);
     ELSE LOCK cPostScriptMutex DO cDPS.dosendps (t, point); END;
      END;
    END;
  cDPS.doflush (t); (* Necessary when sending not in TalkToX thread - 7jun91 *)
  IF calculateTransforms THEN
    LOCK transformChangeMutex DO cDPS.stufftransforms (t); END;
    END;
  END SendInternal;

VAR allocSimple: REF ARRAY OF CHAR;
VAR allocedSimple: INTEGER := 0;
PROCEDURE SimpleSendBig ( t: T; text: TEXT ) = (* Very single threaded. *)
 VAR point: UNTRACED REF CHAR;
  BEGIN
  IF Text.Length(text) > allocedSimple THEN
    Err.Msg ("Allocated buffer in DPS.SendInternal. Size = ",
              Fmt.Int(Text.Length(text)));
    allocSimple := NEW (REF ARRAY OF CHAR, Text.Length(text) + 100 + 1);
    allocedSimple := Text.Length (text) + 100;
    END;
  Text.SetChars (allocSimple^, Text.Cat(text,"\000"));
  point := ADR(allocSimple^[0]);
  cDPS.dosendps (t, point);
  END SimpleSendBig;

PROCEDURE SendClientTransformation (t: T; text: TEXT) =
  BEGIN
  t.currentTransformation := text;
  SendTransformations (t);
  END SendClientTransformation;

PROCEDURE SendTransformations (t: T) =
  BEGIN
  SendInternal ( t, " dps-m3-original-matrix setmatrix "
   & t.backgroundTransformation & " " & t.currentTransformation, TRUE );
  END SendTransformations;

PROCEDURE SendSpecialFoundation (t: T; text: TEXT) =
 VAR wr: Wr.T;
  BEGIN
  (* Do not save in foundation. But Send. DPS versus early PS printers. *)
  wr := t.specialWriter; IF wr#NIL THEN Wr.PutText (wr, text); END;
  SendInternal (t, text);
  END SendSpecialFoundation;

PROCEDURE SendFoundation (t: T; text: TEXT) =
 VAR newList: REF ARRAY OF TEXT;
 VAR slot: INTEGER;
  BEGIN (* Needs to be monitored. *)
  slot := -1;
  IF t.foundationList=NIL THEN t.foundationList := NEW (REF ARRAY OF TEXT, 100); END;
  FOR k := NUMBER(t.foundationList^)-1 TO 0 BY -1 DO
    IF t.foundationList^[k] = NIL THEN slot := k;
     ELSIF Text.Equal (t.foundationList^[k], text) THEN RETURN;
      END;
    END;
  IF slot < 0 THEN (* Full. *)
    newList := NEW (REF ARRAY OF TEXT, NUMBER(t.foundationList^) + 100);
    FOR k := 0 TO NUMBER(t.foundationList^)-1 DO
      newList^[k] := t.foundationList^[k];
      END;
    slot := NUMBER(t.foundationList^);
    t.foundationList := newList;
    END;
  t.foundationList^[slot] := text;
  SendInternal (t, text);
  END SendFoundation;

PROCEDURE UnsendFoundation (t: T; text: TEXT) =
  BEGIN (* Needs to be monitored. *)
  IF t.foundationList=NIL THEN RETURN; END;
  FOR k := NUMBER(t.foundationList^)-1 TO 0 BY -1 DO
    IF Text.Equal (t.foundationList^[k], text) THEN
      t.foundationList^[k] := NIL;
      RETURN;
      END;
    END;
  END UnsendFoundation;

PROCEDURE PostscriptToWriter (t: T; wr: Wr.T) =
 VAR r1, r2: REAL;
  BEGIN (* Not monitored. Should be. *)
  (* Client responsible for any wrapping, including 'showpage' *)
  IF t.foundationList # NIL THEN
    FOR k := 0 TO NUMBER(t.foundationList^)-1 DO
      IF t.foundationList^[k] # NIL THEN
        Wr.PutText (wr, t.foundationList^[k]);
        Wr.PutText (wr, "\n");
        END;
      END;
    END;
  Wr.PutText (wr, " /window { ");
  Wr.PutText (wr, t.backgroundTransformation);
  Wr.PutText (wr, " } def \n");
  (* Wr.PutText (wr, " window \n"); *)
  (* Up to client to invoke 'windiw' if he really wants *)
  (* the screen size as opposed to the 'desired' size. *)
  TransformToDPS (t, t.xWidth, t.xHeight, r1, r2);
  Wr.PutText ( wr,
   " 0.0 0.0 moveto " & Fmt.Real(r1) & " " & Fmt.Real(r2) & " stroke \n" );
  Wr.PutText (wr, t.currentTransformation);
  Wr.PutText (wr, "\n");
  t.specialWriter := wr;
  globalRepainting := TRUE;
  t.Paint (EverywhereBox, NIL);
  globalRepainting := FALSE; (* RISKY *)
  t.specialWriter := NIL;
  END PostscriptToWriter;

PROCEDURE PostscriptToText (t: T): TEXT =
 VAR wr: Wr.T;
  BEGIN
  wr := TextWr.New ();
  PostscriptToWriter (t, wr);
  RETURN TextWr.ToText (wr);
  END PostscriptToText;

PROCEDURE Flush (t: T) =
  BEGIN
  LOCK cPostScriptMutex DO cDPS.doflush (t); END;
  END Flush;

PROCEDURE KillInputFocus (<*UNUSED*> t: T) =
  BEGIN
  (* Work done by subclasser. *)
  END KillInputFocus;

PROCEDURE ModifiersFromX (xModifiers: INTEGER): Modifiers =
 VAR mods: Modifiers;
  BEGIN
  mods := Modifiers{};
  IF (xModifiers) MOD 16 >= 8 THEN mods := mods + Modifiers{Modifier.Option}; END;
  IF (xModifiers) MOD 8 >= 4 THEN mods := mods + Modifiers{Modifier.Ctrl}; END;
  IF (xModifiers) MOD 4 >= 2 THEN mods := mods + Modifiers{Modifier.Lock}; END;
  IF (xModifiers) MOD 2 >= 1 THEN mods := mods + Modifiers{Modifier.Shift}; END;
  RETURN mods;
  END ModifiersFromX;

PROCEDURE PreferredFontName (): TEXT =
  BEGIN
  RETURN preferredFontName;
  END PreferredFontName;

PROCEDURE SetPreferredFontName (name: TEXT) =
  BEGIN
  preferredFontName := name;
  END SetPreferredFontName;

PROCEDURE ShowItAccentedPostScript (text: TEXT): TEXT =
 VAR data: TEXT := "";
 VAR c, baseChar: CHAR;
 VAR isAccent: BOOLEAN;
  BEGIN
  IF ContainsAccent(text) THEN
    FOR j := 0 TO Text.Length(text)-1 DO
      c := Text.GetChar (text,j);
      isAccent := (j > 0) AND IsAccent (c);
      (* Treat initial accent as real character! *)
      IF isAccent THEN
        data := data & " currentpoint currentpoint exch "
         & "(" & Text.FromChar(c) & ") stringwidth pop "
         (* Knowing that accents do not have to be escaped .. *)
         & "(" & EscapeText(Text.FromChar(baseChar)) & ") stringwidth pop "
         & " add 2.0 div 1.0 add sub exch moveto ";
         (* The "1.0 add" is a heuristic for centering over vowels. *)
        ELSE baseChar := c; (* For later. *)
        END;
      data := data
       & " (" & EscapeText(Text.FromChar(c)) & ") " & " show ";
      IF isAccent THEN data := data & " moveto "; END;
      END;
   ELSE data := " (" & EscapeText(text) & ") " & " show ";
    END;
  RETURN data;
  END ShowItAccentedPostScript;

PROCEDURE ContainsAccent (text: TEXT): BOOLEAN =
 VAR it: INTEGER;
  BEGIN
  FOR j := 0 TO Text.Length(text)-1 DO
    it := ORD(Text.GetChar(text,j));
    IF (it > 192) AND (it < 208) THEN RETURN TRUE; END;
    END;
  RETURN FALSE;
  END ContainsAccent;

PROCEDURE IsAccent (char: CHAR): BOOLEAN =
 VAR it: INTEGER;
  BEGIN
  it := ORD(char);
  IF (it > 192) AND (it < 208) THEN RETURN TRUE; END;
  RETURN FALSE;
  END IsAccent;

 VAR recentMeasureFontName: TEXT := "";
 VAR recentMeasurement: REF ARRAY [0..255] OF REAL;
 VAR recentMeasureMutex: MUTEX;

PROCEDURE MeasureText (
 text: TEXT; window: T; fontName: TEXT;
 accentsHaveWidth: BOOLEAN := FALSE ):
 REF ARRAY OF REAL =
 VAR ret: REF ARRAY OF REAL;
 VAR thisMeasurement: REF ARRAY [0..255] OF REAL;
 VAR voidHeight: REAL;
  BEGIN
  ret := NEW ( REF ARRAY OF REAL, Text.Length(text) );
  LOCK recentMeasureMutex DO
    IF Text.Equal (recentMeasureFontName, fontName) THEN
      thisMeasurement := recentMeasurement;
     ELSE thisMeasurement := NIL;
      END;
    END;

  IF thisMeasurement = NIL THEN
     thisMeasurement := NEW (REF ARRAY [0..255] OF REAL);
     FOR j := 0 TO 255 DO
     IF j < 32 THEN thisMeasurement^[j] := 0.0;
      ELSIF (j > 127) AND (j < 161) THEN thisMeasurement^[j] := 0.0;
      ELSIF j = 255 THEN thisMeasurement^[j] := 0.0;
      ELSE
        LOCK tsMonitor DO
          wraps.Stringwidth ( window.ctx, fontName, Text.FromChar(VAL(j,CHAR)),
          voidHeight, thisMeasurement^[j] );
          END;
        END;
      END;
    END;

  LOCK recentMeasureMutex DO
    IF NOT Text.Equal (recentMeasureFontName, fontName) THEN
      recentMeasureFontName := fontName;
      recentMeasurement := thisMeasurement;
      END;
    END;

  FOR j := 0 TO Text.Length(text)-1 DO
    IF (NOT accentsHaveWidth) AND IsAccent(Text.GetChar(text,j)) THEN
      ret^[j] := 0.0;
     ELSE ret^[j] := thisMeasurement^[ORD(Text.GetChar(text,j))];
      END;
    END;
  RETURN ret;
  END MeasureText;

PROCEDURE TextWidth (
 text: TEXT; window: T; fontName: TEXT;
 accentsHaveWidth: BOOLEAN := FALSE ): REAL =
 VAR thisMeasurement: REF ARRAY [0..255] OF REAL;
 VAR voidHeight, width: REAL;
  BEGIN
  LOCK recentMeasureMutex DO
    IF Text.Equal (recentMeasureFontName, fontName) THEN
      thisMeasurement := recentMeasurement;
     ELSE thisMeasurement := NIL;
      END;
    END;

  IF (thisMeasurement = NIL) AND accentsHaveWidth THEN
    LOCK tsMonitor DO
      wraps.Stringwidth ( window.ctx, fontName, text,
      voidHeight, width );
      END;
    RETURN width;
    END;

  IF thisMeasurement = NIL THEN
     thisMeasurement := NEW (REF ARRAY [0..255] OF REAL);
     FOR j := 0 TO 255 DO
     IF j < 32 THEN thisMeasurement^[j] := 0.0;
      ELSIF (j > 127) AND (j < 161) THEN thisMeasurement^[j] := 0.0;
      ELSIF j = 255 THEN thisMeasurement^[j] := 0.0;
      ELSE
        LOCK tsMonitor DO
          wraps.Stringwidth ( window.ctx, fontName, Text.FromChar(VAL(j,CHAR)),
          voidHeight, thisMeasurement^[j] );
          END;
        END;
      END;
    END;

  LOCK recentMeasureMutex DO
    IF NOT Text.Equal (recentMeasureFontName, fontName) THEN
      recentMeasureFontName := fontName;
      recentMeasurement := thisMeasurement;
      END;
    END;

  width := 0.0;
  FOR j := 0 TO Text.Length(text)-1 DO
    IF accentsHaveWidth OR (NOT IsAccent(Text.GetChar(text,j))) THEN
      width := width + thisMeasurement^[ORD(Text.GetChar(text,j))];
      END;
    END;
  RETURN width;
  END TextWidth;

PROCEDURE MeasureChar ( char: CHAR; window: T; fontName: TEXT;
 accentsHaveWidth: BOOLEAN := FALSE ): REAL =
 VAR array: REF ARRAY OF REAL;
  BEGIN
  array := MeasureText ( Text.FromChar(char),
   window, fontName, accentsHaveWidth );
  RETURN array^[0];
  END MeasureChar;

PROCEDURE ButtonFromX (xButton: INTEGER): Button =
  BEGIN
  CASE xButton OF
  | 1 => RETURN Button.Left;
  | 2 => RETURN Button.Middle;
  | 3 => RETURN Button.Right;
    ELSE <*ASSERT FALSE*>
    END;
  END ButtonFromX;

TYPE DirtyBox = Fifo.E OBJECT box: Box; only: REFANY; END;

TYPE CleanThreadClosure = Thread.Closure OBJECT root: T; END;

PROCEDURE Dirty (t: T; box: Box; only: REFANY) =
 (* VAR c: INTEGER;*)
  BEGIN
  t.dirtyFifo.Insert ( NEW(DirtyBox, box := box, only := only) );
  (*
  c := t.dirtyFifo.Count();
  IF c > 9 THEN
    Err.Msg ("Awaiting DPS: ", Fmt.Integer(c), " Requests." );
    END;
  *)
  END Dirty;

PROCEDURE DirtyBoxMatchProc (new, old: Fifo.E): Fifo.E =
 VAR o, n: DirtyBox;
  BEGIN
  TYPECASE old OF DirtyBox => o := NARROW(old, DirtyBox) ELSE RETURN NIL END;
  TYPECASE new OF DirtyBox => n := NARROW(new, DirtyBox) ELSE RETURN NIL END;
  IF n.box = o.box THEN (* Only equality for now. *)
    IF n.only = o.only THEN RETURN old; END;
    IF o.only = NIL THEN RETURN old; END;
    IF n.only = NIL THEN RETURN new; END;
    END;
  RETURN NIL;
  END DirtyBoxMatchProc;

PROCEDURE CallMouseProc ( t: T;
 b: Button; p: Place; m: Modifiers; c: ClickType ) =
  BEGIN
  LOCK mouseOrCleanMutex DO
    globalMouse := TRUE;
    EVAL t.Mouse ( MouseEvent { b, p, m, c } );
    globalMouse := FALSE;
    END;
  END CallMouseProc;

PROCEDURE CallKeyProc ( t: T; k: INTEGER; m: Modifiers; c: ClickType ) =
  BEGIN
  LOCK mouseOrCleanMutex DO
    globalKey := TRUE;
    t.Key ( KeyEvent { k, m, c } );
    globalKey := FALSE;
    END;
  END CallKeyProc;

PROCEDURE TalkToX (<*UNUSED*> tc: TalkToXThreadClosure): REFANY RAISES {} =
 VAR displaySource: T;
 VAR ts: ARRAY [0..7] OF T;
 VAR tscount: INTEGER;
 VAR box: Box;
 VAR in, out: INTEGER;
 VAR win: INTEGER;
 VAR event: INTEGER;
 VAR xButton, xModifiers: INTEGER;
 VAR xX, xY, xW, xH: INTEGER;
 VAR r1, r2, r3, r4, r5, r6, r7, r8: REAL;
 VAR scale1, scale2: REAL;
 VAR num, den: REAL;
 VAR recentDown: Button;
 VAR cursorLocation: T;
 VAR it: INTEGER;
  PROCEDURE EvaluateCursorLocation() =
   BEGIN
    FOR k := 0 TO tscount-1 DO
      IF ts[k].cursor # 0 THEN cursorLocation := ts[k]; RETURN; END;
      END;
    cursorLocation := ts[0];
    END EvaluateCursorLocation;
  BEGIN
  in := 0; out := 0;
  displaySource := NIL;
  WHILE displaySource = NIL DO (* Assuming all windows on same display. *)
    Thread.Pause (10.0d0 * millisecond);
    LOCK tsMonitor DO
      IF globalTs#NIL THEN displaySource := globalTs^.t;
        <* ASSERT displaySource#NIL *>
        END;
      END;
    END;
  LOOP
    win := 0;
    in := in + 1;
    Thread.Pause(0.1d0 * millisecond); (* Thread.Yield() *)
    LOCK cPostScriptMutex DO
      cDPS.doprocessinputs ( displaySource.dpy,
      ADR(win), ADR(event), ADR(xButton), ADR(xModifiers),
      ADR(xX), ADR(xY), ADR(xW), ADR(xH) );
      END;
    out := out + 1;
    IF win # 0 THEN
      tscount := WinToTs (win, ts);
      IF tscount > 0 THEN
        CASE event OF
        | 21 => (* Button Down. *)
             EvaluateCursorLocation();
             TransformToDPS (cursorLocation, xX, xY, r1, r2);
             recentDown := ButtonFromX(xButton);
             CallMouseProc ( cursorLocation,
              recentDown, Place{r1,r2},
              ModifiersFromX (xModifiers), ClickType.FirstDown );
        | 22 => (* Button Up. *)
             EvaluateCursorLocation();
             TransformToDPS (cursorLocation, xX, xY, r1, r2);
             CallMouseProc ( cursorLocation,
              ButtonFromX(xButton), Place{r1,r2},
              ModifiersFromX (xModifiers), ClickType.LastUp );
        | 23 => (* Button Dragging: xButton is -state- not -button-! *)
             EvaluateCursorLocation();
             TransformToDPS (cursorLocation, xX, xY, r1, r2);
             CallMouseProc ( cursorLocation,
              recentDown, Place{r1,r2},
              ModifiersFromX (xModifiers), ClickType.Dragging );
        | 31 => (* Key Down is mostly ignored. *)
             IF (xButton=167) AND (tscount>1) THEN
               (* Cycle the cursor window. *)
               (* 167 thru 170 are arrow keys. *)
               (* 177 is -compose- 174 is top-left function. *)
               it := -1;
               FOR k := 0 TO tscount-1 DO
                 IF ts[k].cursor # 0 THEN it := k; END;
                 END;
               IF it >= 0 THEN
                 ts[(it+1) MOD tscount].cursor := ts[it].cursor;
                 ts[it].cursor := 0;
                 cDPS.noticeCursor (ts[(it+1) MOD tscount]);
                 END;
               END;
        | 32 => (* Key Up. *)
             CallKeyProc ( ts[0], xButton,
              ModifiersFromX (xModifiers), ClickType.LastUp );
        | 41 => (* ConfigureNotify: new values in x, y, width, height. *)
             IF (xW # 0) AND (xH # 0) THEN (* Not bogus / null reformat. *)
               FOR k := 0 TO tscount-1 DO
                 IF ((xW # ts[k].xWidth) OR (xH # ts[k].xHeight)) THEN
                   IF (ts[k].desiredWidth # 0.0)
                    AND (ts[k].desiredHeight # 0.0) THEN
                     scale1 := FLOAT (xW)
                      * PointsPerPixel / ts[k].desiredWidth;
                     scale2 := FLOAT (xH)
                      * PointsPerPixel / ts[k].desiredHeight;
                     IF ts[k].backgroundTransformationMaintainsSimilarity THEN
                       scale1 := MIN (scale1, scale2);
                       IF ts[k].backgroundTransformationScaler > 0.0 THEN
                         scale2 := 1.0; (* Used as a temp. *)
                         WHILE scale2 >= scale1 * 2.0 DO
                           scale2 := scale2 / 2.0;
                           END;
                         WHILE scale2 < scale1 DO scale2 := scale2 * 2.0; END;
                         (* Scale2 is closest 2^n above or equal to scale1. *)
                         num := ts[k].backgroundTransformationScaler * scale2;
                         den := num;
                         WHILE ( scale2 * num / den > scale1 ) DO
                           num := num - 1.0;
                           END;
                         scale1 := scale2 * num / den;
                         END;
                       scale2 := scale1;
                       END;
                     (* DPS with gravity # NorthWest is buggy. *)
                     ts[k].yTranslationNeeded := FLOAT (FullHeight - xH)
                      * PointsPerPixel;
                     ts[k].backgroundTransformation :=
                       " 0.0 " & Fmt.Real(ts[k].yTranslationNeeded)
                       & " translate " & Fmt.Real(scale1) & " "
                       & Fmt.Real(scale2) & " scale ";
                     SendTransformations (ts[k]);
                     ts[k].Dirty (EverywhereBox, NIL);
                    ELSE (* Client doesn't want re-scale. *)
                     (* If height changes, we relocate. *)
                     (* DPS with gravity # NorthWest buggy. *)
                     IF ts[k].xHeight = 0 THEN
                       ts[k].xHeight := FullHeight;
                       END;
                     IF xH # ts[k].xHeight THEN
                       ts[k].yTranslationNeeded := ts[k].yTranslationNeeded
                         + FLOAT (ts[k].xHeight - xH) * PointsPerPixel;
                       ts[k].backgroundTransformation :=
                         " 0.0 " & Fmt.Real(ts[k].yTranslationNeeded)
                         & " translate ";
                       SendTransformations (ts[k]);
                       ts[k].Dirty (EverywhereBox, NIL);
                       END;
                     END;
                   END;
                 ts[k].xWidth := xW;
                 ts[k].xHeight := xH;
                 END; (* of FOR *)
               END; (* of IF not bogus w & h *)
        | 99 =>
             FOR k := 0 TO tscount-1 DO
               TransformToDPS (ts[k], xX, xY, r1, r2);
               TransformToDPS (ts[k], xX+xW, xY, r3, r4);
               TransformToDPS (ts[k], xX, xY+xH, r5, r6);
               TransformToDPS (ts[k], xX+xW, xY+xH, r7, r8);
               box.low := Place { MIN(MIN(r1,r3),MIN(r5,r7)),
                MIN(MIN(r2,r4),MIN(r6,r8)) };
               box.high := Place { MAX(MAX(r1,r3),MAX(r5,r7)),
                MAX(MAX(r2,r4),MAX(r6,r8)) };
               ts[k].Dirty (box, NIL);
               END;
          ELSE
           Err.Msg ("Got unknown event ", Fmt.Int(event), " from X.");
          END;
       ELSE Err.Msg ("Got unknown window from X.");
       END; (* of IF tscount > 0 *)
     ELSE (* win = 0 *)
       (* WaitForX (); *)
       EVAL SchedulerPosix.IOWait (displaySource.fd, read := TRUE);
     END; (* of win # 0 *)
    END; (* of LOOP *)
  END TalkToX;
********** PROCEDURE WaitForX () = VAR maxfd: INTEGER; VAR fds: Unix.FDSet; BEGIN LOCK tsMonitor DO (* Copy to avoid concurrent use.
maxfd := globalMaxXfd;
    fds := globalXfds;
    END;
  EVAL SchedulerPosix.IOSelect (maxfd + 1, ADR(fds), NIL, ADR(fds));
  END WaitForX;
*************)

PROCEDURE TransformToDPS (t: T; x, y: INTEGER; VAR rx, ry: REAL) =
  BEGIN
  LOCK transformChangeMutex DO
    cDPS.transformtodps (t, x, y, ADR(rx), ADR(ry));
    END;
  END TransformToDPS;

PROCEDURE WinToTs (win: INTEGER; VAR ts: ARRAY [0..7] OF T): INTEGER =
 VAR tl: REFTList;
 VAR k: INTEGER;
  BEGIN
  k := 0;
  LOCK tsMonitor DO
    tl := globalTs;
    WHILE tl#NIL DO
      IF tl^.t.win=win THEN ts[k] := tl^.t; k := k + 1; END;
      tl := tl^.next;
      END;
    END;
  RETURN k;
  END WinToTs;

PROCEDURE PlaceToStderr (pre: TEXT; place: Place) =
  BEGIN
    Err.Msg (pre, " ", Fmt.Real (place.x), " " & Fmt.Real (place.y));
  END PlaceToStderr;

PROCEDURE BoxToStderr (pre: TEXT; box: Box) =
  BEGIN
    Err.Msg (pre, " ",
     Fmt.Real(box.low.x) & " "
   & Fmt.Real(box.low.y) & " "
   & Fmt.Real(box.high.x) & " "
   & Fmt.Real(box.high.y) );
  END BoxToStderr;

BEGIN
  cPostScriptMutex := NEW (MUTEX);
  transformChangeMutex := NEW (MUTEX);
  mouseOrCleanMutex := NEW (MUTEX);
  recentMeasureMutex := NEW (MUTEX);

  tsMonitor := NEW (MUTEX);
  globalMaxXfd := 0;
  globalXfds := Unix.FDSet{};

  InitializeCharArrays();

  Thread.MinDefaultStackSize (65536);
  EVAL Thread.Fork (NEW (TalkToXThreadClosure, apply := TalkToX));
  Thread.MinDefaultStackSize (0);
  END DPS.

interface Unix is in:


interface Err is in: