implementation module StdPicture import StdBool, StdFunc, StdInt, StdList, StdMisc, StdReal, StdTuple import ospicture, osfont, osrgn, ostoolbox import commondef, StdPictureDef //import StdDebug,dodebug trace_rgn _ r :== r // Pen attribute functions: setPenAttributes :: ![PenAttribute] !*Picture -> *Picture setPenAttributes atts picture = stateMap2 setattribute atts picture where setattribute :: !PenAttribute !*Picture -> *Picture setattribute (PenSize size) picture = setPenSize size picture setattribute (PenPos pos) picture = setPenPos pos picture setattribute (PenColour c) picture = setPenColour c picture setattribute (PenBack c) picture = setPenBack c picture setattribute (PenFont font) picture = setPenFont font picture getPenAttributes :: !*Picture -> (![PenAttribute],!*Picture) getPenAttributes picture = getpictpenattributes picture // Pen position attributes: setPenPos :: !Point2 !*Picture -> *Picture setPenPos pos picture = setpictpenpos pos picture getPenPos :: !*Picture -> (!Point2,!*Picture) getPenPos picture = getpictpenpos picture class movePenPos figure :: !figure !*Picture -> *Picture // Move the pen position as much as when drawing the figure. instance movePenPos Vector2 where movePenPos v picture = movepictpenpos v picture instance movePenPos Curve where movePenPos curve picture # (curpos,picture) = getpictpenpos picture (_,_,endpos) = getcurve_rect_begin_end curpos curve # picture = setpictpenpos endpos picture = picture // PenSize attributes: setPenSize :: !Int !*Picture -> *Picture setPenSize w picture = setpictpensize w picture getPenSize :: !*Picture -> (!Int,!*Picture) getPenSize picture = getpictpensize picture setDefaultPenSize :: !*Picture -> *Picture setDefaultPenSize picture = setpictpensize 1 picture // Colour attributes: setPenColour :: !Colour !*Picture -> *Picture setPenColour c picture = setpictpencolour c picture getPenColour :: !*Picture -> (!Colour,!*Picture) getPenColour picture = getpictpencolour picture setPenBack :: !Colour !*Picture -> *Picture setPenBack c picture = setpictbackcolour c picture getPenBack :: !*Picture -> (!Colour,!*Picture) getPenBack picture = getpictbackcolour picture // Convert a colour to RGBColour toRGBColour :: !Colour -> RGBColour toRGBColour colour = {r=r,g=g,b=b} where (r,g,b) = toRGBtriple colour setDefaultPenColour :: !*Picture -> *Picture setDefaultPenColour picture = setpictpencolour Black picture setDefaultPenBack :: !*Picture -> *Picture setDefaultPenBack picture = setpictbackcolour White picture // Font attributes: setPenFont :: !Font !*Picture -> *Picture setPenFont f picture = setpictpenfont f picture getPenFont :: !*Picture -> (!Font,!*Picture) getPenFont picture = getpictpenfont picture setDefaultPenFont :: !*Picture -> *Picture setDefaultPenFont picture = setpictpendefaultfont picture // Font operations: openFont :: !FontDef !*Picture -> (!(!Bool,!Font),!*Picture) openFont {fName,fStyles,fSize} picture # (origin,pen,toScreen,context,tb) = peekPicture picture # (found,font,tb) = osSelectfont (fName,fStyles,fSize) tb # picture = unpeekPicture origin pen toScreen context tb = ((found,font),picture) openDefaultFont :: !*Picture -> (!Font,!*Picture) openDefaultFont picture = accpicttoolbox osDefaultfont picture openDialogFont :: !*Picture -> (!Font,!*Picture) openDialogFont picture = accpicttoolbox osDialogfont picture getFontNames :: !*Picture -> (![FontName],!*Picture) getFontNames picture = accpicttoolbox osFontnames picture getFontStyles :: !FontName !*Picture -> (![FontStyle],!*Picture) getFontStyles fName picture = accpicttoolbox (osFontstyles fName) picture getFontSizes :: !Int !Int !FontName !*Picture -> (![FontSize],!*Picture) getFontSizes sizeBound1 sizeBound2 fName picture = accpicttoolbox (osFontsizes sizeBound1 sizeBound2 fName) picture getFontDef :: !Font -> FontDef getFontDef font = {fName=name,fStyles=styles,fSize=size} where (name,styles,size) = osFontgetdef font getFontCharWidth :: !Font !Char !*Picture -> (!Int,!*Picture) getFontCharWidth font char picture # (osPictContext,picture) = peekOSPictContext picture # (widths,picture) = accpicttoolbox (osGetfontcharwidths True osPictContext [char] font) picture = (hd widths,picture) getFontCharWidths :: !Font ![Char] !*Picture -> (![Int],!*Picture) getFontCharWidths font chars picture # (osPictContext,picture) = peekOSPictContext picture = accpicttoolbox (osGetfontcharwidths True osPictContext chars font) picture getFontStringWidth :: !Font !String !*Picture -> (!Int,!*Picture) getFontStringWidth font string picture # (osPictContext,picture) = peekOSPictContext picture # (widths,picture) = accpicttoolbox (osGetfontstringwidths True osPictContext [string] font) picture = (hd widths,picture) getFontStringWidths :: !Font ![String] !*Picture -> (![Int],!*Picture) getFontStringWidths font strings picture # (osPictContext,picture) = peekOSPictContext picture = accpicttoolbox (osGetfontstringwidths True osPictContext strings font) picture getFontMetrics :: !Font !*Picture -> (!FontMetrics,!*Picture) getFontMetrics font picture # (osPictContext,picture) = peekOSPictContext picture # ((ascent,descent,leading,maxwidth),picture) = accpicttoolbox (osGetfontmetrics True osPictContext font) picture = ({fAscent=ascent,fDescent=descent,fLeading=leading,fMaxWidth=maxwidth},picture) getPenFontCharWidth :: !Char !*Picture -> (!Int,!*Picture) getPenFontCharWidth char picture = getPenFontInfo (\font->getFontCharWidth font char) picture getPenFontCharWidths :: ![Char] !*Picture -> (![Int],!*Picture) getPenFontCharWidths chars picture = getPenFontInfo (\font->getFontCharWidths font chars) picture getPenFontStringWidth :: !String !*Picture -> (!Int,!*Picture) getPenFontStringWidth string picture = getPenFontInfo (\font->getFontStringWidth font string) picture getPenFontStringWidths :: ![String] !*Picture -> (![Int],!*Picture) getPenFontStringWidths strings picture = getPenFontInfo (\font->getFontStringWidths font strings) picture getPenFontMetrics :: !*Picture -> (!FontMetrics,!*Picture) getPenFontMetrics picture = getPenFontInfo (\font->getFontMetrics font) picture getPenFontInfo :: !(Font -> *Picture -> (.x,*Picture)) !*Picture -> (!.x,!*Picture) getPenFontInfo fontfun picture # (font,picture) = getPenFont picture # (x,picture) = fontfun font picture # picture = setPenFont font picture = (x,picture) /* Drawing functions. These functions are divided into the following classes: Drawables: draw 'line-oriented' figures at the current pen position. drawAt 'line-oriented' figures at the argument pen position. undraw f = appPicture (draw f o setPenColour background) undrawAt x f = appPicture (drawAt x f o setPenColour background) Fillables: fill 'area-oriented' figures at the current pen position. fillAt 'area-oriented' figures at the argument pen position. unfill f = appPicture (fill f o setPenColour background) unfillAt x f = appPicture (fillAt x f o setPenColour background) Hilites: hilite draws figures in the appropriate 'hilite' mode at the current pen position. hiliteAt draws figures in the appropriate 'hilite' mode at the current pen position. Both functions reset the 'hilite' after drawing. */ class Drawables figure where draw :: !figure !*Picture -> *Picture drawAt :: !Point2 !figure !*Picture -> *Picture undraw :: !figure !*Picture -> *Picture undrawAt:: !Point2 !figure !*Picture -> *Picture class Fillables figure where fill :: !figure !*Picture -> *Picture fillAt :: !Point2 !figure !*Picture -> *Picture unfill :: !figure !*Picture -> *Picture unfillAt:: !Point2 !figure !*Picture -> *Picture class Hilites figure where hilite :: !figure !*Picture -> *Picture hiliteAt:: !Point2 !figure !*Picture -> *Picture /* (app/acc)Picture applies the given drawing function to the given picture. When drawing is done, all picture attributes are set to the attribute values of the original picture. */ appPicture :: !.(IdFun *Picture) !*Picture -> *Picture appPicture drawf picture # (pen,picture) = getpictpen picture # picture = drawf picture # picture = setpictpen pen picture = picture accPicture :: !.(St *Picture .x) !*Picture -> (.x,!*Picture) accPicture drawf picture # (pen,picture) = getpictpen picture # (x,picture) = drawf picture # picture = setpictpen pen picture = (x,picture) // Drawing in a clipping region. :: Region = { region_shape :: ![RegionShape] , region_bound :: !OSRect } :: RegionShape = RegionRect !OSRect | RegionPolygon !Point2 ![Vector2] isEmptyRegion :: !Region -> Bool isEmptyRegion {region_shape=[]} = True isEmptyRegion _ = False getRegionBound :: !Region -> Rectangle getRegionBound {region_bound} = rectToRectangle region_bound class toRegion area :: !area -> Region :: PolygonAt = { polygon_pos :: !Point2 , polygon :: !Polygon } instance toRegion Rectangle where toRegion rectangle | isEmptyRect rect = zero | otherwise = {region_shape=[RegionRect rect],region_bound=rect} where rect = rectangleToRect rectangle instance toRegion PolygonAt where toRegion {polygon_pos=p=:{x,y},polygon={polygon_shape}} | isEmptyRect bound = zero | otherwise = {region_shape=[RegionPolygon p shape],region_bound=bound} where shape = closeShape zero polygon_shape bound = polybound p shape {rleft=x,rtop=y,rright=x,rbottom=y} polybound :: !Point2 ![Vector2] !OSRect -> OSRect polybound p [v:vs] {rleft=minx,rtop=miny,rright=maxx,rbottom=maxy} = polybound p` vs {rleft=minx`,rtop=miny`,rright=maxx`,rbottom=maxy`} where p` = movePoint v p {x,y} = p` minx` = min minx x; miny` = min miny y; maxx` = max maxx x; maxy` = max maxy y; polybound _ _ bound = bound closeShape :: !Vector2 ![Vector2] -> [Vector2] closeShape v [v`:vs] = [v`:closeShape (v+v`) vs] closeShape v [] | v==zero = [] | otherwise = [{vx=0-v.vx,vy=0-v.vy}] instance toRegion [area] | toRegion area where toRegion [area:areas] = toRegion area + toRegion areas toRegion _ = zero instance toRegion (:^: area1 area2) | toRegion area1 & toRegion area2 where toRegion (r1 :^: r2) = toRegion r1 + toRegion r2 instance zero Region where zero = {region_shape=[],region_bound=zero} instance + Region where (+) r1 r2 | isEmptyRect r1.region_bound = r2 | isEmptyRect r2.region_bound = r1 | otherwise = {region_shape=r1.region_shape++r2.region_shape,region_bound=sumbound r1.region_bound r2.region_bound} where sumbound :: !OSRect !OSRect -> OSRect sumbound {rleft=minx,rtop=miny,rright=maxx,rbottom=maxy} {rleft=minx`,rtop=miny`,rright=maxx`,rbottom=maxy`} = {rleft=min minx minx`,rtop=min miny miny`,rright=max maxx maxx`,rbottom=max maxy maxy`} appClipPicture :: !Region !.(IdFun *Picture) !*Picture -> *Picture appClipPicture region drawf picture = snd (accClipPicture region (\p->(undef,drawf p)) picture) accClipPicture :: !Region !.(St *Picture .x) !*Picture -> (.x,!*Picture) accClipPicture region drawf picture #! (curClipRgn,picture) = pictgetcliprgn picture // #! curClipRgn = trace_rgn "accClipPicture: cur" curClipRgn #! (origin,pen,toScreen,context,tb) = peekPicture picture #! (newClipRgn,tb) = osnewrgn tb #! (hFac,vFac,context,tb) = getPictureScalingFactors context tb #! (newClipRgn,tb) = setrgnshapes hFac vFac origin region.region_shape newClipRgn tb // #! newClipRgn = trace_rgn "accClipPicture: new" newClipRgn isEmpty = if (curClipRgn==0) (\_ tb->(True,tb)) osisemptyrgn // PA: you must test for 0, because that's what windows generates if there is no clipping region! #! (emptyCur,tb) = isEmpty curClipRgn tb #! picture = unpeekPicture origin pen toScreen context tb // DvA: Set back to this variant under Windows to avoid window resize bug if window look completely hidden by controls // cf. Search window in CleanIde. (set,dispose) = if (curClipRgn==0) (pictsetcliprgn,\_ x->x) (pictandcliprgn,osdisposergn) // (set,dispose) = if emptyCur (pictsetcliprgn,\_ x->x) (pictandcliprgn,osdisposergn) #! picture = set newClipRgn picture #! (x,picture) = drawf picture // #! (curClipRgn,picture) = (trace_rgn "accClipPicture: cur" curClipRgn,picture) #! picture = pictsetcliprgn curClipRgn picture #! picture = apppicttoolbox (dispose curClipRgn o osdisposergn newClipRgn) picture = (x,picture) where setrgnshapes :: !(!Int,!Int) !(!Int,!Int) !Point2 ![RegionShape] !OSRgnHandle !*OSToolbox -> (!OSRgnHandle,!*OSToolbox) setrgnshapes hFac vFac origin [shape:shapes] rgn tb # (rgn,tb) = setrgnshape hFac vFac origin shape rgn tb = setrgnshapes hFac vFac origin shapes rgn tb where setrgnshape :: !(!Int,!Int) !(!Int,!Int) !Point2 !RegionShape !OSRgnHandle !*OSToolbox -> (!OSRgnHandle,!*OSToolbox) setrgnshape hFac vFac {x=ox,y=oy} (RegionRect {rleft,rtop,rright,rbottom}) rgn tb # (rectrgn,tb) = osnewrectrgn rect tb # (sumrgn, tb) = osunionrgn rectrgn rgn tb # tb = osdisposergn rectrgn tb # tb = osdisposergn rgn tb = (sumrgn,tb) where rect = {rleft=scale hFac (rleft-ox),rtop=scale vFac (rtop-oy),rright=scale hFac (rright-ox),rbottom=scale vFac (rbottom-oy)} setrgnshape hFac vFac {x=ox,y=oy} (RegionPolygon {x,y} shape) rgn tb # (emptyrgn,tb) = osnewrgn tb # (polyrgn, tb) = ospolyrgn (scale hFac (x-ox),scale vFac (y-oy)) (map (\{vx,vy}->(scale hFac vx,scale vFac vy)) shape) emptyrgn tb # (sumrgn, tb) = osunionrgn polyrgn rgn tb # tb = osdisposergn polyrgn tb # tb = osdisposergn rgn tb = (sumrgn,tb) setrgnshapes _ _ _ _ rgn tb = (rgn,tb) scale :: !(!Int,!Int) !Int -> Int scale (n,d) x = n*x/d /* (app/acc)XorPicture applies the given drawing function to the given picture in the platform appropriate xor mode. */ appXorPicture :: !.(IdFun *Picture) !*Picture -> *Picture appXorPicture drawf picture # picture = setpictxormode picture # picture = drawf picture # picture = setpictnormalmode picture = picture accXorPicture :: !.(St *Picture .x) !*Picture -> (.x,!*Picture) accXorPicture drawf picture # picture = setpictxormode picture # (x,picture) = drawf picture # picture = setpictnormalmode picture = (x,picture) /* Hiliting figures: */ instance Hilites Box where hilite box picture # picture = setpicthilitemode picture # (curpos,picture) = getpictpenpos picture # picture = pictfillrect (boxtorect curpos box) picture # picture = setpictnormalmode picture = picture hiliteAt base box picture # picture = setpicthilitemode picture # picture = pictfillrect (boxtorect base box) picture # picture = setpictnormalmode picture = picture instance Hilites Rectangle where hilite rectangle picture # picture = setpicthilitemode picture # picture = pictfillrect (rectangleToRect rectangle) picture # picture = setpictnormalmode picture = picture hiliteAt _ rectangle picture # picture = setpicthilitemode picture # picture = pictfillrect (rectangleToRect rectangle) picture # picture = setpictnormalmode picture = picture drawPoint :: !*Picture -> *Picture drawPoint picture # (curpos,picture) = getpictpenpos picture # picture = pictdrawpoint curpos picture # picture = setpictpenpos {curpos & x=curpos.x+1} picture = picture drawPointAt :: !Point2 !*Picture -> *Picture drawPointAt point picture # (curpos,picture) = getpictpenpos picture # picture = pictdrawpoint point picture # picture = setpictpenpos curpos picture = picture /* Point2 connecting drawing operations: */ drawLineTo :: !Point2 !*Picture -> *Picture drawLineTo pos picture = pictdrawlineto pos picture drawLine :: !Point2 !Point2 !*Picture -> *Picture drawLine pos1 pos2 picture = pictdrawline pos1 pos2 picture /* Text drawing operations: */ instance Drawables Char where draw char picture = pictdrawchar char picture drawAt pos char picture # (curpos,picture) = getpictpenpos picture # picture = setpictpenpos pos picture # picture = pictdrawchar char picture # picture = setpictpenpos curpos picture = picture undraw char picture = pictundrawchar char picture undrawAt pos char picture # (curpos,picture) = getpictpenpos picture # picture = setpictpenpos pos picture # picture = pictundrawchar char picture # picture = setpictpenpos curpos picture = picture instance Drawables {#Char} where draw string picture = pictdrawstring string picture drawAt pos string picture # (curpos,picture) = getpictpenpos picture # picture = setpictpenpos pos picture # picture = pictdrawstring string picture # picture = setpictpenpos curpos picture = picture undraw string picture = pictundrawstring string picture undrawAt pos string picture # (curpos,picture) = getpictpenpos picture # picture = setpictpenpos pos picture # picture = pictundrawstring string picture # picture = setpictpenpos curpos picture = picture /* Line2 drawing operations: */ instance Drawables Line2 where draw {line_end1,line_end2} picture = pictdrawline line_end1 line_end2 picture drawAt _ {line_end1,line_end2} picture = pictdrawline line_end1 line_end2 picture undraw {line_end1,line_end2} picture = pictundrawline line_end1 line_end2 picture undrawAt _ {line_end1,line_end2} picture = pictundrawline line_end1 line_end2 picture /* Vector2 drawing operations: */ instance Drawables Vector2 where draw {vx,vy} picture # (curpos,picture) = getpictpenpos picture endpos = {x=curpos.x+vx,y=curpos.y+vy} # picture = pictdrawlineto endpos picture = picture drawAt pos=:{x,y} {vx,vy} picture = pictdrawline pos {x=x+vx,y=y+vy} picture undraw {vx,vy} picture # (curpos,picture) = getpictpenpos picture endpos = {x=curpos.x+vx,y=curpos.y+vy} # picture = pictundrawlineto endpos picture = picture undrawAt pos=:{x,y} {vx,vy} picture = pictundrawline pos {x=x+vx,y=y+vy} picture /* Oval drawing operations: */ instance Drawables Oval where draw oval picture # (curpos,picture) = getpictpenpos picture # picture = pictdrawoval curpos oval picture = picture drawAt pos oval picture = pictdrawoval pos oval picture undraw oval picture # (curpos,picture) = getpictpenpos picture # picture = pictundrawoval curpos oval picture = picture undrawAt pos oval picture = pictundrawoval pos oval picture instance Fillables Oval where fill oval picture # (curpos,picture) = getpictpenpos picture # picture = pictfilloval curpos oval picture = picture fillAt pos oval picture = pictfilloval pos oval picture unfill oval picture # (curpos,picture) = getpictpenpos picture # picture = pictunfilloval curpos oval picture = picture unfillAt pos oval picture = pictunfilloval pos oval picture /* Curve drawing operations: */ instance Drawables Curve where draw curve picture # (curpos,picture) = getpictpenpos picture # picture = pictdrawcurve True curpos curve picture = picture drawAt point curve picture = pictdrawcurve False point curve picture undraw curve picture # (curpos,picture) = getpictpenpos picture # picture = pictundrawcurve True curpos curve picture = picture undrawAt point curve picture = pictundrawcurve False point curve picture instance Fillables Curve where fill curve picture # (curpos,picture) = getpictpenpos picture # picture = pictfillcurve True curpos curve picture = picture fillAt point curve picture = pictfillcurve False point curve picture unfill curve picture # (curpos,picture) = getpictpenpos picture # picture = pictunfillcurve True curpos curve picture = picture unfillAt point curve picture = pictunfillcurve False point curve picture /* Box drawing operations: */ instance Drawables Box where draw box picture # (curpos,picture) = getpictpenpos picture # picture = pictdrawrect (boxtorect curpos box) picture = picture drawAt point box picture = pictdrawrect (boxtorect point box) picture undraw box picture # (curpos,picture) = getpictpenpos picture # picture = pictundrawrect (boxtorect curpos box) picture = picture undrawAt point box picture = pictundrawrect (boxtorect point box) picture instance Fillables Box where fill box picture # (curpos,picture) = getpictpenpos picture # picture = pictfillrect (boxtorect curpos box) picture = picture fillAt pos box picture = pictfillrect (boxtorect pos box) picture unfill box picture # (curpos,picture) = getpictpenpos picture # picture = pictunfillrect (boxtorect curpos box) picture = picture unfillAt pos box picture = pictunfillrect (boxtorect pos box) picture boxtorect :: !Point2 !Box -> OSRect boxtorect {x,y} {box_w,box_h} = {rleft=l,rtop=t,rright=r,rbottom=b} where (l,r) = minmax x (x+box_w) (t,b) = minmax y (y+box_h) /* Rectangle drawing operations: */ instance Drawables Rectangle where draw rectangle picture = pictdrawrect (rectangleToRect rectangle) picture drawAt _ rectangle picture = pictdrawrect (rectangleToRect rectangle) picture undraw rectangle picture = pictundrawrect (rectangleToRect rectangle) picture undrawAt _ rectangle picture = pictundrawrect (rectangleToRect rectangle) picture instance Fillables Rectangle where fill rectangle picture = pictfillrect (rectangleToRect rectangle) picture fillAt _ rectangle picture = pictfillrect (rectangleToRect rectangle) picture unfill rectangle picture = pictunfillrect (rectangleToRect rectangle) picture unfillAt _ rectangle picture = pictunfillrect (rectangleToRect rectangle) picture /* Polygon drawing operations: */ instance Drawables Polygon where draw polygon picture # (curpos,picture) = getpictpenpos picture # picture = pictdrawpolygon curpos polygon picture = picture drawAt base polygon picture = pictdrawpolygon base polygon picture undraw polygon picture # (curpos,picture) = getpictpenpos picture # picture = pictundrawpolygon curpos polygon picture = picture undrawAt base polygon picture = pictundrawpolygon base polygon picture instance Fillables Polygon where fill polygon picture # (curpos,picture) = getpictpenpos picture # picture = pictfillpolygon curpos polygon picture = picture fillAt base polygon picture = pictfillpolygon base polygon picture unfill polygon picture # (curpos,picture) = getpictpenpos picture # picture = pictunfillpolygon curpos polygon picture = picture unfillAt base polygon picture = pictunfillpolygon base polygon picture getResolution :: !*Picture -> (!(!Int,!Int),!*Picture) getResolution picture # (origin,pen,toScreen,context,tb) = peekPicture picture # (res,tb) = getResolutionC context tb = (res,unpeekPicture origin pen toScreen context tb)