diff options
Diffstat (limited to 'ospicture.icl')
| -rw-r--r-- | ospicture.icl | 663 |
1 files changed, 663 insertions, 0 deletions
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)
|