wumpus-core-0.21.0: src/Wumpus/Core/PictureInternal.hs
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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
, PrimCTM
, PathProps -- hide in Wumpus.Core export?
, LabelProps -- hide in Wumpus.Core export?
, EllipseProps --
, DrawPath(..) -- hide in Wumpus.Core export?
, DrawEllipse(..)
, Locale
-- * Type class
, PSUnit(..)
-- * Transformations on Primitives
, translatePrimitive
, rotatePrimitive
, scalePrimitive
, uniformScalePrimitive
-- * PrimCTM
, identityCTM
, scaleCTM
, matrixRepCTM
, translMatrixRepCTM
-- * 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 -- package: wl-pprint
-- | 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 :: PrimCTM 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
, ellipse_ctm :: PrimCTM u
}
deriving (Eq,Show)
type DPrimEllipse = PrimEllipse Double
data PrimCTM u = PrimCTM { _xscale :: u, _yscale :: u, _rot :: Radian }
deriving (Eq,Show)
-- | 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
<+> pretty ctm
instance Pretty u => Pretty (PrimEllipse u) where
pretty (PrimEllipse ctr w h ctm) = pretty "ellipse" <+> pretty ctr
<+> text "w:" <> pretty w
<+> text "h:" <> pretty h
<+> pretty ctm
instance Pretty u => Pretty (PrimCTM u) where
pretty (PrimCTM x y ang) =
braces (pretty x <> comma <+> pretty y <> comma <+> pretty ang)
--------------------------------------------------------------------------------
-- | 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 = trafoPicture (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
-- | Rotate a Primitive.
--
-- Note - this is not an affine transformation as Primitives are
-- not regarded as being in an affine frame.
--
-- * Paths are rotated about their start point.
--
-- * Labels are rotated about the bottom-left corner.
--
-- * Ellipses are rotated about the center.
--
-- For Primitives and Ellipses applying a rotation and or a scale
-- will generate an additional matrix transformation in the
-- generated PostScript. For Paths all transformations are
-- \"cost-free\".
--
rotatePrimitive :: (Real u, Floating u)
=> Radian -> Primitive u -> Primitive u
rotatePrimitive ang (PPath a path) = PPath a $ rotatePath ang path
rotatePrimitive ang (PLabel a lbl) = PLabel a $ rotateLabel ang lbl
rotatePrimitive ang (PEllipse a ell) = PEllipse a $ rotateEllipse ang ell
-- | Scale a Primitive.
--
-- Note - this is not an affine transformation as Primitives are
-- not regarded as being in an affine frame.
--
-- An affine scaling uniformly scales all the elements in a
-- Picture. It is just a change of the Picture\'s basis vectors.
-- The elements within the Picture are unchanged - though
-- obviously rendering changes according to the transformation.
--
-- By contrast, the scaling operation on Primitives changes the
-- properties of the object as it is applied - e.g. for a path
-- the vector between the start point and all subsequent points
-- is changed with respect to the x,y scaling factors; for an
-- ellipse the half-width and half-height of the ellipse is
-- scaled.
--
-- For Primitives and Ellipses applying a rotation and or a scale
-- will generate an additional matrix transformation in the
-- generated PostScript. For Paths all transformations are
-- \"cost-free\".
--
scalePrimitive :: Num u => u -> u -> Primitive u -> Primitive u
scalePrimitive x y (PPath a path) = PPath a $ scalePath x y path
scalePrimitive x y (PLabel a lbl) = PLabel a $ scaleLabel x y lbl
scalePrimitive x y (PEllipse a ell) = PEllipse a $ scaleEllipse x y ell
-- | Apply a uniform scale to a Primitive.
--
uniformScalePrimitive :: Num u => u -> Primitive u -> Primitive u
uniformScalePrimitive d = scalePrimitive d d
-- | Translate a primitive.
--
-- Translation is essentially \"cost-free\" for the generated
-- PostScript or SVG. Paths are translated before the PostScript
-- is generated. For Ellipses and Labels, translation will
-- either move the bottom-left origin (Label) or center
-- (Ellipse); or if they are also scaled or rotated the
-- translation will be concatenated into the matrix operation in
-- the generated output.
--
translatePrimitive :: Num u => u -> u -> Primitive u -> Primitive u
translatePrimitive x y (PPath a path) = PPath a $ translatePath x y path
translatePrimitive x y (PLabel a lbl) = PLabel a $ translateLabel x y lbl
translatePrimitive x y (PEllipse a ell) = PEllipse a $ translateEllipse x y ell
--------------------------------------------------------------------------------
-- Helpers for the affine transformations
rotatePicture :: (Real u, Floating u) => Radian -> Picture u -> Picture u
rotatePicture ang = trafoPicture (rotate ang) (rotate ang)
rotatePictureAbout :: (Real u, Floating u)
=> Radian -> Point2 u -> Picture u -> Picture u
rotatePictureAbout ang pt =
trafoPicture (rotateAbout ang pt) (rotateAbout ang pt)
scalePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u
scalePicture x y = trafoPicture (scale x y) (scale x y)
translatePicture :: (Num u, Ord u) => u -> u -> Picture u -> Picture u
translatePicture x y = trafoPicture (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.
--
trafoPicture :: (Num u, Ord u)
=> (Point2 u -> Point2 u)
-> (Vec2 u -> Vec2 u)
-> Picture u
-> Picture u
trafoPicture fp fv =
mapLocale $ \(frm,bb) -> (trafoFrame fp fv frm, trafoBBox fp bb)
trafoFrame :: Num u
=> (Point2 u -> Point2 u)
-> (Vec2 u -> Vec2 u)
-> Frame2 u
-> Frame2 u
trafoFrame 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.
trafoBBox :: (Num u, Ord u)
=> (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u
trafoBBox fp bb = traceBoundary $ map fp $ [bl,br,tl,tr]
where
(bl,br,tr,tl) = corners bb
--------------------------------------------------------------------------------
-- Paths
-- Cannot support general matrix transform or rotateAbout on
-- Ellipses or Labels so there are not supported on Paths.
--
-- rotatePath - rotate the path about its start point.
--
-- This is a visually intuitive interpretation - Primitives are
-- not in an affine space (they have an origin, i.e. the location
-- (0,0), but don\'t not basis vectors) so manipulating them
-- cannot follow the standard affine interpretation.
--
rotatePath :: (Real u, Floating u) => Radian -> Path u -> Path u
rotatePath ang (Path start xs) =
Path start $ map (pointwise (rotateAbout ang start)) xs
-- scalePath - scale the vector between each point and the start
-- point.
--
-- This produces visually inituitive results. As primitives
-- don\'t exist in an affine space / affine frame until they
-- are lifted to Pictures their manipulation cannot correspond
-- to the standard affine manipulations.
--
scalePath :: Num u => u -> u -> Path u -> Path u
scalePath x y (Path pt xs) = Path pt (map (pointwise fn) xs)
where
fn p1 = let dif = p1 .-. pt in pt .+^ (scale x y $ dif)
-- translatePath - move all points in the path by the supplied
-- x and y values.
--
translatePath :: Num u => u -> u -> Path u -> Path u
translatePath x y = pointwise (translate x y)
--------------------------------------------------------------------------------
-- Manipulating the Primitive CTM
identityCTM :: Num u => PrimCTM u
identityCTM = PrimCTM 1 1 0
scaleCTM :: Num u => u -> u -> PrimCTM u -> PrimCTM u
scaleCTM x1 y1 (PrimCTM x y ang) = PrimCTM (x1*x) (y1*y) ang
rotateCTM :: Radian -> PrimCTM u -> PrimCTM u
rotateCTM ang1 (PrimCTM x y ang) = PrimCTM x y (ang1+ang)
matrixRepCTM :: (Floating u, Real u) => PrimCTM u -> Matrix3'3 u
matrixRepCTM (PrimCTM x y ang) =
rotationMatrix (circularModulo ang) * scalingMatrix x y
-- Note - the order of combining a translation (i.e. the
-- location of a point) and the CTM is crucial as matrix
-- multiplication is not commutative.
--
-- The function encapsulated the correct order.
--
translMatrixRepCTM :: (Floating u, Real u)
=> u -> u -> PrimCTM u -> Matrix3'3 u
translMatrixRepCTM x y ctm = translationMatrix x y * matrixRepCTM ctm
--------------------------------------------------------------------------------
-- Labels
-- Rotations on a (primitive) Label are interpreted as rotating
-- about the bottom-left corner.
--
rotateLabel :: Radian -> Label u -> Label u
rotateLabel ang (Label pt txt ctm) = Label pt txt (rotateCTM ang ctm)
scaleLabel :: Num u => u -> u -> Label u -> Label u
scaleLabel x y (Label pt txt ctm) = Label pt txt (scaleCTM x y ctm)
-- Change the bottom-left corner.
--
translateLabel :: Num u => u -> u -> Label u -> Label u
translateLabel x y (Label pt txt ctm) = Label (translate x y pt) txt ctm
--------------------------------------------------------------------------------
-- Ellipse
rotateEllipse :: Radian -> PrimEllipse u -> PrimEllipse u
rotateEllipse ang (PrimEllipse pt hw hh ctm) =
PrimEllipse pt hw hh (rotateCTM ang ctm)
scaleEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u
scaleEllipse x y (PrimEllipse pt hw hh ctm) =
PrimEllipse (translate x y pt) hw hh (scaleCTM x y ctm)
-- Change the point
--
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) = traceBoundary $ 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 (Real u, Floating u) => Boundary (Primitive u) where
boundary (PPath _ p) = boundary p
boundary (PLabel (_,a) l) = primLabelBoundary a l
boundary (PEllipse _ e) = boundary e
primLabelBoundary :: (Floating u, Real u)
=> FontAttr -> Label u -> BoundingBox u
primLabelBoundary attr (Label (P2 x y) xs ctm) =
retraceBoundary (disp . (m33 *#)) untraf_bbox
where
disp = (.+^ V2 x y)
m33 = matrixRepCTM ctm
untraf_bbox = textBounds (font_size attr) zeroPt char_count
char_count = textLength xs
instance (Real u, Floating 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 :: (Real u, Floating u) => PrimEllipse u -> BoundingBox u
ellipseBoundary = traceBoundary . 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, Real u)
=> PrimEllipse u -> [Point2 u]
ellipseControlPoints (PrimEllipse (P2 x y) hw hh ctm) =
map (disp . (new_mtrx *#)) circ
where
disp = (.+^ V2 x y)
(radius,(dx,dy)) = circleScalingProps hw hh
new_mtrx = matrixRepCTM $ scaleCTM dx dy ctm
circ = bezierCircle 1 radius (P2 0 0)
-- 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)