never executed always true always false
1 {-# LANGUAGE LambdaCase #-}
2 module Reanimate.Svg
3 ( module Reanimate.Svg
4 , module Reanimate.Svg.Constructors
5 , module Reanimate.Svg.LineCommand
6 , module Reanimate.Svg.BoundingBox
7 , module Reanimate.Svg.Unuse
8 ) where
9
10 import Control.Lens ((%~), (&), (.~), (^.), (?~))
11 import Control.Monad.State
12 import Graphics.SvgTree hiding (height, line, path, use,
13 width)
14 import Linear.V2 hiding (angle)
15 import Reanimate.Constants
16 import Reanimate.Animation (SVG)
17 import Reanimate.Svg.Constructors
18 import Reanimate.Svg.LineCommand
19 import Reanimate.Svg.BoundingBox
20 import Reanimate.Svg.Unuse
21 import qualified Reanimate.Transform as Transform
22
23 -- | Remove transformations (such as translations, rotations, scaling)
24 -- and apply them directly to the SVG nodes. Note, this function
25 -- may convert nodes (such as Circle or Rect) to paths. Also note
26 -- that /does/ change how the SVG is rendered. Particularly, stroke
27 -- width is affected by directly applying scaling.
28 --
29 -- @lowerTransformations (scale 2 (mkCircle 1)) = mkCircle 2@
30 lowerTransformations :: Tree -> Tree
31 lowerTransformations = worker False Transform.identity
32 where
33 updLineCmd m cmd =
34 case cmd of
35 LineMove p -> LineMove $ Transform.transformPoint m p
36 -- LineDraw p -> LineDraw $ Transform.transformPoint m p
37 LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps
38 LineEnd p -> LineEnd $ Transform.transformPoint m p
39 updPath m = lineToPath . map (updLineCmd m) . toLineCommands
40 updPoint m (Num a,Num b) =
41 case Transform.transformPoint m (V2 a b) of
42 V2 x y -> (Num x, Num y)
43 updPoint _ other = other -- XXX: Can we do better here?
44 worker hasPathified m t =
45 let m' = m * Transform.mkMatrix (t^.transform) in
46 case t of
47 PathTree path -> PathTree $
48 path & pathDefinition %~ updPath m'
49 & transform .~ Nothing
50 GroupTree g -> GroupTree $
51 g & groupChildren %~ map (worker hasPathified m')
52 & transform .~ Nothing
53 LineTree line ->
54 LineTree $
55 line & linePoint1 %~ updPoint m
56 & linePoint2 %~ updPoint m
57 ClipPathTree{} -> t
58 -- If we encounter an unknown node and we've already tried to convert
59 -- to paths, give up and insert an explicit transformation.
60 _ | hasPathified ->
61 mkGroup [t] & transform ?~ [ Transform.toTransformation m ]
62 -- If we haven't tried to pathify, run pathify only once.
63 _ -> worker True m (pathify t)
64
65 -- | Remove all @id@ attributes.
66 lowerIds :: Tree -> Tree
67 lowerIds = mapTree worker
68 where
69 worker t@GroupTree{} = t & attrId .~ Nothing
70 worker t@PathTree{} = t & attrId .~ Nothing
71 worker t = t
72
73 -- | Optimize SVG tree without affecting how it is rendered.
74 simplify :: Tree -> Tree
75 simplify root =
76 case worker root of
77 [] -> None
78 [x] -> x
79 xs -> mkGroup xs
80 where
81 worker None = []
82 worker (DefinitionTree d) =
83 concatMap dropNulls
84 [DefinitionTree $ d & groupChildren %~ concatMap worker]
85 worker (GroupTree g)
86 | g ^. drawAttributes == defaultSvg =
87 concatMap dropNulls $
88 concatMap worker (g^.groupChildren)
89 | otherwise =
90 dropNulls $
91 GroupTree $ g & groupChildren %~ concatMap worker
92 worker t = dropNulls t
93
94 dropNulls None = []
95 dropNulls (DefinitionTree d)
96 | null (d^.groupChildren) = []
97 dropNulls (GroupTree g)
98 | null (g^.groupChildren) = []
99 dropNulls t = [t]
100
101 -- | Separate grouped items. This is required by clip nodes.
102 --
103 -- @removeGroups (withFillColor "blue" $ mkGroup [mkCircle 1, mkRect 1 1])
104 -- = [ withFillColor "blue" $ mkCircle 1
105 -- , withFillColor "blue" $ mkRect 1 1 ]@
106 removeGroups :: Tree -> [Tree]
107 removeGroups = worker defaultSvg
108 where
109 worker _attr None = []
110 worker _attr (DefinitionTree d) =
111 concatMap dropNulls
112 [DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)]
113 worker attr (GroupTree g)
114 | g ^. drawAttributes == defaultSvg =
115 concatMap dropNulls $
116 concatMap (worker attr) (g^.groupChildren)
117 | otherwise =
118 concatMap (worker (attr <> g ^. drawAttributes)) (g^.groupChildren)
119 worker attr t = dropNulls (t & drawAttributes .~ attr)
120
121 dropNulls None = []
122 dropNulls (DefinitionTree d)
123 | null (d^.groupChildren) = []
124 dropNulls (GroupTree g)
125 | null (g^.groupChildren) = []
126 dropNulls t = [t]
127
128 -- | Extract all path commands from a node (and its children) and concatenate them.
129 extractPath :: Tree -> [PathCommand]
130 extractPath = worker . simplify . lowerTransformations . pathify
131 where
132 worker (GroupTree g) = concatMap worker (g^.groupChildren)
133 worker (PathTree p) = p^.pathDefinition
134 worker _ = []
135
136 withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree
137 withSubglyphs target fn = \t -> evalState (worker t) 0
138 where
139 worker :: Tree -> State Int Tree
140 worker t =
141 case t of
142 GroupTree g -> do
143 cs <- mapM worker (g ^. groupChildren)
144 return $ GroupTree $ g & groupChildren .~ cs
145 PathTree{} -> handleGlyph t
146 CircleTree{} -> handleGlyph t
147 PolyLineTree{} -> handleGlyph t
148 PolygonTree{} -> handleGlyph t
149 EllipseTree{} -> handleGlyph t
150 LineTree{} -> handleGlyph t
151 RectangleTree{} -> handleGlyph t
152 _ -> return t
153 handleGlyph :: Tree -> State Int Tree
154 handleGlyph svg = do
155 n <- get <* modify (+1)
156 if n `elem` target
157 then return $ fn svg
158 else return svg
159
160 splitGlyphs :: [Int] -> Tree -> (Tree, Tree)
161 splitGlyphs target = \t ->
162 let (_, l, r) = execState (worker id t) (0, [], [])
163 in (mkGroup l, mkGroup r)
164 where
165 handleGlyph :: Tree -> State (Int, [Tree], [Tree]) ()
166 handleGlyph t = do
167 (n, l, r) <- get
168 if n `elem` target
169 then put (n+1, l, t:r)
170 else put (n+1, t:l, r)
171 worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) ()
172 worker acc t =
173 case t of
174 GroupTree g -> do
175 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
176 mapM_ (worker acc') (g ^. groupChildren)
177 PathTree{} -> handleGlyph $ acc t
178 CircleTree{} -> handleGlyph $ acc t
179 PolyLineTree{} -> handleGlyph $ acc t
180 PolygonTree{} -> handleGlyph $ acc t
181 EllipseTree{} -> handleGlyph $ acc t
182 LineTree{} -> handleGlyph $ acc t
183 RectangleTree{} -> handleGlyph $ acc t
184 DefinitionTree{} -> return ()
185 _ ->
186 modify $ \(n, l, r) -> (n, acc t:l, r)
187 {-
188 <g transform="translate(10,10)">
189 <g transform="scale(2)">
190 <circle/>
191 </g>
192 <g transform="scale(0.5)">
193 <rect/>
194 </g>
195 </g>
196
197 [ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>)
198 , (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)]
199 -}
200 svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)]
201 svgGlyphs = worker id defaultSvg
202 where
203 worker acc attr =
204 \case
205 None -> []
206 GroupTree g ->
207 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
208 attr' = (g^.drawAttributes) `mappend` attr
209 in concatMap (worker acc' attr') (g ^. groupChildren)
210 t -> [(acc, (t^.drawAttributes) `mappend` attr, t)]
211
212 {-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or
213 'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being
214 drawn progressively with 'partialSvg'.
215
216 Example:
217
218 > pathifyExample :: Animation
219 > pathifyExample = animate $ \t -> gridLayout
220 > [ [ partialSvg t $ pathify $ mkCircle 1
221 > , partialSvg t $ pathify $ mkRect 2 2
222 > ]
223 > , [ partialSvg t $ pathify $ mkEllipse 1 0.5
224 > , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1)
225 > ]
226 > ]
227
228 <<docs/gifs/doc_pathify.gif>>
229 -}
230 pathify :: Tree -> Tree
231 pathify = mapTree worker
232 where
233 worker =
234 \case
235 RectangleTree rect | Just (x,y,w,h) <- unpackRect rect ->
236 PathTree $ defaultSvg
237 & drawAttributes .~ rect ^. drawAttributes
238 & strokeLineCap .~ pure CapSquare
239 & pathDefinition .~
240 [MoveTo OriginAbsolute [V2 x y]
241 ,HorizontalTo OriginRelative [w]
242 ,VerticalTo OriginRelative [h]
243 ,HorizontalTo OriginRelative [-w]
244 ,EndPath ]
245 LineTree line | Just (x1,y1, x2, y2) <- unpackLine line ->
246 PathTree $ defaultSvg
247 & drawAttributes .~ line ^. drawAttributes
248 & pathDefinition .~
249 [MoveTo OriginAbsolute [V2 x1 y1]
250 ,LineTo OriginAbsolute [V2 x2 y2] ]
251 CircleTree circ | Just (x, y, r) <- unpackCircle circ ->
252 PathTree $ defaultSvg
253 & drawAttributes .~ circ ^. drawAttributes
254 & pathDefinition .~
255 [MoveTo OriginAbsolute [V2 (x-r) y]
256 ,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0)
257 ,(r, r, 0,True,False,V2 (-r*2) 0)]]
258 PolyLineTree pl ->
259 let points = pl ^. polyLinePoints
260 in PathTree $ defaultSvg
261 & drawAttributes .~ pl ^. drawAttributes
262 & pathDefinition .~ pointsToPathCommands points
263 PolygonTree pg ->
264 let points = pg ^. polygonPoints
265 in PathTree $ defaultSvg
266 & drawAttributes .~ pg ^. drawAttributes
267 -- Polygon automatically connects the last point to the first. For path we must do
268 -- it explicitly
269 & pathDefinition .~ (pointsToPathCommands points ++ [EndPath])
270 EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip ->
271 PathTree $ defaultSvg
272 & drawAttributes .~ elip ^. drawAttributes
273 & pathDefinition .~
274 [ MoveTo OriginAbsolute [V2 (cx-rx) cy]
275 , EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0)
276 ,(rx, ry, 0,True,False,V2 (-rx*2) 0)]]
277 t -> t
278 unpackCircle circ = do
279 let (x,y) = circ ^. circleCenter
280 liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius)
281 unpackEllipse elip = do
282 let (x,y) = elip ^. ellipseCenter
283 liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius)
284 (unpackNumber $ elip ^. ellipseYRadius)
285 unpackLine line = do
286 let (x1,y1) = line ^. linePoint1
287 (x2,y2) = line ^. linePoint2
288 liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2)
289 unpackRect rect = do
290 let (x', y') = rect ^. rectUpperLeftCorner
291 x <- unpackNumber x'
292 y <- unpackNumber y'
293 w <- unpackNumber =<< rect ^. rectWidth
294 h <- unpackNumber =<< rect ^. rectHeight
295 return (x,y,w,h)
296 pointsToPathCommands points = case points of
297 [] -> []
298 (p:ps) -> [ MoveTo OriginAbsolute [p]
299 , LineTo OriginAbsolute ps ]
300 unpackNumber n =
301 case toUserUnit defaultDPI n of
302 Num d -> Just d
303 _ -> Nothing
304
305 mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG
306 mapSvgPaths fn = mapTree worker
307 where
308 worker =
309 \case
310 PathTree path -> PathTree $
311 path & pathDefinition %~ fn
312 t -> t
313
314 mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG
315 mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands)
316
317 -- Only maps points in paths
318 mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG
319 mapSvgPoints fn = mapSvgLines (map worker)
320 where
321 worker (LineMove p) = LineMove (fn p)
322 worker (LineBezier ps) = LineBezier (map fn ps)
323 worker (LineEnd p) = LineEnd (fn p)
324
325 svgPointsToRadians :: SVG -> SVG
326 svgPointsToRadians = mapSvgPoints worker
327 where
328 worker (V2 x y) = V2 (x/180*pi) (y/180*pi)