hashirama/reanimate
Watch
1
0
Fork
You've already forked reanimate
 0
mirror of https://github.com/reanimate/reanimate.git synced 2026-09-14 09:32:22 +00:00
Code Issues Projects Releases Wiki Activity
reanimate/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html
Lemmih a41f98c55c Deploying to gh-pages from @ aed34fb5d9 🚀
2020-08-27 08:57:22 +00:00

371 lines
42 KiB
HTML
Raw Blame History

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