Copyright (C) 1994, Digital Equipment Corp. UNSAFE MODULE; IMPORT Unix, Fifo, SchedulerPosix, Text, Err, Fmt; IMPORT TextWr, Thread, Wr, cDPS, wraps, DPS; <*FATAL Wr.Failure, Thread.Alerted *> CONST PointsPerPixel = 0.92182; DPS
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********** PROCEDURE WaitForX () = VAR maxfd: INTEGER; VAR fds: Unix.FDSet; BEGIN LOCK tsMonitor DO (* Copy to avoid concurrent use.GSaveAndClip (box: Box): TEXT = BEGIN RETURN " gsave " & NewPathBox (box) & " clip newpath "; END GSaveAndClip; PROCEDURENewPathBox (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; PROCEDUREGSaveAndClipIf (box, containee: Box): TEXT = BEGIN IF ContainerContainee (box, containee) THEN RETURN " gsave "; ELSE RETURN GSaveAndClip (box); END; END GSaveAndClipIf; PROCEDUREGRestore (): TEXT = BEGIN RETURN " grestore "; END GRestore; PROCEDUREBoxCoordsAsText (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; PROCEDUREBoxAlter (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; PROCEDUREBoxesIntersect (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; PROCEDUREContainerContainee (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; PROCEDUREPlaceIsInBox (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; PROCEDUREBoxUnion (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. *) PROCEDUREEdgedBoxClipAndPaint (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; PROCEDUREEscapeText (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; PROCEDURECharFromKey (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; PROCEDUREInitializeCharArrays () = 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; PROCEDURECleanThreadForkee (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; PROCEDURECreate (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; PROCEDURESend ( 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; PROCEDURESendInternalNervously ( 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; PROCEDURESendNervously ( 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; PROCEDUREAcquireDPSMutex () = BEGIN Thread.Acquire (cPostScriptMutex); END AcquireDPSMutex; PROCEDUREReleaseDPSMutex () = BEGIN Thread.Release (cPostScriptMutex); END ReleaseDPSMutex; PROCEDURESendInternal ( 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; PROCEDURESimpleSendBig ( 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; PROCEDURESendClientTransformation (t: T; text: TEXT) = BEGIN t.currentTransformation := text; SendTransformations (t); END SendClientTransformation; PROCEDURESendTransformations (t: T) = BEGIN SendInternal ( t, " dps-m3-original-matrix setmatrix " & t.backgroundTransformation & " " & t.currentTransformation, TRUE ); END SendTransformations; PROCEDURESendSpecialFoundation (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; PROCEDURESendFoundation (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; PROCEDUREUnsendFoundation (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; PROCEDUREPostscriptToWriter (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; PROCEDUREPostscriptToText (t: T): TEXT = VAR wr: Wr.T; BEGIN wr := TextWr.New (); PostscriptToWriter (t, wr); RETURN TextWr.ToText (wr); END PostscriptToText; PROCEDUREFlush (t: T) = BEGIN LOCK cPostScriptMutex DO cDPS.doflush (t); END; END Flush; PROCEDUREKillInputFocus (<*UNUSED*> t: T) = BEGIN (* Work done by subclasser. *) END KillInputFocus; PROCEDUREModifiersFromX (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; PROCEDUREPreferredFontName (): TEXT = BEGIN RETURN preferredFontName; END PreferredFontName; PROCEDURESetPreferredFontName (name: TEXT) = BEGIN preferredFontName := name; END SetPreferredFontName; PROCEDUREShowItAccentedPostScript (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; PROCEDUREContainsAccent (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; PROCEDUREIsAccent (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; PROCEDUREMeasureText ( 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; PROCEDURETextWidth ( 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; PROCEDUREMeasureChar ( 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; PROCEDUREButtonFromX (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; PROCEDUREDirty (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; PROCEDUREDirtyBoxMatchProc (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; PROCEDURECallMouseProc ( 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; PROCEDURECallKeyProc ( 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; PROCEDURETalkToX (<*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;
maxfd := globalMaxXfd; fds := globalXfds; END; EVAL SchedulerPosix.IOSelect (maxfd + 1, ADR(fds), NIL, ADR(fds)); END WaitForX; *************) PROCEDURETransformToDPS (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; PROCEDUREWinToTs (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; PROCEDUREPlaceToStderr (pre: TEXT; place: Place) = BEGIN Err.Msg (pre, " ", Fmt.Real (place.x), " " & Fmt.Real (place.y)); END PlaceToStderr; PROCEDUREBoxToStderr (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.