<<>> <> <> <> <<>> <> <> << >> DIRECTORY Commander, CommanderOps, Convert, Imager, ImagerBackdoor, ImagerColor, IO, Rope, Xl, XTk, XTkBitmapWidgets, XTkShellWidgets; X11ForeignImageTest: CEDAR MONITOR IMPORTS Commander, CommanderOps, Convert, Imager, ImagerBackdoor, ImagerColor, IO, Xl, Rope, XTkBitmapWidgets, XTkShellWidgets = BEGIN lastStream: IO.STREAM ¬ NIL; lastContext: Imager.Context ¬ NIL; lastWidget: XTk.Widget ¬ NIL; Erase: PROC [] = { <<--"Erases" with a visible pattern (for debugging)>> Imager.SetColor[lastContext, Imager.MakeGray[0.1]]; Imager.MaskRectangleI[lastContext, 0, 0, 10000, 10000]; }; Paint: PROC [] = { <<--Paint some pattern >> Imager.SetColor[lastContext, Imager.black]; Imager.MaskRectangleI[lastContext, 10, 0, 4, 10000]; Imager.SetStrokeWidth[lastContext, 2]; Imager.MaskVectorI[lastContext, 0, 0, 10000, 10000]; Imager.SetStrokeWidth[lastContext, 8]; Imager.MaskVectorI[lastContext, 20, 20, 100, 100]; Imager.SetColor[lastContext, ImagerColor.ColorFromRGB[[1.0, 0.0, 0.0]]]; --use color to expose whether actual context supports colors Imager.SetStrokeWidth[lastContext, 10]; Imager.MaskVectorI[lastContext, 20, 100, 100, 20]; }; ApplicationReportNewSize: PROC [bitmapWidget: XTk.Widget, size: Xl.Size] = { <<--This procedure represents the application which needs to know when to create new imager contexts.>> <<--For debugging we paint a certain pattern>> c: Imager.Context ¬ lastContext ¬ CreateContext[bitmapWidget]; IO.PutF[lastStream, "w: %g, h: %g\n", IO.int[size.width], IO.int[size.height]]; lastWidget ¬ bitmapWidget; Erase[]; Paint[]; }; bitsPerPixel: NAT ¬ 0; AllocateNewBitmap: PROC [bitmapWidget: XTk.Widget] = { size: Xl.Size ~ bitmapWidget.actual.size; XTkBitmapWidgets.CreateAndSetBitmap[widget: bitmapWidget, size: [s: size.height, f: size.width], bpp: bitsPerPixel]; <<--Remark: bpp 0 causes XTkBitmapWidgets to choose a value >> --This will make a new backing bitmap; tell your clients that they ought to replace their old imager contexts --widget ApplicationReportNewSize[bitmapWidget, size]; }; BitmapEventHappened: XTkBitmapWidgets.BitmapEventProc = { <<--This also allocates a new bitmap on resize so the bitmap tracks the size of the widget>> <<--But that is optional, the bitmap and the widget may differ in size >> IF reason=destroyWindow THEN { <<--maybe you want to also notify your application?>> RETURN; }; IF reason=createWindow OR reason=resize THEN { AllocateNewBitmap[widget]; }; }; CreateContextWidget: PROC [windowId: CARD, server: REF ANY ¬ NIL] RETURNS [bitmapWidget: XTk.Widget] = { <<--Main procedure, creating a window which supports an imager context.>> <<--windowId: window to be used >> <<--server: X server to be used. A rope specifying the name, an Xl.Connection, or, NIL. A defaulted server will fall back to a long list of defaults, ending up with using the display environment variable >> foreignParent: Xl.Window ~ [[windowId]]; shellWidget: XTk.Widget ¬ XTkShellWidgets.CreateInteroperabilityShell[]; --creates data structures ready to graft on our stuff bitmapWidget ¬ XTkBitmapWidgets.CreateBitmapWidget[notify: BitmapEventHappened]; XTkShellWidgets.SetShellChild[shellWidget, bitmapWidget]; XTkShellWidgets.BindScreenShell[shellWidget, server, foreignParent]; XTkShellWidgets.RealizeShell[shellWidget]; }; CreateContext: PROC [bitmapWidget: XTk.Widget] RETURNS [Imager.Context] = { <<--This imager context paints into the currently active backing bitmap. It will continue painting int the same old backing bitmap even if the bitmapWidget would display another bitmap. >> RETURN [XTkBitmapWidgets.CreateContext[bitmapWidget]]; }; BindWindow: Commander.CommandProc ~ { <<--Main command exercising this package>> arg: Rope.ROPE ¬ CommanderOps.NextArgument[cmd]; id: CARD; SELECT TRUE FROM Rope.Equal[arg, "-egret", FALSE] => { bitsPerPixel ¬ 24; arg ¬ CommanderOps.NextArgument[cmd]; }; Rope.Equal[arg, "-four", FALSE] => { bitsPerPixel ¬ 4; arg ¬ CommanderOps.NextArgument[cmd]; }; ENDCASE => bitsPerPixel ¬ 0; id ¬ Convert.CardFromRope[arg ! Convert.Error => CommanderOps.Failed["need id"]]; lastStream ¬ cmd.out; [] ¬ CreateContextWidget[id, NIL ! Xl.XError => CommanderOps.Failed[err.explanation]]; }; DebugErase: Commander.CommandProc ~ { <<--Explicitely paint the background for debugging>> Erase[]; }; DebugPaint: Commander.CommandProc ~ { <<--Explicitely paint for debugging>> Paint[]; }; DebugWriteInfo: Commander.CommandProc ~ { <<--Write the imager bounds for debugging>> r: Imager.Rectangle ¬ ImagerBackdoor.GetBounds[lastContext]; IO.PutF[cmd.out, "Bounds x: %g, y:%g, ", IO.real[r.x], IO.real[r.y]]; IO.PutF[cmd.out, "w: %g, h: %g\n", IO.real[r.w], IO.real[r.h]]; }; DebugPaintXDirect: Commander.CommandProc ~ { <<--Direct X commands for drawing; this can expose whether the window is actually not clipped>> w: Xl.Window ¬ lastWidget.window; c: Xl.Connection ¬ lastWidget.connection; gc: Xl.GContext ¬ Xl.MakeGContext[c, w]; screen: Xl.Screen ¬ lastWidget.screenDepth.screen; size: Xl.Size ¬ lastWidget.actual.size; Xl.SetGCForeground[gc, screen.blackPixel]; Xl.SetGCBackground[gc, screen.whitePixel]; Xl.SetGCFunction[gc, copy]; Xl.SetGCLineWidth[gc, 3]; Xl.DrawLine[c, w, [0, 0], [size.width, size.height], gc]; Xl.Flush[c]; IO.PutF[cmd.out, "Size w: %g, h:%g\n", IO.int[size.width], IO.int[size.height]]; }; Commander.Register["X11ForeignImageCreate", BindWindow, "Show drawing into foreign x window"]; Commander.Register["X11ForeignImageErase", DebugErase, "Test for drawing into foreign x window"]; Commander.Register["X11ForeignImagePaint", DebugPaint, "Test for drawing into foreign x window"]; Commander.Register["X11ForeignImageInfo", DebugWriteInfo, "Test for drawing into foreign x window"]; Commander.Register["X11ForeignImageDirect", DebugPaintXDirect, "Test for drawing into foreign x window"]; END.