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 withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree
144 withSubglyphs target fn = \t -> evalState (worker t) 0
145 where
146 worker :: Tree -> State Int Tree
147 worker t =
148 case t of
149 GroupTree g -> do
150 cs <- mapM worker (g ^. groupChildren)
151 return $ GroupTree $ g & groupChildren .~ cs
152 PathTree{} -> handleGlyph t
153 CircleTree{} -> handleGlyph t
154 PolyLineTree{} -> handleGlyph t
155 PolygonTree{} -> handleGlyph t
156 EllipseTree{} -> handleGlyph t
157 LineTree{} -> handleGlyph t
158 RectangleTree{} -> handleGlyph t
159 _ -> return t
160 handleGlyph :: Tree -> State Int Tree
161 handleGlyph svg = do
162 n <- get <* modify (+1)
163 if n `elem` target
164 then return $ fn svg
165 else return svg
166
167 splitGlyphs :: [Int] -> Tree -> (Tree, Tree)
168 splitGlyphs target = \t ->
169 let (_, l, r) = execState (worker id t) (0, [], [])
170 in (mkGroup l, mkGroup r)
171 where
172 handleGlyph :: Tree -> State (Int, [Tree], [Tree]) ()
173 handleGlyph t = do
174 (n, l, r) <- get
175 if n `elem` target
176 then put (n+1, l, t:r)
177 else put (n+1, t:l, r)
178 worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) ()
179 worker acc t =
180 case t of
181 GroupTree g -> do
182 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
183 mapM_ (worker acc') (g ^. groupChildren)
184 PathTree{} -> handleGlyph $ acc t
185 CircleTree{} -> handleGlyph $ acc t
186 PolyLineTree{} -> handleGlyph $ acc t
187 PolygonTree{} -> handleGlyph $ acc t
188 EllipseTree{} -> handleGlyph $ acc t
189 LineTree{} -> handleGlyph $ acc t
190 RectangleTree{} -> handleGlyph $ acc t
191 DefinitionTree{} -> return ()
192 _ ->
193 modify $ \(n, l, r) -> (n, acc t:l, r)
194 {-
195 <g transform="translate(10,10)">
196 <g transform="scale(2)">
197 <circle/>
198 </g>
199 <g transform="scale(0.5)">
200 <rect/>
201 </g>
202 </g>
203
204 [ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>)
205 , (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)]
206 -}
207 svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)]
208 svgGlyphs = worker id defaultSvg
209 where
210 worker acc attr =
211 \case
212 None -> []
213 GroupTree g ->
214 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
215 attr' = (g^.drawAttributes) `mappend` attr
216 in concatMap (worker acc' attr') (g ^. groupChildren)
217 t -> [(acc, (t^.drawAttributes) `mappend` attr, t)]
218
219 {-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or
220 'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being
221 drawn progressively with 'partialSvg'.
222
223 Example:
224
225 > pathifyExample :: Animation
226 > pathifyExample = animate $ \t -> gridLayout
227 > [ [ partialSvg t $ pathify $ mkCircle 1
228 > , partialSvg t $ pathify $ mkRect 2 2
229 > ]
230 > , [ partialSvg t $ pathify $ mkEllipse 1 0.5
231 > , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1)
232 > ]
233 > ]
234
235 <<docs/gifs/doc_pathify.gif>>
236 -}
237 pathify :: Tree -> Tree
238 pathify = mapTree worker
239 where
240 worker =
241 \case
242 RectangleTree rect | Just (x,y,w,h) <- unpackRect rect ->
243 PathTree $ defaultSvg
244 & drawAttributes .~ rect ^. drawAttributes
245 & strokeLineCap .~ pure CapSquare
246 & pathDefinition .~
247 [MoveTo OriginAbsolute [V2 x y]
248 ,HorizontalTo OriginRelative [w]
249 ,VerticalTo OriginRelative [h]
250 ,HorizontalTo OriginRelative [-w]
251 ,EndPath ]
252 LineTree line | Just (x1,y1, x2, y2) <- unpackLine line ->
253 PathTree $ defaultSvg
254 & drawAttributes .~ line ^. drawAttributes
255 & pathDefinition .~
256 [MoveTo OriginAbsolute [V2 x1 y1]
257 ,LineTo OriginAbsolute [V2 x2 y2] ]
258 CircleTree circ | Just (x, y, r) <- unpackCircle circ ->
259 PathTree $ defaultSvg
260 & drawAttributes .~ circ ^. drawAttributes
261 & pathDefinition .~
262 [MoveTo OriginAbsolute [V2 (x-r) y]
263 ,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0)
264 ,(r, r, 0,True,False,V2 (-r*2) 0)]]
265 PolyLineTree pl ->
266 let points = pl ^. polyLinePoints
267 in PathTree $ defaultSvg
268 & drawAttributes .~ pl ^. drawAttributes
269 & pathDefinition .~ pointsToPathCommands points
270 PolygonTree pg ->
271 let points = pg ^. polygonPoints
272 in PathTree $ defaultSvg
273 & drawAttributes .~ pg ^. drawAttributes
274 -- Polygon automatically connects the last point to the first. For path we must do
275 -- it explicitly
276 & pathDefinition .~ (pointsToPathCommands points ++ [EndPath])
277 EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip ->
278 PathTree $ defaultSvg
279 & drawAttributes .~ elip ^. drawAttributes
280 & pathDefinition .~
281 [ MoveTo OriginAbsolute [V2 (cx-rx) cy]
282 , EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0)
283 ,(rx, ry, 0,True,False,V2 (-rx*2) 0)]]
284 t -> t
285 unpackCircle circ = do
286 let (x,y) = circ ^. circleCenter
287 liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius)
288 unpackEllipse elip = do
289 let (x,y) = elip ^. ellipseCenter
290 liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius)
291 (unpackNumber $ elip ^. ellipseYRadius)
292 unpackLine line = do
293 let (x1,y1) = line ^. linePoint1
294 (x2,y2) = line ^. linePoint2
295 liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2)
296 unpackRect rect = do
297 let (x', y') = rect ^. rectUpperLeftCorner
298 x <- unpackNumber x'
299 y <- unpackNumber y'
300 w <- unpackNumber =<< rect ^. rectWidth
301 h <- unpackNumber =<< rect ^. rectHeight
302 return (x,y,w,h)
303 pointsToPathCommands points = case points of
304 [] -> []
305 (p:ps) -> [ MoveTo OriginAbsolute [p]
306 , LineTo OriginAbsolute ps ]
307 unpackNumber n =
308 case toUserUnit defaultDPI n of
309 Num d -> Just d
310 _ -> Nothing
311
312 mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG
313 mapSvgPaths fn = mapTree worker
314 where
315 worker =
316 \case
317 PathTree path -> PathTree $
318 path & pathDefinition %~ fn
319 t -> t
320
321 mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG
322 mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands)
323
324 -- Only maps points in paths
325 mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG
326 mapSvgPoints fn = mapSvgLines (map worker)
327 where
328 worker (LineMove p) = LineMove (fn p)
329 worker (LineBezier ps) = LineBezier (map fn ps)
330 worker (LineEnd p) = LineEnd (fn p)
331
332 svgPointsToRadians :: SVG -> SVG
333 svgPointsToRadians = mapSvgPoints worker
334 where
335 worker (V2 x y) = V2 (x/180*pi) (y/180*pi)