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