{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.Picture -- Copyright : (c) Stephen Tetley 2009-2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable -- Portability : GHC -- -- Construction of pictures, paths and text labels. -- -- Note - the text label functions are only appropriate for single -- printed lines of text. Wumpus-Core does not interpret special -- white-space characters (i.e. tab or newline) and passes them -- forward into the output file. Renderers will then deal with -- white-space as they please, which is usually to ignore it. -- -- Also, SVG output does not currently use @space=\"preserve\"@. -- It would be desirable to do so, as the PostScript generated by -- Wumpus can use doubled up spaces to print wide spaces. -- Unfortunately, SVG renderers seem to differ as to whether they -- can inherit @space=\"preserve\"@ from a top level attribute or -- whether it must be annotated on every @\@ element. -- Wumpus considers the latter to be a too-high burden as it will -- expand the code size (this view may change). -- -------------------------------------------------------------------------------- module Wumpus.Core.Picture ( -- * Construction frame , multi , fontDeltaContext , absPrimPath , absLineTo , absCurveTo , relPrimPath , relLineTo , relCurveTo , vertexPrimPath , vectorPrimPath , emptyPrimPath , curvedPrimPath , xlinkhref , xlinkPrim , svgattr , annotateGroup , annotateXLink , primGroup , primCat -- * Constructing primitives , ostroke , cstroke , zostroke , zcstroke , fill , zfill , fillStroke , clip , textlabel , rtextlabel , ztextlabel , escapedlabel , rescapedlabel , zescapedlabel , hkernlabel , vkernlabel , kernchar , kernEscInt , kernEscName , strokeEllipse , rstrokeEllipse , fillEllipse , rfillEllipse , zellipse , fillStrokeEllipse , rfillStrokeEllipse -- * Operations , extendBoundary -- * Picture composition , picOver , picMoveBy , picBeside -- * Illustrating pictures and primitives , printPicture , illustrateBounds , illustrateBoundsPrim , illustrateControlPoints ) where import Wumpus.Core.AffineTrans import Wumpus.Core.BoundingBox import Wumpus.Core.Colour import Wumpus.Core.Geometry import Wumpus.Core.GraphicProps import Wumpus.Core.PictureInternal import Wumpus.Core.Text.Base import Wumpus.Core.TrafoInternal -- import Wumpus.Core.Units import Wumpus.Core.Utils.FormatCombinators hiding ( fill ) import Wumpus.Core.Utils.HList import Wumpus.Core.Utils.JoinList import Data.AffineSpace -- package: vector-space import Data.VectorSpace import Data.List ( mapAccumL ) -------------------------------------------------------------------------------- -- Construction -- | Lift a list of primitives to a composite picture. -- -- The order of the list maps to the order of printing - the -- front of the list is drawn first in the file. This also means -- that the front of the list is drawn /underneath/ in the -- Z-Order. -- -- \*\* WARNING \*\* - this function throws a runtime error when -- supplied the empty list. -- frame :: [Primitive] -> Picture frame [] = error "Wumpus.Core.Picture.frame - empty list" frame (p:ps) = let (bb,ones) = step p ps in Leaf (bb,[]) ones where step a [] = (boundary a, one a) step a (x:xs) = let (bb', rest) = step x xs in ( boundary a `boundaryUnion` bb', cons a rest ) -- | Place multiple pictures within the standard affine frame. -- -- \*\* WARNING \*\* - this function throws a runtime error when -- supplied the empty list. -- multi :: [Picture] -> Picture multi [] = error "Wumpus.Core.Picture.multi - empty list" multi (p:ps) = let (bb,ones) = step p ps in Picture (bb,[]) ones where step a [] = (boundary a, one a) step a (x:xs) = let (bb', rest) = step x xs in ( boundary a `boundaryUnion` bb', cons a rest ) -- | Update the font /delta/ attributes for SVG output. -- -- Note - 'fontDeltaContext' does not set the font properties of -- elements in the supplied Picture, it is solely a mechanism to -- help reduce the code size of the generated SVG by factoring -- common attributes into a group (g) element. For instance, -- settting the font properties with 'fontDeltaContext' can -- eliminate the repeated use of font-family and font-size in -- this code: -- -- > ... -- > ... -- > ... -- -- With the appropriate font delta context, this code will be -- generated: -- -- > -- > ... -- > ... -- > ... -- > -- -- Wumpus ignores 'fontDeltaContext' directives when generating -- PostScript. Unlike SVG, PostScript is not naturally nested, so -- introducing nesting with @gsave@ and @grestore@ is not likely -- to improve the PostScript Wumpus generates. -- fontDeltaContext :: FontAttr -> Primitive -> Primitive fontDeltaContext fa p = PContext (FontCtx fa) p -- | 'absPrimPath' : @ start_point * [abs_path_segment] -> PrimPath @ -- -- Create a 'PrimPath' from a start point and a list of /absolute/ -- path segments. -- absPrimPath :: DPoint2 -> [AbsPathSegment] -> PrimPath absPrimPath pt xs = PrimPath (step pt xs) (startPointCTM pt) where step p (AbsLineTo p1:rest) = RelLineTo (p1 .-. p) : step p1 rest step p (AbsCurveTo p1 p2 p3:rest) = RelCurveTo (p1 .-. p) (p2 .-. p1) (p3 .-. p2) : step p3 rest step _ [] = [] -- | 'absLineTo' : @ end_point -> path_segment @ -- -- Create a straight-line 'AbsPathSegment', the start point is -- implicitly the previous point in a path. -- absLineTo :: DPoint2 -> AbsPathSegment absLineTo = AbsLineTo -- | 'absCurveTo' : @ control_point1 * control_point2 * end_point -> -- path_segment @ -- -- Create a curved 'AbsPathSegment', the start point is implicitly -- the previous point in a path. -- -- absCurveTo :: DPoint2 -> DPoint2 -> DPoint2 -> AbsPathSegment absCurveTo = AbsCurveTo -- | 'relPrimPath' : @ start_point * [rel_path_segment] -> PrimPath @ -- -- Create a 'PrimPath' from a start point and a list of /relative/ -- path segments. -- -- Note - internally Wumpus works with relative paths so -- constructing them directly with 'relPrimPath' is more efficient -- than using 'absPrimPath'. -- relPrimPath :: DPoint2 -> [PrimPathSegment] -> PrimPath relPrimPath pt xs = PrimPath xs (startPointCTM pt) -- | 'relLineTo' : @ vec_to_end -> path_segment @ -- -- Create a straight-line 'PrimPathSegment', the vector is the -- relative displacement. -- relLineTo :: DVec2 -> PrimPathSegment relLineTo = RelLineTo -- | 'relCurveTo' : @ vec_to_cp1 * vec_to_cp2 * vec_to_end -> -- path_segment @ -- -- Create a curved 'RelPathSegment'. -- -- relCurveTo :: DVec2 -> DVec2 -> DVec2 -> PrimPathSegment relCurveTo = RelCurveTo -- | 'vertexPrimPath' : @ [point] -> PrimPath @ -- -- Convert the list of vertices to a path of straight line -- segments. -- -- \*\* WARNING \*\* - this function throws a runtime error when -- supplied the empty list. -- vertexPrimPath :: [DPoint2] -> PrimPath vertexPrimPath [] = error "Picture.vertexPath - empty point list" vertexPrimPath (x:xs) = PrimPath (snd $ mapAccumL step x xs) (startPointCTM x) where step a b = let v = b .-. a in (b, RelLineTo v) -- | 'vectorPrimPath' : @ start_point -> [next_vector] -> PrimPath @ -- -- Build a \"relative\" path from the start point, appending -- successive straight line segments formed from the list of -- next_vectors. -- -- This function can be supplied with an empty list - this -- simulates a null graphic. -- vectorPrimPath :: DPoint2 -> [DVec2] -> PrimPath vectorPrimPath pt xs = PrimPath (map RelLineTo xs) (startPointCTM pt) -- | 'emptyPrimPath' : @ start_point -> PrimPath @ -- -- Build an empty path. The start point must be specified even -- though the path is not drawn - a start point is the minimum -- information needed to calculate a bounding box. -- emptyPrimPath :: DPoint2 -> PrimPath emptyPrimPath pt = PrimPath [] (startPointCTM pt) -- | 'curvedPrimPath' : @ points -> PrimPath @ -- -- Convert a list of vertices to a path of curve segments. -- The first point in the list makes the start point, each curve -- segment thereafter takes 3 points. /Spare/ points at the end -- are discarded. -- -- \*\* WARNING - this function throws an error when supplied the -- empty list. -- curvedPrimPath :: [DPoint2] -> PrimPath curvedPrimPath [] = error "Picture.curvedPath - empty point list" curvedPrimPath (x:xs) = PrimPath (step x xs) (startPointCTM x) where step p (a:b:c:ys) = let v1 = a .-. p v2 = b .-. a v3 = c .-. b in RelCurveTo v1 v2 v3 : step c ys step _ _ = [] -- | Create a hyperlink for SVG output. -- -- Note - hyperlinks are ignored in the PostScript output. -- xlinkhref :: String -> XLink xlinkhref = XLink -- | Create a hyperlinked Primitive. -- -- Note - hyperlinks are ignored in the PostScript output. -- xlinkPrim :: XLink -> Primitive -> Primitive xlinkPrim hypl p = PSVG (ALink hypl) p -- | Create an attribute for SVG output. -- -- Attributes are expected to be /non-graphical/ e.g. @onclick@ -- events or similar. Wumpus does not check the syntax and simply -- emits the Strings as-is in the output. -- -- Graphical properties should not be encoded, they may conflict -- with output that Wumpus produces. -- -- \*\* WARNING \*\* - currently this functionality is -- undercooked. Because SVG has more /extra-graphical/ facilities -- than PostScript (hyperlinks, mouseovers, etc.) it seems -- important to have an escape hatch to them, yet so far the -- escape hatch has not been needed. -- svgattr :: String -> String -> SvgAttr svgattr = SvgAttr -- | Add SVG attribute annotations to a Primitive. -- -- The primitive will be printed in a @g@ (group) element -- labelled with the annotations. -- annotateGroup :: [SvgAttr] -> Primitive -> Primitive annotateGroup xs p = PSVG (GAnno xs) p -- | Add SVG XLink and attribute annotations to a Primitive. -- -- The primitive will be printed in a @g@ (group) element, itself -- inside an @a@ link. -- annotateXLink :: XLink -> [SvgAttr] -> Primitive -> Primitive annotateXLink hypl xs p = PSVG (SvgAG hypl xs) p -- | Group a list of Primitives. -- -- \*\* WARNING \*\* - this function throws a runtime error when -- supplied the empty list. -- primGroup :: [Primitive] -> Primitive primGroup [] = error "Picture.primGroup - empty prims list" primGroup (x:xs) = PGroup (step x xs) where step a [] = one a step a (y:ys) = cons a (step y ys) -- | Concatenate two Primitives. -- -- If both primitves are groups, then the groups are merged. -- -- If one or other primitive is a group, the singleton is added -- into the group at the respective end. -- -- Otherwise a group is formed adding both elements as /children/. -- -- The Primitive type in Wumpus is a tree. In theory 'primCat' -- can make flatter and wider trees than 'primGroup', though in -- practice this may have no noticeable benefit as Wumpus has very -- simple access patterns into the Primitive tree. -- primCat :: Primitive -> Primitive -> Primitive primCat (PGroup a) (PGroup b) = PGroup $ join a b primCat (PGroup a) prim = PGroup $ join a (one prim) primCat prim (PGroup b) = PGroup $ join (one prim) b primCat p1 p2 = PGroup $ join (one p1) (one p2) -------------------------------------------------------------------------------- -- Take Paths to Primitives -- *** Stroke -- | 'ostroke' : @ rgb * stroke_attr * path -> Primitive @ -- -- Create an open, stroked path from the 'PrimPath' specification. -- ostroke :: RGBi -> StrokeAttr -> PrimPath -> Primitive ostroke rgb sa p = PPath (OStroke sa rgb) p -- | 'cstroke' : @ rgb * stroke_attr * path -> Primitive @ -- -- Create a closed, stroked path from the 'PrimPath' specfication. -- cstroke :: RGBi -> StrokeAttr -> PrimPath -> Primitive cstroke rgb sa p = PPath (CStroke sa rgb) p -- | 'zostroke' : @ path -> Primitive @ -- -- Create an open, stroked path using the default stroke -- attributes and coloured black. -- zostroke :: PrimPath -> Primitive zostroke = ostroke black default_stroke_attr -- | 'zcstroke' : @ path -> Primitive @ -- -- Create a closed stroked path using the default stroke -- attributes and coloured black. -- zcstroke :: PrimPath -> Primitive zcstroke = cstroke black default_stroke_attr -------------------------------------------------------------------------------- -- *** Fill -- | 'fill' : @ rgb * path -> Primitive @ -- -- Create a filled path from the 'PrimPath' specification. -- fill :: RGBi -> PrimPath -> Primitive fill rgb p = PPath (CFill rgb) p -- | 'zfill' : @ path -> Primitive @ -- -- Draw a filled path coloured black. -- zfill :: PrimPath -> Primitive zfill = fill black -------------------------------------------------------------------------------- -- Filled and stroked (closed) paths -- | 'fillStroke' : @ fill_rgb * stroke_attr * stroke_rgb * path -> Primitive @ -- -- Create a closed path that is both filled and stroked (the fill -- is below in the zorder). -- fillStroke :: RGBi -> StrokeAttr -> RGBi -> PrimPath -> Primitive fillStroke frgb sa srgb p = PPath (CFillStroke frgb sa srgb) p -------------------------------------------------------------------------------- -- Clipping -- | 'clip' : @ path * primitive -> Primitive @ -- -- Clip a primitive to be inside the supplied path. -- clip :: PrimPath -> Primitive -> Primitive clip cp p = PClip cp p -------------------------------------------------------------------------------- -- Labels to primitive -- | 'textlabel' : @ rgb * font_attr * string * baseline_left -> Primitive @ -- -- Create a text label. The string should not contain newline -- or tab characters. Also double-spaces should not be used - a -- rendering agent for SVG will coalesce double-spaces into a -- single space. For precise control of spacing and kerning use -- 'hkernlabel'. -- -- The supplied point is the left baseline. -- textlabel :: RGBi -> FontAttr -> String -> DPoint2 -> Primitive textlabel rgb attr txt pt = rtextlabel rgb attr txt 0 pt -- | 'rtextlabel' : @ rgb * font_attr * string * theta * -- baseline_left -> Primitive @ -- -- Create a text label rotated by the supplied angle about the -- baseline-left. -- -- The supplied point is the left baseline. -- rtextlabel :: RGBi -> FontAttr -> String -> Radian -> DPoint2 -> Primitive rtextlabel rgb attr txt pt theta = rescapedlabel rgb attr (escapeString txt) pt theta -- | 'ztextlabel' : @ string * baseline_left -> Primitive @ -- -- Create a label where the font is @Courier@, text size is 14pt -- and colour is black. -- ztextlabel :: String -> DPoint2 -> Primitive ztextlabel = textlabel black wumpus_default_font -- | 'escapedlabel' : @ rgb * font_attr * escaped_text * -- baseline_left -> Primitive @ -- -- Version of 'textlabel' where the label text has already been -- parsed for special characters. -- -- The supplied point is the left baseline. -- escapedlabel :: RGBi -> FontAttr -> EscapedText -> DPoint2 -> Primitive escapedlabel rgb attr txt pt = rescapedlabel rgb attr txt 0 pt -- | 'rescapedlabel' : @ rgb * font_attr * escaped_text * theta * -- baseline_left -> Primitive @ -- -- Version of 'rtextlabel' where the label text has already been -- parsed for special characters. -- -- The supplied point is the left baseline. -- rescapedlabel :: RGBi -> FontAttr -> EscapedText -> Radian -> DPoint2 -> Primitive rescapedlabel rgb attr txt theta (P2 dx dy) = PLabel (LabelProps rgb attr) lbl where lbl = PrimLabel (StdLayout txt) (makeThetaCTM dx dy theta) -- | 'zescapedlabel' : @ escaped_text * baseline_left -> Primitive @ -- -- Version of 'ztextlabel' where the label text has already been -- encoded. -- zescapedlabel :: EscapedText -> DPoint2 -> Primitive zescapedlabel = escapedlabel black wumpus_default_font -------------------------------------------------------------------------------- -- | 'hkernlabel' : @ rgb * font_attr * kerning_chars * -- baseline_left -> Primitive @ -- -- Create a text label with horizontal /kerning/ for each -- character. -- -- Note - kerning is relative to the left baseline of the -- previous character, it is \*not relative\* to the right-hand -- boundary of the previous char. While the later would be more -- obvious it would take a lot of effort to implement as it would -- need access to the metrics encoded in font files. -- -- Characters are expected to be drawn left to right, so -- displacements should not be negative. If the displacement is -- zero the character will be drawn ontop of the previous char. -- -- The charcters should not contain newline or tab characters. -- -- The supplied point is the left baseline. -- -- \*\* CAUTION \*\* - for SVG, @hkernlabel@ generates a -- coordinate list of X-positions rather than a single start -- point. This is syntactically valid SVG, but it is not -- universally supported by renderers. Chrome support is fine, -- but Firefox and Safari currently seem lacking. -- -- Also, note this feature does not have a directly compatible -- PostScript analogue. While the same picture is generated in -- both cases, the PostScript code is not particularly inefficient. -- hkernlabel :: RGBi -> FontAttr -> [KerningChar] -> DPoint2 -> Primitive hkernlabel rgb attr xs (P2 x y) = PLabel (LabelProps rgb attr) lbl where lbl = PrimLabel (KernTextH xs) (makeTranslCTM x y) -- | 'vkernlabel' : @ rgb * font_attr * kerning_chars * -- baseline_left -> Primitive @ -- -- Create a text label with vertical /kerning/ for each -- character - the text is expected to grow downwards. -- -- Note - /kerning/ here is the measure between baselines of -- sucessive characters, it is \*not\* the distance between the -- bottom of one chararter and the top of the next character. -- -- While the later maybe be more obvious from a drawing -- perspective, it would take a lot of effort to implement as it -- would need access to the metrics encoded in font files. -- -- Characters are expected to be drawn downwards - a positive -- number represents the downward displacement - so displacements -- should not be negative. If the displacement is zero the -- character will be drawn ontop of the previous char. -- -- The charcters should not contain newline or tab characters. -- -- The supplied point is the left baseline of the top character. -- -- \*\* CAUTION \*\* - for SVG, @hkernlabel@ generates a -- coordinate list of Y-positions rather than a single start -- point. This is syntactically valid SVG, but it is not -- universally supported by renderers. Chrome support is fine, -- but Firefox and Safari currently seem lacking. -- -- Also, note this feature does not have a directly compatible -- PostScript analogue. While the same picture is generated in -- both cases, the PostScript code is not particularly inefficient. -- vkernlabel :: RGBi -> FontAttr -> [KerningChar] -> DPoint2 -> Primitive vkernlabel rgb attr xs (P2 x y) = PLabel (LabelProps rgb attr) lbl where lbl = PrimLabel (KernTextV xs) (makeTranslCTM x y) -- | 'kernchar' : @ displacement * char -> KerningChar @ -- -- Construct a regular (i.e. non-special) Char along with its -- displacement from the left-baseline of the previous Char. -- kernchar :: Double -> Char -> KerningChar kernchar u c = (u, CharLiteral c) -- | 'kernEscInt' : @ displacement * char_code -> KerningChar @ -- -- Construct a Char by its character code along with its -- displacement from the left-baseline of the previous Char. -- kernEscInt :: Double -> Int -> KerningChar kernEscInt u i = (u, CharEscInt i) -- | 'kernEscName' : @ displacement * char_name -> KerningChar @ -- -- Construct a Char by its character name along with its -- displacement from the left-baseline of the previous Char. -- kernEscName :: Double -> String -> KerningChar kernEscName u s = (u, CharEscName s) -------------------------------------------------------------------------------- -- | 'strokeEllipse' : @ rgb * stroke_attr * rx * ry * center -> Primtive @ -- -- Create a stroked ellipse. -- -- Note - within Wumpus, ellipses are considered an unfortunate -- but useful /optimization/. Drawing good cicles with Beziers -- needs four curves, but drawing them with PostScript\'s @arc@ -- command uses a single operation. For drawings with many dots -- (e.g. scatter plots) it seems sensible to employ this -- optimization. -- -- A deficiency of using PostScript\'s @arc@ command to draw -- ellipses is that (non-uniformly) scaling a stroked ellipse -- also (non-uniformly) scales the pen it is drawn with. Where -- the ellipse is wider, the pen stroke -- will be wider too. -- -- Avoid non-uniform scaling stroked ellipses! -- strokeEllipse :: RGBi -> StrokeAttr -> Double -> Double -> DPoint2 -> Primitive strokeEllipse rgb sa hw hh pt = rstrokeEllipse rgb sa hw hh 0 pt -- | 'rstrokeEllipse' : @ rgb * stroke_attr * rx * ry * theta * -- center -> Primtive @ -- -- Create a stroked primitive ellipse rotated about the center by -- /theta/. -- rstrokeEllipse :: RGBi -> StrokeAttr -> Double -> Double -> Radian -> DPoint2 -> Primitive rstrokeEllipse rgb sa rx ry theta pt = PEllipse (EStroke sa rgb) (mkPrimEllipse rx ry theta pt) -- | 'fillEllipse' : @ rgb * rx * ry * center -> Primtive @ -- -- Create a filled primitive ellipse. -- fillEllipse :: RGBi -> Double -> Double -> DPoint2 -> Primitive fillEllipse rgb rx ry pt = rfillEllipse rgb rx ry 0 pt -- | 'rfillEllipse' : @ rgb * rx * ry * theta * center -> Primitive @ -- -- Create a filled primitive ellipse rotated about the center by -- /theta/. -- rfillEllipse :: RGBi -> Double -> Double -> Radian -> DPoint2 -> Primitive rfillEllipse rgb rx ry theta pt = PEllipse (EFill rgb) (mkPrimEllipse rx ry theta pt) -- | 'zellipse' : @ rx * ry * center -> Primtive @ -- -- Create a black, filled ellipse. -- zellipse :: Double -> Double -> DPoint2 -> Primitive zellipse hw hh pt = rfillEllipse black hw hh 0 pt -- | 'fillStrokeEllipse' : @ fill_rgb * stroke_attr * stroke_rgb * rx * ry * -- center -> Primtive @ -- -- Create a bordered (i.e. filled and stroked) primitive ellipse. -- fillStrokeEllipse :: RGBi -> StrokeAttr -> RGBi -> Double -> Double -> DPoint2 -> Primitive fillStrokeEllipse frgb sa srgb rx ry pt = rfillStrokeEllipse frgb sa srgb rx ry 0 pt -- | 'rfillStrokeEllipse' : @ fill_rgb * stroke_attr * stroke_rgb * rx * ry * -- theta * center -> Primtive @ -- -- Create a bordered (i.e. filled and stroked) ellipse rotated -- about the center by /theta/. -- rfillStrokeEllipse :: RGBi -> StrokeAttr -> RGBi -> Double -> Double -> Radian -> DPoint2 -> Primitive rfillStrokeEllipse frgb sa srgb rx ry theta pt = PEllipse (EFillStroke frgb sa srgb) (mkPrimEllipse rx ry theta pt) mkPrimEllipse :: Double -> Double -> Radian -> DPoint2 -> PrimEllipse mkPrimEllipse rx ry theta (P2 dx dy) = PrimEllipse rx ry (makeThetaCTM dx dy theta) -------------------------------------------------------------------------------- -- Operations -- | 'extendBoundary' : @ x * y * picture -> Picture @ -- -- Extend the bounding box of a picture. -- -- The bounding box is both horizontal directions by @x@ and -- both vertical directions by @y@. @x@ and @y@ must be positive -- This function cannot be used to shrink a boundary. -- extendBoundary :: Double -> Double -> Picture -> Picture extendBoundary x y = mapLocale (\(bb,xs) -> (extBB (posve x) (posve y) bb, xs)) where extBB x' y' (BBox (P2 x0 y0) (P2 x1 y1)) = BBox pt1 pt2 where pt1 = P2 (x0-x') (y0-y') pt2 = P2 (x1+x') (y1+y') posve n | n < 0 = 0 | otherwise = n -------------------------------------------------------------------------------- -- Minimal support for Picture composition infixr 6 `picBeside`, `picOver` -- | 'picOver' : @ picture * picture -> Picture @ -- -- Draw the first picture on top of the second picture - -- neither picture will be moved. -- picOver :: Picture -> Picture -> Picture a `picOver` b = Picture (bb,[]) (join (one b) (one a)) where bb = boundary a `boundaryUnion` boundary b -- NOTE - picOver - draw b, put b first in the list, so it draws -- first in the output (this is also @behind@ in the Z-Order). -- | 'picMoveBy' : @ picture * vector -> Picture @ -- -- Move a picture by the supplied vector. -- picMoveBy :: Picture -> DVec2 -> Picture p `picMoveBy` (V2 x y) = translate x y p -- | 'picBeside' : @ picture * picture -> Picture @ -- -- Move the second picture to sit at the right side of the -- first picture -- picBeside :: Picture -> Picture -> Picture a `picBeside` b = a `picOver` (b `picMoveBy` v) where (P2 x1 _) = ur_corner $ boundary a (P2 x2 _) = ll_corner $ boundary b v = hvec $ x1 - x2 -------------------------------------------------------------------------------- -- Illustrating pictures and primitives -- | Print the syntax tree of a Picture to the console. -- printPicture :: Picture -> IO () printPicture pic = putStrLn (show $ format pic) >> putStrLn [] -- | 'illustrateBounds' : @ bbox_rgb * picture -> Picture @ -- -- Draw the picture on top of an image of its bounding box. -- The bounding box image will be drawn in the supplied colour. -- illustrateBounds :: RGBi -> Picture -> Picture illustrateBounds rgb p = p `picOver` (frame $ boundsPrims rgb (boundary p) $ []) -- | 'illustrateBoundsPrim' : @ bbox_rgb * primitive -> Picture @ -- -- Draw the primitive on top of an image of its bounding box. -- The bounding box image will be drawn in the supplied colour. -- -- The result will be lifted from Primitive to Picture. -- illustrateBoundsPrim :: RGBi -> Primitive -> Picture illustrateBoundsPrim rgb p = frame $ boundsPrims rgb (boundary p) $ [p] -- | Draw a the rectangle of a bounding box, plus cross lines -- joining the corners. -- boundsPrims :: RGBi -> BoundingBox Double -> H Primitive boundsPrims rgb bb = fromListH $ [ bbox_rect, bl_to_tr, br_to_tl ] where (bl,br,tr,tl) = boundaryCorners bb bbox_rect = cstroke rgb line_attr $ vertexPrimPath [bl,br,tr,tl] bl_to_tr = ostroke rgb line_attr $ vertexPrimPath [bl,tr] br_to_tl = ostroke rgb line_attr $ vertexPrimPath [br,tl] line_attr = default_stroke_attr { line_cap = CapRound , dash_pattern = Dash 0 [(1,2)] } -- | 'illustrateControlPoints' : @ control_point_rgb * primitive -> Picture @ -- -- Generate the control points illustrating the Bezier curves -- within a picture. -- -- This has no effect on TextLabels. Nor does it draw Beziers of -- a hyperlinked object. -- illustrateControlPoints :: RGBi -> Primitive -> Picture illustrateControlPoints rgb elt = frame $ fn elt where fn (PPath _ p) = pathCtrlLines rgb p $ [elt] fn a = [a] -- | Generate lines illustrating the control points of curves on -- a Path. -- -- Two lines are generated for a Bezier curve: -- start-point to control-point1; control-point2 to end-point -- -- Nothing is generated for a straight line. -- pathCtrlLines :: RGBi -> PrimPath -> H Primitive pathCtrlLines rgb ppath = let (start,ss) = extractRelPath ppath in step start ss where step s (RelLineTo v:xs) = step (s .+^ v) xs step s (RelCurveTo v1 v2 v3:xs) = let e = s .+^ (v1 ^+^ v2 ^+^ v3) v3r = vreverse v3 in mkLine s v1 `consH` mkLine e v3r `consH` step e xs step _ [] = emptyH mkLine s v = let seg1 = absLineTo $ s .+^ v pp = absPrimPath s [seg1] in ostroke rgb default_stroke_attr pp