{-# 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
import           Linear.V2                  (V2 (V2))
import           Reanimate.Animation        (SVG)
import           Reanimate.Constants        (defaultDPI)
import           Reanimate.Svg.BoundingBox  (boundingBox, svgHeight, svgWidth)
import           Reanimate.Svg.Constructors
import           Reanimate.Svg.LineCommand
import           Reanimate.Svg.Unuse        (embedDocument, replaceUses, unbox, unboxFit)
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 :: SVG -> SVG
lowerTransformations :: SVG -> SVG
lowerTransformations = Bool -> Matrix Coord -> SVG -> SVG
worker Bool
False Matrix Coord
Transform.identity
  where
    updLineCmd :: Matrix Coord -> LineCommand -> LineCommand
updLineCmd Matrix Coord
m LineCommand
cmd =
      case LineCommand
cmd of
        LineMove RPoint
p    -> RPoint -> LineCommand
LineMove (RPoint -> LineCommand) -> RPoint -> LineCommand
forall a b. (a -> b) -> a -> b
$ Matrix Coord -> RPoint -> RPoint
Transform.transformPoint Matrix Coord
m RPoint
p
        -- LineDraw p -> LineDraw $ Transform.transformPoint m p
        LineBezier [RPoint]
ps -> [RPoint] -> LineCommand
LineBezier ([RPoint] -> LineCommand) -> [RPoint] -> LineCommand
forall a b. (a -> b) -> a -> b
$ (RPoint -> RPoint) -> [RPoint] -> [RPoint]
forall a b. (a -> b) -> [a] -> [b]
map (Matrix Coord -> RPoint -> RPoint
Transform.transformPoint Matrix Coord
m) [RPoint]
ps
        LineEnd RPoint
p     -> RPoint -> LineCommand
LineEnd (RPoint -> LineCommand) -> RPoint -> LineCommand
forall a b. (a -> b) -> a -> b
$ Matrix Coord -> RPoint -> RPoint
Transform.transformPoint Matrix Coord
m RPoint
p
    updPath :: Matrix Coord -> [PathCommand] -> [PathCommand]
updPath Matrix Coord
m = [LineCommand] -> [PathCommand]
lineToPath ([LineCommand] -> [PathCommand])
-> ([PathCommand] -> [LineCommand])
-> [PathCommand]
-> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineCommand -> LineCommand) -> [LineCommand] -> [LineCommand]
forall a b. (a -> b) -> [a] -> [b]
map (Matrix Coord -> LineCommand -> LineCommand
updLineCmd Matrix Coord
m) ([LineCommand] -> [LineCommand])
-> ([PathCommand] -> [LineCommand])
-> [PathCommand]
-> [LineCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathCommand] -> [LineCommand]
toLineCommands
    updPoint :: Matrix Coord -> (Number, Number) -> (Number, Number)
updPoint Matrix Coord
m (Num Coord
a,Num Coord
b) =
      case Matrix Coord -> RPoint -> RPoint
Transform.transformPoint Matrix Coord
m (Coord -> Coord -> RPoint
forall a. a -> a -> V2 a
V2 Coord
a Coord
b) of
        V2 Coord
x Coord
y -> (Coord -> Number
Num Coord
x, Coord -> Number
Num Coord
y)
    updPoint Matrix Coord
_ (Number, Number)
other = (Number, Number)
other -- XXX: Can we do better here?
    worker :: Bool -> Matrix Coord -> SVG -> SVG
worker Bool
hasPathified Matrix Coord
m SVG
t =
      let m' :: Matrix Coord
m' = Matrix Coord
m Matrix Coord -> Matrix Coord -> Matrix Coord
forall a. Num a => a -> a -> a
* Maybe [Transformation] -> Matrix Coord
Transform.mkMatrix (SVG
tSVG
-> Getting (Maybe [Transformation]) SVG (Maybe [Transformation])
-> Maybe [Transformation]
forall s a. s -> Getting a s a -> a
^.Getting (Maybe [Transformation]) SVG (Maybe [Transformation])
forall c. HasDrawAttributes c => Lens' c (Maybe [Transformation])
transform) in
      case SVG
t of
        PathTree Path
path -> Path -> SVG
PathTree (Path -> SVG) -> Path -> SVG
forall a b. (a -> b) -> a -> b
$
          Path
path Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& ([PathCommand] -> Identity [PathCommand]) -> Path -> Identity Path
Lens' Path [PathCommand]
pathDefinition (([PathCommand] -> Identity [PathCommand])
 -> Path -> Identity Path)
-> ([PathCommand] -> [PathCommand]) -> Path -> Path
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Matrix Coord -> [PathCommand] -> [PathCommand]
updPath Matrix Coord
m'
               Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& (Maybe [Transformation] -> Identity (Maybe [Transformation]))
-> Path -> Identity Path
forall c. HasDrawAttributes c => Lens' c (Maybe [Transformation])
transform ((Maybe [Transformation] -> Identity (Maybe [Transformation]))
 -> Path -> Identity Path)
-> Maybe [Transformation] -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe [Transformation]
forall a. Maybe a
Nothing
        GroupTree Group
g -> Group -> SVG
GroupTree (Group -> SVG) -> Group -> SVG
forall a b. (a -> b) -> a -> b
$
          Group
g Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([SVG] -> Identity [SVG]) -> Group -> Identity Group
Lens' Group [SVG]
groupChildren (([SVG] -> Identity [SVG]) -> Group -> Identity Group)
-> ([SVG] -> [SVG]) -> Group -> Group
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (SVG -> SVG) -> [SVG] -> [SVG]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Matrix Coord -> SVG -> SVG
worker Bool
hasPathified Matrix Coord
m')
            Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& (Maybe [Transformation] -> Identity (Maybe [Transformation]))
-> Group -> Identity Group
forall c. HasDrawAttributes c => Lens' c (Maybe [Transformation])
transform ((Maybe [Transformation] -> Identity (Maybe [Transformation]))
 -> Group -> Identity Group)
-> Maybe [Transformation] -> Group -> Group
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe [Transformation]
forall a. Maybe a
Nothing
        LineTree Line
