<<>> <> <> <> <> <<>> DIRECTORY Ascii, FanoutStream, IO, RefText, Rope, Xl, XlCursor, XlFontOps, XTk, XTkFriends, XTkPrivate, XTkStreamWidgets; XTkStreamWidgetsImpl: CEDAR MONITOR IMPORTS FanoutStream, IO, RefText, Xl, XlCursor, XlFontOps, XTk, XTkFriends, XTkPrivate EXPORTS XTkStreamWidgets = BEGIN SetWindowSize: ENTRY PROC [oRef: REF OutputRec, s: Xl.Size] = { IF oRef#NIL THEN oRef.wSize ¬ s }; HomePos: ENTRY PROC [oRef: REF OutputRec] = { IF oRef#NIL THEN { oRef.pos.x ¬ oRef.leftSpace; oRef.pos.y ¬ oRef.topOffset; }; }; PosAndIncrement: ENTRY PROC [oRef: REF OutputRec, rr: INT] RETURNS [pos: Xl.Point ¬ [0, 0]] = { <<--increments position but returns previous value atomicly>> IF oRef#NIL THEN { pos ¬ oRef.pos; oRef.pos.x ¬ oRef.pos.x+rr; }; }; UnflushedOutChar: PROC [oRef: REF OutputRec, ch: CHAR] = { w: XTk.Widget ~ oRef.widget; IF w.fastAccessAllowed#ok THEN RETURN; SELECT ch FROM Ascii.CR, Ascii.LF => { NewLine[oRef]; }; Ascii.FF => { HomePos[oRef]; Xl.ClearArea[w.connection, w.window, [0, 0], [2000, 2000], FALSE]; }; Ascii.NUL => {}; Ascii.BS => { oRef.pos.x ¬ MAX[oRef.pos.x-oRef.charDX, 0]; Xl.ClearArea[w.connection, w.window, [oRef.pos.x, MAX[oRef.pos.y, oRef.ascent]-oRef.ascent], [oRef.charDX, oRef.lineDY], FALSE]; }; ENDCASE => { pos: Xl.Point; IF INT[oRef.pos.x+oRef.charDX+oRef.rightSpace]>INT[oRef.wSize.width] AND oRef.pos.x>oRef.leftSpace THEN NewLine[oRef]; pos ¬ PosAndIncrement[oRef, oRef.charDX]; Xl.ImageChar[w.connection, w.window.drawable, pos, oRef.gc, ch]; }; }; NewLine: PROC [oRef: REF OutputRec] = { w: XTk.Widget ~ oRef.widget; mustScroll: INT ¬ AdvanceLine[oRef]; IF mustScroll>0 AND w.fastAccessAllowed=ok THEN { y: INT; <<--scrollup>> Xl.CopyArea[c: w.connection, src: w.window.drawable, dst: w.window.drawable, srcP: [0, mustScroll], dstP: [0, 0], size: [oRef.wSize.width, oRef.wSize.height-mustScroll], gc: oRef.gc]; <<--clear bottom>> y ¬ MAX[oRef.pos.y, oRef.ascent]-oRef.ascent; Xl.ClearArea[w.connection, w.window, [0, y], [2000, 2000]]; }; }; AdvanceLine: ENTRY PROC [oRef: REF OutputRec] RETURNS [mustScroll: INT¬0] = { oRef.pos.y ¬ oRef.pos.y+oRef.lineDY; oRef.pos.x ¬ oRef.leftSpace; IF INT[oRef.pos.y+oRef.bottomOffset] > INT[oRef.wSize.height] THEN { <> <> mustScroll ¬ MIN[oRef.lineDY, oRef.wSize.height]; oRef.pos.y ¬ oRef.pos.y - mustScroll; } }; outputStreamProcs: REF IO.StreamProcs ¬ IO.CreateStreamProcs[ variety: $output, class: $XlTexts, putChar: OutputTextWindowStreamPutChar, putBlock: OutputTextWindowStreamPutBlock, eraseChar: OutputTextWindowStreamEraseChar ]; OutputTextWindowStreamPutChar: PROC [self: IO.STREAM, char: CHAR] = { ENABLE UNCAUGHT => GOTO Oops; oRef: REF OutputRec ~ NARROW[self.streamData]; w: XTk.Widget ~ oRef.widget; IF w.fastAccessAllowed#ok THEN RETURN; UnflushedOutChar[oRef, char]; Xl.Flush[w.connection, TRUE]; EXITS Oops => {} }; OutputTextWindowStreamPutBlock: PROC [self: IO.STREAM, block: REF READONLY TEXT, startIndex: NAT, count: NAT] = { ENABLE UNCAUGHT => GOTO Oops; oRef: REF OutputRec ~ NARROW[self.streamData]; w: XTk.Widget ~ oRef.widget; Action: PROC[c: CHAR] RETURNS [BOOL¬FALSE] = {UnflushedOutChar[oRef, c]}; IF w.fastAccessAllowed#ok THEN RETURN; [] ¬ RefText.Map[s: block, action: Action, len: count, start: startIndex]; Xl.Flush[w.connection, TRUE]; EXITS Oops => {} }; OutputTextWindowStreamEraseChar: PROC [self: IO.STREAM, char: CHAR] = { OutputTextWindowStreamPutChar[self, Ascii.BS] }; outputClass: XTk.ImplementorClass ¬ XTkFriends.CreateClass[[key: $StreamWidget, wDataNum: 1, classNameHint: $Typescript, configureLR: Configure, initInstPart: StreamInitInstPart, forgetScreenLR: ForgetScreen]]; OutputRec: TYPE = RECORD [ widget: XTk.Widget, --backpointer for liveness slave: IO.STREAM ¬ NIL, font: Xl.Font ¬ Xl.nullFont, wSize: Xl.Size ¬ [0, 0], --size of window lineDY: INT ¬ 15, --distance between lines leftSpace: NAT ¬ 2, --distance between left border and first character x origin rightSpace: NAT ¬ 2, --distance between window right border and last characters right border topOffset, bottomOffset: NAT ¬ 2, --distance between baseline and border ascent, descent: NAT ¬ 2, bottomSpace: NAT ¬ 2, charDX: NAT ¬ 10, lineSpace: NAT ¬ 2, pos: Xl.Point ¬ [0, 0], --position for next character; not yet clipped gc: Xl.GContext ¬ NIL --could we somehow share gc's? ]; GetOutputData: PROC [w: XTk.Widget] RETURNS [REF OutputRec] = INLINE { RETURN [NARROW[XTkFriends.InstPart[w, outputClass]]]; }; NiceOpenFont: PROC [c: Xl.Connection, name: Rope.ROPE] RETURNS [Xl.Font ¬ Xl.nullFont] = { font: Xl.Font; IF Rope.IsEmpty[name] OR ~Xl.Alive[c] THEN RETURN; font ¬ Xl.OpenFont[c, name, XTkPrivate.detailsForSynchronous ! Xl.XError => GOTO Oops]; RETURN [font]; EXITS Oops => {}; }; Configure: XTk.ConfigureProc = { oRef: REF OutputRec ~ GetOutputData[widget]; existW: BOOL ¬ widget.actualMapping> oRef.font ¬ XlFontOps.GetDefaultFont[widget.connection]; }; BEGIN fi: REF READONLY Xl.FontInfoRec ¬ Xl.QueryFont[widget.connection, oRef.font]; oRef.ascent ¬ fi.fontAscent; oRef.descent ¬ fi.fontDescent; oRef.lineDY ¬ oRef.ascent+oRef.descent+oRef.lineSpace; oRef.charDX ¬ fi.maxBounds.charWidth; oRef.topOffset ¬ oRef.ascent+oRef.lineSpace; oRef.bottomOffset ¬ oRef.descent+oRef.bottomSpace; oRef.gc ¬ Xl.MakeGContext[widget.connection]; --should we share contexts of same screen? Xl.SetGCForeground[oRef.gc, widget.screenDepth.screen.blackPixel]; Xl.SetGCBackground[oRef.gc, widget.screenDepth.screen.whitePixel]; Xl.SetGCFont[oRef.gc, oRef.font]; END; HomePos[oRef]; }; XTkFriends.SimpleConfigureOneLevelLR[widget, geometry, mapping, reConsiderChildren]; IF existW OR createW THEN SetWindowSize[oRef, widget.actual.size] }; ForgetScreen: XTk.TerminateProc = { oRef: REF OutputRec ~ GetOutputData[widget]; oRef.font ¬ Xl.nullFont; oRef.gc ¬ NIL; }; StreamInitInstPart: XTk.InitInstancePartProc = { oRef: REF OutputRec ~ NEW[OutputRec]; oRef.slave ¬ IO.CreateStream[streamProcs: outputStreamProcs, streamData: oRef]; oRef.widget ¬ widget; XTkFriends.AssignInstPart[widget, outputClass, oRef]; }; CreateStreamWidget: PUBLIC PROC [widgetSpec: XTk.WidgetSpec ¬ [], widgetStream: IO.STREAM ¬ NIL] RETURNS [widget: XTk.Widget] = { widget ¬ XTk.CreateWidget[widgetSpec, outputClass]; IF widgetStream#NIL THEN BindStream[widget, widgetStream]; }; CreateStream: PUBLIC PROC [w: XTk.Widget ¬ NIL] RETURNS [widgetStream: IO.STREAM] = { widgetStream ¬ FanoutStream.Create[reportErrors: FALSE, forwardClose: FALSE]; IF w#NIL THEN BindStream[w, widgetStream]; }; <<>> BindStream: PUBLIC PROC [w: XTk.Widget, widgetStream: IO.STREAM] = { oRef: REF OutputRec ~ GetOutputData[w]; FanoutStream.AddSlave[master: widgetStream, slave: oRef.slave]; }; END.