<> <> <> <> DIRECTORY ForkOps, Imager, ImagerSample, Process, Rope, SF, Xl, XlBitmap, XlBWFriends, XlColorAccess, XlDetails, XlShmPixmaps, XTk, XTkFriends, XTkBitmapWidgets, XTkBitmapWidgetsExtras, XTkShellWidgets; XTkBitmapWidgetsImpl: CEDAR MONITOR LOCKS bmRef USING bmRef: REF BMRec IMPORTS ForkOps, ImagerSample, Process, Rope, SF, Xl, XlBitmap, XlBWFriends, XlColorAccess, XlDetails, XlShmPixmaps, XTk, XTkFriends, XTkShellWidgets EXPORTS XTkBitmapWidgets, XTkBitmapWidgetsExtras SHARES XlBWFriends = BEGIN OPEN Xl, XTk, XTkBitmapWidgets; bmClass: ImplementorClass ¬ XTkFriends.CreateClass[[ key: $bitmapWidget, wDataNum: 1, configureLR: BMConfigureLR, destroyWindowLR: BMDestroyWindowLR, preStopFastAccess: BMPreStopFastAccess, fullStopFastAccessLR: BMFullStopFastAccessLR, destroyWidget: BMDestroyWidget, initInstPart: InitInstPart, eventMask: [exposure: TRUE, structureNotify: TRUE], backgroundKey: $white ]]; BMRec: TYPE = MONITORED RECORD [ wAsUsed: XlBWFriends.WRef ¬ NIL, wInternal: XlBWFriends.WRef ¬ NIL, bm: XlBitmap.Bitmap ¬ NIL, origin: Xl.Point ¬ [0, 0], restrict: SF.Box ¬ SF.maxBox, notify: BitmapEventProc, mapped: BOOL ¬ FALSE, data: REF ¬ NIL, ownedBitmap: XlBitmap.Bitmap ¬ NIL, <<--window relative>> support8: BOOL ¬ FALSE, support4: BOOL ¬ FALSE, support2: BOOL ¬ FALSE, shmData: REF ShmData ¬ NIL, gc: Xl.GContext ]; ShmData: TYPE = RECORD [ shmPixmap: Xl.Pixmap ¬ Xl.nullPixmap, c: Xl.Connection ¬ NIL, bm: XlBitmap.Bitmap ¬ NIL ]; noErrors: Xl.Details ~ XlDetails.ignoreErrors; NoOp: Xl.EventProcType ~ {}; mPadNoErrors: Xl.Details ~ NEW[Xl.DetailsRec ¬ [ errorMatch: NEW[Xl.MatchRep ¬ [proc: NoOp]], specific: $ZPixmap ]]; MPadBugActualPaint1: PROC[b: SF.Box, ref: REF] = { w: XlBWFriends.WRef ~ NARROW[ref]; bpp: INT ~ 1; dirtyFix: INT ¬ b.min.f MOD 32; IF w.offset.x+b.min.f> <<--However, some pixels will be missing>> dirtyFix ¬ dirtyFix - 32; }; Xl.PutImage[c: w.c, drawable: w.d, gc: w.gc, base: w.base, dest: [w.offset.x+b.min.f-dirtyFix, w.offset.y+b.min.s], size: [b.max.f-b.min.f+dirtyFix, b.max.s-b.min.s], offx: b.min.f-dirtyFix, offy: b.min.s, scanLineBytes: w.scanLineBytes, bitsPerPixel: bpp, details: mPadNoErrors]; }; IBMBugActualPaint1: PROC[b: SF.Box, ref: REF] = { w: XlBWFriends.WRef ~ NARROW[ref]; bpp: INT ~ 1; dirtyFix: INT ¬ b.min.f MOD 32; IF w.offset.x+b.min.f> <<--However, some pixels will be missing>> dirtyFix ¬ dirtyFix - 32; }; Xl.PutImage[c: w.c, drawable: w.d, gc: w.gc, base: w.base, dest: [w.offset.x+b.min.f-dirtyFix, w.offset.y+b.min.s], size: [b.max.f-b.min.f+dirtyFix, b.max.s-b.min.s], offx: b.min.f-dirtyFix, offy: b.min.s, scanLineBytes: w.scanLineBytes, bitsPerPixel: bpp, details: noErrors]; }; ActualPaint1: PROC[b: SF.Box, ref: REF] = { w: XlBWFriends.WRef ~ NARROW[ref]; bpp: INT ~ 1; dirtyFix: INT ~ 0; Xl.PutImage[c: w.c, drawable: w.d, gc: w.gc, base: w.base, dest: [w.offset.x+b.min.f-dirtyFix, w.offset.y+b.min.s], size: [b.max.f-b.min.f+dirtyFix, b.max.s-b.min.s], offx: b.min.f-dirtyFix, offy: b.min.s, scanLineBytes: w.scanLineBytes, bitsPerPixel: bpp, details: noErrors]; }; ActualPaint2: PROC[b: SF.Box, ref: REF] = { w: XlBWFriends.WRef ~ NARROW[ref]; bpp: INT ~ 2; modulus: INT ~ 32 / bpp; --Oops, this line knows unit size is 32... dirtyFix: INT ¬ b.min.f MOD modulus; <<--X protocol says left-pad must be 0 for zPixmap format>> IF w.offset.x+b.min.f> <<--Prevent raising an error on negative dest.x. >> <<--However, some pixels will be missing>> dirtyFix ¬ dirtyFix - modulus; }; Xl.PutImage[c: w.c, drawable: w.d, gc: w.gc, base: w.base, dest: [w.offset.x+b.min.f-dirtyFix, w.offset.y+b.min.s], size: [b.max.f-b.min.f+dirtyFix, b.max.s-b.min.s], offx: b.min.f-dirtyFix, offy: b.min.s, scanLineBytes: w.scanLineBytes, bitsPerPixel: bpp, details: noErrors]; }; ActualPaint4: PROC[b: SF.Box, ref: REF] = { w: XlBWFriends.WRef ~ NARROW[ref]; bpp: INT ~ 4; modulus: INT ~ 32 / bpp; --Oops, this line knows unit size is 32... dirtyFix: INT ¬ b.min.f MOD modulus; <<--X protocol says left-pad must be 0 for zPixmap format>> IF w.offset.x+b.min.f> <<--Prevent raising an error on negative dest.x. >> <<--However, some pixels will be missing>> dirtyFix ¬ dirtyFix - modulus; }; Xl.PutImage[c: w.c, drawable: w.d, gc: w.gc, base: w.base, dest: [w.offset.x+b.min.f-dirtyFix, w.offset.y+b.min.s], size: [b.max.f-b.min.f+dirtyFix, b.max.s-b.min.s], offx: b.min.f-dirtyFix, offy: b.min.s, scanLineBytes: w.scanLineBytes, bitsPerPixel: bpp, details: noErrors]; }; ActualPaint8: PROC[b: SF.Box, ref: REF] = { w: XlBWFriends.WRef ~ NARROW[ref]; bpp: INT ~ 8; modulus: INT ~ 32 / bpp; --Oops, this line knows unit size is 32... dirtyFix: INT ¬ b.min.f MOD modulus; <<--X protocol says left-pad must be 0 for zPixmap format>> IF w.offset.x+b.min.f> <<--Prevent raising an error on negative dest.x. >> <<--However, some pixels will be missing>> dirtyFix ¬ dirtyFix - modulus; }; Xl.PutImage[c: w.c, drawable: w.d, gc: w.gc, base: w.base, dest: [w.offset.x+b.min.f-dirtyFix, w.offset.y+b.min.s], size: [b.max.f-b.min.f+dirtyFix, b.max.s-b.min.s], offx: b.min.f-dirtyFix, offy: b.min.s, scanLineBytes: w.scanLineBytes, bitsPerPixel: bpp, details: noErrors]; }; ActualPaint24: PROC[b: SF.Box, ref: REF] = { w: XlBWFriends.WRef ~ NARROW[ref]; bpp: INT ~ 24; dirtyFix: INT ¬ b.min.f MOD 3; <<--X protocol says left-pad must be 0 for zPixmap format>> --Oops, this line knows unit size is 32... IF w.offset.x+b.min.f> <<--Prevent raising an error on negative dest.x. >> <<--However, some pixels will be missing>> dirtyFix ¬ dirtyFix - 3; }; Xl.PutImage[c: w.c, drawable: w.d, gc: w.gc, base: w.base, dest: [w.offset.x+b.min.f-dirtyFix, w.offset.y+b.min.s], size: [b.max.f-b.min.f+dirtyFix, b.max.s-b.min.s], offx: b.min.f-dirtyFix, offy: b.min.s, scanLineBytes: w.scanLineBytes, bitsPerPixel: bpp, details: noErrors]; }; ShmPaintCopyPlane: PROC[b: SF.Box, ref: REF] = { w: XlBWFriends.WRef ~ NARROW[ref]; Xl.CopyPlane[c: w.c, src: w.sharedD, dst: w.d, srcP: [b.min.f, b.min.s], dstP: [w.offset.x+b.min.f, w.offset.y+b.min.s], size: [b.max.f-b.min.f, b.max.s-b.min.s], gc: w.gc, bitPlane: 1, details: noErrors] }; ShmPaintCopyArea: PROC[b: SF.Box, ref: REF] = { w: XlBWFriends.WRef ~ NARROW[ref]; Xl.CopyArea[c: w.c, src: w.sharedD, dst: w.d, srcP: [b.min.f, b.min.s], dstP: [w.offset.x+b.min.f, w.offset.y+b.min.s], size: [b.max.f-b.min.f, b.max.s-b.min.s], gc: w.gc, details: noErrors] }; GetInstData: PROC [w: Widget] RETURNS [REF BMRec] = INLINE { RETURN [NARROW[XTkFriends.InstPart[w, bmClass]]]; }; eventFilter: Xl.EventFilter = Xl.CreateEventFilter[unmapNotify, mapNotify, expose]; EventHandler: Xl.EventProcType = { widget: Widget ~ NARROW[clientData]; bmRef: REF BMRec ~ GetInstData[widget]; IF bmRef.notify#NIL THEN { SELECT event.type FROM mapNotify => { bmRef.mapped ¬ TRUE; SetBM[bmRef, widget, FALSE, FALSE]; bmRef.notify[widget, map, bmRef.data]; }; unmapNotify => { bmRef.mapped ¬ FALSE; Stop[bmRef]; bmRef.notify[widget, unmap, bmRef.data]; }; expose => { e: Xl.ExposeEvent ~ NARROW[event]; s: XlBWFriends.SRef; w: XlBWFriends.WRef ~ bmRef.wAsUsed; IF w=NIL OR (s ¬ w.s)=NIL THEN RETURN; XlBWFriends.IncludeRect[s, w, [ min: [s: e.pos.y-w.offset.y, f: e.pos.x-w.offset.x], max: [s: e.pos.y+e.size.height-w.offset.y, f: e.pos.x+e.size.width-w.offset.x] ], e.count#0]; }; ENDCASE => {}; }; }; FreeShmData: PROC [x: REF] = { WITH x SELECT FROM sd: REF ShmData => { pm: Xl.Pixmap ¬ sd.shmPixmap; sd.shmPixmap ¬ Xl.nullPixmap; IF Xl.Alive[sd.c] AND pm#Xl.nullPixmap THEN Xl.FreePixmap[sd.c, pm, noErrors]; }; ENDCASE => {} }; DelayedDestroyShmData: PROC [sd: REF ShmData] = { <<--Because we do not stop the painters immediately>> <<--Very short delay so bitmap will be finalized soon >> IF sd#NIL THEN ForkOps.ForkDelayed[100, FreeShmData, sd] }; BMDestroyWindowLR: TerminateProc = { bmRef: REF BMRec ~ GetInstData[widget]; sd: REF ShmData ~ bmRef.shmData; bmRef.shmData ¬ NIL; IF bmRef.notify#NIL THEN bmRef.notify[widget, destroyWindow, bmRef.data]; XTkFriends.SimpleDestroyWindowLR[widget, reason]; Stop[bmRef]; IF sd#NIL THEN DelayedDestroyShmData[sd]; }; BMConfigureLR: ConfigureProc = { bmRef: REF BMRec ~ GetInstData[widget]; existW, createW: BOOL; reason: BitmapEventReason ¬ resize; existW ¬ widget.actualMapping> Xl.SetGCFunction[gc, copyInverted]; RETURN [gc] }; }; Xl.SetGCFunction[gc, copy]; Xl.SetGCGrounds[gc: gc, foreground: screen.blackPixel, background: screen.whitePixel]; RETURN [gc] }; SetBM: PROC [bmRef: REF BMRec, widget: BitmapWidget, immediateRefresh: BOOL, retainRefreshs: BOOL] = { Range: PROC [x: INT] RETURNS [INTEGER] = { RETURN[ MIN[ MAX[x, FIRST[INTEGER]], LAST[INTEGER] ] ] }; vendor: Rope.ROPE; bm: XlBitmap.Bitmap ¬ bmRef.bm; IF bm=NIL OR widget.state#realized THEN Stop[bmRef] ELSE { sd: REF ShmData; shmP: Xl.Pixmap ¬ Xl.nullPixmap; rsm: ImagerSample.RasterSampleMap ¬ NARROW[XlBitmap.GetSM[bm]]; paintProc: PROC[b: SF.Box, ref: REF]; currentCase: Rope.ROPE ¬ NIL; w: XlBWFriends.WRef; origin: Xl.Point ¬ bmRef.origin; clip: SF.Box ¬ [ min: [s: Range[-origin.y], f: Range[-origin.x]], max: [s: Range[widget.actual.size.height-origin.y], f: Range[widget.actual.size.width-origin.x]] ]; restrict: SF.Box ¬ SF.Intersect[bmRef.restrict, clip]; bpp: NAT ¬ ImagerSample.GetBitsPerSample[XlBitmap.GetSM[bm]]; SELECT bpp FROM 1 => NULL; --always works 8 => IF ~bmRef.support8 THEN RETURN; --it wouldn't work 4 => IF ~bmRef.support4 THEN RETURN; --it wouldn't work 2 => IF ~bmRef.support2 THEN RETURN; --it wouldn't work ENDCASE => { <<--No test yet developped; >> <<--Take your chance that it works or crashes>> }; Stop[bmRef]; w ¬ NEW[XlBWFriends.WRec]; w.c ¬ widget.connection; w.d ¬ widget.window; w.bm ¬ bm; w.base ¬ LOOPHOLE[ImagerSample.GetBase[rsm].word]; w.offset ¬ origin; sd ¬ bmRef.shmData; IF sd#NIL AND sd.c=w.c AND sd.bm=bm AND sd.shmPixmap#Xl.nullPixmap THEN shmP ¬ sd.shmPixmap --reuse it ELSE { IF XlShmPixmaps.ConnectionSupportsPixmaps[w.c] AND XlShmPixmaps.SampleMapSupportsThis[rsm] THEN { shmP ¬ XlShmPixmaps.UnsafeCreatePixmap[c: w.c, drawable: w.d, sm: rsm ! Xl.XError => { <<--we wrongly believed shared memory would work>> shmP ¬ Xl.nullPixmap; CONTINUE } ]; IF shmP=Xl.nullPixmap THEN bmRef.shmData ¬ NIL ELSE bmRef.shmData ¬ NEW[ShmData ¬ [shmPixmap: shmP, c: w.c, bm: bm]]; IF sd#NIL THEN DelayedDestroyShmData[sd]; }; }; w.clip ¬ SF.Intersect[clip, SF.Intersect[pseudoInfinitBox, XlBitmap.GetBox[bm]]]; w.scanLineBytes ¬ ImagerSample.GetBitsPerLine[rsm]/8; w.gc ¬ bmRef.gc; IF shmP=Xl.nullPixmap THEN { <<--overhead cost compensates for transferring request overhead (PutImage=6 words)>> <<--it is scaled to compensate for cost function strictly assuming 8 bits per pixel>> <<--is sligtly increased for a wild guess of per request overhead >> SELECT ImagerSample.GetBitsPerSample[rsm] FROM 1 => { IF widget.screenDepth.depth=4 THEN {paintProc ¬ IBMBugActualPaint1; currentCase ¬ "ibm 6000 bug fix"} ELSE {paintProc ¬ ActualPaint1; currentCase ¬ "1 bpp, remote"}; w.overheadCost ¬ 48+40 }; 8 => { paintProc ¬ ActualPaint8; w.overheadCost ¬ 6+10; currentCase ¬ "8 bpp, remote"; }; 2 => { paintProc ¬ ActualPaint2; w.overheadCost ¬ 24+20; currentCase ¬ "2 bpp, remote"; }; 4 => { paintProc ¬ ActualPaint4; w.overheadCost ¬ 12+20; currentCase ¬ "4 bpp, remote"; }; 24 => { paintProc ¬ ActualPaint24; w.overheadCost ¬ 0+4; currentCase ¬ "24 bpp, remote"; }; ENDCASE => {RETURN}; } ELSE { w.sharedD ¬ shmP; <<--overhead is wild guess on how much unification is justified>> IF ImagerSample.GetBitsPerSample[rsm]=1 THEN { paintProc ¬ ShmPaintCopyPlane; w.overheadCost ¬ 40000; currentCase ¬ "1 bpp, shm"; } ELSE { paintProc ¬ ShmPaintCopyArea; w.overheadCost ¬ 20000; currentCase ¬ "multi bpp, shm"; } }; vendor ¬ Xl.Info[w.c].vendor; IF Rope.Equal[vendor, "Xerox Split MPAD"] THEN { <<--This server uses slow radio communication in spite of possible presence of shared memory>> w.overheadCost ¬ 2; w.serverQueueLimit ¬ 10; paintProc ¬ MPadBugActualPaint1; currentCase ¬ Rope.Concat[currentCase, " MPAD"]; }; <<--for experimenting to find out reasonable overheadCost>> WITH XTk.GetWidgetProp[widget, $OverheadCost] SELECT FROM ri: REF INT => { w.overheadCost ¬ ri­; WITH XTk.GetWidgetProp[widget, $ServerQueueLimit] SELECT FROM ri: REF INT => w.serverQueueLimit ¬ ri­; ENDCASE => {}; }; ENDCASE => {}; w.report ¬ LIST[[paintProc, w]]; XTk.PutWidgetProp[widget, $XTkBitmapWidgetsImpl, currentCase]; bmRef.wInternal ¬ w; IF bmRef.mapped THEN { XlBWFriends.StartWRef[w]; Set[bmRef, w]; ClearOutsideAreas[widget]; IF immediateRefresh OR retainRefreshs THEN XlBWFriends.IncludeRect[w.s, w, clip, FALSE]; }; } }; ClearOutsideAreas: PROC [w: XTk.Widget] = { ENABLE ANY => GOTO Oops; Clear: PROC [pos: Point, size: Size] = { Xl.ClearArea[c, win, pos, size, FALSE, noErrors]; }; Fill: PROC [pos: Point, size: Size] = { Xl.FillRectangle[c, win, bmRef.gc, pos, size, noErrors]; }; infinite: INT = 9999; bmRef: REF BMRec ~ GetInstData[w]; c: Xl.Connection ¬ w.connection; win: Xl.Window ¬ w.window; r: SF.Box ¬ SF.Displace[bmRef.restrict, [bmRef.origin.y, bmRef.origin.x]]; IF win=Xl.nullWindow OR w.fastAccessAllowed#ok THEN RETURN; <<--remember: paints [0, 0] of bitmap at point "origin" in window>> <<--clear left half space>> IF r.min.f>0 THEN Clear[[0, 0], [r.min.f, infinite]]; <<--clear direct upper and upper right quarter space>> IF r.min.s>0 THEN Clear[[r.min.f, 0], [infinite, r.min.s]]; <<--clear direct right and right lower quarter space>> Clear[[r.max.f, 0], [infinite, infinite]]; <<--clear direct under and right lower quarter space>> Clear[[0, r.max.s], [infinite, infinite]]; IF XTk.GetWidgetProp[w, $BitmapBorder]#NIL THEN { <> Fill[[r.min.f-1, r.min.s-1], [1, r.max.s-r.min.s+2]]; <> Fill[[r.max.f, r.min.s-1], [1, r.max.s-r.min.s+2]]; <> Fill[[r.min.f-1, r.min.s-1], [r.max.f-r.min.f+2, 1]]; <> Fill[[r.min.f-1, r.max.s], [r.max.f-r.min.f+2, 1]]; }; EXITS Oops => {}; }; pseudoInfinitBox: SF.Box ~ [min: [-8000, -8000], max: [8000, 8000]]; --artificial clip region used to prevent arithmetic overflow GetImplData: PUBLIC PROC [widget: BitmapWidget] RETURNS [REF] = { bmRef: REF BMRec ~ GetInstData[widget]; RETURN [bmRef.wAsUsed]; }; Wait: PUBLIC PROC [widget: BitmapWidget, server: BOOL ¬ FALSE] = { bmRef: REF BMRec ~ GetInstData[widget]; w: XlBWFriends.WRef ¬ bmRef.wAsUsed; IF w#NIL THEN { timedOut: BOOL ¬ XlBWFriends.WaitLocal[w.s, w].timedOut; IF timedOut AND server THEN { WHILE XlBWFriends.WaitLocal[w.s, w].timedOut DO ENDLOOP; }; IF server AND Xl.Alive[w.c] THEN Xl.RoundTrip[w.c]; } ELSE Process.Yield[]; }; noWhereBM: XlBitmap.Bitmap ~ XlBitmap.Create[[1, 1], 1, FALSE]; CreateContext: PUBLIC PROC [widget: BitmapWidget, surfaceUnitsPerPixel: NAT ¬ 1] RETURNS [context: Imager.Context] = { bmRef: REF BMRec ~ GetInstData[widget]; bm: XlBitmap.Bitmap ¬ bmRef.bm; IF bm=NIL THEN bm ¬ noWhereBM; context ¬ XlBitmap.CreateContext[bm, surfaceUnitsPerPixel]; }; CreateAndSetBitmap: PUBLIC PROC [widget: BitmapWidget, size: SF.Vec, bpp: NAT ¬ 1, origin: Xl.Point ¬ [0, 0]] = { bmRef: REF BMRec ~ GetInstData[widget]; bm: XlBitmap.Bitmap; IF bpp=0 AND widget.screenDepth#NIL THEN { IF XlColorAccess.FindVisualType[widget.screenDepth.screen, 8, Xl.VisualClass.pseudoColor]#NIL THEN bpp ¬ 8 ELSE IF XlColorAccess.FindVisualType[widget.screenDepth.screen, 4, Xl.VisualClass.pseudoColor]#NIL THEN bpp ¬ 4 ELSE bpp ¬ 1; }; IF bpp=0 THEN bpp ¬ 1; bm ¬ XlBitmap.Create[size, bpp]; SetBitmap[widget: widget, bitmap: bm, origin: origin]; FollowColors[widget, bm]; }; FollowColors: PUBLIC PROC [widget: XTk.Widget, bitmap: XlBitmap.Bitmap] = { bmRef: REF BMRec ~ GetInstData[widget]; bmRef.ownedBitmap ¬ bitmap; FollowColorsOnce[widget, bitmap]; }; FollowColorsOnce: PUBLIC PROC [widget: XTk.Widget, bitmap: XlBitmap.Bitmap] = { screenDepth: Xl.ScreenDepth ¬ widget.screenDepth; IF bitmap#NIL AND screenDepth#NIL THEN { sm: ImagerSample.RasterSampleMap ~ XlBitmap.GetSM[bitmap]; bbp: NAT ¬ ImagerSample.GetBitsPerSample[sm]; IF bbp>1 THEN { cd: XlColorAccess.ColorData ¬ XlColorAccess.Access[screenDepth.screen, bbp, Xl.VisualClass.pseudoColor]; IF cd#NIL AND cd.hasColors THEN { XlBitmap.SetColormap[bitmap, cd.entries]; IF cd.hasPrivateColormap AND widget.attributes.colorMap#cd.colormap AND widget.fastAccessAllowed=ok THEN { attributes: Xl.Attributes ¬ []; widget.attributes.colorMap ¬ attributes.colorMap ¬ cd.colormap; XlBitmap.SetColormap[bitmap, cd.entries]; XTkShellWidgets.TrackColorMap[shell: NIL, w: widget]; Xl.ChangeWindowAttributes[widget.connection, widget.window, attributes, noErrors]; }; }; }; }; }; END.