line ->
          Line -> SVG
LineTree (Line -> SVG) -> Line -> SVG
forall a b. (a -> b) -> a -> b
$
            Line
line Line -> (Line -> Line) -> Line
forall a b. a -> (a -> b) -> b
& ((Number, Number) -> Identity (Number, Number))
-> Line -> Identity Line
Lens' Line (Number, Number)
linePoint1 (((Number, Number) -> Identity (Number, Number))
 -> Line -> Identity Line)
-> ((Number, Number) -> (Number, Number)) -> Line -> Line
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Matrix Coord -> (Number, Number) -> (Number, Number)
updPoint Matrix Coord
m
                 Line -> (Line -> Line) -> Line
forall a b. a -> (a -> b) -> b
& ((Number, Number) -> Identity (Number, Number))
-> Line -> Identity Line
Lens' Line (Number, Number)
linePoint2 (((Number, Number) -> Identity (Number, Number))
 -> Line -> Identity Line)
-> ((Number, Number) -> (Number, Number)) -> Line -> Line
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Matrix Coord -> (Number, Number) -> (Number, Number)
updPoint Matrix Coord
m
        ClipPathTree{} -> SVG
t
        DefinitionTree{} -> SVG
t
        -- If we encounter an unknown node and we've already tried to convert
        -- to paths, give up and insert an explicit transformation.
        SVG
_ | Bool
hasPathified ->
          [SVG] -> SVG
mkGroup [SVG
t] SVG -> (SVG -> SVG) -> SVG
forall a b. a -> (a -> b) -> b
& (Maybe [Transformation] -> Identity (Maybe [Transformation]))
-> SVG -> Identity SVG
forall c. HasDrawAttributes c => Lens' c (Maybe [Transformation])
transform ((Maybe [Transformation] -> Identity (Maybe [Transformation]))
 -> SVG -> Identity SVG)
-> [Transformation] -> SVG -> SVG
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [ Matrix Coord -> Transformation
Transform.toTransformation Matrix Coord
m ]
        -- If we haven't tried to pathify, run pathify only once.
        SVG
_ -> Bool -> Matrix Coord -> SVG -> SVG
worker Bool
True Matrix Coord
m (SVG -> SVG
pathify SVG
t)

-- | Remove all @id@ attributes.
lowerIds :: SVG -> SVG
lowerIds :: SVG -> SVG
lowerIds = (SVG -> SVG) -> SVG -> SVG
mapTree SVG -> SVG
worker
  where
    worker :: SVG -> SVG
worker t :: SVG
t@GroupTree{} = SVG
t SVG -> (SVG -> SVG) -> SVG
forall a b. a -> (a -> b) -> b
& (Maybe String -> Identity (Maybe String)) -> SVG -> Identity SVG
forall c. HasDrawAttributes c => Lens' c (Maybe String)
attrId ((Maybe String -> Identity (Maybe String)) -> SVG -> Identity SVG)
-> Maybe String -> SVG -> SVG
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe String
forall a. Maybe a
Nothing
    worker t :: SVG
t@PathTree{}  = SVG
t SVG -> (SVG -> SVG) -> SVG
forall a b. a -> (a -> b) -> b
& (Maybe String -> Identity (Maybe String)) -> SVG -> Identity SVG
forall c. HasDrawAttributes c => Lens' c (Maybe String)
attrId ((Maybe String -> Identity (Maybe String)) -> SVG -> Identity SVG)
-> Maybe String -> SVG -> SVG
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe String
forall a. Maybe a
Nothing
    worker SVG
t             = SVG
t

-- | Remove all draw attributes such as 'stroke', 'fill' and 'fill-opacity'.
clearDrawAttributes :: SVG -> SVG
clearDrawAttributes :: SVG -> SVG
clearDrawAttributes = (SVG -> SVG) -> SVG -> SVG
mapTree SVG -> SVG
forall b. HasDrawAttributes b => b -> b
worker
  where
    worker :: b -> b
worker b
t = b
t b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes) -> b -> Identity b
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes) -> b -> Identity b)
-> DrawAttributes -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DrawAttributes
forall a. WithDefaultSvg a => a
defaultSvg

-- | Optimize SVG tree without affecting how it is rendered.
simplify :: SVG -> SVG
simplify :: SVG -> SVG
simplify SVG
root =
  case SVG -> [SVG]
worker SVG
root of
    []  -> SVG
None
    [SVG
x] -> SVG
x
    [SVG]
xs  -> [SVG] -> SVG
mkGroup [SVG]
xs
  where
    worker :: SVG -> [SVG]
worker SVG
None = []
    worker (DefinitionTree Group
d) =
      (SVG -> [SVG]) -> [SVG] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SVG -> [SVG]
dropNulls
      [Group -> SVG
DefinitionTree (Group -> SVG) -> Group -> SVG
forall a b. (a -> b) -> a -> b
$ Group
d Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([SVG] -> Identity [SVG]) -> Group -> Identity Group
Lens' Group [SVG]
groupChildren (([SVG] -> Identity [SVG]) -> Group -> Identity Group)
-> ([SVG] -> [SVG]) -> Group -> Group
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (SVG -> [SVG]) -> [SVG] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SVG -> [SVG]
worker]
    worker (GroupTree Group
g)
      | Group
gGroup
-> Getting DrawAttributes Group DrawAttributes -> DrawAttributes
forall s a. s -> Getting a s a -> a
^.Getting DrawAttributes Group DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes DrawAttributes -> DrawAttributes -> Bool
forall a. Eq a => a -> a -> Bool
== DrawAttributes
forall a. WithDefaultSvg a => a
defaultSvg =
        (SVG -> [SVG]) -> [SVG] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SVG -> [SVG]
dropNulls ([SVG] -> [SVG]) -> [SVG] -> [SVG]
forall a b. (a -> b) -> a -> b
$
        (SVG -> [SVG]) -> [SVG] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SVG -> [SVG]
worker (Group
gGroup -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^.Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren)
      | Bool
otherwise =
        SVG -> [SVG]
