From 7553b7f9d4dddc2235c137d41de8ce22547bebe3 Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Wed, 1 Jul 2015 17:36:37 +0200 Subject: Initial commit --- ospicture.icl | 663 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 663 insertions(+) create mode 100644 ospicture.icl (limited to 'ospicture.icl') diff --git a/ospicture.icl b/ospicture.icl new file mode 100644 index 0000000..f0cfe01 --- /dev/null +++ b/ospicture.icl @@ -0,0 +1,663 @@ +implementation module ospicture + +import StdBool, StdFunc, StdInt, StdList, StdReal, StdTuple +import pictCCall_12, osfont, ostypes +from osrgn import :: OSRgnHandle +from ostoolbox import OSNewToolbox +import StdPictureDef +from commondef import class toTuple(..), instance toTuple Point2, instance toTuple Vector2, + class subVector(..), instance subVector OSRect, setBetween + +:: Picture + = { pictContext :: !OSPictContext // The context for drawing operations + , pictToolbox :: !.OSToolbox // The continuation value + , pictOrigin :: !Origin // The current origin of the picture + , pictPen :: !.Pen // The current state of the pen + , pictToScreen :: !Bool // Flag: the output goes to screen (True) or printer (False) + } +:: Origin + :== Point2 +/* PA: moved to ostypes +:: OSPictContext + :== HDC +*/ +:: Pen + = { penSize :: !Int // The width and height of the pen + , penForeColour :: !Colour // The drawing colour of the pen + , penBackColour :: !Colour // The background colour of the pen + , penPos :: !.Point2 // The pen position in local coordinates + , penFont :: !Font // The font information to draw text and characters + } + + +// Conversion operations to and from Picture +/* +initialisePicture :: !Origin !Pen !OSPictContext !*OSToolbox -> (!OSPictContext,!*OSToolbox) +initialisePicture origin pen=:{penSize,penForeColour,penBackColour,penPos,penFont} hdc tb + # {osfontname,osfontstyles,osfontsize} = osFontgetimp penFont + # (hdc,tb) = winInitPicture + penSize + iModeCopy + initforecolour + initbackcolour + initpen + (osfontname,osfontstyles,osfontsize) + (0,0) + (hdc,tb) + # (_,_,_,_,_,_,(hdc,tb)) = winDonePicture (hdc,tb) + = (hdc,tb) +where + initforecolour = toRGBtriple penForeColour + initbackcolour = toRGBtriple penBackColour + initpen = toTuple (penPos-origin) +*/ +packPicture :: !Origin !*Pen !Bool !OSPictContext !*OSToolbox -> *Picture +packPicture origin pen=:{penSize,penForeColour,penBackColour,penPos,penFont} isScreenOutput hdc tb + #! {osfontname,osfontstyles,osfontsize}= osFontgetimp penFont + #! (hdc,tb) = winInitPicture + penSize + iModeCopy + initforecolour + initbackcolour + initpen + (osfontname,osfontstyles,osfontsize) + (0,0) + (hdc,tb) + = { pictContext = hdc + , pictToolbox = tb + , pictOrigin = origin + , pictPen = pen + , pictToScreen= isScreenOutput + } +where + initforecolour = toRGBtriple penForeColour + initbackcolour = toRGBtriple penBackColour + initpen = toTuple (penPos-origin) + +unpackPicture :: !*Picture -> (!Origin,!*Pen,!Bool,!OSPictContext,!*OSToolbox) +unpackPicture {pictOrigin,pictPen,pictToScreen,pictContext,pictToolbox} +// PA: intend to use simplified version of winDonePicture; crashes for some reason. + # (_,_,_,_,_,_,(hdc,tb)) = winDonePicture (pictContext,pictToolbox) +// # (hdc,tb) = WinDonePicture (pictContext,pictToolbox) + = (pictOrigin,pictPen,pictToScreen,hdc,tb) + +peekPicture :: !*Picture -> (!Origin,!*Pen,!Bool,!OSPictContext,!*OSToolbox) +peekPicture {pictOrigin,pictPen,pictToScreen,pictContext,pictToolbox} + = (pictOrigin,pictPen,pictToScreen,pictContext,pictToolbox) + +unpeekPicture :: !Origin !*Pen !Bool !OSPictContext !*OSToolbox -> *Picture +unpeekPicture origin pen isScreenOutput hdc tb + = {pictOrigin=origin,pictPen=pen,pictToScreen=isScreenOutput,pictContext=hdc,pictToolbox=tb} + +peekOSPictContext :: !*Picture -> (!OSPictContext,!*Picture) +peekOSPictContext picture=:{pictContext} + = (pictContext,picture) + +sharePicture :: !*Picture -> (!Picture,!*Picture) +sharePicture picture=:{pictOrigin,pictPen,pictToScreen} + # (sPen,uPen) = sharePen pictPen + = ({pictContext=0,pictToolbox=OSNewToolbox,pictOrigin=pictOrigin,pictPen=sPen,pictToScreen=pictToScreen},{picture & pictPen=uPen}) + +sharePen :: !*Pen -> (!Pen,!*Pen) +sharePen pen=:{penSize,penForeColour,penBackColour,penPos,penFont} + # (sPenPos,uPenPos) = sharePoint penPos + = ({penSize=penSize,penForeColour=penForeColour,penBackColour=penBackColour,penPos=sPenPos,penFont=penFont},{pen & penPos=uPenPos}) +where + sharePoint :: !*Point2 -> (!Point2,!*Point2) + sharePoint point=:{x,y} = ({x=x,y=y},point) + +copyPen :: !Pen -> *Pen +copyPen {penSize,penForeColour,penBackColour,penPos={x,y},penFont} + = {penSize=penSize,penForeColour=penForeColour,penBackColour=penBackColour,penPos={x=x,y=y},penFont=penFont} + +peekScreen :: !.(St *Picture .x) !*OSToolbox -> (!.x,!*OSToolbox) +peekScreen f tb + # (hdc,tb) = winCreateScreenHDC tb + # picture = packPicture zero defaultPen True hdc tb + # (x,picture) = f picture + # (_,_,_,hdc,tb)= unpackPicture picture + # tb = winDestroyScreenHDC (hdc,tb) + = (x,tb) + + +defaultPen :: *Pen +defaultPen + = { penSize = 1 + , penForeColour = Black + , penBackColour = White + , penPos = {x=0,y=0} + , penFont = defaultFont + } +where + (defaultFont,_) = osDefaultfont OSNewToolbox + +dialogPen :: *Pen +dialogPen + = { penSize = 1 + , penForeColour = Black + , penBackColour = White + , penPos = {x=0,y=0} + , penFont = dialogFont + } +where + (dialogFont,_) = osDialogfont OSNewToolbox + +setPenAttribute :: !PenAttribute !u:Pen -> u:Pen +setPenAttribute (PenSize size) pen = {pen & penSize =max 1 size} +setPenAttribute (PenPos {x,y}) pen = {pen & penPos ={x=x,y=y} } +setPenAttribute (PenColour colour) pen = {pen & penForeColour=colour } +setPenAttribute (PenBack colour) pen = {pen & penBackColour=colour } +setPenAttribute (PenFont font) pen = {pen & penFont =font } + + +/* Picture interface functions. +*/ +apppicttoolbox :: !(IdFun *OSToolbox) !*Picture -> *Picture +apppicttoolbox f picture=:{pictToolbox} + = {picture & pictToolbox=f pictToolbox} + +accpicttoolbox :: !(St *OSToolbox .x) !*Picture -> (!.x,!*Picture) +accpicttoolbox f picture=:{pictToolbox} + # (x,tb) = f pictToolbox + = (x,{picture & pictToolbox=tb}) + + +/* Attribute functions. +*/ +// Access to Origin and Pen: +getpictorigin :: !*Picture -> (!Origin,!*Picture) +getpictorigin picture=:{pictOrigin} + = (pictOrigin,picture) + +setpictorigin :: !Origin !*Picture -> *Picture +setpictorigin origin picture + = {picture & pictOrigin=origin} + +getpictpen :: !*Picture -> (!Pen,!*Picture) +getpictpen picture=:{pictPen} + # (sPen,uPen) = sharePen pictPen + = (sPen,{picture & pictPen=uPen}) + +setpictpen :: !Pen !*Picture -> *Picture +setpictpen {penSize,penForeColour,penBackColour,penPos,penFont} picture + # picture = setpictpensize penSize picture + # picture = setpictpencolour penForeColour picture + # picture = setpictbackcolour penBackColour picture + # picture = setpictpenpos penPos picture + # picture = setpictpenfont penFont picture + = picture + + +// Change the pen position: +setpictpenpos :: !Point2 !*Picture -> *Picture +setpictpenpos newpos=:{x=x`,y=y`} picture=:{pictToolbox,pictOrigin,pictPen=pen=:{penPos={x,y}},pictContext} + | x==x` && y==y` + = picture + | otherwise + # (context,tb) = winMovePenTo (toTuple (newpos-pictOrigin)) (pictContext,pictToolbox) + pen = {pen & penPos={x=x`,y=y`}} + = {picture & pictToolbox=tb,pictContext=context,pictPen=pen} + +getpictpenpos :: !*Picture -> (!Point2,!*Picture) +getpictpenpos picture=:{pictPen={penPos={x,y}}} + = ({x=x,y=y},picture) + +movepictpenpos :: !Vector2 !*Picture -> *Picture +movepictpenpos v=:{vx,vy} picture=:{pictToolbox,pictPen=pen=:{penPos={x,y}},pictContext} + # (context,tb) = winMovePen (toTuple v) (pictContext,pictToolbox) + pen = {pen & penPos={x=x+vx,y=y+vy}} + = {picture & pictToolbox=tb,pictContext=context,pictPen=pen} + +// Change the pen size: +setpictpensize :: !Int !*Picture -> *Picture +setpictpensize w picture=:{pictToolbox,pictContext,pictPen} + | w`==pictPen.penSize + = picture + | otherwise + # (context,tb) = winSetPenSize w` (pictContext,pictToolbox) + pen = {pictPen & penSize=w`} + = {picture & pictToolbox=tb,pictContext=context,pictPen=pen} +where + w` = max 1 w + +getpictpensize :: !*Picture -> (!Int,!*Picture) +getpictpensize picture=:{pictPen={penSize}} + = (penSize,picture) + + +// Change the PenColour: +setpictpencolour :: !Colour !*Picture -> *Picture +setpictpencolour colour picture=:{pictToolbox,pictPen,pictContext} + | reqRGB==curRGB + = picture + | otherwise + # (context,tb) = winSetPenColor reqRGB (pictContext,pictToolbox) + pen = {pictPen & penForeColour=colour} + = {picture & pictPen=pen,pictToolbox=tb,pictContext=context} +where + reqRGB = toRGBtriple colour + curRGB = toRGBtriple pictPen.penForeColour + +setpictbackcolour :: !Colour !*Picture -> *Picture +setpictbackcolour colour picture=:{pictToolbox,pictPen,pictContext} + | reqRGB==curRGB + = picture + | otherwise + # (context,tb) = winSetBackColor (toRGBtriple colour) (pictContext,pictToolbox) + pen = {pictPen & penBackColour=colour} + = {picture & pictPen=pen,pictToolbox=tb,pictContext=context} +where + reqRGB = toRGBtriple colour + curRGB = toRGBtriple pictPen.penBackColour + +toRGBtriple :: !Colour -> (!Int,!Int,!Int) +toRGBtriple (RGB {r,g,b}) = (setBetween r MinRGB MaxRGB,setBetween g MinRGB MaxRGB,setBetween b MinRGB MaxRGB) +toRGBtriple Black = (MinRGB,MinRGB,MinRGB) +toRGBtriple DarkGrey = ( MaxRGB>>2, MaxRGB>>2, MaxRGB>>2) +toRGBtriple Grey = ( MaxRGB>>1, MaxRGB>>1, MaxRGB>>1) +toRGBtriple LightGrey = ((MaxRGB>>2)*3,(MaxRGB>>2)*3,(MaxRGB>>2)*3) +toRGBtriple White = (MaxRGB,MaxRGB,MaxRGB) +toRGBtriple Red = (MaxRGB,MinRGB,MinRGB) +toRGBtriple Green = (MinRGB,MaxRGB,MinRGB) +toRGBtriple Blue = (MinRGB,MinRGB,MaxRGB) +toRGBtriple Cyan = (MinRGB,MaxRGB,MaxRGB) +toRGBtriple Magenta = (MaxRGB,MinRGB,MaxRGB) +toRGBtriple Yellow = (MaxRGB,MaxRGB,MinRGB) + +getpictpencolour :: !*Picture -> (!Colour,!*Picture) +getpictpencolour picture=:{pictPen={penForeColour}} + = (penForeColour,picture) + +getpictbackcolour :: !*Picture -> (!Colour,!*Picture) +getpictbackcolour picture=:{pictPen={penBackColour}} + = (penBackColour,picture) + + +// Change the font attributes: +setpictpenfont :: !Font !*Picture -> *Picture +setpictpenfont font picture=:{pictToolbox,pictContext,pictPen=pen} + | imp==osFontgetimp pen.penFont + = picture + | otherwise + # (context,tb) = winSetFont (osfontname,osfontstyles,osfontsize) (pictContext,pictToolbox) + pen = {pen & penFont=font} + = {picture & pictToolbox=tb,pictContext=context,pictPen=pen} +where + imp = osFontgetimp font + {osfontname,osfontstyles,osfontsize} = imp + +getpictpenfont :: !*Picture -> (!Font,!*Picture) +getpictpenfont picture=:{pictPen={penFont}} + = (penFont,picture) + +setpictpendefaultfont :: !*Picture -> *Picture +setpictpendefaultfont picture=:{pictToolbox,pictContext,pictPen} + # (font,tb) = osDefaultfont pictToolbox + {osfontname,osfontstyles,osfontsize} + = osFontgetimp font + # (context,tb) = winSetFont (osfontname,osfontstyles,osfontsize) (pictContext,tb) + pen = {pictPen & penFont=font} + = {picture & pictToolbox=tb,pictContext=context,pictPen=pen} + + +/* Drawing mode setting functions. +*/ +setpictxormode :: !*Picture -> *Picture +setpictxormode picture=:{pictToolbox,pictContext} + # (context,tb) = winSetMode iModeXor (pictContext,pictToolbox) + = {picture & pictToolbox=tb,pictContext=context} + +setpicthilitemode :: !*Picture -> *Picture +setpicthilitemode picture=:{pictToolbox,pictContext} + # (context,tb) = winSetMode iModeXor (pictContext,pictToolbox) + = {picture & pictToolbox=tb,pictContext=context} + +setpictnormalmode :: !*Picture -> *Picture +setpictnormalmode picture=:{pictToolbox,pictContext} + # (context,tb) = winSetMode iModeCopy (pictContext,pictToolbox) + = {picture & pictToolbox=tb,pictContext=context} + + +/* Point2 drawing operations. + pictdrawpoint + only draws a point at that position. The pen position is not changed. +*/ +pictdrawpoint :: !Point2 !*Picture -> *Picture +pictdrawpoint pos=:{x,y} picture=:{pictPen={penSize},pictOrigin={x=ox,y=oy},pictToolbox,pictContext} + | penSize==1 + # (context,tb) = winDrawPoint (x`,y`) (pictContext,pictToolbox) + = {picture & pictToolbox=tb,pictContext=context} + | otherwise + # (context,tb) = winFillRectangle {rleft=x`,rtop=y`,rright=x`+penSize,rbottom=y`+penSize} (pictContext,pictToolbox) + = {picture & pictToolbox=tb,pictContext=context} +where + (x`,y`) = (x-ox,y-oy) + + +/* Line drawing operations. + pictdrawlineto + draws a line from the current pen position to the given pen position. + The new pen position is the endpoint of the line. + pictdrawline + draws a line from the first point to the second point. The pen position + is not changed. +*/ +pictdrawlineto :: !Point2 !*Picture -> *Picture +pictdrawlineto pos=:{x,y} picture=:{pictOrigin,pictToolbox,pictContext,pictPen} + # (context,tb) = winLinePenTo (toTuple (pos-pictOrigin)) (pictContext,pictToolbox) + pen = {pictPen & penPos={x=x,y=y}} + = {picture & pictToolbox=tb,pictContext=context,pictPen=pen} + +pictundrawlineto :: !Point2 !*Picture -> *Picture +pictundrawlineto pos=:{x,y} picture=:{pictOrigin,pictToolbox,pictContext,pictPen=pen=:{penForeColour,penBackColour}} + # (context,tb) = winSetPenColor (toRGBtriple penBackColour) (pictContext,pictToolbox) + # (context,tb) = winLinePenTo (toTuple (pos-pictOrigin)) (context,tb) + # (context,tb) = winSetPenColor (toRGBtriple penForeColour) (context,tb) + = {picture & pictToolbox=tb,pictContext=context,pictPen={pen & penPos={x=x,y=y}}} + +pictdrawline :: !Point2 !Point2 !*Picture -> *Picture +pictdrawline a b picture=:{pictOrigin,pictToolbox,pictContext} + # (context,tb) = winDrawLine (toTuple (a-pictOrigin)) (toTuple (b-pictOrigin)) (pictContext,pictToolbox) + = {picture & pictToolbox=tb,pictContext=context} + +pictundrawline :: !Point2 !Point2 !*Picture -> *Picture +pictundrawline a b picture=:{pictOrigin,pictToolbox,pictContext,pictPen={penForeColour,penBackColour}} + # (context,tb) = winSetPenColor (toRGBtriple penBackColour) (pictContext,pictToolbox) + # (context,tb) = winDrawLine (toTuple (a-pictOrigin)) (toTuple (b-pictOrigin)) (context,tb) + # (context,tb) = winSetPenColor (toRGBtriple penForeColour) (context,tb) + = {picture & pictToolbox=tb,pictContext=context} + + +/* Text drawing operations. + pictdraw(char/string) draws a char/string at the current pen position. The new + pen position is immediately after the drawn char/string. +*/ +pictdrawchar :: !Char !*Picture -> *Picture +pictdrawchar char picture=:{pictContext,pictToolbox,pictPen,pictOrigin} + # (context,tb) = winDrawChar (toInt char) (pictContext,pictToolbox) + # (x`,y`,context,tb)= winGetPenPos (context,tb) + #! {x,y} = pictOrigin + #! pen = {pictPen & penPos={x=x+x`,y=y+y`}} + = {picture & pictContext=context,pictToolbox=tb,pictPen=pen} + +pictundrawchar :: !Char !*Picture -> *Picture +pictundrawchar char picture=:{pictContext,pictToolbox,pictPen=pen=:{penForeColour,penBackColour},pictOrigin={x=ox,y=oy}} + # (context,tb) = winSetPenColor (toRGBtriple penBackColour) (pictContext,pictToolbox) + # (context,tb) = winDrawChar (toInt char) (context,tb) + # (context,tb) = winSetPenColor (toRGBtriple penForeColour) (context,tb) + # (x,y,context,tb) = winGetPenPos (context,tb) + = {picture & pictContext=context,pictToolbox=tb,pictPen={pen & penPos={x=x+ox,y=y+oy}}} + +pictdrawstring :: !String !*Picture -> *Picture +pictdrawstring string picture=:{pictContext,pictToolbox,pictPen,pictOrigin={x=ox,y=oy}} // PA: + # (context,tb) = winDrawString string (pictContext,pictToolbox) + # (x,y,context,tb) = winGetPenPos (context,tb) + pen = {pictPen & penPos={x=x+ox,y=y+oy}} + = {picture & pictContext=context,pictToolbox=tb,pictPen=pen} + +pictundrawstring :: !String !*Picture -> *Picture +pictundrawstring string picture=:{pictContext,pictToolbox,pictPen=pen=:{penForeColour,penBackColour},pictOrigin={x=ox,y=oy}} + # (context,tb) = winSetPenColor (toRGBtriple penBackColour) (pictContext,pictToolbox) + # (context,tb) = winDrawString string (context,tb) + # (context,tb) = winSetPenColor (toRGBtriple penForeColour) (context,tb) + # (x,y,context,tb) = winGetPenPos (context,tb) + = {picture & pictContext=context,pictToolbox=tb,pictPen={pen & penPos={x=x+ox,y=y+oy}}} + + +/* Oval drawing operations. + pict(draw/fill)oval center oval + draws/fills an oval at center with horizontal and vertical radius. The new + pen position is not changed. +*/ +pictdrawoval :: !Point2 !Oval !*Picture -> *Picture +pictdrawoval center oval picture=:{pictContext,pictToolbox,pictOrigin} + # (context,tb) = winDrawOval rect (pictContext,pictToolbox) + = {picture & pictContext=context,pictToolbox=tb} +where + rect = ovalToRect (center-pictOrigin) oval + +pictundrawoval :: !Point2 !Oval !*Picture -> *Picture +pictundrawoval center oval picture=:{pictContext,pictToolbox,pictOrigin,pictPen={penBackColour,penForeColour}} + # (context,tb) = winSetPenColor (toRGBtriple penBackColour) (pictContext,pictToolbox) + # (context,tb) = winDrawOval rect (context,tb) + # (context,tb) = winSetPenColor (toRGBtriple penForeColour) (context,tb) + = {picture & pictContext=context,pictToolbox=tb} +where + rect = ovalToRect (center-pictOrigin) oval + +pictfilloval :: !Point2 !Oval !*Picture -> *Picture +pictfilloval center oval picture=:{pictContext,pictToolbox,pictOrigin} + # (context,tb) = winFillOval rect (pictContext,pictToolbox) + = {picture & pictContext=context,pictToolbox=tb} +where + rect = ovalToRect (center-pictOrigin) oval + +pictunfilloval :: !Point2 !Oval !*Picture -> *Picture +pictunfilloval center oval picture=:{pictContext,pictToolbox,pictOrigin,pictPen} + # (context,tb) = winEraseOval rect (pictContext,pictToolbox) + = {picture & pictContext=context,pictToolbox=tb} +where + rect = ovalToRect (center-pictOrigin) oval + +ovalToRect :: !Point2 !Oval -> OSRect +ovalToRect {x,y} {oval_rx,oval_ry} + = {rleft=x-rx,rtop=y-ry,rright=x+rx,rbottom=y+ry} +where + rx = abs oval_rx + ry = abs oval_ry + + +/* Curve drawing operations. + pict(draw/fill)curve movePen point curve + draws/fills a curve starting at point with a shape defined by curve. If movePen + is True, then the new pen position is at the end of the curve, otherwise it does + not change. +*/ +pictdrawcurve :: !Bool !Point2 !Curve !*Picture -> *Picture +pictdrawcurve movePen start=:{x,y} curve picture=:{pictContext,pictToolbox,pictOrigin} + # (context,tb) = winDrawCurve wrect (toTuple wstart) (toTuple wend) (pictContext,pictToolbox) + # picture = {picture & pictContext=context,pictToolbox=tb} + | not movePen = picture + | otherwise = setpictpenpos end picture +where + start` = start-pictOrigin + (wrect,wstart,wend) = getcurve_rect_begin_end start` curve + end = wend+pictOrigin + +pictundrawcurve :: !Bool !Point2 !Curve !*Picture -> *Picture +pictundrawcurve movePen start=:{x,y} curve picture=:{pictContext,pictToolbox,pictOrigin,pictPen={penForeColour,penBackColour}} + # (context,tb) = winSetPenColor (toRGBtriple penBackColour) (pictContext,pictToolbox) + # (context,tb) = winDrawCurve wrect (toTuple wstart) (toTuple wend) (context,tb) + # (context,tb) = winSetPenColor (toRGBtriple penForeColour) (context,tb) + # picture = {picture & pictContext=context,pictToolbox=tb} + | not movePen = picture + | otherwise = setpictpenpos end picture +where + start` = start-pictOrigin + (wrect,wstart,wend) = getcurve_rect_begin_end start` curve + end = wend+pictOrigin + +pictfillcurve :: !Bool !Point2 !Curve !*Picture -> *Picture +pictfillcurve movePen start curve picture=:{pictContext,pictToolbox,pictOrigin} + # (context,tb) = winFillWedge wrect (toTuple wstart) (toTuple wend) (pictContext,pictToolbox) + # picture = {picture & pictContext=context,pictToolbox=tb} + | not movePen = picture + | otherwise = setpictpenpos end picture +where + start` = start-pictOrigin + (wrect,wstart,wend) = getcurve_rect_begin_end start` curve + end = wend+pictOrigin + +pictunfillcurve :: !Bool !Point2 !Curve !*Picture -> *Picture +pictunfillcurve movePen start curve picture=:{pictContext,pictToolbox,pictOrigin,pictPen={penForeColour,penBackColour}} + # (context,tb) = winSetPenColor (toRGBtriple penBackColour) (pictContext,pictToolbox) + # (context,tb) = winFillWedge wrect (toTuple wstart) (toTuple wend) (context,tb) + # (context,tb) = winSetPenColor (toRGBtriple penForeColour) (context,tb) + # picture = {picture & pictContext=context,pictToolbox=tb} + | not movePen = picture + | otherwise = setpictpenpos end picture +where + start` = start-pictOrigin + (wrect,wstart,wend) = getcurve_rect_begin_end start` curve + end = wend+pictOrigin + +getcurve_rect_begin_end :: !Point2 !Curve -> (!OSRect,!Point2,!Point2) +getcurve_rect_begin_end start=:{x,y} {curve_oval={oval_rx,oval_ry},curve_from,curve_to,curve_clockwise} + | curve_clockwise = (rect,end,start) + | otherwise = (rect,start,end) +where + rx` = toReal (abs oval_rx) + ry` = toReal (abs oval_ry) + cx = x -(toInt ((cos curve_from)*rx`)) + cy = y +(toInt ((sin curve_from)*ry`)) + ex = cx+(toInt ((cos curve_to )*rx`)) + ey = cy-(toInt ((sin curve_to )*ry`)) + end = {x=ex,y=ey} + rect = {rleft=cx-oval_rx,rtop=cy-oval_ry,rright=cx+oval_rx,rbottom=cy+oval_ry} + + +/* OSRect drawing operations. + pict(draw/fill)rect rect + draws/fills a rect. The pen position is not changed. +*/ +pictdrawrect :: !OSRect !*Picture -> *Picture +pictdrawrect r picture=:{pictContext,pictToolbox,pictOrigin} + # (context,tb) = winDrawRectangle (subVector (toVector pictOrigin) r) (pictContext,pictToolbox) + = {picture & pictContext=context,pictToolbox=tb} + +pictundrawrect :: !OSRect !*Picture -> *Picture +pictundrawrect r picture=:{pictContext,pictToolbox,pictOrigin,pictPen={penForeColour,penBackColour}} + # (context,tb) = winSetPenColor (toRGBtriple penBackColour) (pictContext,pictToolbox) + # (context,tb) = winDrawRectangle (subVector (toVector pictOrigin) r) (context,tb) + # (context,tb) = winSetPenColor (toRGBtriple penForeColour) (context,tb) + = {picture & pictContext=context,pictToolbox=tb} + +pictfillrect :: !OSRect !*Picture -> *Picture +pictfillrect r picture=:{pictContext,pictToolbox,pictOrigin} + # (context,tb) = winFillRectangle (subVector (toVector pictOrigin) r) (pictContext,pictToolbox) + = {picture & pictContext=context,pictToolbox=tb} + +pictunfillrect :: !OSRect !*Picture -> *Picture +pictunfillrect r picture=:{pictContext,pictToolbox,pictOrigin} + # (context,tb) = winEraseRectangle (subVector (toVector pictOrigin) r) (pictContext,pictToolbox) + = {picture & pictContext=context,pictToolbox=tb} + + +/* Scrolling operation (handle with care). +*/ +pictscroll :: !OSRect !Vector2 !*Picture -> (!OSRect,!*Picture) +pictscroll r v picture=:{pictContext,pictToolbox,pictOrigin} + # (updRect,(context,tb)) = winScrollRectangle (subVector (toVector pictOrigin) r) (toTuple v) (pictContext,pictToolbox) + = (updRect,{picture & pictContext=context,pictToolbox=tb}) + +pictscroll2 :: !OSRect !Vector2 !*Picture -> (!OSRect,!*Picture) +pictscroll2 r v picture=:{pictContext,pictToolbox,pictOrigin} + # (updRect,(context,tb)) = winScrollRectangle2 (subVector (toVector pictOrigin) r) (toTuple v) (pictContext,pictToolbox) + = (updRect,{picture & pictContext=context,pictToolbox=tb}) + +/* Polygon drawing operations. + pict(draw/fill)polygon point polygon + draws/fills a polygon starting at point. The pen position is not changed. +*/ +pictdrawpolygon :: !Point2 !Polygon !*Picture -> *Picture +pictdrawpolygon start {polygon_shape} picture=:{pictContext,pictToolbox,pictOrigin} + # tb = transferPolygon (start-pictOrigin) polygon_shape pictToolbox + # (context,tb) = winDrawPolygon (pictContext,tb) + # tb = winEndPolygon tb + = {picture & pictContext=context,pictToolbox=tb} + +pictundrawpolygon :: !Point2 !Polygon !*Picture -> *Picture +pictundrawpolygon start {polygon_shape} picture=:{pictContext,pictToolbox,pictOrigin,pictPen={penForeColour,penBackColour}} + # tb = transferPolygon (start-pictOrigin) polygon_shape pictToolbox + # (context,tb) = winSetPenColor (toRGBtriple penBackColour) (pictContext,tb) + # (context,tb) = winDrawPolygon (context,tb) + # tb = winEndPolygon tb + # (context,tb) = winSetPenColor (toRGBtriple penForeColour) (context,tb) + = {picture & pictContext=context,pictToolbox=tb} + +pictfillpolygon :: !Point2 !Polygon !*Picture -> *Picture +pictfillpolygon start {polygon_shape} picture=:{pictPen={penSize},pictContext,pictToolbox,pictOrigin} + # tb = transferPolygon (start-pictOrigin) polygon_shape pictToolbox + # (context,tb) = winSetPenSize 1 (pictContext,tb) + # (context,tb) = winFillPolygon (context,tb) + # (context,tb) = winDrawPolygon (context,tb) + # (context,tb) = winSetPenSize penSize (context,tb) + # tb = winEndPolygon tb + = {picture & pictContext=context,pictToolbox=tb} + +pictunfillpolygon :: !Point2 !Polygon !*Picture -> *Picture +pictunfillpolygon start {polygon_shape} picture=:{pictPen={penSize,penForeColour,penBackColour},pictContext,pictToolbox,pictOrigin} + # tb = transferPolygon (start-pictOrigin) polygon_shape pictToolbox + # (context,tb) = winSetPenColor (toRGBtriple penBackColour) (pictContext,tb) + # (context,tb) = winSetPenSize 1 (context,tb) + # (context,tb) = winFillPolygon (context,tb) + # (context,tb) = winDrawPolygon (context,tb) + # (context,tb) = winSetPenSize penSize (context,tb) + # tb = winEndPolygon tb + # (context,tb) = winSetPenColor (toRGBtriple penForeColour) (context,tb) + = {picture & pictContext=context,pictToolbox=tb} + +transferPolygon :: !Point2 ![Vector2] !*OSToolbox -> *OSToolbox +transferPolygon start vs tb + # tb = winStartPolygon (1 + length vs) tb + # tb = winAddPolygonPoint wstart tb + # tb = transferShape wstart vs tb + = tb +where + wstart = toTuple start + + transferShape :: !(!Int,!Int) ![Vector2] !*OSToolbox -> *OSToolbox + transferShape (x,y) [{vx,vy}:vs] tb + = transferShape newpos vs (winAddPolygonPoint newpos tb) + where + newpos = (x+vx,y+vy) + transferShape _ _ tb + = tb + +/* Clipping operations. + pictgetcliprgn gets the current clipping region. + pictsetcliprgn sets the given clipping region. + pictandcliprgn takes the intersection of the current clipping region and the argument region. +*/ +pictgetcliprgn :: !*Picture -> (!OSRgnHandle,!*Picture) +pictgetcliprgn picture=:{pictContext,pictToolbox} + # (cliprgn,(context,tb)) = winGetClipRgnPicture (pictContext,pictToolbox) + = (cliprgn,{picture & pictContext=context,pictToolbox=tb}) + +pictsetcliprgn :: !OSRgnHandle !*Picture -> *Picture +pictsetcliprgn cliprgn picture=:{pictContext,pictToolbox} + # (context,tb) = winSetClipRgnPicture cliprgn (pictContext,pictToolbox) + = {picture & pictContext=context,pictToolbox=tb} + +pictandcliprgn :: !OSRgnHandle !*Picture -> *Picture +pictandcliprgn cliprgn picture=:{pictContext,pictToolbox} + # (context,tb) = winClipRgnPicture cliprgn (pictContext,pictToolbox) + = {picture & pictContext=context,pictToolbox=tb} + +/* Resolution access function (added by MW): +*/ +getResolutionC :: !OSPictContext !*OSToolbox -> (!(!Int,!Int),!*OSToolbox) +getResolutionC _ _ + = code { + ccall getResolutionC "I:VII:I" + } + +// MW: scaling of screen coordinates to printer coordinates. +getPictureScalingFactors :: !OSPictContext !*OSToolbox -> (!(!Int,!Int),!(!Int,!Int),!OSPictContext,!*OSToolbox) +getPictureScalingFactors _ _ + = code + { + ccall WinGetPictureScaleFactor "II-IIIIII" + } + +getpictpenattributes :: !*Picture -> (![PenAttribute],!*Picture) +getpictpenattributes picture + # (pen,picture) = getpictpen picture + = (getpenattribute pen,picture) +where + getpenattribute :: !Pen -> [PenAttribute] + getpenattribute {penSize,penForeColour,penBackColour,penPos,penFont} + = [PenSize penSize,PenPos penPos,PenColour penForeColour,PenBack penBackColour,PenFont penFont] + +getPenPenPos :: !*Pen -> (!Point2,!*Pen) +getPenPenPos pen=:{penPos={x,y}} = ({x=x,y=y},pen) -- cgit v1.2.3