{-# LANGUAGE LambdaCase #-}
{-|
Copyright : Written by David Himmelstrup
License : Unlicense
Maintainer : lemmih@gmail.com
Stability : experimental
Portability : POSIX
-}
module Reanimate.Svg
( module Reanimate.Svg
, module Reanimate.Svg.Constructors
, module Reanimate.Svg.LineCommand
, module Reanimate.Svg.BoundingBox
, module Reanimate.Svg.Unuse
) where
import Control.Lens ((%~), (&), (.~), (^.), (?~))
import Control.Monad.State
import Graphics.SvgTree hiding (height, line, path, use,
width)
import Linear.V2 hiding (angle)
import Reanimate.Constants
import Reanimate.Animation (SVG)
import Reanimate.Svg.Constructors
import Reanimate.Svg.LineCommand
import Reanimate.Svg.BoundingBox
import Reanimate.Svg.Unuse
import qualified Reanimate.Transform as Transform
-- | Remove transformations (such as translations, rotations, scaling)
-- and apply them directly to the SVG nodes. Note, this function
-- may convert nodes (such as Circle or Rect) to paths. Also note
-- that /does/ change how the SVG is rendered. Particularly, stroke
-- width is affected by directly applying scaling.
--
-- @lowerTransformations (scale 2 (mkCircle 1)) = mkCircle 2@
lowerTransformations :: Tree -> Tree
lowerTransformations = worker False Transform.identity
where
updLineCmd m cmd =
case cmd of
LineMove p -> LineMove $ Transform.transformPoint m p
-- LineDraw p -> LineDraw $ Transform.transformPoint m p
LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps
LineEnd p -> LineEnd $ Transform.transformPoint m p
updPath m = lineToPath . map (updLineCmd m) . toLineCommands
updPoint m (Num a,Num b) =
case Transform.transformPoint m (V2 a b) of
V2 x y -> (Num x, Num y)
updPoint _ other = other -- XXX: Can we do better here?
worker hasPathified m t =
let m' = m * Transform.mkMatrix (t^.transform) in
case t of
PathTree path -> PathTree $
path & pathDefinition %~ updPath m'
& transform .~ Nothing
GroupTree g -> GroupTree $
g & groupChildren %~ map (worker hasPathified m')
& transform .~ Nothing
LineTree line ->
LineTree $
line & linePoint1 %~ updPoint m
& linePoint2 %~ updPoint m
ClipPathTree{} -> t
-- If we encounter an unknown node and we've already tried to convert
-- to paths, give up and insert an explicit transformation.
_ | hasPathified ->
mkGroup [t] & transform ?~ [ Transform.toTransformation m ]
-- If we haven't tried to pathify, run pathify only once.
_ -> worker True m (pathify t)
-- | Remove all @id@ attributes.
lowerIds :: Tree -> Tree
lowerIds = mapTree worker
where
worker t@GroupTree{} = t & attrId .~ Nothing
worker t@PathTree{} = t & attrId .~ Nothing
worker t = t
-- | Optimize SVG tree without affecting how it is rendered.
simplify :: Tree -> Tree
simplify root =
case worker root of
[] -> None
[x] -> x
xs -> mkGroup xs
where
worker None = []
worker (DefinitionTree d) =
concatMap dropNulls
[DefinitionTree $ d & groupChildren %~ concatMap worker]
worker (GroupTree g)
| g ^. drawAttributes == defaultSvg =
concatMap dropNulls $
concatMap worker (g^.groupChildren)
| otherwise =
dropNulls $
GroupTree $ g & groupChildren %~ concatMap worker
worker t = dropNulls t
dropNulls None = []
dropNulls (DefinitionTree d)
| null (d^.groupChildren) = []
dropNulls (GroupTree g)
| null (g^.groupChildren) = []
dropNulls t = [t]
-- | Separate grouped items. This is required by clip nodes.
--
-- @removeGroups (withFillColor "blue" $ mkGroup [mkCircle 1, mkRect 1 1])
-- = [ withFillColor "blue" $ mkCircle 1
-- , withFillColor "blue" $ mkRect 1 1 ]@
removeGroups :: Tree -> [Tree]
removeGroups = worker defaultSvg
where
worker _attr None = []
worker _attr (DefinitionTree d) =
concatMap dropNulls
[DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)]
worker attr (GroupTree g)
| g ^. drawAttributes == defaultSvg =
concatMap dropNulls $
concatMap (worker attr) (g^.groupChildren)
| otherwise =
concatMap (worker (attr <> g ^. drawAttributes)) (g^.groupChildren)
worker attr t = dropNulls (t & drawAttributes .~ attr)
dropNulls None = []
dropNulls (DefinitionTree d)
| null (d^.groupChildren) = []
dropNulls (GroupTree g)
| null (g^.groupChildren) = []
dropNulls t = [t]
-- | Extract all path commands from a node (and its children) and concatenate them.
extractPath :: Tree -> [PathCommand]
extractPath = worker . simplify . lowerTransformations . pathify
where
worker (GroupTree g) = concatMap worker (g^.groupChildren)
worker (PathTree p) = p^.pathDefinition
worker _ = []
-- | Map over indexed symbols.
--
-- @withSubglyphs [0,2] (scale 2) (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2])
-- = mkGroup [scale 2 (mkCircle 1), mkRect 2, scale 2 (mkEllipse 1 2)]@
withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree
withSubglyphs target fn = \t -> evalState (worker t) 0
where
worker :: Tree -> State Int Tree
worker t =
case t of
GroupTree g -> do
cs <- mapM worker (g ^. groupChildren)
return $ GroupTree $ g & groupChildren .~ cs
PathTree{} -> handleGlyph t
CircleTree{} -> handleGlyph t
PolyLineTree{} -> handleGlyph t
PolygonTree{} -> handleGlyph t
EllipseTree{} -> handleGlyph t
LineTree{} -> handleGlyph t
RectangleTree{} -> handleGlyph t
_ -> return t
handleGlyph :: Tree -> State Int Tree
handleGlyph svg = do
n <- get <* modify (+1)
if n `elem` target
then return $ fn svg
else return svg
-- | Split symbols.
--
-- @splitGlyphs [0,2] (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2])
-- = ([mkRect 2], [mkCircle 1, mkEllipse 1 2])@
splitGlyphs :: [Int] -> Tree -> (Tree, Tree)
splitGlyphs target = \t ->
let (_, l, r) = execState (worker id t) (0, [], [])
in (mkGroup l, mkGroup r)
where
handleGlyph :: Tree -> State (Int, [Tree], [Tree]) ()
handleGlyph t = do
(n, l, r) <- get
if n `elem` target
then put (n+1, l, t:r)
else put (n+1, t:l, r)
worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) ()
worker acc t =
case t of
GroupTree g -> do
let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
mapM_ (worker acc') (g ^. groupChildren)
PathTree{} -> handleGlyph $ acc t
CircleTree{} -> handleGlyph $ acc t
PolyLineTree{} -> handleGlyph $ acc t
PolygonTree{} -> handleGlyph $ acc t
EllipseTree{} -> handleGlyph $ acc t
LineTree{} -> handleGlyph $ acc t
RectangleTree{} -> handleGlyph $ acc t
DefinitionTree{} -> return ()
_ ->
modify $ \(n, l, r) -> (n, acc t:l, r)
{-
[ (\svg -> svg, )
, (\svg -> svg, )]
-}
-- | Split symbols and include their context and drawing attributes.
svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)]
svgGlyphs = worker id defaultSvg
where
worker acc attr =
\case
None -> []
GroupTree g ->
let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
attr' = (g^.drawAttributes) `mappend` attr
in concatMap (worker acc' attr') (g ^. groupChildren)
t -> [(acc, (t^.drawAttributes) `mappend` attr, t)]
{-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or
'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being
drawn progressively with 'partialSvg'.
Example:
> pathifyExample :: Animation
> pathifyExample = animate $ \t -> gridLayout
> [ [ partialSvg t $ pathify $ mkCircle 1
> , partialSvg t $ pathify $ mkRect 2 2
> ]
> , [ partialSvg t $ pathify $ mkEllipse 1 0.5
> , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1)
> ]
> ]
<>
-}
pathify :: Tree -> Tree
pathify = mapTree worker
where
worker =
\case
RectangleTree rect | Just (x,y,w,h) <- unpackRect rect ->
PathTree $ defaultSvg
& drawAttributes .~ rect ^. drawAttributes
& strokeLineCap .~ pure CapSquare
& pathDefinition .~
[MoveTo OriginAbsolute [V2 x y]
,HorizontalTo OriginRelative [w]
,VerticalTo OriginRelative [h]
,HorizontalTo OriginRelative [-w]
,EndPath ]
LineTree line | Just (x1,y1, x2, y2) <- unpackLine line ->
PathTree $ defaultSvg
& drawAttributes .~ line ^. drawAttributes
& pathDefinition .~
[MoveTo OriginAbsolute [V2 x1 y1]
,LineTo OriginAbsolute [V2 x2 y2] ]
CircleTree circ | Just (x, y, r) <- unpackCircle circ ->
PathTree $ defaultSvg
& drawAttributes .~ circ ^. drawAttributes
& pathDefinition .~
[MoveTo OriginAbsolute [V2 (x-r) y]
,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0)
,(r, r, 0,True,False,V2 (-r*2) 0)]]
PolyLineTree pl ->
let points = pl ^. polyLinePoints
in PathTree $ defaultSvg
& drawAttributes .~ pl ^. drawAttributes
& pathDefinition .~ pointsToPathCommands points
PolygonTree pg ->
let points = pg ^. polygonPoints
in PathTree $ defaultSvg
& drawAttributes .~ pg ^. drawAttributes
-- Polygon automatically connects the last point to the first. For path we must do
-- it explicitly
& pathDefinition .~ (pointsToPathCommands points ++ [EndPath])
EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip ->
PathTree $ defaultSvg
& drawAttributes .~ elip ^. drawAttributes
& pathDefinition .~
[ MoveTo OriginAbsolute [V2 (cx-rx) cy]
, EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0)
,(rx, ry, 0,True,False,V2 (-rx*2) 0)]]
t -> t
unpackCircle circ = do
let (x,y) = circ ^. circleCenter
liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius)
unpackEllipse elip = do
let (x,y) = elip ^. ellipseCenter
liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius)
(unpackNumber $ elip ^. ellipseYRadius)
unpackLine line = do
let (x1,y1) = line ^. linePoint1
(x2,y2) = line ^. linePoint2
liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2)
unpackRect rect = do
let (x', y') = rect ^. rectUpperLeftCorner
x <- unpackNumber x'
y <- unpackNumber y'
w <- unpackNumber =<< rect ^. rectWidth
h <- unpackNumber =<< rect ^. rectHeight
return (x,y,w,h)
pointsToPathCommands points = case points of
[] -> []
(p:ps) -> [ MoveTo OriginAbsolute [p]
, LineTo OriginAbsolute ps ]
unpackNumber n =
case toUserUnit defaultDPI n of
Num d -> Just d
_ -> Nothing
-- | Map over all recursively-found path commands.
mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG
mapSvgPaths fn = mapTree worker
where
worker =
\case
PathTree path -> PathTree $
path & pathDefinition %~ fn
t -> t
-- | Map over all recursively-found line commands.
mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG
mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands)
-- Only maps points in paths
-- | Map over all line command control points.
mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG
mapSvgPoints fn = mapSvgLines (map worker)
where
worker (LineMove p) = LineMove (fn p)
worker (LineBezier ps) = LineBezier (map fn ps)
worker (LineEnd p) = LineEnd (fn p)
-- | Convert coordinate system from degrees to radians.
svgPointsToRadians :: SVG -> SVG
svgPointsToRadians = mapSvgPoints worker
where
worker (V2 x y) = V2 (x/180*pi) (y/180*pi)