dropNulls (SVG -> [SVG]) -> SVG -> [SVG]
forall a b. (a -> b) -> a -> b
$
        Group -> SVG
GroupTree (Group -> SVG) -> Group -> SVG
forall a b. (a -> b) -> a -> b
$ Group
g Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([SVG] -> Identity [SVG]) -> Group -> Identity Group
Lens' Group [SVG]
groupChildren (([SVG] -> Identity [SVG]) -> Group -> Identity Group)
-> ([SVG] -> [SVG]) -> Group -> Group
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (SVG -> [SVG]) -> [SVG] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SVG -> [SVG]
worker
    worker SVG
t = SVG -> [SVG]
dropNulls SVG
t

    dropNulls :: SVG -> [SVG]
dropNulls SVG
None = []
    dropNulls (DefinitionTree Group
d)
      | [SVG] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Group
dGroup -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^.Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren) = []
    dropNulls (GroupTree Group
g)
      | [SVG] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Group
gGroup -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^.Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren) = []
    dropNulls SVG
t = [SVG
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 :: SVG -> [SVG]
removeGroups :: SVG -> [SVG]
removeGroups = DrawAttributes -> SVG -> [SVG]
worker DrawAttributes
forall a. WithDefaultSvg a => a
defaultSvg
  where
    worker :: DrawAttributes -> SVG -> [SVG]
worker DrawAttributes
_attr SVG
None = []
    worker DrawAttributes
_attr (DefinitionTree Group
d) =
      (SVG -> [SVG]) -> [SVG] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SVG -> [SVG]
dropNulls
      [Group -> SVG
DefinitionTree (Group -> SVG) -> Group -> SVG
forall a b. (a -> b) -> a -> b
$ Group
d Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([SVG] -> Identity [SVG]) -> Group -> Identity Group
Lens' Group [SVG]
groupChildren (([SVG] -> Identity [SVG]) -> Group -> Identity Group)
-> ([SVG] -> [SVG]) -> Group -> Group
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (SVG -> [SVG]) -> [SVG] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DrawAttributes -> SVG -> [SVG]
worker DrawAttributes
forall a. WithDefaultSvg a => a
defaultSvg)]
    worker DrawAttributes
attr (GroupTree Group
g)
      | Group
gGroup
-> Getting DrawAttributes Group DrawAttributes -> DrawAttributes
forall s a. s -> Getting a s a -> a
^.Getting DrawAttributes Group DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes DrawAttributes -> DrawAttributes -> Bool
forall a. Eq a => a -> a -> Bool
== DrawAttributes
forall a. WithDefaultSvg a => a
defaultSvg =
        (SVG -> [SVG]) -> [SVG] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SVG -> [SVG]
dropNulls ([SVG] -> [SVG]) -> [SVG] -> [SVG]
forall a b. (a -> b) -> a -> b
$
        (SVG -> [SVG]) -> [SVG] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DrawAttributes -> SVG -> [SVG]
worker DrawAttributes
attr) (Group
gGroup -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^.Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren)
      | Bool
otherwise =
        (SVG -> [SVG]) -> [SVG] -> [SVG]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DrawAttributes -> SVG -> [SVG]
worker (DrawAttributes
attr DrawAttributes -> DrawAttributes -> DrawAttributes
forall a. Semigroup a => a -> a -> a
<> Group
gGroup
-> Getting DrawAttributes Group DrawAttributes -> DrawAttributes
forall s a. s -> Getting a s a -> a
^.Getting DrawAttributes Group DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes)) (Group
gGroup -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^.Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren)
    worker DrawAttributes
attr SVG
t = SVG -> [SVG]
dropNulls (SVG
t SVG -> (SVG -> SVG) -> SVG
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes) -> SVG -> Identity SVG
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes)
 -> SVG -> Identity SVG)
-> DrawAttributes -> SVG -> SVG
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DrawAttributes
attr)

    dropNulls :: SVG -> [SVG]
dropNulls SVG
None = []
    dropNulls (DefinitionTree Group
d)
      | [SVG] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Group
dGroup -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^.Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren) = []
    dropNulls (GroupTree Group
g)
      | [SVG] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Group
gGroup -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^.Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren) = []
    dropNulls SVG
t = [SVG
t]

-- | Extract all path commands from a node (and its children) and concatenate them.
extractPath :: SVG -> [PathCommand]
extractPath :: SVG -> [PathCommand]
extractPath = SVG -> [PathCommand]
worker (SVG -> [PathCommand]) -> (SVG -> SVG) -> SVG -> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SVG -> SVG
simplify (SVG -> SVG) -> (SVG -> SVG) -> SVG -> SVG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SVG -> SVG
lowerTransformations (SVG -> SVG) -> (SVG -> SVG) -> SVG -> SVG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SVG -> SVG
pathify
  where
    worker :: SVG -> [PathCommand]
worker (GroupTree Group
g) = (SVG -> [PathCommand]) -> [SVG] -> [PathCommand]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SVG -> [PathCommand]
worker (Group
gGroup -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^.Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren)
    worker (PathTree Path
p)  = Path
pPath -> Getting [PathCommand] Path [PathCommand] -> [PathCommand]
forall s a. s -> Getting a s a -> a
^.Getting [PathCommand] Path [PathCommand]
Lens' Path [PathCommand]
pathDefinition
    worker SVG
_             = []

-- | 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] -> (SVG -> SVG) -> SVG -> SVG
withSubglyphs :: [Int] -> (SVG -> SVG) -> SVG -> SVG
withSubglyphs [Int]
target SVG -> SVG
fn = \SVG
t -> State Int SVG -> Int -> SVG
forall s a. State s a -> s -> a
evalState (SVG -> State Int SVG
worker SVG
t) Int
0
  where
    worker :: Tree -> State Int Tree
    worker :: SVG -> State Int SVG
worker SVG
t =
      case SVG
t of
        GroupTree Group
g -> do
          [SVG]
cs <- (SVG -> State Int SVG) -> [SVG] -> StateT Int Identity [SVG]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SVG -> State Int SVG
worker (Group
g Group -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^. Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren)
          SVG -> State Int SVG
