module Wumpus.Core.PictureInternal
(
Picture(..)
, DPicture
, Locale
, AffineTrafo(..)
, FontCtx(..)
, PrimElement(..)
, DPrimElement
, Primitive(..)
, DPrimitive
, XLink(..)
, PrimPath(..)
, DPrimPath
, PathProps(..)
, PrimPathSegment(..)
, DPrimPathSegment
, PrimLabel(..)
, DPrimLabel
, LabelProps(..)
, LabelBody(..)
, DLabelBody
, KerningChar
, DKerningChar
, PrimEllipse(..)
, EllipseProps(..)
, PrimCTM(..)
, pathBoundary
, mapLocale
, identityCTM
, scaleCTM
, rotateCTM
, matrixRepCTM
, translMatrixRepCTM
, rotatePrim
, scalePrim
, uniformScalePrim
, translatePrim
, concatTrafos
, deconsMatrix
, repositionDeltas
) where
import Wumpus.Core.AffineTrans
import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.FontSize
import Wumpus.Core.FormatCombinators
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicsState
import Wumpus.Core.OneList
import Wumpus.Core.PtSize
import Wumpus.Core.TextInternal
import Wumpus.Core.Utils
import Data.AffineSpace
import Data.Semigroup
import qualified Data.Foldable as F
data Picture u = Leaf (Locale u) (OneList (PrimElement u))
| Picture (Locale u) (OneList (Picture u))
| Clip (Locale u) (PrimPath u) (Picture u)
| Group (Locale u) FontCtx (Picture u)
deriving (Show)
type DPicture = Picture Double
data PrimElement u = Atom (Primitive u)
| XLinkGroup XLink (OneList (PrimElement u))
deriving (Show)
type DPrimElement = PrimElement Double
newtype FontCtx = FontCtx { getFontCtx :: FontAttr }
deriving (Eq,Show)
type Locale u = (BoundingBox u, [AffineTrafo u])
data AffineTrafo u = Matrix (Matrix3'3 u)
| Rotate Radian
| RotAbout Radian (Point2 u)
| Scale u u
| Translate u u
deriving (Eq,Show)
data Primitive u = PPath PathProps (PrimPath u)
| PLabel LabelProps (PrimLabel u)
| PEllipse EllipseProps (PrimEllipse u)
deriving (Eq,Show)
type DPrimitive = Primitive Double
newtype XLink = XLink { getXLink :: String }
deriving (Eq,Show)
data PrimPath u = PrimPath (Point2 u) [PrimPathSegment u]
deriving (Eq,Show)
type DPrimPath = PrimPath Double
data PrimPathSegment u = PCurveTo (Point2 u) (Point2 u) (Point2 u)
| PLineTo (Point2 u)
deriving (Eq,Show)
type DPrimPathSegment = PrimPathSegment Double
data PathProps = CFill RGBi
| CStroke StrokeAttr RGBi
| OStroke StrokeAttr RGBi
| CFillStroke RGBi StrokeAttr RGBi
deriving (Eq,Show)
data PrimLabel u = PrimLabel
{ label_baseline_left :: Point2 u
, label_body :: LabelBody u
, label_ctm :: PrimCTM u
}
deriving (Eq,Show)
type DPrimLabel = PrimLabel Double
data LabelProps = LabelProps
{ label_colour :: RGBi
, label_font :: FontAttr
}
deriving (Eq,Ord,Show)
data LabelBody u = StdLayout EncodedText
| KernTextH [KerningChar u]
| KernTextV [KerningChar u]
deriving (Eq,Show)
type DLabelBody = LabelBody Double
type KerningChar u = (u,EncodedChar)
type DKerningChar = KerningChar Double
data PrimEllipse u = PrimEllipse
{ ellipse_center :: Point2 u
, ellipse_half_width :: u
, ellipse_half_height :: u
, ellipse_ctm :: PrimCTM u
}
deriving (Eq,Show)
data EllipseProps = EFill RGBi
| EStroke StrokeAttr RGBi
| EFillStroke RGBi StrokeAttr RGBi
deriving (Eq,Show)
data PrimCTM u = PrimCTM
{ ctm_scale_x :: u
, ctm_scale_y :: u
, ctm_rotation :: Radian
}
deriving (Eq,Show)
type instance DUnit (Picture u) = u
type instance DUnit (PrimElement u) = u
type instance DUnit (Primitive u) = u
type instance DUnit (PrimEllipse u) = u
instance (Num u, PSUnit u) => Format (Picture u) where
format (Leaf m prims) = indent 2 $ vcat [ text "** Leaf-pic **"
, fmtLocale m
, fmtPrimElems prims ]
format (Picture m pics) = indent 2 $ vcat [ text "** Tree-pic **"
, fmtLocale m
, fmtPics pics ]
format (Clip m path pic) = indent 2 $ vcat [ text "** Clip-path **"
, fmtLocale m
, format path
, format pic ]
format (Group m _ pic) = indent 2 $ vcat [ text "** Group **"
, fmtLocale m
, format pic ]
fmtPics :: PSUnit u => OneList (Picture u) -> Doc
fmtPics ones = snd $ F.foldl' fn (0,empty) ones
where
fn (n,acc) e = (n+1, vcat [ acc, text "-- " <+> int n, format e, line])
fmtPrimElems :: PSUnit u => OneList (PrimElement u) -> Doc
fmtPrimElems ones = snd $ F.foldl' fn (0,empty) ones
where
fn (n,acc) e = (n+1, vcat [ acc, text "-- leaf" <+> int n, format e, line])
instance PSUnit u => Format (PrimElement u) where
format (Atom prim) = format prim
format (XLinkGroup xl ones) = vcat [ text "-- xlink " <+> format xl
, fmtPrimElems ones ]
fmtLocale :: (Num u, PSUnit u) => Locale u -> Doc
fmtLocale (bb,_) = format bb
instance PSUnit u => Format (Primitive u) where
format (PPath props p) =
indent 2 $ vcat [ text "path:" <+> format props, format p ]
format (PLabel props l) =
indent 2 $ vcat [ text "label:" <+> format props, format l ]
format (PEllipse props e) =
indent 2 $ vcat [ text "ellipse:" <+> format props, format e ]
instance PSUnit u => Format (PrimPath u) where
format (PrimPath pt ps) = vcat (start : map format ps)
where
start = text "start_point " <> format pt
instance PSUnit u => Format (PrimPathSegment u) where
format (PCurveTo p1 p2 p3) =
text "curve_to " <> format p1 <+> format p2 <+> format p3
format (PLineTo pt) = text "line_to " <> format pt
instance PSUnit u => Format (PrimLabel u) where
format (PrimLabel pt s ctm) =
vcat [ dquotes (format s)
, text "baseline_left=" <> format pt
<+> text "ctm=" <> format ctm
]
instance PSUnit u => Format (LabelBody u) where
format (StdLayout enctext) = format enctext
format (KernTextH xs) = text "(KernH)" <+> hcat (map (format .snd) xs)
format (KernTextV xs) = text "(KernV)" <+> hcat (map (format .snd) xs)
instance PSUnit u => Format (PrimEllipse u) where
format (PrimEllipse ctr hw hh ctm) = text "center=" <> format ctr
<+> text "hw=" <> dtruncFmt hw
<+> text "hh=" <> dtruncFmt hh
<+> text "ctm=" <> format ctm
instance PSUnit u => Format (PrimCTM u) where
format (PrimCTM x y ang) =
parens (text "CTM" <+> text "sx=" <> dtruncFmt x
<+> text "sy=" <> dtruncFmt y
<+> text "ang=" <> format ang )
instance Format PathProps where
format (CFill rgb) = format rgb <+> text "Fill"
format (CStroke _ rgb) = format rgb <+> text "Closed-stroke"
format (OStroke _ rgb) = format rgb <+> text "Open-stroke"
format (CFillStroke f _ s) = format f <+> text "Fill" <> char '/'
<+> format s <+> text "Stroke"
instance Format LabelProps where
format (LabelProps rgb attr) = format rgb
<+> text (font_name $ font_face attr)
instance Format EllipseProps where
format (EFill rgb) = format rgb <+> text "Fill"
format (EStroke _ rgb) = format rgb <+> text "Stroke"
format (EFillStroke f _ s) = format f <+> text "Fill" <> char '/'
<+> format s <+> text "Stroke"
instance Format XLink where
format (XLink ss) = text "xlink" <+> text ss
instance Boundary (Picture u) where
boundary (Leaf (bb,_) _) = bb
boundary (Picture (bb,_) _) = bb
boundary (Clip (bb,_) _ _) = bb
boundary (Group (bb,_) _ _) = bb
instance (Real u, Floating u, FromPtSize u) => Boundary (PrimElement u) where
boundary (Atom prim) = boundary prim
boundary (XLinkGroup _ ones) = outer $ viewl ones
where
outer (OneL a) = boundary a
outer (a :< as) = inner (boundary a) (viewl as)
inner bb (OneL a) = bb `append` boundary a
inner bb (a :< as) = inner (bb `append` boundary a) (viewl as)
instance (Real u, Floating u, FromPtSize u) => Boundary (Primitive u) where
boundary (PPath _ p) = pathBoundary p
boundary (PLabel a l) = labelBoundary (label_font a) l
boundary (PEllipse _ e) = ellipseBoundary e
pathBoundary :: Ord u => PrimPath u -> BoundingBox u
pathBoundary (PrimPath st xs) = step (st,st) xs
where
step (lo,hi) [] = BBox lo hi
step (lo,hi) (PLineTo p1:rest) = step (lo2 lo p1, hi2 hi p1) rest
step (lo,hi) (PCurveTo p1 p2 p3:rest) = let lo' = lo4 lo p1 p2 p3
hi' = hi4 hi p1 p2 p3
in step (lo',hi') rest
lo2 (P2 x1 y1) (P2 x2 y2) = P2 (min x1 x2) (min y1 y2)
hi2 (P2 x1 y1) (P2 x2 y2) = P2 (max x1 x2) (max y1 y2)
lo4 (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) (P2 x4 y4) =
P2 (min x1 $ min x2 $ min x3 x4) (min y1 $ min y2 $ min y3 y4)
hi4 (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) (P2 x4 y4) =
P2 (max x1 $ max x2 $ max x3 x4) (max y1 $ max y2 $ max y3 y4)
labelBoundary :: (Floating u, Real u, FromPtSize u)
=> FontAttr -> PrimLabel u -> BoundingBox u
labelBoundary attr (PrimLabel (P2 x y) body ctm) =
retraceBoundary (disp . (m33 *#)) untraf_bbox
where
disp = (.+^ V2 x y)
m33 = matrixRepCTM ctm
untraf_bbox = labelBodyBoundary (font_size attr) body
labelBodyBoundary :: (Num u, Ord u, FromPtSize u)
=> FontSize -> LabelBody u -> BoundingBox u
labelBodyBoundary sz (StdLayout etxt) = stdLayoutBB sz etxt
labelBodyBoundary sz (KernTextH xs) = hKerningBB sz xs
labelBodyBoundary sz (KernTextV xs) = vKerningBB sz xs
stdLayoutBB :: (Num u, Ord u, FromPtSize u)
=> FontSize -> EncodedText -> BoundingBox u
stdLayoutBB sz etxt = textBoundsEnc sz zeroPt etxt
hKerningBB :: (Num u, Ord u, FromPtSize u)
=> FontSize -> [(u,EncodedChar)] -> BoundingBox u
hKerningBB sz xs = rightGrow (sumDiffs xs) $ textBounds sz zeroPt "A"
where
sumDiffs = foldr (\(u,_) i -> i+u) 0
rightGrow u (BBox ll (P2 x1 y1)) = BBox ll (P2 (x1+u) y1)
vKerningBB :: (Num u, Ord u, FromPtSize u)
=> FontSize -> [(u,EncodedChar)] -> BoundingBox u
vKerningBB sz xs = downGrow (sumDiffs xs) $ textBounds sz zeroPt "A"
where
sumDiffs = foldr (\(u,_) i -> i+u) 0
downGrow u (BBox (P2 x0 y0) (P2 x1 y1)) = BBox (P2 x0 (y0u)) (P2 x1 y1)
ellipseBoundary :: (Real u, Floating u) => PrimEllipse u -> BoundingBox u
ellipseBoundary (PrimEllipse pt hw0 hh0 (PrimCTM sx sy theta)) =
traceBoundary $ applyIf (theta /= 0) (map (rotm *#)) [ll,lr,ur,ul]
where
hw = hw0 * sx
hh = hh0 * sy
ll = pt .+^ V2 (hw) (hh)
lr = pt .+^ V2 hw (hh)
ur = pt .+^ V2 hw hh
ul = pt .+^ V2 (hw) hh
rotm = rotationMatrix theta
instance (Num u, Ord u) => Transform (Picture u) where
transform mtrx =
mapLocale $ \(bb,xs) -> (transform mtrx bb, Matrix mtrx:xs)
instance (Real u, Floating u) => Rotate (Picture u) where
rotate theta =
mapLocale $ \(bb,xs) -> (rotate theta bb, Rotate theta:xs)
instance (Real u, Floating u) => RotateAbout (Picture u) where
rotateAbout theta pt =
mapLocale $ \(bb,xs) -> (rotateAbout theta pt bb, RotAbout theta pt:xs)
instance (Num u, Ord u) => Scale (Picture u) where
scale sx sy =
mapLocale $ \(bb,xs) -> (scale sx sy bb, Scale sx sy : xs)
instance (Num u, Ord u) => Translate (Picture u) where
translate dx dy =
mapLocale $ \(bb,xs) -> (translate dx dy bb, Translate dx dy:xs)
mapLocale :: (Locale u -> Locale u) -> Picture u -> Picture u
mapLocale f (Leaf lc ones) = Leaf (f lc) ones
mapLocale f (Picture lc ones) = Picture (f lc) ones
mapLocale f (Clip lc pp pic) = Clip (f lc) pp pic
mapLocale f (Group lc upd pic) = Group (f lc) upd pic
identityCTM :: Num u => PrimCTM u
identityCTM = PrimCTM { ctm_scale_x = 1, ctm_scale_y = 1, ctm_rotation = 0 }
scaleCTM :: Num u => u -> u -> PrimCTM u -> PrimCTM u
scaleCTM x1 y1 (PrimCTM sx sy ang) = PrimCTM (x1*sx) (y1*sy) ang
rotateCTM :: Radian -> PrimCTM u -> PrimCTM u
rotateCTM ang1 (PrimCTM sx sy ang) = PrimCTM sx sy (circularModulo $ ang1+ang)
matrixRepCTM :: (Floating u, Real u) => PrimCTM u -> Matrix3'3 u
matrixRepCTM (PrimCTM sx sy ang) =
rotationMatrix (circularModulo ang) * scalingMatrix sx sy
translMatrixRepCTM :: (Floating u, Real u)
=> u -> u -> PrimCTM u -> Matrix3'3 u
translMatrixRepCTM x y ctm = translationMatrix x y * matrixRepCTM ctm
rotatePrim :: (Real u, Floating u)
=> Radian -> PrimElement u -> PrimElement u
rotatePrim ang (Atom prim) = Atom $ rotatePrimitive ang prim
rotatePrim ang (XLinkGroup xlink ones) =
XLinkGroup xlink $ fmap (rotatePrim ang) ones
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
scalePrim :: Num u => u -> u -> PrimElement u -> PrimElement u
scalePrim x y (Atom prim) = Atom $ scalePrimitive x y prim
scalePrim x y (XLinkGroup xlink ones) =
XLinkGroup xlink $ fmap (scalePrim x y) ones
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
uniformScalePrim :: Num u => u -> PrimElement u -> PrimElement u
uniformScalePrim d = scalePrim d d
translatePrim :: Num u => u -> u -> PrimElement u -> PrimElement u
translatePrim x y (Atom prim) =
Atom $ translatePrimitive x y prim
translatePrim x y (XLinkGroup xlink ones) =
XLinkGroup xlink $ fmap (translatePrim x y) ones
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
rotatePath :: (Real u, Floating u) => Radian -> PrimPath u -> PrimPath u
rotatePath ang (PrimPath start xs) = PrimPath start $ map (mapSeg fn) xs
where
fn = rotateAbout ang start
scalePath :: Num u => u -> u -> PrimPath u -> PrimPath u
scalePath x y (PrimPath pt xs) = PrimPath pt $ map (mapSeg fn) xs
where
fn p1 = let dif = p1 .-. pt in pt .+^ (scale x y $ dif)
translatePath :: Num u => u -> u -> PrimPath u -> PrimPath u
translatePath x y = mapPath (translate x y)
mapPath :: (Point2 u -> Point2 u) -> PrimPath u -> PrimPath u
mapPath fn (PrimPath st xs) = PrimPath (fn st) (map (mapSeg fn) xs)
mapSeg :: (Point2 u -> Point2 u) -> PrimPathSegment u -> PrimPathSegment u
mapSeg fn (PLineTo p) = PLineTo (fn p)
mapSeg fn (PCurveTo p1 p2 p3) = PCurveTo (fn p1) (fn p2) (fn p3)
rotateLabel :: Radian -> PrimLabel u -> PrimLabel u
rotateLabel ang (PrimLabel pt txt ctm) = PrimLabel pt txt (rotateCTM ang ctm)
scaleLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u
scaleLabel x y (PrimLabel pt txt ctm) = PrimLabel pt txt (scaleCTM x y ctm)
translateLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u
translateLabel x y (PrimLabel pt txt ctm) = PrimLabel (translate x y pt) txt ctm
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)
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
concatTrafos :: (Floating u, Real u) => [AffineTrafo u] -> Matrix3'3 u
concatTrafos = foldr (\e ac -> matrixRepr e * ac) identityMatrix
matrixRepr :: (Floating u, Real u) => AffineTrafo u -> Matrix3'3 u
matrixRepr (Matrix mtrx) = mtrx
matrixRepr (Rotate theta) = rotationMatrix theta
matrixRepr (RotAbout theta pt) = originatedRotationMatrix theta pt
matrixRepr (Scale sx sy) = scalingMatrix sx sy
matrixRepr (Translate dx dy) = translationMatrix dx dy
deconsMatrix :: Matrix3'3 u -> (u,u,u,u,u,u)
deconsMatrix (M3'3 e0x e1x ox
e0y e1y oy
_ _ _ ) = (e0x,e0y, e1x,e1y, ox,oy)
repositionDeltas :: (Num u, Ord u)
=> Picture u -> (BoundingBox u, Maybe (Vec2 u))
repositionDeltas = step . boundary
where
step 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)