{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Core.PictureInternal -- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com -- Stability : unstable -- Portability : GHC with TypeFamilies and more -- -- Internal representation of Pictures -- -------------------------------------------------------------------------------- module Wumpus.Core.PictureInternal ( -- * Data types Picture(..) , DPicture , Primitive(..) , DPrimitive , Path(..) , DPath , PathSegment(..) , DPathSegment , Label(..) , DLabel , PrimEllipse(..) , DPrimEllipse , PathProps -- hide in Wumpus.Core export? , LabelProps -- hide in Wumpus.Core export? , EllipseProps -- , DrawPath(..) -- hide in Wumpus.Core export? , DrawEllipse(..) , Locale -- * Type class , PSUnit(..) -- * Extras , mapLocale , movePic , moveLocale , extractFrame , repositionProperties , ellipseControlPoints ) where import Wumpus.Core.AffineTrans import Wumpus.Core.BoundingBox import Wumpus.Core.FontSize import Wumpus.Core.Geometry import Wumpus.Core.GraphicsState import Wumpus.Core.OneList import Wumpus.Core.TextEncodingInternal import Wumpus.Core.Utils import Data.AffineSpace import Data.Semigroup import Text.PrettyPrint.Leijen -- | Picture is a leaf attributed tree - where attributes are -- colour, line-width etc. It is parametric on the unit type -- of points (typically Double). -- -- Wumpus\'s leaf attributed tree, is not directly matched to -- PostScript\'s picture representation, which might be -- considered a node attributed tree (if you consider graphics -- state changes less imperatively - setting attributes rather -- than global state change). -- -- Considered as a node-attributed tree PostScript precolates -- graphics state updates downwards in the tree (vis-a-vis -- inherited attributes in an attibute grammar), where a -- graphics state change deeper in the tree overrides a higher -- one. -- -- Wumpus on the other hand, simply labels each leaf with its -- drawing attributes - there is no attribute inheritance. -- When it draws the PostScript picture it does some -- optimization to avoid generating excessive graphics state -- changes in the PostScript code. -- -- Apropos the constructors, Picture is a simple non-empty -- leaf-labelled rose tree via: -- -- > Single (aka leaf) | Picture (OneList tree) -- -- Where OneList is a variant of the standard list type that -- disallows empty lists. -- -- The additional constructors are convenience: -- -- @PicBlank@ has a bounding box but no content and is useful for -- some picture language operations (e.g. @hsep@). -- -- @Clip@ nests a picture (tree) inside a clipping path. -- data Picture u = PicBlank (Locale u) | Single (Locale u) (Primitive u) | Picture (Locale u) (OneList (Picture u)) | Clip (Locale u) (Path u) (Picture u) deriving (Eq,Show) type DPicture = Picture Double -- | Wumpus\'s drawings are built from two fundamental -- primitives: paths (line segments and Bezier curves) and -- labels (single lines of text). -- -- Ellipses are a included as a primitive only for optimization -- - drawing a reasonable circle with Bezier curves needs at -- least eight curves. This is inconvenient for drawing dots -- which can otherwise be drawn with a single @arc@ command. -- -- Wumpus does not follow PostScript and employ arcs as general -- path primitives - they are used only to draw ellipses. This -- is because arcs do not enjoy the nice properties of Bezier -- curves, whereby the affine transformation of a Bezier curve -- can simply be achieved by the affine transformation of it\'s -- control points. -- -- Ellipses are represented by their center, half-width and -- half-height. Half-width and half-height are used so the -- bounding box can be calculated using only multiplication, and -- thus initially only obliging a Num constraint on the unit. -- Though typically for affine transformations a Fractional -- constraint is also obliged. -- data Primitive u = PPath PathProps (Path u) | PLabel LabelProps (Label u) | PEllipse EllipseProps (PrimEllipse u) deriving (Eq,Show) type DPrimitive = Primitive Double -- | Path - start point and a list of path segments. -- data Path u = Path (Point2 u) [PathSegment u] deriving (Eq,Show) type DPath = Path Double -- | PathSegment - either a cubic Bezier curve or a line. -- data PathSegment u = PCurveTo (Point2 u) (Point2 u) (Point2 u) | PLineTo (Point2 u) deriving (Eq,Show) type DPathSegment = PathSegment Double -- | Label - represented by bottom left corner and text. -- data Label u = Label { label_bottom_left :: Point2 u , label_text :: EncodedText , label_CTM :: Matrix3'3 u } deriving (Eq,Show) type DLabel = Label Double -- Ellipse represented by center and half_width * half_height -- data PrimEllipse u = PrimEllipse { ellipse_center :: Point2 u , ellipse_half_width :: u , ellipse_half_height :: u , ellispe_CTM :: Matrix3'3 u } deriving (Eq,Show) type DPrimEllipse = PrimEllipse Double -- | Note when drawn /filled/ and drawn /stroked/ the same -- polygon will have (slightly) different size: -- -- * A filled shape fills /within/ the boundary of the shape -- -- * A stroked shape draws a pen line around the boundary -- of the shape. The actual size depends on the thickness -- of the line (stroke width). -- data DrawPath = CFill | CStroke [StrokeAttr] | OStroke [StrokeAttr] deriving (Eq,Show) -- | Ellipses and circles are always closed. data DrawEllipse = EFill | EStroke [StrokeAttr] deriving (Eq,Show) type PathProps = (PSRgb, DrawPath) type LabelProps = (PSRgb, FontAttr) type EllipseProps = (PSRgb, DrawEllipse) -- | Locale = (current frame x bounding box) -- -- Pictures (and sub-pictures) are located within an affine frame. -- So pictures can be arranged (vertical and horizontal -- composition) their bounding box is cached. -- -- In Wumpus, affine transformations (scalings, rotations...) -- transform the frame rather than the constituent points of -- the primitives. Changes of frame are transmitted to PostScript -- as @concat@ commands (and matrix transforms in SVG) - the -- @point-in-world-coordinate@ of a point on a path is never -- calculated. -- -- So that picture composition is remains stable under affine -- transformation, the corners of bounding boxes are transformed -- pointwise when the picture is scaled, rotated etc. -- type Locale u = (Frame2 u, BoundingBox u) -------------------------------------------------------------------------------- -- Pretty printing instance (Num u, Pretty u) => Pretty (Picture u) where pretty (PicBlank m) = text "*BLANK*" <+> ppLocale m pretty (Single m prim) = ppLocale m <$> indent 2 (pretty prim) pretty (Picture m ones) = ppLocale m <$> indent 2 (list $ toListF pretty ones) pretty (Clip m cpath p) = text "Clip:" <+> ppLocale m <$> indent 2 (pretty cpath) <$> indent 2 (pretty p) ppLocale :: (Num u, Pretty u) => Locale u -> Doc ppLocale (fr,bb) = align (ppfr <$> pretty bb) where ppfr = if standardFrame fr then text "*std-frame*" else pretty fr instance Pretty u => Pretty (Primitive u) where pretty (PPath _ p) = pretty "path:" <+> pretty p pretty (PLabel _ lbl) = pretty lbl pretty (PEllipse _ e) = pretty e instance Pretty u => Pretty (Path u) where pretty (Path pt ps) = pretty pt <> hcat (map pretty ps) instance Pretty u => Pretty (PathSegment u) where pretty (PCurveTo p1 p2 p3) = text ".*" <> pretty p1 <> text ",," <> pretty p2 <> text "*." <> pretty p3 pretty (PLineTo pt) = text "--" <> pretty pt instance Pretty u => Pretty (Label u) where pretty (Label pt s ctm) = dquotes (pretty s) <> char '@' <> pretty pt <+> ppMatrixCTM ctm instance Pretty u => Pretty (PrimEllipse u) where pretty (PrimEllipse c w h ctm) = pretty "ellipse" <+> pretty c <+> text "w:" <> pretty w <+> text "h:" <> pretty h <+> ppMatrixCTM ctm ppMatrixCTM :: Pretty u => Matrix3'3 u -> Doc ppMatrixCTM = pp . toCTM where pp (CTM a b c d x y) = list $ map pretty [a,b,c,d,x,y] -------------------------------------------------------------------------------- -- | Paths are sensibly a Semigroup - there is no notion of -- /empty path/. instance Semigroup (Path u) where Path st xs `append` Path st' xs' = Path st (xs ++ (PLineTo st' : xs')) instance Pointwise (Path u) where type Pt (Path u) = Point2 u pointwise f (Path st xs) = Path (f st) (map (pointwise f) xs) instance Pointwise (PathSegment u) where type Pt (PathSegment u) = Point2 u pointwise f (PLineTo p) = PLineTo (f p) pointwise f (PCurveTo p1 p2 p3) = PCurveTo (f p1) (f p2) (f p3) -------------------------------------------------------------------------------- -- Affine trans instances type instance DUnit (Picture u) = u type instance DUnit (Primitive u) = u type instance DUnit (Path u) = u type instance DUnit (PrimEllipse u) = u instance (Num u, Ord u) => Transform (Picture u) where transform ctm pic = transformPicture (transform ctm) (transform ctm) pic instance (Floating u, Real u) => Rotate (Picture u) where rotate = rotatePicture instance (Floating u, Real u) => RotateAbout (Picture u) where rotateAbout = rotatePictureAbout instance (Num u, Ord u) => Scale (Picture u) where scale = scalePicture instance (Num u, Ord u) => Translate (Picture u) where translate = translatePicture -- Primitives instance Num u => Transform (Primitive u) where transform ctm (PPath attr path) = PPath attr $ transformPath (transform ctm) path transform ctm (PLabel attr lbl) = PLabel attr $ transformLabel ctm lbl transform ctm (PEllipse attr ell) = PEllipse attr $ transformEllipse ctm ell instance (Real u, Floating u) => Rotate (Primitive u) where rotate ang (PPath attr path) = PPath attr $ rotatePath ang path rotate ang (PLabel attr lbl) = PLabel attr $ rotateLabel ang lbl rotate ang (PEllipse attr ell) = PEllipse attr $ rotateEllipse ang ell instance (Real u, Floating u) => RotateAbout (Primitive u) where rotateAbout ang pt (PPath attr path) = PPath attr $ rotatePathAbout ang pt path rotateAbout ang pt (PLabel attr lbl) = PLabel attr $ rotateLabelAbout ang pt lbl rotateAbout ang pt (PEllipse attr ell) = PEllipse attr $ rotateEllipseAbout ang pt ell instance Num u => Scale (Primitive u) where scale x y (PPath attr path) = PPath attr $ scalePath x y path scale x y (PLabel attr lbl) = PLabel attr $ scaleLabel x y lbl scale x y (PEllipse attr ell) = PEllipse attr $ scaleEllipse x y ell instance Num u => Translate (Primitive u) where translate x y (PPath attr path) = PPath attr $ translatePath x y path translate x y (PLabel attr lbl) = PLabel attr $ translateLabel x y lbl translate x y (PEllipse attr ell) = PEllipse attr $ translateEllipse x y ell -------------------------------------------------------------------------------- -- Helpers for the affine transformations rotatePicture :: (Real u, Floating u) => Radian -> Picture u -> Picture u rotatePicture ang = transformPicture (rotate ang) (rotate ang) rotatePictureAbout :: (Real u, Floating u) => Radian -> Point2 u -> Picture u -> Picture u rotatePictureAbout ang pt = transformPicture (rotateAbout ang pt) (rotateAbout ang pt) scalePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u scalePicture x y = transformPicture (scale x y) (scale x y) translatePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u translatePicture x y = transformPicture (translate x y) (translate x y) -- TODO - the nameing for these functions is confusing now that -- I've added a Transform typeclass. -- -- Look to unifying the naming scheme in someway. -- transformPicture :: (Num u, Ord u) => (Point2 u -> Point2 u) -> (Vec2 u -> Vec2 u) -> Picture u -> Picture u transformPicture fp fv = mapLocale $ \(frm,bb) -> (transformFrame fp fv frm, transformBBox fp bb) transformFrame :: Num u => (Point2 u -> Point2 u) -> (Vec2 u -> Vec2 u) -> Frame2 u -> Frame2 u transformFrame fp fv (Frame2 e0 e1 o) = Frame2 (fv e0) (fv e1) (fp o) -- Bounding boxes need recalculating after a transformation. -- For instance after a reflection in the y-axis br becomes bl. transformBBox :: (Num u, Ord u) => (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u transformBBox fp bb = trace $ map fp $ [bl,br,tl,tr] where (bl,br,tr,tl) = corners bb -- Paths rotatePath :: (Real u, Floating u) => Radian -> Path u -> Path u rotatePath ang = transformPath (rotate ang) rotatePathAbout :: (Real u, Floating u) => Radian -> Point2 u -> Path u -> Path u rotatePathAbout ang pt = transformPath (rotateAbout ang pt) scalePath :: Num u => u -> u -> Path u -> Path u scalePath x y = transformPath (scale x y) translatePath :: Num u => u -> u -> Path u -> Path u translatePath x y = transformPath (translate x y) transformPath :: (Point2 u -> Point2 u) -> Path u -> Path u transformPath fp (Path start ss) = Path (fp start) (map (transformPathSegment fp) ss) -- Path Segments transformPathSegment :: (Point2 u -> Point2 u) -> PathSegment u -> PathSegment u transformPathSegment fp = pointwise fp -- Labels transformLabel :: Num u => Matrix3'3 u -> Label u -> Label u transformLabel m33 (Label pt txt ctm) = Label pt txt (ctm * m33) -- rotate CTM and pt or just CTM ?? rotateLabel :: (Real u, Floating u) => Radian -> Label u -> Label u rotateLabel ang (Label pt txt ctm) = Label pt txt (ctm * rotationMatrix ang) -- rotate CTM and pt or just CTM ?? rotateLabelAbout :: (Real u, Floating u) => Radian -> Point2 u -> Label u -> Label u rotateLabelAbout ang rpt (Label pt txt ctm) = Label pt txt (ctm * originatedRotationMatrix ang rpt) scaleLabel :: Num u => u -> u -> Label u -> Label u scaleLabel x y (Label pt txt ctm) = Label pt txt (ctm * scalingMatrix x y) -- no need to change CTM for translation (??) translateLabel :: Num u => u -> u -> Label u -> Label u translateLabel x y (Label pt txt ctm) = Label (translate x y pt) txt ctm -- transformEllipse :: Num u => Matrix3'3 u -> PrimEllipse u -> PrimEllipse u transformEllipse m33 (PrimEllipse pt hw hh ctm) = PrimEllipse pt hw hh (ctm * m33) rotateEllipse :: (Real u, Floating u) => Radian -> PrimEllipse u -> PrimEllipse u rotateEllipse ang (PrimEllipse pt hw hh ctm) = PrimEllipse pt hw hh (ctm * rotationMatrix ang) rotateEllipseAbout :: (Real u, Floating u) => Radian -> Point2 u -> PrimEllipse u -> PrimEllipse u rotateEllipseAbout ang rpt (PrimEllipse pt hw hh ctm) = PrimEllipse pt hw hh (ctm * originatedRotationMatrix ang rpt) scaleEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u scaleEllipse x y (PrimEllipse pt hw hh ctm) = PrimEllipse pt hw hh (ctm * scalingMatrix x y) translateEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u translateEllipse x y (PrimEllipse pt hw hh ctm) = PrimEllipse (translate x y pt) hw hh ctm -------------------------------------------------------------------------------- -- Boundary instance Boundary (Picture u) where boundary (PicBlank (_,bb)) = bb boundary (Single (_,bb) _) = bb boundary (Picture (_,bb) _) = bb boundary (Clip (_,bb) _ _) = bb instance (Num u, Ord u) => Boundary (Path u) where boundary (Path st xs) = trace $ st : foldr f [] xs where f (PLineTo p1) acc = p1 : acc f (PCurveTo p1 p2 p3) acc = p1 : p2 : p3 : acc -- Note - this will calculate an approximate bounding box for -- text. instance (Fractional u, Floating u, Ord u) => Boundary (Primitive u) where boundary (PPath _ p) = boundary p boundary (PLabel (_,a) l) = primLabelBoundary a l boundary (PEllipse _ e) = boundary e primLabelBoundary :: (Fractional u, Ord u) => FontAttr -> Label u -> BoundingBox u primLabelBoundary attr (Label pt xs ctm) = retrace (ctm *#) untraf_bbox where untraf_bbox = textBounds (font_size attr) pt char_count char_count = textLength xs instance (Floating u, Ord u) => Boundary (PrimEllipse u) where boundary = ellipseBoundary -- Find the bbox of an ellipse by drawing it as four bezier -- curves then trace all the points and control points to find -- the bbox. -- -- Note all_points takes three of the four points to avoid -- duplicating -- /matched/ start-end points -- ellipseBoundary :: (Floating u, Ord u) => PrimEllipse u -> BoundingBox u ellipseBoundary = trace . ellipseControlPoints -- PROBLEM: -- Currently a rotated circle has a different BBox to a -- non-rotated circle, because of how tangents are selected... -- -- This is the same as a diamond having a larger BBox -- than a square with same side-length -- -------------------------------------------------------------------------------- -- mapLocale :: (Locale u -> Locale u) -> Picture u -> Picture u mapLocale f (PicBlank m) = PicBlank (f m) mapLocale f (Single m prim) = Single (f m) prim mapLocale f (Picture m ones) = Picture (f m) ones mapLocale f (Clip m x p) = Clip (f m) x p movePic :: Num u => Vec2 u -> Picture u -> Picture u movePic v = mapLocale (moveLocale v) moveLocale :: Num u => Vec2 u -> Locale u -> Locale u moveLocale v (fr,bb) = (displaceOrigin v fr, pointwise (.+^ v) bb) -------------------------------------------------------------------------------- -- | Should this really be public? extractFrame :: Num u => Picture u -> Frame2 u extractFrame (PicBlank (fr,_)) = fr extractFrame (Single (fr,_) _) = fr extractFrame (Picture (fr,_) _) = fr extractFrame (Clip (fr,_) _ _) = fr -- This needs is for PostScript and SVG output - it should be -- hidden in the export list of Wumpus.Core -- If a picture has coordinates smaller than (P2 4 4) then it -- needs repositioning before it is drawn to PostSCript or SVG. -- -- (P2 4 4) gives a 4 pt margin - maybe it sould be (0,0) or -- user defined. -- repositionProperties :: (Num u, Ord u) => Picture u -> (BoundingBox u, Maybe (Vec2 u)) repositionProperties = fn . boundary where fn bb@(BBox (P2 llx lly) (P2 urx ury)) | llx < 4 || lly < 4 = (BBox ll ur, Just $ V2 x y) | otherwise = (bb, Nothing) where x = 4 - llx y = 4 - lly ll = P2 (llx+x) (lly+y) ur = P2 (urx+x) (ury+y) -- | Get the control points as a list -- -- There are no duplicates in the list except for the final -- /wrap-around/. We take 4 points initially (start,cp1,cp2,end) -- then (cp1,cp2,end) for the other three quadrants. -- ellipseControlPoints :: (Floating u, Ord u) => PrimEllipse u -> [Point2 u] ellipseControlPoints (PrimEllipse ctr hw hh ctm) = map (new_mtrx *#) circ where (radius,(dx,dy)) = circleScalingProps hw hh new_mtrx = ctm * scalingMatrix dx dy circ = bezierCircle 1 radius ctr -- subdivide the bezierCircle with 1 to get two -- control points per quadrant. -- -- I don't know how to calculate bezier arcs (and thus control -- points) for an ellipse but I know how to do it for a circle... -- -- So a make a circle with the largest of half-width and -- half-height then apply a scale to the points -- circleScalingProps :: (Fractional u, Ord u) => u -> u -> (u,(u,u)) circleScalingProps hw hh = (radius, (dx,dy)) where radius = max hw hh (dx,dy) = if radius == hw then (1, rescale (0,hw) (0,1) hh) else (rescale (0,hh) (0,1) hw, 1)