forall (m :: * -> *) a. Monad m => a -> m a
return (SVG -> State Int SVG) -> SVG -> State Int SVG
forall a b. (a -> b) -> a -> b
$ Group -> SVG
GroupTree (Group -> SVG) -> Group -> SVG
forall a b. (a -> b) -> a -> b
$ Group
g Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([SVG] -> Identity [SVG]) -> Group -> Identity Group
Lens' Group [SVG]
groupChildren (([SVG] -> Identity [SVG]) -> Group -> Identity Group)
-> [SVG] -> Group -> Group
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [SVG]
cs
        PathTree{} -> SVG -> State Int SVG
handleGlyph SVG
t
        CircleTree{} -> SVG -> State Int SVG
handleGlyph SVG
t
        PolyLineTree{} -> SVG -> State Int SVG
handleGlyph SVG
t
        PolygonTree{} -> SVG -> State Int SVG
handleGlyph SVG
t
        EllipseTree{} -> SVG -> State Int SVG
handleGlyph SVG
t
        LineTree{} -> SVG -> State Int SVG
handleGlyph SVG
t
        RectangleTree{} -> SVG -> State Int SVG
handleGlyph SVG
t
        SVG
_ -> SVG -> State Int SVG
forall (m :: * -> *) a. Monad m => a -> m a
return SVG
t
    handleGlyph :: Tree -> State Int Tree
    handleGlyph :: SVG -> State Int SVG
handleGlyph SVG
svg = do
      Int
n <- StateT Int Identity Int
forall s (m :: * -> *). MonadState s m => m s
get StateT Int Identity Int
-> StateT Int Identity () -> StateT Int Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Int -> Int) -> StateT Int Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
      if Int
n Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
target
        then SVG -> State Int SVG
forall (m :: * -> *) a. Monad m => a -> m a
return (SVG -> State Int SVG) -> SVG -> State Int SVG
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
fn SVG
svg
        else SVG -> State Int SVG
forall (m :: * -> *) a. Monad m => a -> m a
return SVG
svg

-- | Split symbols.
--
--   @splitGlyphs [0,2] (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2])
--      = ([mkRect 2], [mkCircle 1, mkEllipse 1 2])@
splitGlyphs :: [Int] -> SVG -> (SVG, SVG)
splitGlyphs :: [Int] -> SVG -> (SVG, SVG)
splitGlyphs [Int]
target = \SVG
t ->
    let (Int
_, [SVG]
l, [SVG]
r) = State (Int, [SVG], [SVG]) ()
-> (Int, [SVG], [SVG]) -> (Int, [SVG], [SVG])
forall s a. State s a -> s -> s
execState ((SVG -> SVG) -> SVG -> State (Int, [SVG], [SVG]) ()
worker SVG -> SVG
forall a. a -> a
id SVG
t) (Int
0, [], [])
    in ([SVG] -> SVG
mkGroup [SVG]
l, [SVG] -> SVG
mkGroup [SVG]
r)
  where
    handleGlyph :: SVG -> State (Int, [SVG], [SVG]) ()
    handleGlyph :: SVG -> State (Int, [SVG], [SVG]) ()
handleGlyph SVG
t = do
      (Int
n, [SVG]
l, [SVG]
r) <- StateT (Int, [SVG], [SVG]) Identity (Int, [SVG], [SVG])
forall s (m :: * -> *). MonadState s m => m s
get
      if Int
n Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
target
        then (Int, [SVG], [SVG]) -> State (Int, [SVG], [SVG]) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, [SVG]
l, SVG
tSVG -> [SVG] -> [SVG]
forall a. a -> [a] -> [a]
:[SVG]
r)
        else (Int, [SVG], [SVG]) -> State (Int, [SVG], [SVG]) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, SVG
tSVG -> [SVG] -> [SVG]
forall a. a -> [a] -> [a]
:[SVG]
l, [SVG]
r)
    worker :: (SVG -> SVG) -> SVG -> State (Int, [SVG], [SVG]) ()
    worker :: (SVG -> SVG) -> SVG -> State (Int, [SVG], [SVG]) ()
worker SVG -> SVG
acc SVG
t =
      case SVG
t of
        GroupTree Group
g -> do
          let acc' :: SVG -> SVG
acc' SVG
sub = SVG -> SVG
acc (Group -> SVG
GroupTree (Group -> SVG) -> Group -> SVG
forall a b. (a -> b) -> a -> b
$ Group
g Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([SVG] -> Identity [SVG]) -> Group -> Identity Group
Lens' Group [SVG]
groupChildren (([SVG] -> Identity [SVG]) -> Group -> Identity Group)
-> [SVG] -> Group -> Group
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [SVG
sub])
          (SVG -> State (Int, [SVG], [SVG]) ())
-> [SVG] -> State (Int, [SVG], [SVG]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SVG -> SVG) -> SVG -> State (Int, [SVG], [SVG]) ()
worker SVG -> SVG
acc') (Group
g Group -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^. Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren)
        PathTree{} -> SVG -> State (Int, [SVG], [SVG]) ()
handleGlyph (SVG -> State (Int, [SVG], [SVG]) ())
-> SVG -> State (Int, [SVG], [SVG]) ()
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
acc SVG
t
        CircleTree{} -> SVG -> State (Int, [SVG], [SVG]) ()
handleGlyph (SVG -> State (Int, [SVG], [SVG]) ())
-> SVG -> State (Int, [SVG], [SVG]) ()
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
acc SVG
t
        PolyLineTree{} -> SVG -> State (Int, [SVG], [SVG]) ()
handleGlyph (SVG -> State (Int, [SVG], [SVG]) ())
-> SVG -> State (Int, [SVG], [SVG]) ()
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
acc SVG
t
        PolygonTree{} -> SVG -> State (Int, [SVG], [SVG]) ()
handleGlyph (SVG -> State (Int, [SVG], [SVG]) ())
-> SVG -> State (Int, [SVG], [SVG]) ()
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
acc SVG
t
        EllipseTree{} -> SVG -> State (Int, [SVG], [SVG]) ()
