module Wumpus.Core.PictureInternal
(
Picture(..)
, DPicture
, Primitive(..)
, DPrimitive
, Path(..)
, DPath
, PathSegment(..)
, DPathSegment
, Label(..)
, DLabel
, PrimEllipse(..)
, DPrimEllipse
, PathProps
, LabelProps
, EllipseProps
, DrawPath(..)
, DrawEllipse(..)
, Locale
, PSUnit(..)
, 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
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
data Primitive u = PPath PathProps (Path u)
| PLabel LabelProps (Label u)
| PEllipse EllipseProps (PrimEllipse u)
deriving (Eq,Show)
type DPrimitive = Primitive Double
data Path u = Path (Point2 u) [PathSegment u]
deriving (Eq,Show)
type DPath = Path Double
data PathSegment u = PCurveTo (Point2 u) (Point2 u) (Point2 u)
| PLineTo (Point2 u)
deriving (Eq,Show)
type DPathSegment = PathSegment Double
data Label u = Label
{ label_bottom_left :: Point2 u
, label_text :: EncodedText
, label_CTM :: Matrix3'3 u
}
deriving (Eq,Show)
type DLabel = Label Double
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
data DrawPath = CFill | CStroke [StrokeAttr] | OStroke [StrokeAttr]
deriving (Eq,Show)
data DrawEllipse = EFill | EStroke [StrokeAttr]
deriving (Eq,Show)
type PathProps = (PSRgb, DrawPath)
type LabelProps = (PSRgb, FontAttr)
type EllipseProps = (PSRgb, DrawEllipse)
type Locale u = (Frame2 u, BoundingBox u)
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]
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)
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
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
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)
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)
transformBBox :: (Num u, Ord u)
=> (Point2 u -> Point2 u) -> BoundingBox u -> BoundingBox u
transformBBox fp bb = traceBoundary $ map fp $ [bl,br,tl,tr]
where
(bl,br,tr,tl) = corners bb
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)
transformPathSegment :: (Point2 u -> Point2 u) -> PathSegment u -> PathSegment u
transformPathSegment fp = pointwise fp
transformLabel :: Num u => Matrix3'3 u -> Label u -> Label u
transformLabel m33 (Label pt txt ctm) = Label pt txt (ctm * m33)
rotateLabel :: (Real u, Floating u) => Radian -> Label u -> Label u
rotateLabel ang (Label pt txt ctm) = Label pt txt (ctm * rotationMatrix ang)
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)
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
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
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) =
retraceBoundary (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
ellipseBoundary :: (Floating u, Ord u) => PrimEllipse u -> BoundingBox u
ellipseBoundary = traceBoundary . ellipseControlPoints
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)
extractFrame :: Num u => Picture u -> Frame2 u
extractFrame (PicBlank (fr,_)) = fr
extractFrame (Single (fr,_) _) = fr
extractFrame (Picture (fr,_) _) = fr
extractFrame (Clip (fr,_) _ _) = fr
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)
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
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)