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