handleGlyph (SVG -> State (Int, [SVG], [SVG]) ())
-> SVG -> State (Int, [SVG], [SVG]) ()
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
acc SVG
t
        LineTree{} -> SVG -> State (Int, [SVG], [SVG]) ()
handleGlyph (SVG -> State (Int, [SVG], [SVG]) ())
-> SVG -> State (Int, [SVG], [SVG]) ()
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
acc SVG
t
        RectangleTree{} -> SVG -> State (Int, [SVG], [SVG]) ()
handleGlyph (SVG -> State (Int, [SVG], [SVG]) ())
-> SVG -> State (Int, [SVG], [SVG]) ()
forall a b. (a -> b) -> a -> b
$ SVG -> SVG
acc SVG
t
        DefinitionTree{} -> () -> State (Int, [SVG], [SVG]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        SVG
_ ->
          ((Int, [SVG], [SVG]) -> (Int, [SVG], [SVG]))
-> State (Int, [SVG], [SVG]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Int, [SVG], [SVG]) -> (Int, [SVG], [SVG]))
 -> State (Int, [SVG], [SVG]) ())
-> ((Int, [SVG], [SVG]) -> (Int, [SVG], [SVG]))
-> State (Int, [SVG], [SVG]) ()
forall a b. (a -> b) -> a -> b
$ \(Int
n, [SVG]
l, [SVG]
r) -> (Int
n, SVG -> SVG
acc SVG
tSVG -> [SVG] -> [SVG]
forall a. a -> [a] -> [a]
:[SVG]
l, [SVG]
r)
{-
<g transform="translate(10,10)">
  <g transform="scale(2)">
    <circle/>
  </g>
  <g transform="scale(0.5)">
    <rect/>
  </g>
</g>

[ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>)
, (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)]
-}
-- | Split symbols and include their context and drawing attributes.
svgGlyphs :: SVG -> [(SVG -> SVG, DrawAttributes, SVG)]
svgGlyphs :: SVG -> [(SVG -> SVG, DrawAttributes, SVG)]
svgGlyphs = (SVG -> SVG)
-> DrawAttributes -> SVG -> [(SVG -> SVG, DrawAttributes, SVG)]
forall t.
(SVG -> t)
-> DrawAttributes -> SVG -> [(SVG -> t, DrawAttributes, SVG)]
worker SVG -> SVG
forall a. a -> a
id DrawAttributes
forall a. WithDefaultSvg a => a
defaultSvg
  where
    worker :: (SVG -> t)
-> DrawAttributes -> SVG -> [(SVG -> t, DrawAttributes, SVG)]
worker SVG -> t
acc DrawAttributes
attr =
      \case
        SVG
None -> []
        GroupTree Group
g ->
          let acc' :: SVG -> t
acc' SVG
sub = SVG -> t
acc (Group -> SVG
GroupTree (Group -> SVG) -> Group -> SVG
forall a b. (a -> b) -> a -> b
$ Group
g Group -> (Group -> Group) -> Group
forall a b. a -> (a -> b) -> b
& ([SVG] -> Identity [SVG]) -> Group -> Identity Group
Lens' Group [SVG]
groupChildren (([SVG] -> Identity [SVG]) -> Group -> Identity Group)
-> [SVG] -> Group -> Group
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [SVG
sub])
              attr' :: DrawAttributes
attr' = (Group
gGroup
-> Getting DrawAttributes Group DrawAttributes -> DrawAttributes
forall s a. s -> Getting a s a -> a
^.Getting DrawAttributes Group DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes) DrawAttributes -> DrawAttributes -> DrawAttributes
forall a. Monoid a => a -> a -> a
`mappend` DrawAttributes
attr
          in (SVG -> [(SVG -> t, DrawAttributes, SVG)])
-> [SVG] -> [(SVG -> t, DrawAttributes, SVG)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((SVG -> t)
-> DrawAttributes -> SVG -> [(SVG -> t, DrawAttributes, SVG)]
worker SVG -> t
acc' DrawAttributes
attr') (Group
g Group -> Getting [SVG] Group [SVG] -> [SVG]
forall s a. s -> Getting a s a -> a
^. Getting [SVG] Group [SVG]
Lens' Group [SVG]
groupChildren)
        SVG
t -> [(SVG -> t
acc, (SVG
tSVG -> Getting DrawAttributes SVG DrawAttributes -> DrawAttributes
forall s a. s -> Getting a s a -> a
^.Getting DrawAttributes SVG DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes) DrawAttributes -> DrawAttributes -> DrawAttributes
forall a. Monoid a => a -> a -> a
`mappend` DrawAttributes
attr, SVG
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)
    >       ]
    >     ]

    <<docs/gifs/doc_pathify.gif>>
 -}
pathify :: SVG -> SVG
pathify :: SVG -> SVG
pathify = (SVG -> SVG) -> SVG -> SVG
mapTree SVG -> SVG
worker
  where
    worker :: SVG -> SVG
worker =
      \case
        RectangleTree Rectangle
rect | Just (Coord
x,Coord
y,Coord
w,Coord
h) <- Rectangle -> Maybe (Coord, Coord, Coord, Coord)
unpackRect Rectangle
rect ->
          Path -> SVG
PathTree (Path -> SVG) -> Path -> SVG
forall a b. (a -> b) -> a -> b
$ Path
forall a. WithDefaultSvg a => a
defaultSvg
            Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes)
-> Path -> Identity Path
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes)
 -> Path -> Identity Path)
-> DrawAttributes -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Rectangle
rect Rectangle
-> Getting DrawAttributes Rectangle DrawAttributes
-> DrawAttributes
forall s a. s -> Getting a s a -> a
^. Getting DrawAttributes Rectangle DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes
            Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& (Last Cap -> Identity (Last Cap)) -> Path -> Identity Path
forall c. HasDrawAttributes c => Lens' c (Last Cap)
strokeLineCap ((Last Cap -> Identity (Last Cap)) -> Path -> Identity Path)
-> Last Cap -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Cap -> Last Cap
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cap
CapSquare
            Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& ([PathCommand] -> Identity [PathCommand]) -> Path -> Identity Path
