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