Lens' Path [PathCommand]
pathDefinition (([PathCommand] -> Identity [PathCommand])
 -> Path -> Identity Path)
-> [PathCommand] -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~
              [Origin -> [RPoint] -> PathCommand
MoveTo Origin
OriginAbsolute [Coord -> Coord -> RPoint
forall a. a -> a -> V2 a
V2 Coord
x Coord
y]
              ,Origin -> [Coord] -> PathCommand
HorizontalTo Origin
OriginRelative [Coord
w]
              ,Origin -> [Coord] -> PathCommand
VerticalTo Origin
OriginRelative [Coord
h]
              ,Origin -> [Coord] -> PathCommand
HorizontalTo Origin
OriginRelative [-Coord
w]
              ,PathCommand
EndPath ]
        LineTree Line
line | Just (Coord
x1,Coord
y1, Coord
x2, Coord
y2) <- Line -> Maybe (Coord, Coord, Coord, Coord)
unpackLine Line
line ->
          Path -> SVG
PathTree (Path -> SVG) -> Path -> SVG
forall a b. (a -> b) -> a -> b
$ Path
forall a. WithDefaultSvg a => a
defaultSvg
            Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes)
-> Path -> Identity Path
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes)
 -> Path -> Identity Path)
-> DrawAttributes -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Line
line Line
-> Getting DrawAttributes Line DrawAttributes -> DrawAttributes
forall s a. s -> Getting a s a -> a
^. Getting DrawAttributes Line DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes
            Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& ([PathCommand] -> Identity [PathCommand]) -> Path -> Identity Path
Lens' Path [PathCommand]
pathDefinition (([PathCommand] -> Identity [PathCommand])
 -> Path -> Identity Path)
-> [PathCommand] -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~
              [Origin -> [RPoint] -> PathCommand
MoveTo Origin
OriginAbsolute [Coord -> Coord -> RPoint
forall a. a -> a -> V2 a
V2 Coord
x1 Coord
y1]
              ,Origin -> [RPoint] -> PathCommand
LineTo Origin
OriginAbsolute [Coord -> Coord -> RPoint
forall a. a -> a -> V2 a
V2 Coord
x2 Coord
y2] ]
        CircleTree Circle
circ | Just (Coord
x, Coord
y, Coord
r) <- Circle -> Maybe (Coord, Coord, Coord)
unpackCircle Circle
circ ->
          Path -> SVG
PathTree (Path -> SVG) -> Path -> SVG
forall a b. (a -> b) -> a -> b
$ Path
forall a. WithDefaultSvg a => a
defaultSvg
            Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes)
-> Path -> Identity Path
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes)
 -> Path -> Identity Path)
-> DrawAttributes -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Circle
circ Circle
-> Getting DrawAttributes Circle DrawAttributes -> DrawAttributes
forall s a. s -> Getting a s a -> a
^. Getting DrawAttributes Circle DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes
            Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& ([PathCommand] -> Identity [PathCommand]) -> Path -> Identity Path
Lens' Path [PathCommand]
pathDefinition (([PathCommand] -> Identity [PathCommand])
 -> Path -> Identity Path)
-> [PathCommand] -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~
              [Origin -> [RPoint] -> PathCommand
MoveTo Origin
OriginAbsolute [Coord -> Coord -> RPoint
forall a. a -> a -> V2 a
V2 (Coord
xCoord -> Coord -> Coord
forall a. Num a => a -> a -> a
-Coord
r) Coord
y]
              ,Origin
-> [(Coord, Coord, Coord, Bool, Bool, RPoint)] -> PathCommand
EllipticalArc Origin
OriginRelative [(Coord
r, Coord
r, Coord
0,Bool
True,Bool
False,Coord -> Coord -> RPoint
forall a. a -> a -> V2 a
V2 (Coord
rCoord -> Coord -> Coord
forall a. Num a => a -> a -> a
*Coord
2) Coord
0)
                                            ,(Coord
r, Coord
r, Coord
0,Bool
True,Bool
False,Coord -> Coord -> RPoint
forall a. a -> a -> V2 a
V2 (-Coord
rCoord -> Coord -> Coord
forall a. Num a => a -> a -> a
*Coord
2) Coord
0)]]
        PolyLineTree PolyLine
pl ->
          let points :: [RPoint]
points = PolyLine
pl PolyLine -> Getting [RPoint] PolyLine [RPoint] -> [RPoint]
forall s a. s -> Getting a s a -> a
^. Getting [RPoint] PolyLine [RPoint]
Lens' PolyLine [RPoint]
polyLinePoints
          in Path -> SVG
PathTree (Path -> SVG) -> Path -> SVG
forall a b. (a -> b) -> a -> b
$ Path
forall a. WithDefaultSvg a => a
defaultSvg
               Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes)
-> Path -> Identity Path
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes)
 -> Path -> Identity Path)
-> DrawAttributes -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyLine
pl PolyLine
-> Getting DrawAttributes PolyLine DrawAttributes -> DrawAttributes
forall s a. s -> Getting a s a -> a
^. Getting DrawAttributes PolyLine DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes
               Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& ([PathCommand] -> Identity [PathCommand]) -> Path -> Identity Path
Lens' Path [PathCommand]
pathDefinition (([PathCommand] -> Identity [PathCommand])
 -> Path -> Identity Path)
-> [PathCommand] -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [RPoint] -> [PathCommand]
pointsToPathCommands [RPoint]
points
        PolygonTree Polygon
pg ->
          let points :: [RPoint]
points = Polygon
pg Polygon -> Getting [RPoint] Polygon [RPoint] -> [RPoint]
forall s a. s -> Getting a s a -> a
^. Getting [RPoint] Polygon [RPoint]
Lens' Polygon [RPoint]
polygonPoints
          in Path -> SVG
PathTree (Path -> SVG) -> Path -> SVG
forall a b. (a -> b) -> a -> b
$ Path
forall a. WithDefaultSvg a => a
defaultSvg
               Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes)
-> Path -> Identity Path
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes)
 -> Path -> Identity Path)
-> DrawAttributes -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Polygon
pg Polygon
-> Getting DrawAttributes Polygon DrawAttributes -> DrawAttributes
forall s a. s -> Getting a s a -> a
^. Getting DrawAttributes Polygon DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes
               -- Polygon automatically connects the last point to the first. For path we must do
               -- it explicitly
               Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& ([PathCommand] -> Identity [PathCommand]) -> Path -> Identity Path
Lens' Path [PathCommand]
pathDefinition (([PathCommand] -> Identity [PathCommand])
 -> Path -> Identity Path)
-> [PathCommand] -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ([RPoint] -> [PathCommand]
pointsToPathCommands [RPoint]
points [PathCommand] -> [PathCommand] -> [PathCommand]
forall a. [a] -> [a] -> [a]
++ [PathCommand
EndPath])
        EllipseTree Ellipse
elip | Just (Coord
cx,Coord
cy,Coord
rx,Coord
ry) <- Ellipse -> Maybe (Coord, Coord, Coord, Coord)
unpackEllipse Ellipse
elip ->
          Path -> SVG
PathTree (Path -> SVG) -> Path -> SVG
forall a b. (a -> b) -> a -> b
$ Path
forall a. WithDefaultSvg a => a
defaultSvg
             Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes)
-> Path -> Identity Path
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes)
 -> Path -> Identity Path)
-> DrawAttributes -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Ellipse
elip Ellipse
-> Getting DrawAttributes Ellipse DrawAttributes -> DrawAttributes
forall s a. s -> Getting a s a -> a
^. Getting DrawAttributes Ellipse DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes
             Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& ([PathCommand] -> Identity [PathCommand]) -> Path -> Identity Path
Lens' Path [PathCommand]
pathDefinition (([PathCommand] -> Identity [PathCommand])
 -> Path -> Identity Path)
-> [PathCommand] -> Path -> Path
forall s t a b. ASetter s t a b -> b -> s -> t
.~
               [ Origin -> [RPoint] -> PathCommand
MoveTo Origin
OriginAbsolute [Coord -> Coord -> RPoint
forall a. a -> a -> V2 a
V2 (Coord
cxCoord -> Coord -> Coord
forall a. Num a => a -> a -> a
-Coord
rx) Coord
cy]
               , Origin
-> [(Coord, Coord, Coord, Bool, Bool, RPoint)] -> PathCommand
EllipticalArc Origin
OriginRelative [(Coord
rx, Coord
ry, Coord
0,Bool
True,Bool
False,Coord -> Coord -> RPoint
forall a. a -> a -> V2 a
V2 (Coord
rxCoord -> Coord -> Coord
forall a. Num a => a -> a -> a
*Coord
2) Coord
0)
                                              ,(Coord
rx, Coord
ry, Coord
0,Bool
True,Bool
False,Coord -> Coord -> RPoint
forall a. a -> a -> V2 a
V2 (-Coord
rxCoord -> Coord -> Coord
forall a. Num a => a -> a -> a
*Coord
2) Coord
0)]]
        SVG
t -> SVG
t
    unpackCircle :: Circle -> Maybe (Coord, Coord, Coord)
unpackCircle Circle
circ = do
      let (Number
x,Number
y) = Circle
circ Circle
-> Getting (Number, Number) Circle (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Circle (Number, Number)
Lens' Circle (Number, Number)
circleCenter
      (Coord -> Coord -> Coord -> (Coord, Coord, Coord))
-> Maybe Coord
-> Maybe Coord
-> Maybe Coord
-> Maybe (Coord, Coord, Coord)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (,,) (Number -> Maybe Coord
unpackNumber Number
x) (Number -> Maybe Coord
unpackNumber Number
y) (Number -> Maybe Coord
unpackNumber (Number -> Maybe Coord) -> Number -> Maybe Coord
forall a b. (a -> b) -> a -> b
$ Circle
circ Circle -> Getting Number Circle Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Circle Number
Lens' Circle Number
circleRadius)
    unpackEllipse :: Ellipse -> Maybe (Coord, Coord, Coord, Coord)
unpackEllipse Ellipse
elip = do
      let (Number
x,Number
y) = Ellipse
elip Ellipse
-> Getting (Number, Number) Ellipse (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Ellipse (Number, Number)
Lens' Ellipse (Number, Number)
ellipseCenter
      (Coord -> Coord -> Coord -> Coord -> (Coord, Coord, Coord, Coord))
-> Maybe Coord
-> Maybe Coord
-> Maybe Coord
-> Maybe Coord
-> Maybe (Coord, Coord, Coord, Coord)
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (,,,) (Number -> Maybe Coord
unpackNumber Number
x) (Number -> Maybe Coord
unpackNumber Number
y) (Number -> Maybe Coord
unpackNumber (Number -> Maybe Coord) -> Number -> Maybe Coord
forall a b. (a -> b) -> a -> b
$ Ellipse
elip Ellipse -> Getting Number Ellipse Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Ellipse Number
Lens' Ellipse Number
ellipseXRadius)
                  (Number -> Maybe Coord
unpackNumber (Number -> Maybe Coord) -> Number -> Maybe Coord
forall a b. (a -> b) -> a -> b
$ Ellipse
elip Ellipse -> Getting Number Ellipse Number -> Number
forall s a. s -> Getting a s a -> a
^. Getting Number Ellipse Number
Lens' Ellipse Number
ellipseYRadius)
    unpackLine :: Line -> Maybe (Coord, Coord, Coord, Coord)
unpackLine Line
line = do
      let (Number
x1,Number
y1) = Line
line Line
-> Getting (Number, Number) Line (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Line (Number, Number)
Lens' Line (Number, Number)
linePoint1
          (Number
x2,Number
y2) = Line
line Line
-> Getting (Number, Number) Line (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Line (Number, Number)
Lens' Line (Number, Number)
linePoint2
      (Coord -> Coord -> Coord -> Coord -> (Coord, Coord, Coord, Coord))
-> Maybe Coord
-> Maybe Coord
-> Maybe Coord
-> Maybe Coord
-> Maybe (Coord, Coord, Coord, Coord)
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (,,,) (Number -> Maybe Coord
unpackNumber Number
x1) (Number -> Maybe Coord
unpackNumber Number
y1) (Number -> Maybe Coord
unpackNumber Number
x2) (Number -> Maybe Coord
unpackNumber Number
y2)
    unpackRect :: Rectangle -> Maybe (Coord, Coord, Coord, Coord)
unpackRect Rectangle
rect = do
      let (Number
x', Number
y') = Rectangle
rect Rectangle
-> Getting (Number, Number) Rectangle (Number, Number)
-> (Number, Number)
forall s a. s -> Getting a s a -> a
^. Getting (Number, Number) Rectangle (Number, Number)
Lens' Rectangle (Number, Number)
rectUpperLeftCorner
      Coord
x <- Number -> Maybe Coord
unpackNumber Number
x'
      Coord
y <- Number -> Maybe Coord
unpackNumber Number
y'
      Coord
w <- Number -> Maybe Coord
unpackNumber (Number -> Maybe Coord) -> Maybe Number -> Maybe Coord
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Rectangle
rect Rectangle
-> Getting (Maybe Number) Rectangle (Maybe Number) -> Maybe Number
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Number) Rectangle (Maybe Number)
Lens' Rectangle (Maybe Number)
rectWidth
      Coord
h <- Number -> Maybe Coord
unpackNumber (Number -> Maybe Coord) -> Maybe Number -> Maybe Coord
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Rectangle
rect Rectangle
-> Getting (Maybe Number) Rectangle (Maybe Number) -> Maybe Number
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Number) Rectangle (Maybe Number)
Lens' Rectangle (Maybe Number)
rectHeight
      (Coord, Coord, Coord, Coord) -> Maybe (Coord, Coord, Coord, Coord)
forall (m :: * -> *) a. Monad m => a -> m a
return (Coord
x,Coord
y,Coord
w,Coord
h)
    pointsToPathCommands :: [RPoint] -> [PathCommand]
pointsToPathCommands [RPoint]
points = case [RPoint]
points of
      [] -> []
      (RPoint
p:[RPoint]
ps) -> [ Origin -> [RPoint] -> PathCommand
MoveTo Origin
OriginAbsolute [RPoint
p]
                , Origin -> [RPoint] -> PathCommand
LineTo Origin
OriginAbsolute [RPoint]
ps ]
    unpackNumber :: Number -> Maybe Coord
unpackNumber Number
n =
      case Int -> Number -> Number
toUserUnit Int
defaultDPI Number
n of
        Num Coord
d -> Coord -> Maybe Coord
forall a. a -> Maybe a
Just Coord
d
        Number
_     -> Maybe Coord
forall a. Maybe a
Nothing

-- | Map over all recursively-found path commands.
mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG
mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG
mapSvgPaths [PathCommand] -> [PathCommand]
fn = (SVG -> SVG) -> SVG -> SVG
mapTree SVG -> SVG
worker
  where
    worker :: SVG -> SVG
worker =
      \case
        PathTree Path
path -> Path -> SVG
PathTree (Path -> SVG) -> Path -> SVG
forall a b. (a -> b) -> a -> b
$
          Path
path Path -> (Path -> Path) -> Path
forall a b. a -> (a -> b) -> b
& ([PathCommand] -> Identity [PathCommand]) -> Path -> Identity Path
Lens' Path [PathCommand]
pathDefinition (([PathCommand] -> Identity [PathCommand])
 -> Path -> Identity Path)
-> ([PathCommand] -> [PathCommand]) -> Path -> Path
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ [PathCommand] -> [PathCommand]
fn
        SVG
t -> SVG
t

-- | Map over all recursively-found line commands.
mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG
mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG
mapSvgLines [LineCommand] -> [LineCommand]
fn = ([PathCommand] -> [PathCommand]) -> SVG -> SVG
mapSvgPaths ([LineCommand] -> [PathCommand]
lineToPath ([LineCommand] -> [PathCommand])
-> ([PathCommand] -> [LineCommand])
-> [PathCommand]
-> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LineCommand] -> [LineCommand]
fn ([LineCommand] -> [LineCommand])
-> ([PathCommand] -> [LineCommand])
-> [PathCommand]
-> [LineCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathCommand] -> [LineCommand]
toLineCommands)

-- Only maps points in paths
-- | Map over all line command control points.
mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG
mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG
mapSvgPoints RPoint -> RPoint
fn = ([LineCommand] -> [LineCommand]) -> SVG -> SVG
mapSvgLines ((LineCommand -> LineCommand) -> [LineCommand] -> [LineCommand]
forall a b. (a -> b) -> [a] -> [b]
map LineCommand -> LineCommand
worker)
  where
    worker :: LineCommand -> LineCommand
worker (LineMove RPoint
p)    = RPoint -> LineCommand
LineMove (RPoint -> RPoint
fn RPoint
p)
    worker (LineBezier [RPoint]
ps) = [RPoint] -> LineCommand
LineBezier ((RPoint -> RPoint) -> [RPoint] -> [RPoint]
forall a b. (a -> b) -> [a] -> [b]
map RPoint -> RPoint
fn [RPoint]
ps)
    worker (LineEnd RPoint
p)     = RPoint -> LineCommand
LineEnd (RPoint -> RPoint
fn RPoint
p)

-- | Convert coordinate system from degrees to radians.
svgPointsToRadians :: SVG -> SVG
svgPointsToRadians :: SVG -> SVG
svgPointsToRadians = (RPoint -> RPoint) -> SVG -> SVG
mapSvgPoints RPoint -> RPoint
forall a. Floating a => V2 a -> V2 a
worker
  where
    worker :: V2 a -> V2 a
worker (V2 a
x a
y) = a -> a -> V2 a
forall a. a -> a -> V2 a
V2 (a
xa -> a -> a
forall a. Fractional a => a -> a -> a
/a
180a -> a -> a
forall a. Num a => a -> a -> a
*a
forall a. Floating a => a
pi) (a
ya -> a -> a
forall a. Fractional a => a -> a -> a
/a
180a -> a -> a
forall a. Num a => a -> a -> a
*a
forall a. Floating a => a
pi)