diff --git a/haddock.txt b/haddock.txt index c0d68c0..adc2714 100644 --- a/haddock.txt +++ b/haddock.txt @@ -1,25 +1,29 @@ + 100% ( 55 / 55) in 'Reanimate.Svg.Constructors' 100% ( 22 / 22) in 'Reanimate.Effect' 100% ( 17 / 17) in 'Reanimate.Parameters' 100% ( 13 / 13) in 'Reanimate.ColorMap' 100% ( 12 / 12) in 'Reanimate.ColorComponents' + 100% ( 9 / 9) in 'Reanimate.Voice' + 100% ( 9 / 9) in 'Reanimate.Povray' 100% ( 9 / 9) in 'Reanimate.Constants' - 94% (145 /155) in 'Reanimate' + 100% ( 5 / 5) in 'Reanimate.Transform' + 100% ( 4 / 4) in 'Reanimate.Svg.BoundingBox' + 100% ( 3 / 3) in 'Reanimate.Blender' + 99% (154 /155) in 'Reanimate' + 95% ( 40 / 42) in 'Reanimate.Animation' + 93% ( 13 / 14) in 'Reanimate.Raster' + 91% ( 10 / 11) in 'Reanimate.Ease' 88% ( 7 / 8) in 'Reanimate.Transition' - 85% ( 47 / 55) in 'Reanimate.Svg.Constructors' - 77% ( 33 / 43) in 'Reanimate.Animation' - 73% ( 8 / 11) in 'Reanimate.Ease' - 71% ( 10 / 14) in 'Reanimate.Raster' - 67% ( 6 / 9) in 'Reanimate.Voice' + 75% ( 6 / 8) in 'Reanimate.Builtin.Documentation' + 75% ( 3 / 4) in 'Reanimate.Svg.Unuse' 67% ( 4 / 6) in 'Reanimate.Builtin.Images' + 56% ( 10 / 18) in 'Reanimate.Svg' 50% ( 1 / 2) in 'Reanimate.Builtin.CirclePlot' 44% ( 4 / 9) in 'Reanimate.LaTeX' + 42% ( 47 /111) in 'Reanimate.Scene' 42% ( 17 / 40) in 'Reanimate.GeoProjection' - 41% ( 45 /111) in 'Reanimate.Scene' - 38% ( 3 / 8) in 'Reanimate.Builtin.Documentation' 33% ( 4 / 12) in 'Reanimate.Render' - 28% ( 5 / 18) in 'Reanimate.Svg' 25% ( 1 / 4) in 'Reanimate.Builtin.Slide' - 17% ( 1 / 6) in 'Reanimate.Svg.BoundingBox' 12% ( 2 / 17) in 'Reanimate.Math.SSSP' 10% ( 3 / 30) in 'Reanimate.PolyShape' 7% ( 2 / 29) in 'Reanimate.Math.Common' @@ -34,7 +38,6 @@ 0% ( 0 / 10) in 'Reanimate.Math.Render' 0% ( 0 / 10) in 'Reanimate.ColorSpace' 0% ( 0 / 10) in 'Reanimate.Builtin.TernaryPlot' - 0% ( 0 / 9) in 'Reanimate.Povray' 0% ( 0 / 9) in 'Reanimate.Math.Smooth' 0% ( 0 / 8) in 'Reanimate.Misc' 0% ( 0 / 8) in 'Reanimate.Math.Balloon' @@ -43,12 +46,9 @@ 0% ( 0 / 6) in 'Reanimate.Morph.Linear' 0% ( 0 / 6) in 'Reanimate.Math.Triangulate' 0% ( 0 / 6) in 'Reanimate.Math.EarClip' - 0% ( 0 / 5) in 'Reanimate.Transform' 0% ( 0 / 5) in 'Reanimate.Builtin.Flip' - 0% ( 0 / 4) in 'Reanimate.Svg.Unuse' 0% ( 0 / 4) in 'Reanimate.Debug' 0% ( 0 / 3) in 'Reanimate.Morph.Rotational' 0% ( 0 / 3) in 'Reanimate.Morph.LineBend' 0% ( 0 / 3) in 'Reanimate.Memo' - 0% ( 0 / 3) in 'Reanimate.Blender' 0% ( 0 / 2) in 'Reanimate.Morph.Cache' diff --git a/haddock_badge.json b/haddock_badge.json index 0e2504c..fdd4f61 100644 --- a/haddock_badge.json +++ b/haddock_badge.json @@ -1 +1 @@ - { "schemaVersion": 1, "label": "api docs", "message": "34%", "color": "success" } + { "schemaVersion": 1, "label": "api docs", "message": "41%", "color": "success" } diff --git a/hpc_index.html b/hpc_index.html index 5545cb6..edbe096 100644 --- a/hpc_index.html +++ b/hpc_index.html @@ -11,7 +11,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 20%3/15
- 0/0 20%12/58
  module reanimate-0.4.1.0-inplace/Reanimate.Animation -84%28/33
57%8/14
85%298/349
+87%28/32
57%8/14
85%298/347
  module reanimate-0.4.1.0-inplace/Reanimate.Builtin.Documentation 85%6/7
- 0/0 87%117/134
@@ -131,5 +131,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 100%6/6
50%1/2
95%43/45
  Program Coverage Total -31%253/803
16%131/811
30%4760/15671
+31%253/802
16%131/811
30%4760/15669
diff --git a/hpc_index_alt.html b/hpc_index_alt.html index ba0c15f..333ed22 100644 --- a/hpc_index_alt.html +++ b/hpc_index_alt.html @@ -20,7 +20,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 75%12/16
58%43/74
69%659/943
  module reanimate-0.4.1.0-inplace/Reanimate.Animation -84%28/33
57%8/14
85%298/349
+87%28/32
57%8/14
85%298/347
  module reanimate-0.4.1.0-inplace/Reanimate.Chiphunk 57%4/7
50%2/4
63%121/192
@@ -131,5 +131,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 15%3/20
- 0/0 14%7/49
  Program Coverage Total -31%253/803
16%131/811
30%4760/15671
+31%253/802
16%131/811
30%4760/15669
diff --git a/hpc_index_exp.html b/hpc_index_exp.html index 2a0b8ac..9616ca7 100644 --- a/hpc_index_exp.html +++ b/hpc_index_exp.html @@ -17,7 +17,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 85%6/7
- 0/0 87%117/134
  module reanimate-0.4.1.0-inplace/Reanimate.Animation -84%28/33
57%8/14
85%298/349
+87%28/32
57%8/14
85%298/347
  module reanimate-0.4.1.0-inplace/Reanimate.ColorComponents 75%9/12
50%1/2
81%135/166
@@ -131,5 +131,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 0%0/1
0%0/4
0%0/61
  Program Coverage Total -31%253/803
16%131/811
30%4760/15671
+31%253/802
16%131/811
30%4760/15669
diff --git a/hpc_index_fun.html b/hpc_index_fun.html index 7ebc226..d23233b 100644 --- a/hpc_index_fun.html +++ b/hpc_index_fun.html @@ -13,12 +13,12 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black }   module reanimate-0.4.1.0-inplace/Reanimate.Transition 100%6/6
50%1/2
95%43/45
+  module reanimate-0.4.1.0-inplace/Reanimate.Animation +87%28/32
57%8/14
85%298/347
+   module reanimate-0.4.1.0-inplace/Reanimate.Builtin.Documentation 85%6/7
- 0/0 87%117/134
-  module reanimate-0.4.1.0-inplace/Reanimate.Animation -84%28/33
57%8/14
85%298/349
-   module reanimate-0.4.1.0-inplace/Reanimate.Transform 83%5/6
33%4/12
45%76/166
@@ -131,5 +131,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 0%0/1
0%0/4
0%0/61
  Program Coverage Total -31%253/803
16%131/811
30%4760/15671
+31%253/802
16%131/811
30%4760/15669
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Animation.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Animation.hs.html index dc3cb9b..6d5d655 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Animation.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Animation.hs.html @@ -54,351 +54,357 @@ span.spaces { background: white } 35 , freezeAtPercentage 36 , addStatic 37 -- * Misc - 38 , (#) - 39 , getAnimationFrame - 40 , Sync(..) - 41 -- * Rendering - 42 , renderTree - 43 , renderSvg - 44 ) where - 45 - 46 import Control.Arrow () - 47 import Data.Fixed (mod') - 48 import Graphics.SvgTree (Alignment (..), Document (..), - 49 Number (..), - 50 PreserveAspectRatio (..), - 51 Tree (..), xmlOfTree) - 52 import Graphics.SvgTree.Printer - 53 import Reanimate.Constants - 54 import Reanimate.Ease - 55 import Reanimate.Svg.Constructors - 56 import Text.XML.Light.Output - 57 - 58 -- | Duration of an animation or effect. Usually measured in seconds. - 59 type Duration = Double - 60 -- | Time signal. Goes from 0 to 1, inclusive. - 61 type Time = Double - 62 + 38 , getAnimationFrame + 39 , Sync(..) + 40 -- * Rendering + 41 , renderTree + 42 , renderSvg + 43 ) where + 44 + 45 import Control.Arrow () + 46 import Data.Fixed (mod') + 47 import Graphics.SvgTree (Alignment (..), Document (..), + 48 Number (..), + 49 PreserveAspectRatio (..), + 50 Tree (..), xmlOfTree) + 51 import Graphics.SvgTree.Printer + 52 import Reanimate.Constants + 53 import Reanimate.Ease + 54 import Reanimate.Svg.Constructors + 55 import Text.XML.Light.Output + 56 + 57 -- | Duration of an animation or effect. Usually measured in seconds. + 58 type Duration = Double + 59 -- | Time signal. Goes from 0 to 1, inclusive. + 60 type Time = Double + 61 + 62 -- | SVG node. 63 type SVG = Tree 64 65 -- | Animations are SVGs over a finite time. 66 data Animation = Animation Duration (Time -> SVG) 67 - 68 mkAnimation :: Duration -> (Time -> SVG) -> Animation - 69 mkAnimation = Animation - 70 - 71 -- | Construct an animation with a duration of @1@. - 72 animate :: (Time -> SVG) -> Animation - 73 animate = Animation 1 - 74 - 75 -- | Create an animation with provided @duration@, which consists of stationary frame displayed for its entire duration. - 76 staticFrame :: Duration -> SVG -> Animation - 77 staticFrame d svg = Animation d (const svg) - 78 - 79 -- | Query the duration of an animation. - 80 duration :: Animation -> Duration - 81 duration (Animation d _) = d - 82 - 83 -- | Play animations in sequence. The @lhs@ animation is removed after it has - 84 -- completed. New animation duration is '@duration lhs + duration rhs@'. - 85 -- - 86 -- Example: - 87 -- - 88 -- > drawBox `seqA` drawCircle - 89 -- - 90 -- <<docs/gifs/doc_seqA.gif>> - 91 seqA :: Animation -> Animation -> Animation - 92 seqA (Animation d1 f1) (Animation d2 f2) = - 93 Animation totalD $ \t -> - 94 if t < d1/totalD - 95 then f1 (t * totalD/d1) - 96 else f2 ((t-d1/totalD) * totalD/d2) - 97 where - 98 totalD = d1+d2 - 99 - 100 -- | Play two animation concurrently. Shortest animation freezes on last frame. - 101 -- New animation duration is '@max (duration lhs) (duration rhs)@'. - 102 -- - 103 -- Example: - 104 -- - 105 -- > drawBox `parA` adjustDuration (*2) drawCircle - 106 -- - 107 -- <<docs/gifs/doc_parA.gif>> - 108 parA :: Animation -> Animation -> Animation - 109 parA (Animation d1 f1) (Animation d2 f2) = - 110 Animation (max d1 d2) $ \t -> - 111 let t1 = t * totalD/d1 - 112 t2 = t * totalD/d2 in - 113 mkGroup - 114 [ f1 (min 1 t1) - 115 , f2 (min 1 t2) ] - 116 where - 117 totalD = max d1 d2 - 118 - 119 -- | Play two animation concurrently. Shortest animation loops. - 120 -- New animation duration is '@max (duration lhs) (duration rhs)@'. - 121 -- - 122 -- Example: - 123 -- - 124 -- > drawBox `parLoopA` adjustDuration (*2) drawCircle - 125 -- - 126 -- <<docs/gifs/doc_parLoopA.gif>> - 127 parLoopA :: Animation -> Animation -> Animation - 128 parLoopA (Animation d1 f1) (Animation d2 f2) = - 129 Animation totalD $ \t -> - 130 let t1 = t * totalD/d1 - 131 t2 = t * totalD/d2 in - 132 mkGroup - 133 [ f1 (t1 `mod'` 1) - 134 , f2 (t2 `mod'` 1) ] - 135 where - 136 totalD = max d1 d2 - 137 - 138 -- | Play two animation concurrently. Animations disappear after playing once. - 139 -- New animation duration is '@max (duration lhs) (duration rhs)@'. - 140 -- - 141 -- Example: - 142 -- - 143 -- > drawBox `parLoopA` adjustDuration (*2) drawCircle - 144 -- - 145 -- <<docs/gifs/doc_parDropA.gif>> - 146 parDropA :: Animation -> Animation -> Animation - 147 parDropA (Animation d1 f1) (Animation d2 f2) = - 148 Animation totalD $ \t -> - 149 let t1 = t * totalD/d1 - 150 t2 = t * totalD/d2 in - 151 mkGroup - 152 [ if t1>1 then None else f1 t1 - 153 , if t2>1 then None else f2 t2 ] - 154 where - 155 totalD = max d1 d2 - 156 - 157 -- | Empty animation (no SVG output) with a fixed duration. - 158 -- - 159 -- Example: - 160 -- - 161 -- > pause 1 `seqA` drawProgress - 162 -- - 163 -- <<docs/gifs/doc_pause.gif>> - 164 pause :: Duration -> Animation - 165 pause d = Animation d (const None) - 166 - 167 -- | Play left animation and freeze on the last frame, then play the right - 168 -- animation. New duration is '@duration lhs + duration rhs@'. - 169 -- - 170 -- Example: - 171 -- - 172 -- > drawBox `andThen` drawCircle - 173 -- - 174 -- <<docs/gifs/doc_andThen.gif>> - 175 andThen :: Animation -> Animation -> Animation - 176 andThen a b = a `parA` (pause (duration a) `seqA` b) - 177 - 178 -- | Calculate the frame that would be displayed at given point in @time@ of running @animation@. - 179 -- - 180 -- The provided time parameter is clamped between 0 and animation duration. - 181 frameAt :: Time -> Animation -> SVG - 182 frameAt t (Animation d f) = f t' - 183 where - 184 t' = clamp 0 1 (t/d) - 185 - 186 renderTree :: SVG -> String - 187 renderTree t = maybe "" ppElement $ xmlOfTree t - 188 - 189 renderSvg :: Maybe Number -- ^ The number to use as value of the @width@ attribute of the resulting top-level svg element. If @Nothing@, the width attribute won't be rendered. - 190 -> Maybe Number -- ^ Similar to previous argument, but for @height@ attribute. - 191 -> SVG -- ^ SVG to render - 192 -> String -- ^ String representation of SVG XML markup - 193 renderSvg w h t = ppDocument doc - 194 -- renderSvg w h t = ppFastElement (xmlOfDocument doc) - 195 where - 196 width = 16 - 197 height = 9 - 198 doc = Document - 199 { _viewBox = Just (-width/2, -height/2, width, height) - 200 , _width = w - 201 , _height = h - 202 , _elements = [withStrokeWidth defaultStrokeWidth $ scaleXY 1 (-1) t] - 203 , _description = "" - 204 , _documentLocation = "" - 205 , _documentAspectRatio = PreserveAspectRatio False AlignNone Nothing - 206 } - 207 - 208 -- | Map over the SVG produced by an animation at every frame. - 209 -- - 210 -- Example: - 211 -- - 212 -- > mapA (scale 0.5) drawCircle - 213 -- - 214 -- <<docs/gifs/doc_mapA.gif>> - 215 - 216 mapA :: (SVG -> SVG) -> Animation -> Animation - 217 mapA fn (Animation d f) = Animation d (fn . f) + 68 -- | Construct an animation with a given duration. + 69 mkAnimation :: Duration -> (Time -> SVG) -> Animation + 70 mkAnimation = Animation + 71 + 72 -- | Construct an animation with a duration of @1@. + 73 animate :: (Time -> SVG) -> Animation + 74 animate = Animation 1 + 75 + 76 -- | Create an animation with provided @duration@, which consists of stationary frame displayed for its entire duration. + 77 staticFrame :: Duration -> SVG -> Animation + 78 staticFrame d svg = Animation d (const svg) + 79 + 80 -- | Query the duration of an animation. + 81 duration :: Animation -> Duration + 82 duration (Animation d _) = d + 83 + 84 -- | Play animations in sequence. The @lhs@ animation is removed after it has + 85 -- completed. New animation duration is '@duration lhs + duration rhs@'. + 86 -- + 87 -- Example: + 88 -- + 89 -- > drawBox `seqA` drawCircle + 90 -- + 91 -- <<docs/gifs/doc_seqA.gif>> + 92 seqA :: Animation -> Animation -> Animation + 93 seqA (Animation d1 f1) (Animation d2 f2) = + 94 Animation totalD $ \t -> + 95 if t < d1/totalD + 96 then f1 (t * totalD/d1) + 97 else f2 ((t-d1/totalD) * totalD/d2) + 98 where + 99 totalD = d1+d2 + 100 + 101 -- | Play two animation concurrently. Shortest animation freezes on last frame. + 102 -- New animation duration is '@max (duration lhs) (duration rhs)@'. + 103 -- + 104 -- Example: + 105 -- + 106 -- > drawBox `parA` adjustDuration (*2) drawCircle + 107 -- + 108 -- <<docs/gifs/doc_parA.gif>> + 109 parA :: Animation -> Animation -> Animation + 110 parA (Animation d1 f1) (Animation d2 f2) = + 111 Animation (max d1 d2) $ \t -> + 112 let t1 = t * totalD/d1 + 113 t2 = t * totalD/d2 in + 114 mkGroup + 115 [ f1 (min 1 t1) + 116 , f2 (min 1 t2) ] + 117 where + 118 totalD = max d1 d2 + 119 + 120 -- | Play two animation concurrently. Shortest animation loops. + 121 -- New animation duration is '@max (duration lhs) (duration rhs)@'. + 122 -- + 123 -- Example: + 124 -- + 125 -- > drawBox `parLoopA` adjustDuration (*2) drawCircle + 126 -- + 127 -- <<docs/gifs/doc_parLoopA.gif>> + 128 parLoopA :: Animation -> Animation -> Animation + 129 parLoopA (Animation d1 f1) (Animation d2 f2) = + 130 Animation totalD $ \t -> + 131 let t1 = t * totalD/d1 + 132 t2 = t * totalD/d2 in + 133 mkGroup + 134 [ f1 (t1 `mod'` 1) + 135 , f2 (t2 `mod'` 1) ] + 136 where + 137 totalD = max d1 d2 + 138 + 139 -- | Play two animation concurrently. Animations disappear after playing once. + 140 -- New animation duration is '@max (duration lhs) (duration rhs)@'. + 141 -- + 142 -- Example: + 143 -- + 144 -- > drawBox `parLoopA` adjustDuration (*2) drawCircle + 145 -- + 146 -- <<docs/gifs/doc_parDropA.gif>> + 147 parDropA :: Animation -> Animation -> Animation + 148 parDropA (Animation d1 f1) (Animation d2 f2) = + 149 Animation totalD $ \t -> + 150 let t1 = t * totalD/d1 + 151 t2 = t * totalD/d2 in + 152 mkGroup + 153 [ if t1>1 then None else f1 t1 + 154 , if t2>1 then None else f2 t2 ] + 155 where + 156 totalD = max d1 d2 + 157 + 158 -- | Empty animation (no SVG output) with a fixed duration. + 159 -- + 160 -- Example: + 161 -- + 162 -- > pause 1 `seqA` drawProgress + 163 -- + 164 -- <<docs/gifs/doc_pause.gif>> + 165 pause :: Duration -> Animation + 166 pause d = Animation d (const None) + 167 + 168 -- | Play left animation and freeze on the last frame, then play the right + 169 -- animation. New duration is '@duration lhs + duration rhs@'. + 170 -- + 171 -- Example: + 172 -- + 173 -- > drawBox `andThen` drawCircle + 174 -- + 175 -- <<docs/gifs/doc_andThen.gif>> + 176 andThen :: Animation -> Animation -> Animation + 177 andThen a b = a `parA` (pause (duration a) `seqA` b) + 178 + 179 -- | Calculate the frame that would be displayed at given point in @time@ of running @animation@. + 180 -- + 181 -- The provided time parameter is clamped between 0 and animation duration. + 182 frameAt :: Time -> Animation -> SVG + 183 frameAt t (Animation d f) = f t' + 184 where + 185 t' = clamp 0 1 (t/d) + 186 + 187 -- | Helper function for pretty-printing SVG nodes. + 188 renderTree :: SVG -> String + 189 renderTree t = maybe "" ppElement $ xmlOfTree t + 190 + 191 -- | Helper function for pretty-printing SVG nodes as SVG documents. + 192 renderSvg :: Maybe Number -- ^ The number to use as value of the @width@ attribute of the resulting top-level svg element. If @Nothing@, the width attribute won't be rendered. + 193 -> Maybe Number -- ^ Similar to previous argument, but for @height@ attribute. + 194 -> SVG -- ^ SVG to render + 195 -> String -- ^ String representation of SVG XML markup + 196 renderSvg w h t = ppDocument doc + 197 -- renderSvg w h t = ppFastElement (xmlOfDocument doc) + 198 where + 199 width = 16 + 200 height = 9 + 201 doc = Document + 202 { _viewBox = Just (-width/2, -height/2, width, height) + 203 , _width = w + 204 , _height = h + 205 , _elements = [withStrokeWidth defaultStrokeWidth $ scaleXY 1 (-1) t] + 206 , _description = "" + 207 , _documentLocation = "" + 208 , _documentAspectRatio = PreserveAspectRatio False AlignNone Nothing + 209 } + 210 + 211 -- | Map over the SVG produced by an animation at every frame. + 212 -- + 213 -- Example: + 214 -- + 215 -- > mapA (scale 0.5) drawCircle + 216 -- + 217 -- <<docs/gifs/doc_mapA.gif>> 218 - 219 -- | Freeze the last frame for @t@ seconds at the end of the animation. - 220 -- - 221 -- Example: - 222 -- - 223 -- > pauseAtEnd 1 drawProgress - 224 -- - 225 -- <<docs/gifs/doc_pauseAtEnd.gif>> - 226 pauseAtEnd :: Duration -> Animation -> Animation - 227 pauseAtEnd t a = a `andThen` pause t - 228 - 229 -- | Freeze the first frame for @t@ seconds at the beginning of the animation. - 230 -- - 231 -- Example: - 232 -- - 233 -- > pauseAtBeginning 1 drawProgress - 234 -- - 235 -- <<docs/gifs/doc_pauseAtBeginning.gif>> - 236 pauseAtBeginning :: Duration -> Animation -> Animation - 237 pauseAtBeginning t a = - 238 Animation t (freezeFrame 0 a) `seqA` a - 239 - 240 -- | Freeze the first and the last frame of the animation for a specified duration. - 241 -- - 242 -- Example: - 243 -- - 244 -- > pauseAround 1 1 drawProgress - 245 -- - 246 -- <<docs/gifs/doc_pauseAround.gif>> - 247 pauseAround :: Duration -> Duration -> Animation -> Animation - 248 pauseAround start end = pauseAtEnd end . pauseAtBeginning start - 249 - 250 -- XXX: Rename to 'setDurationFreeze'. Add 'setDurationDrop' and - 251 -- 'setDurationLoop'. - 252 pauseUntil :: Duration -> Animation -> Animation - 253 pauseUntil d a = pauseAtEnd (d-duration a) a - 254 - 255 -- Freeze frame at time @t@. - 256 freezeFrame :: Time -> Animation -> (Time -> SVG) - 257 freezeFrame t (Animation d f) = const $ f (t/d) - 258 - 259 -- | Change the duration of an animation. Animates are stretched or squished - 260 -- (rather than truncated) to fit the new duration. - 261 adjustDuration :: (Duration -> Duration) -> Animation -> Animation - 262 adjustDuration fn (Animation d gen) = - 263 Animation (fn d) gen - 264 - 265 -- | Set the duration of an animation by adjusting its playback rate. The - 266 -- animation is still played from start to finish without being cropped. - 267 setDuration :: Duration -> Animation -> Animation - 268 setDuration newD = adjustDuration (const newD) - 269 - 270 -- | Play an animation in reverse. Duration remains unchanged. Shorthand for: - 271 -- @'signalA' 'reverseS'@. - 272 -- - 273 -- Example: - 274 -- - 275 -- > reverseA drawCircle - 276 -- - 277 -- <<docs/gifs/doc_reverseA.gif>> - 278 reverseA :: Animation -> Animation - 279 reverseA = signalA reverseS - 280 - 281 -- | Play animation before playing it again in reverse. Duration is twice - 282 -- the duration of the input. - 283 -- - 284 -- Example: - 285 -- - 286 -- > playThenReverseA drawCircle - 287 -- - 288 -- <<docs/gifs/doc_playThenReverseA.gif>> - 289 playThenReverseA :: Animation -> Animation - 290 playThenReverseA a = a `seqA` reverseA a - 291 - 292 -- | Loop animation @n@ number of times. This number may be fractional and it - 293 -- may be less than 1. It must be greater than or equal to 0, though. - 294 -- New duration is @n*duration input@. - 295 -- - 296 -- Example: - 297 -- - 298 -- > repeatA 1.5 drawCircle - 299 -- - 300 -- <<docs/gifs/doc_repeatA.gif>> - 301 repeatA :: Double -> Animation -> Animation - 302 repeatA n (Animation d f) = Animation (d*n) $ \t -> - 303 f ((t*n) `mod'` 1) - 304 - 305 - 306 -- | @freezeAtPercentage time animation@ creates an animation consisting of stationary frame, - 307 -- that would be displayed in the provided @animation@ at given @time@. - 308 -- The duration of the new animation is the same as the duration of provided @animation@. - 309 freezeAtPercentage :: Time -- ^ value between 0 and 1. The frame displayed at this point in the original animation will be displayed for the duration of the new animation - 310 -> Animation -- ^ original animation, from which the frame will be taken - 311 -> Animation -- ^ new animation consisting of static frame displayed for the duration of the original animation - 312 freezeAtPercentage frac (Animation d genFrame) = - 313 Animation d $ const $ genFrame frac - 314 - 315 -- | Overlay animation on top of static SVG image. - 316 -- - 317 -- Example: - 318 -- - 319 -- > addStatic (mkBackground "lightblue") drawCircle - 320 -- - 321 -- <<docs/gifs/doc_addStatic.gif>> - 322 addStatic :: SVG -> Animation -> Animation - 323 addStatic static = mapA (\frame -> mkGroup [static, frame]) - 324 - 325 -- | Modify the time component of an animation. Animation duration is unchanged. - 326 -- - 327 -- Example: - 328 -- - 329 -- > signalA (fromToS 0.25 0.75) drawCircle - 330 -- - 331 -- <<docs/gifs/doc_signalA.gif>> - 332 signalA :: Signal -> Animation -> Animation - 333 signalA fn (Animation d gen) = Animation d $ gen . fn - 334 - 335 -- | @takeA duration animation@ creates a new animation consisting of initial segment of - 336 -- @animation@ of given @duration@, played at the same rate as the original animation. - 337 -- - 338 -- The @duration@ parameter is clamped to be between 0 and @animation@'s duration. - 339 -- New animation duration is equal to (eventually clamped) @duration@. - 340 takeA :: Duration -> Animation -> Animation - 341 takeA len (Animation d gen) = Animation len' $ \t -> - 342 gen (t * len'/d) - 343 where - 344 len' = clamp 0 d len - 345 - 346 -- | @dropA duration animation@ creates a new animation by dropping initial segment - 347 -- of length @duration@ from the provided @animation@, played at the same rate as the original animation. - 348 -- - 349 -- The @duration@ parameter is clamped to be between 0 and @animation@'s duration. - 350 -- The duration of the resulting animation is duration of provided @animation@ minus (eventually clamped) @duration@. - 351 dropA :: Duration -> Animation -> Animation - 352 dropA len (Animation d gen) = Animation len' $ \t -> - 353 gen (t * len'/d + len/d) - 354 where - 355 len' = d - clamp 0 d len - 356 - 357 lastA :: Duration -> Animation -> Animation - 358 lastA len a = dropA (duration a - len) a + 219 mapA :: (SVG -> SVG) -> Animation -> Animation + 220 mapA fn (Animation d f) = Animation d (fn . f) + 221 + 222 -- | Freeze the last frame for @t@ seconds at the end of the animation. + 223 -- + 224 -- Example: + 225 -- + 226 -- > pauseAtEnd 1 drawProgress + 227 -- + 228 -- <<docs/gifs/doc_pauseAtEnd.gif>> + 229 pauseAtEnd :: Duration -> Animation -> Animation + 230 pauseAtEnd t a = a `andThen` pause t + 231 + 232 -- | Freeze the first frame for @t@ seconds at the beginning of the animation. + 233 -- + 234 -- Example: + 235 -- + 236 -- > pauseAtBeginning 1 drawProgress + 237 -- + 238 -- <<docs/gifs/doc_pauseAtBeginning.gif>> + 239 pauseAtBeginning :: Duration -> Animation -> Animation + 240 pauseAtBeginning t a = + 241 Animation t (freezeFrame 0 a) `seqA` a + 242 + 243 -- | Freeze the first and the last frame of the animation for a specified duration. + 244 -- + 245 -- Example: + 246 -- + 247 -- > pauseAround 1 1 drawProgress + 248 -- + 249 -- <<docs/gifs/doc_pauseAround.gif>> + 250 pauseAround :: Duration -> Duration -> Animation -> Animation + 251 pauseAround start end = pauseAtEnd end . pauseAtBeginning start + 252 + 253 -- XXX: Rename to 'setDurationFreeze'. Add 'setDurationDrop' and + 254 -- 'setDurationLoop'. + 255 pauseUntil :: Duration -> Animation -> Animation + 256 pauseUntil d a = pauseAtEnd (d-duration a) a + 257 + 258 -- Freeze frame at time @t@. + 259 freezeFrame :: Time -> Animation -> (Time -> SVG) + 260 freezeFrame t (Animation d f) = const $ f (t/d) + 261 + 262 -- | Change the duration of an animation. Animates are stretched or squished + 263 -- (rather than truncated) to fit the new duration. + 264 adjustDuration :: (Duration -> Duration) -> Animation -> Animation + 265 adjustDuration fn (Animation d gen) = + 266 Animation (fn d) gen + 267 + 268 -- | Set the duration of an animation by adjusting its playback rate. The + 269 -- animation is still played from start to finish without being cropped. + 270 setDuration :: Duration -> Animation -> Animation + 271 setDuration newD = adjustDuration (const newD) + 272 + 273 -- | Play an animation in reverse. Duration remains unchanged. Shorthand for: + 274 -- @'signalA' 'reverseS'@. + 275 -- + 276 -- Example: + 277 -- + 278 -- > reverseA drawCircle + 279 -- + 280 -- <<docs/gifs/doc_reverseA.gif>> + 281 reverseA :: Animation -> Animation + 282 reverseA = signalA reverseS + 283 + 284 -- | Play animation before playing it again in reverse. Duration is twice + 285 -- the duration of the input. + 286 -- + 287 -- Example: + 288 -- + 289 -- > playThenReverseA drawCircle + 290 -- + 291 -- <<docs/gifs/doc_playThenReverseA.gif>> + 292 playThenReverseA :: Animation -> Animation + 293 playThenReverseA a = a `seqA` reverseA a + 294 + 295 -- | Loop animation @n@ number of times. This number may be fractional and it + 296 -- may be less than 1. It must be greater than or equal to 0, though. + 297 -- New duration is @n*duration input@. + 298 -- + 299 -- Example: + 300 -- + 301 -- > repeatA 1.5 drawCircle + 302 -- + 303 -- <<docs/gifs/doc_repeatA.gif>> + 304 repeatA :: Double -> Animation -> Animation + 305 repeatA n (Animation d f) = Animation (d*n) $ \t -> + 306 f ((t*n) `mod'` 1) + 307 + 308 + 309 -- | @freezeAtPercentage time animation@ creates an animation consisting of stationary frame, + 310 -- that would be displayed in the provided @animation@ at given @time@. + 311 -- The duration of the new animation is the same as the duration of provided @animation@. + 312 freezeAtPercentage :: Time -- ^ value between 0 and 1. The frame displayed at this point in the original animation will be displayed for the duration of the new animation + 313 -> Animation -- ^ original animation, from which the frame will be taken + 314 -> Animation -- ^ new animation consisting of static frame displayed for the duration of the original animation + 315 freezeAtPercentage frac (Animation d genFrame) = + 316 Animation d $ const $ genFrame frac + 317 + 318 -- | Overlay animation on top of static SVG image. + 319 -- + 320 -- Example: + 321 -- + 322 -- > addStatic (mkBackground "lightblue") drawCircle + 323 -- + 324 -- <<docs/gifs/doc_addStatic.gif>> + 325 addStatic :: SVG -> Animation -> Animation + 326 addStatic static = mapA (\frame -> mkGroup [static, frame]) + 327 + 328 -- | Modify the time component of an animation. Animation duration is unchanged. + 329 -- + 330 -- Example: + 331 -- + 332 -- > signalA (fromToS 0.25 0.75) drawCircle + 333 -- + 334 -- <<docs/gifs/doc_signalA.gif>> + 335 signalA :: Signal -> Animation -> Animation + 336 signalA fn (Animation d gen) = Animation d $ gen . fn + 337 + 338 -- | @takeA duration animation@ creates a new animation consisting of initial segment of + 339 -- @animation@ of given @duration@, played at the same rate as the original animation. + 340 -- + 341 -- The @duration@ parameter is clamped to be between 0 and @animation@'s duration. + 342 -- New animation duration is equal to (eventually clamped) @duration@. + 343 takeA :: Duration -> Animation -> Animation + 344 takeA len (Animation d gen) = Animation len' $ \t -> + 345 gen (t * len'/d) + 346 where + 347 len' = clamp 0 d len + 348 + 349 -- | @dropA duration animation@ creates a new animation by dropping initial segment + 350 -- of length @duration@ from the provided @animation@, played at the same rate as the original animation. + 351 -- + 352 -- The @duration@ parameter is clamped to be between 0 and @animation@'s duration. + 353 -- The duration of the resulting animation is duration of provided @animation@ minus (eventually clamped) @duration@. + 354 dropA :: Duration -> Animation -> Animation + 355 dropA len (Animation d gen) = Animation len' $ \t -> + 356 gen (t * len'/d + len/d) + 357 where + 358 len' = d - clamp 0 d len 359 - 360 clamp :: Double -> Double -> Double -> Double - 361 clamp a b number - 362 | a < b = max a (min b number) - 363 | otherwise = max b (min a number) - 364 - 365 (#) :: a -> (a -> b) -> b - 366 o # f = f o - 367 - 368 getAnimationFrame :: Sync -> Animation -> Time -> Duration -> SVG - 369 getAnimationFrame sync (Animation aDur aGen) t d = - 370 case sync of - 371 SyncStretch -> aGen (t/d) - 372 SyncLoop -> aGen (takeFrac $ t/aDur) - 373 SyncDrop -> if t > aDur then None else aGen (t/aDur) - 374 SyncFreeze -> aGen (min 1 $ t/aDur) - 375 where - 376 takeFrac f = snd (properFraction f :: (Int, Double)) - 377 - 378 data Sync - 379 = SyncStretch - 380 | SyncLoop - 381 | SyncDrop - 382 | SyncFreeze + 360 -- | @lastA duration animation@ return the last @duration@ seconds of the animation. + 361 lastA :: Duration -> Animation -> Animation + 362 lastA len a = dropA (duration a - len) a + 363 + 364 clamp :: Double -> Double -> Double -> Double + 365 clamp a b number + 366 | a < b = max a (min b number) + 367 | otherwise = max b (min a number) + 368 + 369 -- (#) :: a -> (a -> b) -> b + 370 -- o # f = f o + 371 + 372 -- | Ask for an animation frame using a given synchronization policy. + 373 getAnimationFrame :: Sync -> Animation -> Time -> Duration -> SVG + 374 getAnimationFrame sync (Animation aDur aGen) t d = + 375 case sync of + 376 SyncStretch -> aGen (t/d) + 377 SyncLoop -> aGen (takeFrac $ t/aDur) + 378 SyncDrop -> if t > aDur then None else aGen (t/aDur) + 379 SyncFreeze -> aGen (min 1 $ t/aDur) + 380 where + 381 takeFrac f = snd (properFraction f :: (Int, Double)) + 382 + 383 -- | Animation synchronization policies. + 384 data Sync + 385 = SyncStretch + 386 | SyncLoop + 387 | SyncDrop + 388 | SyncFreeze diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Documentation.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Documentation.hs.html index cc08c25..a5e7513 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Documentation.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Builtin.Documentation.hs.html @@ -25,51 +25,54 @@ span.spaces { background: white } 6 import Reanimate.Constants 7 import Codec.Picture 8 - 9 docEnv :: Animation -> Animation - 10 docEnv = mapA $ \svg -> mkGroup - 11 [ mkBackground "white" - 12 , withFillOpacity 0 $ - 13 withStrokeWidth 0.1 $ - 14 withStrokeColor "black" (mkGroup [svg]) ] - 15 - 16 -- | <<docs/gifs/doc_drawBox.gif>> - 17 drawBox :: Animation - 18 drawBox = mkAnimation 2 $ \t -> - 19 partialSvg t $ pathify $ - 20 mkRect (screenWidth/2) (screenHeight/2) - 21 - 22 -- | <<docs/gifs/doc_drawCircle.gif>> - 23 drawCircle :: Animation - 24 drawCircle = mkAnimation 2 $ \t -> - 25 partialSvg t $ pathify $ - 26 mkCircle (screenHeight/3) - 27 - 28 drawBall :: Animation - 29 drawBall = mkAnimation 2 $ \t -> - 30 scale t $ withFillOpacity 1 $ withFillColor "red" $ - 31 mkCircle (screenHeight/3) - 32 - 33 -- | <<docs/gifs/doc_drawProgress.gif>> - 34 drawProgress :: Animation - 35 drawProgress = mkAnimation 2 $ \t -> - 36 mkGroup - 37 [ mkLine (-screenWidth/2*widthP,0) - 38 (screenWidth/2*widthP,0) - 39 , translate (-screenWidth/2*widthP + screenWidth*widthP*t) 0 $ - 40 withFillOpacity 1 $ mkCircle 0.5 ] - 41 where - 42 widthP = 0.8 - 43 - 44 showColorMap :: (Double -> PixelRGB8) -> SVG - 45 showColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img - 46 where - 47 width = 256 - 48 height = 1 - 49 img = generateImage pixelRenderer width height - 50 pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) - 51 - 52 rtfdBackgroundColor :: PixelRGBA8 - 53 rtfdBackgroundColor = PixelRGBA8 252 252 252 0xFF + 9 -- | Default environment for API documentation GIFs. + 10 docEnv :: Animation -> Animation + 11 docEnv = mapA $ \svg -> mkGroup + 12 [ mkBackground "white" + 13 , withFillOpacity 0 $ + 14 withStrokeWidth 0.1 $ + 15 withStrokeColor "black" (mkGroup [svg]) ] + 16 + 17 -- | <<docs/gifs/doc_drawBox.gif>> + 18 drawBox :: Animation + 19 drawBox = mkAnimation 2 $ \t -> + 20 partialSvg t $ pathify $ + 21 mkRect (screenWidth/2) (screenHeight/2) + 22 + 23 -- | <<docs/gifs/doc_drawCircle.gif>> + 24 drawCircle :: Animation + 25 drawCircle = mkAnimation 2 $ \t -> + 26 partialSvg t $ pathify $ + 27 mkCircle (screenHeight/3) + 28 + 29 drawBall :: Animation + 30 drawBall = mkAnimation 2 $ \t -> + 31 scale t $ withFillOpacity 1 $ withFillColor "red" $ + 32 mkCircle (screenHeight/3) + 33 + 34 -- | <<docs/gifs/doc_drawProgress.gif>> + 35 drawProgress :: Animation + 36 drawProgress = mkAnimation 2 $ \t -> + 37 mkGroup + 38 [ mkLine (-screenWidth/2*widthP,0) + 39 (screenWidth/2*widthP,0) + 40 , translate (-screenWidth/2*widthP + screenWidth*widthP*t) 0 $ + 41 withFillOpacity 1 $ mkCircle 0.5 ] + 42 where + 43 widthP = 0.8 + 44 + 45 -- | Render a full-screen view of a color-map. + 46 showColorMap :: (Double -> PixelRGB8) -> SVG + 47 showColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img + 48 where + 49 width = 256 + 50 height = 1 + 51 img = generateImage pixelRenderer width height + 52 pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1)) + 53 + 54 -- | Default background color for videos on reanimate.rtfd.io + 55 rtfdBackgroundColor :: PixelRGBA8 + 56 rtfdBackgroundColor = PixelRGBA8 252 252 252 0xFF diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Ease.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Ease.hs.html index 8ff1fca..01b94ef 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Ease.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Ease.hs.html @@ -17,113 +17,124 @@ span.spaces { background: white } never executed always true always false 
-    1 module Reanimate.Ease
-    2   ( Signal
-    3   , constantS
-    4   , fromToS
-    5   , reverseS
-    6   , curveS
-    7   , powerS
-    8   , bellS
-    9   , oscillateS
-   10   , fromListS
-   11   , cubicBezierS
-   12   ) where
-   13 
-   14 -- | Signals are time-varying variables. Signals can be composed using function
-   15 --   composition.
-   16 type Signal = Double -> Double
+    1 {-|
+    2   Easing functions modify the rate of change in animations.
+    3   More examples can be seen here: <https://easings.net/>.
+    4 -}
+    5 module Reanimate.Ease
+    6   ( Signal
+    7   , constantS
+    8   , fromToS
+    9   , reverseS
+   10   , curveS
+   11   , powerS
+   12   , bellS
+   13   , oscillateS
+   14   , fromListS
+   15   , cubicBezierS
+   16   ) where
    17 
-   18 fromListS :: [(Double, Signal)] -> Signal
-   19 fromListS fns t = worker 0 fns
-   20   where
-   21     worker _ [] = 0
-   22     worker now [(len, fn)] = fn (min 1 ((t-now) / min (1-now) len))
-   23     worker now ((len, fn):rest)
-   24       | now+len < t = worker (now+len) rest
-   25       | otherwise = fn ((t-now) / len)
-   26 
-   27 -- | Constant signal.
-   28 --
-   29 --   Example:
-   30 --
-   31 --   > signalA (constantS 0.5) drawProgress
+   18 -- | Signals are time-varying variables. Signals can be composed using function
+   19 --   composition.
+   20 type Signal = Double -> Double
+   21 
+   22 fromListS :: [(Double, Signal)] -> Signal
+   23 fromListS fns t = worker 0 fns
+   24   where
+   25     worker _ [] = 0
+   26     worker now [(len, fn)] = fn (min 1 ((t-now) / min (1-now) len))
+   27     worker now ((len, fn):rest)
+   28       | now+len < t = worker (now+len) rest
+   29       | otherwise = fn ((t-now) / len)
+   30 
+   31 -- | Constant signal.
    32 --
-   33 --   <<docs/gifs/doc_constantS.gif>>
-   34 constantS :: Double -> Signal
-   35 constantS = const
-   36 
-   37 -- | Signal with new starting and end values.
-   38 --
-   39 --   Example:
-   40 --
-   41 --   > signalA (fromToS 0.8 0.2) drawProgress
+   33 --   Example:
+   34 --
+   35 --   > signalA (constantS 0.5) drawProgress
+   36 --
+   37 --   <<docs/gifs/doc_constantS.gif>>
+   38 constantS :: Double -> Signal
+   39 constantS = const
+   40 
+   41 -- | Signal with new starting and end values.
    42 --
-   43 --   <<docs/gifs/doc_fromToS.gif>>
-   44 fromToS :: Double -> Double -> Signal
-   45 fromToS from to t = from + (to-from)*t
-   46 
-   47 -- | Reverse signal order.
-   48 --
-   49 --   Example:
-   50 --
-   51 --   > signalA reverseS drawProgress
+   43 --   Example:
+   44 --
+   45 --   > signalA (fromToS 0.8 0.2) drawProgress
+   46 --
+   47 --   <<docs/gifs/doc_fromToS.gif>>
+   48 fromToS :: Double -> Double -> Signal
+   49 fromToS from to t = from + (to-from)*t
+   50 
+   51 -- | Reverse signal order.
    52 --
-   53 --   <<docs/gifs/doc_reverseS.gif>>
-   54 reverseS :: Signal
-   55 reverseS t = 1-t
-   56 
-   57 -- | S-curve signal. Takes a steepness parameter. 2 is a good default.
-   58 --
-   59 --   Example:
-   60 --
-   61 --   > signalA (curveS 2) drawProgress
+   53 --   Example:
+   54 --
+   55 --   > signalA reverseS drawProgress
+   56 --
+   57 --   <<docs/gifs/doc_reverseS.gif>>
+   58 reverseS :: Signal
+   59 reverseS t = 1-t
+   60 
+   61 -- | S-curve signal. Takes a steepness parameter. 2 is a good default.
    62 --
-   63 --   <<docs/gifs/doc_curveS.gif>>
-   64 curveS :: Double -> Signal
-   65 curveS steepness s =
-   66   if s < 0.5
-   67     then 0.5 * (2*s)**steepness
-   68     else 1-0.5 * (2 - 2*s)**steepness
-   69 
-   70 powerS :: Double -> Signal
-   71 powerS steepness s = s**steepness
-   72 
-   73 -- | Oscillate signal.
-   74 --
-   75 --   Example:
-   76 --
-   77 --   > signalA oscillateS drawProgress
-   78 --
-   79 --   <<docs/gifs/doc_oscillateS.gif>>
-   80 oscillateS :: Signal
-   81 oscillateS t =
-   82   if t < 1/2
-   83     then t*2
-   84     else 2-t*2
-   85 
-   86 -- | Bell-curve signal. Takes a steepness parameter. 2 is a good default.
+   63 --   Example:
+   64 --
+   65 --   > signalA (curveS 2) drawProgress
+   66 --
+   67 --   <<docs/gifs/doc_curveS.gif>>
+   68 curveS :: Double -> Signal
+   69 curveS steepness s =
+   70   if s < 0.5
+   71     then 0.5 * (2*s)**steepness
+   72     else 1-0.5 * (2 - 2*s)**steepness
+   73 
+   74 -- | Power curve signal. Takes a steepness parameter. 2 is a good default.
+   75 --
+   76 --   Example:
+   77 --
+   78 --   > signalA (powerS 2) drawProgress
+   79 --
+   80 --   <<docs/gifs/doc_powerS.gif>>
+   81 powerS :: Double -> Signal
+   82 powerS steepness s = s**steepness
+   83 
+   84 -- | Oscillate signal.
+   85 --
+   86 --   Example:
    87 --
-   88 --   Example:
+   88 --   > signalA oscillateS drawProgress
    89 --
-   90 --   > signalA (bellS 2) drawProgress
-   91 --
-   92 --   <<docs/gifs/doc_bellS.gif>>
-   93 bellS :: Double -> Signal
-   94 bellS steepness = curveS steepness . oscillateS
-   95 
-   96 -- | Cubic Bezier signal. Gives you a fair amount of control over how the
-   97 --   signal will 'curve'.
+   90 --   <<docs/gifs/doc_oscillateS.gif>>
+   91 oscillateS :: Signal
+   92 oscillateS t =
+   93   if t < 1/2
+   94     then t*2
+   95     else 2-t*2
+   96 
+   97 -- | Bell-curve signal. Takes a steepness parameter. 2 is a good default.
    98 --
    99 --   Example:
   100 --
-  101 --   > signalA (cubicBezierS (0.0, 0.8, 0.9, 1.0)) drawProgress
-  102 --   
-  103 --   <<docs/gifs/doc_cubicBezierS.gif>>
-  104 cubicBezierS :: (Double, Double, Double, Double) -> Signal
-  105 cubicBezierS (x1, x2, x3, x4) s = 
-  106   let ms = 1-s
-  107   in x1*ms^(3::Int) + 3*x2*ms^(2::Int)*s + 3*x3*ms*s^(2::Int) + x4*s^(3::Int)
+  101 --   > signalA (bellS 2) drawProgress
+  102 --
+  103 --   <<docs/gifs/doc_bellS.gif>>
+  104 bellS :: Double -> Signal
+  105 bellS steepness = curveS steepness . oscillateS
+  106 
+  107 -- | Cubic Bezier signal. Gives you a fair amount of control over how the
+  108 --   signal will 'curve'.
+  109 --
+  110 --   Example:
+  111 --
+  112 --   > signalA (cubicBezierS (0.0, 0.8, 0.9, 1.0)) drawProgress
+  113 --   
+  114 --   <<docs/gifs/doc_cubicBezierS.gif>>
+  115 cubicBezierS :: (Double, Double, Double, Double) -> Signal
+  116 cubicBezierS (x1, x2, x3, x4) s = 
+  117   let ms = 1-s
+  118   in x1*ms^(3::Int) + 3*x2*ms^(2::Int)*s + 3*x3*ms*s^(2::Int) + x4*s^(3::Int)
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Raster.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Raster.hs.html index 6c52a4a..cafdfd0 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Raster.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Raster.hs.html @@ -138,180 +138,189 @@ span.spaces { background: white } 119 target = pRootDirectory </> encodeInt hashPath <.> takeExtension path 120 hashPath = hash path 121 - 122 cacheImage :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath - 123 cacheImage key gen = unsafePerformIO $ cacheFile template $ \path -> - 124 writePng path gen - 125 where template = encodeInt (hash key) <.> "png" - 126 - 127 -- Warning: Caching svg elements with links to external objects does - 128 -- not work. 2020-06-01 - 129 prerenderSvgFile :: Hashable a => a -> Width -> Height -> SVG -> FilePath - 130 prerenderSvgFile key width height svg = - 131 unsafePerformIO $ cacheFile template $ \path -> do - 132 let svgPath = replaceExtension path "svg" - 133 writeFile svgPath rendered - 134 engine <- requireRaster pRaster - 135 applyRaster engine svgPath - 136 where - 137 template = encodeInt (hash (key, width, height)) <.> "png" - 138 rendered = renderSvg (Just $ Px $ fromIntegral width) - 139 (Just $ Px $ fromIntegral height) - 140 svg - 141 - 142 prerenderSvg :: Hashable a => a -> SVG -> SVG - 143 prerenderSvg key = - 144 mkImage screenWidth screenHeight . prerenderSvgFile key pWidth pHeight + 122 -- | Write in-memory image to cache file if (and only if) such cache file doesn't + 123 -- already exist. + 124 cacheImage :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath + 125 cacheImage key gen = unsafePerformIO $ cacheFile template $ \path -> + 126 writePng path gen + 127 where template = encodeInt (hash key) <.> "png" + 128 + 129 -- Warning: Caching svg elements with links to external objects does + 130 -- not work. 2020-06-01 + 131 -- | Same as 'prerenderSvg' but returns the location of the rendered image + 132 -- as a FilePath. + 133 prerenderSvgFile :: Hashable a => a -> Width -> Height -> SVG -> FilePath + 134 prerenderSvgFile key width height svg = + 135 unsafePerformIO $ cacheFile template $ \path -> do + 136 let svgPath = replaceExtension path "svg" + 137 writeFile svgPath rendered + 138 engine <- requireRaster pRaster + 139 applyRaster engine svgPath + 140 where + 141 template = encodeInt (hash (key, width, height)) <.> "png" + 142 rendered = renderSvg (Just $ Px $ fromIntegral width) + 143 (Just $ Px $ fromIntegral height) + 144 svg 145 - 146 - 147 {-# INLINE embedImage #-} - 148 -- | Embed an in-memory PNG image. Note, the pixel size of the image - 149 -- is used as the dimensions. As such, embedding a 100x100 PNG will - 150 -- result in an image 100 units wide and 100 units high. Consider - 151 -- using with 'scaleToSize'. - 152 embedImage :: PngSavable a => Image a -> SVG - 153 embedImage img = embedPng width height (encodePng img) - 154 where - 155 width = fromIntegral $ imageWidth img - 156 height = fromIntegral $ imageHeight img - 157 - 158 -- | Embed in-memory PNG bytestring without parsing it. - 159 embedPng - 160 :: Double -- ^ Width - 161 -> Double -- ^ Height - 162 -> LBS.ByteString -- ^ Raw PNG data - 163 -> SVG - 164 -- embedPng w h png = unsafePerformIO $ do - 165 -- LBS.writeFile path png - 166 -- return $ ImageTree $ defaultSvg - 167 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2)) - 168 -- & Svg.imageWidth .~ Svg.Num w - 169 -- & Svg.imageHeight .~ Svg.Num h - 170 -- & Svg.imageHref .~ ("file://"++path) - 171 -- where - 172 -- path = "/tmp" </> show (hash png) <.> "png" - 173 embedPng w h png = - 174 flipYAxis - 175 $ ImageTree - 176 $ defaultSvg - 177 & Svg.imageCornerUpperLeft - 178 .~ (Svg.Num (-w / 2), Svg.Num (-h / 2)) - 179 & Svg.imageWidth - 180 .~ Svg.Num w - 181 & Svg.imageHeight - 182 .~ Svg.Num h - 183 & Svg.imageHref - 184 .~ ("data:image/png;base64," ++ imgData) - 185 where imgData = LBS.unpack $ Base64.encode png - 186 - 187 - 188 {-# INLINE embedDynamicImage #-} - 189 -- | Embed an in-memory image. Note, the pixel size of the image - 190 -- is used as the dimensions. As such, embedding a 100x100 image will - 191 -- result in an image 100 units wide and 100 units high. Consider - 192 -- using with 'scaleToSize'. - 193 embedDynamicImage :: DynamicImage -> SVG - 194 embedDynamicImage img = embedPng width height imgData - 195 where - 196 width = fromIntegral $ dynamicMap imageWidth img - 197 height = fromIntegral $ dynamicMap imageHeight img - 198 imgData = case encodeDynamicPng img of - 199 Left err -> error err - 200 Right dat -> dat - 201 - 202 -- embedImageFile :: FilePath -> Tree - 203 -- embedImageFile path = unsafePerformIO $ do - 204 -- png <- B.readFile path - 205 -- case decodePng png of - 206 -- Left{} -> error "bad image" - 207 -- Right img -> return $ - 208 -- let width = fromIntegral $ dynamicMap imageWidth img - 209 -- height = fromIntegral $ dynamicMap imageHeight img in - 210 -- ImageTree $ defaultSvg - 211 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-width/2), Svg.Num (-height/2)) - 212 -- & Svg.imageWidth .~ Svg.Num width - 213 -- & Svg.imageHeight .~ Svg.Num height - 214 -- & Svg.imageHref .~ ("file://" ++ path) - 215 - 216 - 217 -- | Convert an SVG object to a pixel-based image. The default resolution - 218 -- is 2560x1440. See also 'rasterSized'. Multiple raster engines are supported - 219 -- and are selected using the '--raster' flag in the driver. - 220 raster :: SVG -> DynamicImage - 221 raster = rasterSized 2560 1440 - 222 - 223 -- | Convert an SVG object to a pixel-based image. - 224 rasterSized - 225 :: Width -- ^ X resolution in pixels - 226 -> Height -- ^ Y resolution in pixels - 227 -> SVG -- ^ SVG object - 228 -> DynamicImage - 229 rasterSized w h svg = unsafePerformIO $ do - 230 png <- B.readFile (svgAsPngFile' w h svg) - 231 case decodePng png of - 232 Left{} -> error "bad image" - 233 Right img -> return img - 234 - 235 -- | Use 'potrace' to trace edges in a raster image and convert them to SVG polygons. - 236 vectorize :: FilePath -> SVG - 237 vectorize = vectorize_ [] - 238 - 239 -- | Same as 'vectorize' but takes a list of arguments for 'potrace'. - 240 vectorize_ :: [String] -> FilePath -> SVG - 241 vectorize_ _ path | pNoExternals = mkText $ T.pack path - 242 vectorize_ args path = unsafePerformIO $ do - 243 root <- getXdgDirectory XdgCache "reanimate" - 244 createDirectoryIfMissing True root - 245 let svgPath = root </> encodeInt key <.> "svg" - 246 hit <- doesFileExist svgPath - 247 unless hit $ withSystemTempFile "file.svg" $ \tmpSvgPath svgH -> - 248 withSystemTempFile "file.bmp" $ \tmpBmpPath bmpH -> do - 249 hClose svgH - 250 hClose bmpH - 251 potrace <- requireExecutable "potrace" - 252 magick <- requireExecutable magickCmd - 253 runCmd magick [path, "-flatten", tmpBmpPath] - 254 runCmd potrace (args ++ ["--svg", "--output", tmpSvgPath, tmpBmpPath]) - 255 renameOrCopyFile tmpSvgPath svgPath - 256 svg_data <- B.readFile svgPath - 257 case parseSvgFile svgPath svg_data of - 258 Nothing -> do - 259 removeFile svgPath - 260 error "Malformed svg" - 261 Just svg -> return $ unbox $ replaceUses svg - 262 where key = hash (path, args) - 263 - 264 -- imageAsFile :: DynamicImage -> FilePath - 265 -- imageAsFile img - 266 - 267 -- | Convert an SVG object to a pixel-based image and save it to disk, returning - 268 -- the filepath. The default resolution is 2560x1440. See also 'svgAsPngFile''. - 269 -- Multiple raster engines are supported and are selected using the '--raster' - 270 -- flag in the driver. - 271 svgAsPngFile :: SVG -> FilePath - 272 svgAsPngFile = svgAsPngFile' width height - 273 where - 274 width = 2560 - 275 height = width * 9 `div` 16 - 276 - 277 -- | Convert an SVG object to a pixel-based image and save it to disk, returning - 278 -- the filepath. - 279 svgAsPngFile' - 280 :: Width -- ^ Width - 281 -> Height -- ^ Height - 282 -> SVG -- ^ SVG object - 283 -> FilePath - 284 svgAsPngFile' _ _ _ | pNoExternals = "/svgAsPngFile/has/been/disabled" - 285 svgAsPngFile' width height svg = - 286 unsafePerformIO $ cacheFile template $ \pngPath -> do - 287 let svgPath = replaceExtension pngPath "svg" - 288 writeFile svgPath rendered - 289 engine <- requireRaster pRaster - 290 applyRaster engine svgPath - 291 where - 292 template = encodeInt (hash rendered) <.> "png" - 293 rendered = renderSvg (Just $ Px $ fromIntegral width) - 294 (Just $ Px $ fromIntegral height) - 295 svg + 146 -- | Render SVG node to a PNG file and return a new node containing + 147 -- that image. For static SVG nodes, this can hugely improve performance. + 148 -- The first argument is the key that determines SVG uniqueness. It + 149 -- is entirely your responsibility to ensure that all keys are unique. + 150 -- If they are not, you will be served stale results from the cache. + 151 prerenderSvg :: Hashable a => a -> SVG -> SVG + 152 prerenderSvg key = + 153 mkImage screenWidth screenHeight . prerenderSvgFile key pWidth pHeight + 154 + 155 + 156 {-# INLINE embedImage #-} + 157 -- | Embed an in-memory PNG image. Note, the pixel size of the image + 158 -- is used as the dimensions. As such, embedding a 100x100 PNG will + 159 -- result in an image 100 units wide and 100 units high. Consider + 160 -- using with 'scaleToSize'. + 161 embedImage :: PngSavable a => Image a -> SVG + 162 embedImage img = embedPng width height (encodePng img) + 163 where + 164 width = fromIntegral $ imageWidth img + 165 height = fromIntegral $ imageHeight img + 166 + 167 -- | Embed in-memory PNG bytestring without parsing it. + 168 embedPng + 169 :: Double -- ^ Width + 170 -> Double -- ^ Height + 171 -> LBS.ByteString -- ^ Raw PNG data + 172 -> SVG + 173 -- embedPng w h png = unsafePerformIO $ do + 174 -- LBS.writeFile path png + 175 -- return $ ImageTree $ defaultSvg + 176 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2)) + 177 -- & Svg.imageWidth .~ Svg.Num w + 178 -- & Svg.imageHeight .~ Svg.Num h + 179 -- & Svg.imageHref .~ ("file://"++path) + 180 -- where + 181 -- path = "/tmp" </> show (hash png) <.> "png" + 182 embedPng w h png = + 183 flipYAxis + 184 $ ImageTree + 185 $ defaultSvg + 186 & Svg.imageCornerUpperLeft + 187 .~ (Svg.Num (-w / 2), Svg.Num (-h / 2)) + 188 & Svg.imageWidth + 189 .~ Svg.Num w + 190 & Svg.imageHeight + 191 .~ Svg.Num h + 192 & Svg.imageHref + 193 .~ ("data:image/png;base64," ++ imgData) + 194 where imgData = LBS.unpack $ Base64.encode png + 195 + 196 + 197 {-# INLINE embedDynamicImage #-} + 198 -- | Embed an in-memory image. Note, the pixel size of the image + 199 -- is used as the dimensions. As such, embedding a 100x100 image will + 200 -- result in an image 100 units wide and 100 units high. Consider + 201 -- using with 'scaleToSize'. + 202 embedDynamicImage :: DynamicImage -> SVG + 203 embedDynamicImage img = embedPng width height imgData + 204 where + 205 width = fromIntegral $ dynamicMap imageWidth img + 206 height = fromIntegral $ dynamicMap imageHeight img + 207 imgData = case encodeDynamicPng img of + 208 Left err -> error err + 209 Right dat -> dat + 210 + 211 -- embedImageFile :: FilePath -> Tree + 212 -- embedImageFile path = unsafePerformIO $ do + 213 -- png <- B.readFile path + 214 -- case decodePng png of + 215 -- Left{} -> error "bad image" + 216 -- Right img -> return $ + 217 -- let width = fromIntegral $ dynamicMap imageWidth img + 218 -- height = fromIntegral $ dynamicMap imageHeight img in + 219 -- ImageTree $ defaultSvg + 220 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-width/2), Svg.Num (-height/2)) + 221 -- & Svg.imageWidth .~ Svg.Num width + 222 -- & Svg.imageHeight .~ Svg.Num height + 223 -- & Svg.imageHref .~ ("file://" ++ path) + 224 + 225 + 226 -- | Convert an SVG object to a pixel-based image. The default resolution + 227 -- is 2560x1440. See also 'rasterSized'. Multiple raster engines are supported + 228 -- and are selected using the '--raster' flag in the driver. + 229 raster :: SVG -> DynamicImage + 230 raster = rasterSized 2560 1440 + 231 + 232 -- | Convert an SVG object to a pixel-based image. + 233 rasterSized + 234 :: Width -- ^ X resolution in pixels + 235 -> Height -- ^ Y resolution in pixels + 236 -> SVG -- ^ SVG object + 237 -> DynamicImage + 238 rasterSized w h svg = unsafePerformIO $ do + 239 png <- B.readFile (svgAsPngFile' w h svg) + 240 case decodePng png of + 241 Left{} -> error "bad image" + 242 Right img -> return img + 243 + 244 -- | Use 'potrace' to trace edges in a raster image and convert them to SVG polygons. + 245 vectorize :: FilePath -> SVG + 246 vectorize = vectorize_ [] + 247 + 248 -- | Same as 'vectorize' but takes a list of arguments for 'potrace'. + 249 vectorize_ :: [String] -> FilePath -> SVG + 250 vectorize_ _ path | pNoExternals = mkText $ T.pack path + 251 vectorize_ args path = unsafePerformIO $ do + 252 root <- getXdgDirectory XdgCache "reanimate" + 253 createDirectoryIfMissing True root + 254 let svgPath = root </> encodeInt key <.> "svg" + 255 hit <- doesFileExist svgPath + 256 unless hit $ withSystemTempFile "file.svg" $ \tmpSvgPath svgH -> + 257 withSystemTempFile "file.bmp" $ \tmpBmpPath bmpH -> do + 258 hClose svgH + 259 hClose bmpH + 260 potrace <- requireExecutable "potrace" + 261 magick <- requireExecutable magickCmd + 262 runCmd magick [path, "-flatten", tmpBmpPath] + 263 runCmd potrace (args ++ ["--svg", "--output", tmpSvgPath, tmpBmpPath]) + 264 renameOrCopyFile tmpSvgPath svgPath + 265 svg_data <- B.readFile svgPath + 266 case parseSvgFile svgPath svg_data of + 267 Nothing -> do + 268 removeFile svgPath + 269 error "Malformed svg" + 270 Just svg -> return $ unbox $ replaceUses svg + 271 where key = hash (path, args) + 272 + 273 -- imageAsFile :: DynamicImage -> FilePath + 274 -- imageAsFile img + 275 + 276 -- | Convert an SVG object to a pixel-based image and save it to disk, returning + 277 -- the filepath. The default resolution is 2560x1440. See also 'svgAsPngFile''. + 278 -- Multiple raster engines are supported and are selected using the '--raster' + 279 -- flag in the driver. + 280 svgAsPngFile :: SVG -> FilePath + 281 svgAsPngFile = svgAsPngFile' width height + 282 where + 283 width = 2560 + 284 height = width * 9 `div` 16 + 285 + 286 -- | Convert an SVG object to a pixel-based image and save it to disk, returning + 287 -- the filepath. + 288 svgAsPngFile' + 289 :: Width -- ^ Width + 290 -> Height -- ^ Height + 291 -> SVG -- ^ SVG object + 292 -> FilePath + 293 svgAsPngFile' _ _ _ | pNoExternals = "/svgAsPngFile/has/been/disabled" + 294 svgAsPngFile' width height svg = + 295 unsafePerformIO $ cacheFile template $ \pngPath -> do + 296 let svgPath = replaceExtension pngPath "svg" + 297 writeFile svgPath rendered + 298 engine <- requireRaster pRaster + 299 applyRaster engine svgPath + 300 where + 301 template = encodeInt (hash rendered) <.> "png" + 302 rendered = renderSvg (Just $ Px $ fromIntegral width) + 303 (Just $ Px $ fromIntegral height) + 304 svg diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Scene.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Scene.hs.html index a8f6eff..b7900f8 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Scene.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Scene.hs.html @@ -24,1016 +24,1018 @@ span.spaces { background: white } 5 {-# LANGUAGE RecordWildCards #-} 6 {-| 7 Module : Reanimate.Scene - 8 Description : Imperative animation API - 9 Copyright : Written by David Himmelstrup - 10 License : Unlicense - 11 Maintainer : lemmih@gmail.com - 12 Stability : experimental - 13 Portability : POSIX - 14 - 15 Scenes are an imperative way of defining animations. - 16 - 17 -} - 18 module Reanimate.Scene - 19 ( -- * Scenes - 20 Scene - 21 , ZIndex - 22 , sceneAnimation -- :: (forall s. Scene s a) -> Animation - 23 , play -- :: Animation -> Scene s () - 24 , fork -- :: Scene s a -> Scene s a - 25 , queryNow -- :: Scene s Time - 26 , wait -- :: Duration -> Scene s () - 27 , waitUntil -- :: Time -> Scene s () - 28 , waitOn -- :: Scene s a -> Scene s a - 29 , adjustZ -- :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a - 30 , withSceneDuration -- :: Scene s () -> Scene s Duration - 31 -- * Variables - 32 , Var - 33 , newVar -- :: a -> Scene s (Var s a) - 34 , readVar -- :: Var s a -> Scene s a - 35 , writeVar -- :: Var s a -> a -> Scene s () - 36 , modifyVar -- :: Var s a -> (a -> a) -> Scene s () - 37 , tweenVar -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () - 38 , tweenVarUnclamped -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () - 39 , simpleVar -- :: (a -> SVG) -> a -> Scene s (Var s a) - 40 , findVar -- :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) - 41 -- * Sprites - 42 , Sprite - 43 , Frame - 44 , unVar -- :: Var s a -> Frame s a - 45 , spriteT -- :: Frame s Time - 46 , spriteDuration -- :: Frame s Duration - 47 , newSprite -- :: Frame s SVG -> Scene s (Sprite s) - 48 , newSprite_ -- :: Frame s SVG -> Scene s () - 49 , newSpriteA -- :: Animation -> Scene s (Sprite s) - 50 , newSpriteA' -- :: Sync -> Animation -> Scene s (Sprite s) - 51 , newSpriteSVG -- :: SVG -> Scene s (Sprite s) - 52 , newSpriteSVG_ -- :: SVG -> Scene s () - 53 , destroySprite -- :: Sprite s -> Scene s () - 54 , applyVar -- :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () - 55 , spriteModify -- :: Sprite s -> Frame s ((SVG,ZIndex) -> (SVG, ZIndex)) -> Scene s () - 56 , spriteMap -- :: Sprite s -> (SVG -> SVG) -> Scene s () - 57 , spriteTween -- :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () - 58 , spriteVar -- :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) - 59 , spriteE -- :: Sprite s -> Effect -> Scene s () - 60 , spriteZ -- :: Sprite s -> ZIndex -> Scene s () - 61 , spriteScope -- :: Scene s a -> Scene s a - 62 - 63 -- * Object API - 64 , Renderable(..) - 65 , Object - 66 , ObjectData - 67 , oTranslate - 68 , oSVG - 69 , oContext - 70 , oMargin - 71 , oMarginTop - 72 , oMarginRight - 73 , oMarginBottom - 74 , oMarginLeft - 75 , oBB - 76 , oBBMinX - 77 , oBBMinY - 78 , oBBWidth - 79 , oBBHeight - 80 , oOpacity - 81 , oShown - 82 , oZIndex - 83 , oEasing - 84 , oScale - 85 , oScaleOrigin - 86 , oTopY - 87 , oBottomY - 88 , oLeftX - 89 , oRightX - 90 , oCenterXY - 91 , newObject - 92 , oValue - 93 , oModify - 94 , oModifyS - 95 , oRead - 96 , oTween - 97 , oTweenS - 98 , oTweenV - 99 , oTweenVS - 100 - 101 -- ** Graphics object methods - 102 , oShow - 103 , oHide - 104 , oFadeIn - 105 , oFadeOut - 106 , oGrow - 107 , oShrink - 108 , oTransform - 109 - 110 -- ** Pre-defined objects - 111 , Circle(..) - 112 , circleRadius - 113 , Rectangle(..) - 114 , rectWidth - 115 , rectHeight - 116 , Morph(..) - 117 , morphDelta - 118 , morphSrc - 119 , morphDst - 120 , Camera(..) - 121 , cameraAttach - 122 , cameraFocus - 123 , cameraSetZoom - 124 , cameraZoom - 125 , cameraSetPan - 126 , cameraPan - 127 - 128 -- * ST internals - 129 , liftST - 130 , asAnimation -- :: (forall s. Scene s a) -> Scene s Animation - 131 , transitionO - 132 , evalScene - 133 ) - 134 where - 135 - 136 import Control.Lens - 137 import Control.Monad (void) - 138 import Control.Monad.Fix - 139 import Control.Monad.ST - 140 import Control.Monad.State (execState, State) - 141 import Data.List - 142 import Data.STRef - 143 import Graphics.SvgTree (Tree (None)) - 144 import Reanimate.Animation - 145 import Reanimate.Ease (Signal, curveS, fromToS) - 146 import Reanimate.Effect - 147 import Reanimate.Svg.Constructors - 148 import Reanimate.Svg.BoundingBox - 149 import Reanimate.Transition - 150 import Reanimate.Morph.Common (morph) - 151 import Reanimate.Morph.Linear (linear) - 152 - 153 -- | The ZIndex property specifies the stack order of sprites and animations. Elements - 154 -- with a higher ZIndex will be drawn on top of elements with a lower index. - 155 type ZIndex = Int + 8 Copyright : Written by David Himmelstrup + 9 License : Unlicense + 10 Maintainer : lemmih@gmail.com + 11 Stability : experimental + 12 Portability : POSIX + 13 + 14 Scenes are an imperative way of defining animations. + 15 + 16 -} + 17 module Reanimate.Scene + 18 ( -- * Scenes + 19 Scene + 20 , ZIndex + 21 , sceneAnimation -- :: (forall s. Scene s a) -> Animation + 22 , play -- :: Animation -> Scene s () + 23 , fork -- :: Scene s a -> Scene s a + 24 , queryNow -- :: Scene s Time + 25 , wait -- :: Duration -> Scene s () + 26 , waitUntil -- :: Time -> Scene s () + 27 , waitOn -- :: Scene s a -> Scene s a + 28 , adjustZ -- :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a + 29 , withSceneDuration -- :: Scene s () -> Scene s Duration + 30 -- * Variables + 31 , Var + 32 , newVar -- :: a -> Scene s (Var s a) + 33 , readVar -- :: Var s a -> Scene s a + 34 , writeVar -- :: Var s a -> a -> Scene s () + 35 , modifyVar -- :: Var s a -> (a -> a) -> Scene s () + 36 , tweenVar -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () + 37 , tweenVarUnclamped -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () + 38 , simpleVar -- :: (a -> SVG) -> a -> Scene s (Var s a) + 39 , findVar -- :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) + 40 -- * Sprites + 41 , Sprite + 42 , Frame + 43 , unVar -- :: Var s a -> Frame s a + 44 , spriteT -- :: Frame s Time + 45 , spriteDuration -- :: Frame s Duration + 46 , newSprite -- :: Frame s SVG -> Scene s (Sprite s) + 47 , newSprite_ -- :: Frame s SVG -> Scene s () + 48 , newSpriteA -- :: Animation -> Scene s (Sprite s) + 49 , newSpriteA' -- :: Sync -> Animation -> Scene s (Sprite s) + 50 , newSpriteSVG -- :: SVG -> Scene s (Sprite s) + 51 , newSpriteSVG_ -- :: SVG -> Scene s () + 52 , destroySprite -- :: Sprite s -> Scene s () + 53 , applyVar -- :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () + 54 , spriteModify -- :: Sprite s -> Frame s ((SVG,ZIndex) -> (SVG, ZIndex)) -> Scene s () + 55 , spriteMap -- :: Sprite s -> (SVG -> SVG) -> Scene s () + 56 , spriteTween -- :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () + 57 , spriteVar -- :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) + 58 , spriteE -- :: Sprite s -> Effect -> Scene s () + 59 , spriteZ -- :: Sprite s -> ZIndex -> Scene s () + 60 , spriteScope -- :: Scene s a -> Scene s a + 61 + 62 -- * Object API + 63 , Renderable(..) + 64 , Object + 65 , ObjectData + 66 , oTranslate + 67 , oSVG + 68 , oContext + 69 , oMargin + 70 , oMarginTop + 71 , oMarginRight + 72 , oMarginBottom + 73 , oMarginLeft + 74 , oBB + 75 , oBBMinX + 76 , oBBMinY + 77 , oBBWidth + 78 , oBBHeight + 79 , oOpacity + 80 , oShown + 81 , oZIndex + 82 , oEasing + 83 , oScale + 84 , oScaleOrigin + 85 , oTopY + 86 , oBottomY + 87 , oLeftX + 88 , oRightX + 89 , oCenterXY + 90 , newObject + 91 , oValue + 92 , oModify + 93 , oModifyS + 94 , oRead + 95 , oTween + 96 , oTweenS + 97 , oTweenV + 98 , oTweenVS + 99 + 100 -- ** Graphics object methods + 101 , oShow + 102 , oHide + 103 , oFadeIn + 104 , oFadeOut + 105 , oGrow + 106 , oShrink + 107 , oTransform + 108 + 109 -- ** Pre-defined objects + 110 , Circle(..) + 111 , circleRadius + 112 , Rectangle(..) + 113 , rectWidth + 114 , rectHeight + 115 , Morph(..) + 116 , morphDelta + 117 , morphSrc + 118 , morphDst + 119 , Camera(..) + 120 , cameraAttach + 121 , cameraFocus + 122 , cameraSetZoom + 123 , cameraZoom + 124 , cameraSetPan + 125 , cameraPan + 126 + 127 -- * ST internals + 128 , liftST + 129 , asAnimation -- :: (forall s. Scene s a) -> Scene s Animation + 130 , transitionO + 131 , evalScene + 132 ) + 133 where + 134 + 135 import Control.Lens + 136 import Control.Monad (void) + 137 import Control.Monad.Fix + 138 import Control.Monad.ST + 139 import Control.Monad.State (execState, State) + 140 import Data.List + 141 import Data.STRef + 142 import Graphics.SvgTree (Tree (None)) + 143 import Reanimate.Animation + 144 import Reanimate.Ease (Signal, curveS, fromToS) + 145 import Reanimate.Effect + 146 import Reanimate.Svg.Constructors + 147 import Reanimate.Svg.BoundingBox + 148 import Reanimate.Transition + 149 import Reanimate.Morph.Common (morph) + 150 import Reanimate.Morph.Linear (linear) + 151 + 152 -- | The ZIndex property specifies the stack order of sprites and animations. Elements + 153 -- with a higher ZIndex will be drawn on top of elements with a lower index. + 154 type ZIndex = Int + 155 156 - 157 - 158 -- (seq duration, par duration) - 159 -- [(Time, Animation, ZIndex)] - 160 -- Map Time [(Animation, ZIndex)] - 161 type Gen s = ST s (Duration -> Time -> (SVG, ZIndex)) - 162 newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, [Gen s]) } - 163 - 164 instance Functor (Scene s) where - 165 fmap f action = M $ \t -> do - 166 (a, d1, d2, gens) <- unM action t - 167 return (f a, d1, d2, gens) - 168 - 169 instance Applicative (Scene s) where - 170 pure a = M $ \_ -> return (a, 0, 0, []) - 171 f <*> g = M $ \t -> do - 172 (f', s1, p1, gen1) <- unM f t - 173 (g', s2, p2, gen2) <- unM g (t + s1) - 174 return (f' g', s1 + s2, max p1 (s1 + p2), gen1 ++ gen2) - 175 - 176 instance Monad (Scene s) where - 177 return = pure - 178 f >>= g = M $ \t -> do - 179 (a, s1, p1, gen1) <- unM f t - 180 (b, s2, p2, gen2) <- unM (g a) (t + s1) - 181 return (b, s1 + s2, max p1 (s1 + p2), gen1 ++ gen2) - 182 - 183 instance MonadFix (Scene s) where - 184 mfix fn = M $ \t -> mfix (\v -> let (a, _s, _p, _gens) = v in unM (fn a) t) - 185 - 186 liftST :: ST s a -> Scene s a - 187 liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, []) - 188 - 189 evalScene :: (forall s . Scene s a) -> a - 190 evalScene action = runST $ do - 191 (val, _, _ , _) <- unM action 0 - 192 return val - 193 - 194 sceneAnimation :: (forall s . Scene s a) -> Animation - 195 sceneAnimation action = runST - 196 (do - 197 (_, s, p, gens) <- unM action 0 - 198 let dur = max s p - 199 genFns <- sequence gens - 200 return $ mkAnimation - 201 dur - 202 (\t -> mkGroup $ map fst $ sortOn - 203 snd - 204 [ spriteRender dur (t * dur) | spriteRender <- genFns ] - 205 ) - 206 ) - 207 - 208 -- | Execute actions in a scene without advancing the clock. Note that scenes do not end before - 209 -- all forked actions have completed. - 210 -- - 211 -- Example: + 157 -- (seq duration, par duration) + 158 -- [(Time, Animation, ZIndex)] + 159 -- Map Time [(Animation, ZIndex)] + 160 type Gen s = ST s (Duration -> Time -> (SVG, ZIndex)) + 161 -- | A 'Scene' represents a sequence of animations and variables + 162 -- that change over time. + 163 newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, [Gen s]) } + 164 + 165 instance Functor (Scene s) where + 166 fmap f action = M $ \t -> do + 167 (a, d1, d2, gens) <- unM action t + 168 return (f a, d1, d2, gens) + 169 + 170 instance Applicative (Scene s) where + 171 pure a = M $ \_ -> return (a, 0, 0, []) + 172 f <*> g = M $ \t -> do + 173 (f', s1, p1, gen1) <- unM f t + 174 (g', s2, p2, gen2) <- unM g (t + s1) + 175 return (f' g', s1 + s2, max p1 (s1 + p2), gen1 ++ gen2) + 176 + 177 instance Monad (Scene s) where + 178 return = pure + 179 f >>= g = M $ \t -> do + 180 (a, s1, p1, gen1) <- unM f t + 181 (b, s2, p2, gen2) <- unM (g a) (t + s1) + 182 return (b, s1 + s2, max p1 (s1 + p2), gen1 ++ gen2) + 183 + 184 instance MonadFix (Scene s) where + 185 mfix fn = M $ \t -> mfix (\v -> let (a, _s, _p, _gens) = v in unM (fn a) t) + 186 + 187 liftST :: ST s a -> Scene s a + 188 liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, []) + 189 + 190 evalScene :: (forall s . Scene s a) -> a + 191 evalScene action = runST $ do + 192 (val, _, _ , _) <- unM action 0 + 193 return val + 194 + 195 -- | Render a 'Scene' to an 'Animation'. + 196 sceneAnimation :: (forall s . Scene s a) -> Animation + 197 sceneAnimation action = runST + 198 (do + 199 (_, s, p, gens) <- unM action 0 + 200 let dur = max s p + 201 genFns <- sequence gens + 202 return $ mkAnimation + 203 dur + 204 (\t -> mkGroup $ map fst $ sortOn + 205 snd + 206 [ spriteRender dur (t * dur) | spriteRender <- genFns ] + 207 ) + 208 ) + 209 + 210 -- | Execute actions in a scene without advancing the clock. Note that scenes do not end before + 211 -- all forked actions have completed. 212 -- - 213 -- > do fork $ play drawBox - 214 -- > play drawCircle - 215 -- - 216 -- <<docs/gifs/doc_fork.gif>> - 217 fork :: Scene s a -> Scene s a - 218 fork (M action) = M $ \t -> do - 219 (a, s, p, gens) <- action t - 220 return (a, 0, max s p, gens) - 221 - 222 -- | Play an animation once and then remove it. This advances the clock by the duration of the - 223 -- animation. - 224 -- - 225 -- Example: + 213 -- Example: + 214 -- + 215 -- > do fork $ play drawBox + 216 -- > play drawCircle + 217 -- + 218 -- <<docs/gifs/doc_fork.gif>> + 219 fork :: Scene s a -> Scene s a + 220 fork (M action) = M $ \t -> do + 221 (a, s, p, gens) <- action t + 222 return (a, 0, max s p, gens) + 223 + 224 -- | Play an animation once and then remove it. This advances the clock by the duration of the + 225 -- animation. 226 -- - 227 -- > do play drawBox - 228 -- > play drawCircle - 229 -- - 230 -- <<docs/gifs/doc_play.gif>> - 231 play :: Animation -> Scene s () - 232 play ani = newSpriteA ani >>= destroySprite - 233 - 234 -- | Query the current clock timestamp. - 235 -- - 236 -- Example: + 227 -- Example: + 228 -- + 229 -- > do play drawBox + 230 -- > play drawCircle + 231 -- + 232 -- <<docs/gifs/doc_play.gif>> + 233 play :: Animation -> Scene s () + 234 play ani = newSpriteA ani >>= destroySprite + 235 + 236 -- | Query the current clock timestamp. 237 -- - 238 -- > do now <- play drawCircle *> queryNow - 239 -- > play $ staticFrame 1 $ scale 2 $ withStrokeWidth 0.05 $ - 240 -- > mkText $ "Now=" <> T.pack (show now) - 241 -- - 242 -- <<docs/gifs/doc_queryNow.gif>> - 243 queryNow :: Scene s Time - 244 queryNow = M $ \t -> return (t, 0, 0, []) - 245 - 246 -- | Advance the clock by a given number of seconds. - 247 -- - 248 -- Example: + 238 -- Example: + 239 -- + 240 -- > do now <- play drawCircle *> queryNow + 241 -- > play $ staticFrame 1 $ scale 2 $ withStrokeWidth 0.05 $ + 242 -- > mkText $ "Now=" <> T.pack (show now) + 243 -- + 244 -- <<docs/gifs/doc_queryNow.gif>> + 245 queryNow :: Scene s Time + 246 queryNow = M $ \t -> return (t, 0, 0, []) + 247 + 248 -- | Advance the clock by a given number of seconds. 249 -- - 250 -- > do fork $ play drawBox - 251 -- > wait 1 - 252 -- > play drawCircle - 253 -- - 254 -- <<docs/gifs/doc_wait.gif>> - 255 wait :: Duration -> Scene s () - 256 wait d = M $ \_ -> return ((), d, 0, []) - 257 - 258 -- | Wait until the clock is equal to the given timestamp. - 259 waitUntil :: Time -> Scene s () - 260 waitUntil tNew = do - 261 now <- queryNow - 262 wait (max 0 (tNew - now)) - 263 - 264 -- | Wait until all forked and sequential animations have finished. - 265 -- - 266 -- Example: + 250 -- Example: + 251 -- + 252 -- > do fork $ play drawBox + 253 -- > wait 1 + 254 -- > play drawCircle + 255 -- + 256 -- <<docs/gifs/doc_wait.gif>> + 257 wait :: Duration -> Scene s () + 258 wait d = M $ \_ -> return ((), d, 0, []) + 259 + 260 -- | Wait until the clock is equal to the given timestamp. + 261 waitUntil :: Time -> Scene s () + 262 waitUntil tNew = do + 263 now <- queryNow + 264 wait (max 0 (tNew - now)) + 265 + 266 -- | Wait until all forked and sequential animations have finished. 267 -- - 268 -- > do waitOn $ fork $ play drawBox - 269 -- > play drawCircle - 270 -- - 271 -- <<docs/gifs/doc_waitOn.gif>> - 272 waitOn :: Scene s a -> Scene s a - 273 waitOn (M action) = M $ \t -> do - 274 (a, s, p, gens) <- action t - 275 return (a, max s p, 0, gens) - 276 - 277 -- | Change the ZIndex of a scene. - 278 adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a - 279 adjustZ fn (M action) = M $ \t -> do - 280 (a, s, p, gens) <- action t - 281 return (a, s, p, map genFn gens) - 282 where - 283 genFn gen = do - 284 frameGen <- gen - 285 return $ \d t -> let (svg, z) = frameGen d t in (svg, fn z) - 286 - 287 -- | Query the duration of a scene. - 288 withSceneDuration :: Scene s () -> Scene s Duration - 289 withSceneDuration s = do - 290 t1 <- queryNow - 291 s - 292 t2 <- queryNow - 293 return (t2 - t1) - 294 - 295 addGen :: Gen s -> Scene s () - 296 addGen gen = M $ \_ -> return ((), 0, 0, [gen]) - 297 - 298 -- | Time dependent variable. - 299 newtype Var s a = Var (STRef s (Time -> a)) - 300 - 301 -- | Create a new variable with a default value. - 302 -- Variables always have a defined value even if they are read at a timestamp that is - 303 -- earlier than when the variable was created. For example: - 304 -- - 305 -- > do v <- fork (wait 10 >> newVar 0) -- Create a variable at timestamp '10'. - 306 -- > readVar v -- Read the variable at timestamp '0'. - 307 -- > -- The value of the variable will be '0'. - 308 newVar :: a -> Scene s (Var s a) - 309 newVar def = Var <$> liftST (newSTRef (const def)) - 310 - 311 -- | Read the value of a variable at the current timestamp. - 312 readVar :: Var s a -> Scene s a - 313 readVar (Var ref) = liftST (readSTRef ref) <*> queryNow - 314 - 315 -- | Write the value of a variable at the current timestamp. - 316 -- - 317 -- Example: + 268 -- Example: + 269 -- + 270 -- > do waitOn $ fork $ play drawBox + 271 -- > play drawCircle + 272 -- + 273 -- <<docs/gifs/doc_waitOn.gif>> + 274 waitOn :: Scene s a -> Scene s a + 275 waitOn (M action) = M $ \t -> do + 276 (a, s, p, gens) <- action t + 277 return (a, max s p, 0, gens) + 278 + 279 -- | Change the ZIndex of a scene. + 280 adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a + 281 adjustZ fn (M action) = M $ \t -> do + 282 (a, s, p, gens) <- action t + 283 return (a, s, p, map genFn gens) + 284 where + 285 genFn gen = do + 286 frameGen <- gen + 287 return $ \d t -> let (svg, z) = frameGen d t in (svg, fn z) + 288 + 289 -- | Query the duration of a scene. + 290 withSceneDuration :: Scene s () -> Scene s Duration + 291 withSceneDuration s = do + 292 t1 <- queryNow + 293 s + 294 t2 <- queryNow + 295 return (t2 - t1) + 296 + 297 addGen :: Gen s -> Scene s () + 298 addGen gen = M $ \_ -> return ((), 0, 0, [gen]) + 299 + 300 -- | Time dependent variable. + 301 newtype Var s a = Var (STRef s (Time -> a)) + 302 + 303 -- | Create a new variable with a default value. + 304 -- Variables always have a defined value even if they are read at a timestamp that is + 305 -- earlier than when the variable was created. For example: + 306 -- + 307 -- > do v <- fork (wait 10 >> newVar 0) -- Create a variable at timestamp '10'. + 308 -- > readVar v -- Read the variable at timestamp '0'. + 309 -- > -- The value of the variable will be '0'. + 310 newVar :: a -> Scene s (Var s a) + 311 newVar def = Var <$> liftST (newSTRef (const def)) + 312 + 313 -- | Read the value of a variable at the current timestamp. + 314 readVar :: Var s a -> Scene s a + 315 readVar (Var ref) = liftST (readSTRef ref) <*> queryNow + 316 + 317 -- | Write the value of a variable at the current timestamp. 318 -- - 319 -- > do v <- newVar 0 - 320 -- > newSprite $ mkCircle <$> unVar v - 321 -- > writeVar v 1; wait 1 - 322 -- > writeVar v 2; wait 1 - 323 -- > writeVar v 3; wait 1 - 324 -- - 325 -- <<docs/gifs/doc_writeVar.gif>> - 326 writeVar :: Var s a -> a -> Scene s () - 327 writeVar var val = modifyVar var (const val) - 328 - 329 -- | Modify the value of a variable at the current timestamp and all future timestamps. - 330 modifyVar :: Var s a -> (a -> a) -> Scene s () - 331 modifyVar (Var ref) fn = do - 332 now <- queryNow - 333 liftST $ modifySTRef ref $ \prev t -> if t < now then prev t else fn (prev t) - 334 - 335 -- | Modify a variable between @now@ and @now+duration@. - 336 -- Note: The modification function is invoked for past timestamps (with a time value of 0) and - 337 -- for timestamps after @now+duration@ (with a time value of 1). See 'tweenVarUnclamped'. - 338 tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () - 339 tweenVar (Var ref) dur fn = do - 340 now <- queryNow - 341 liftST $ modifySTRef ref $ \prev t -> - 342 if t < now - 343 then prev t - 344 else fn (prev t) (max 0 (min dur $ t - now) / dur) - 345 wait dur - 346 - 347 -- | Modify a variable between @now@ and @now+duration@. - 348 -- Note: The modification function is invoked for past timestamps (with a negative time value) and - 349 -- for timestamps after @now+duration@ (with a time value greater than 1). - 350 tweenVarUnclamped :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () - 351 tweenVarUnclamped (Var ref) dur fn = do - 352 now <- queryNow - 353 liftST $ modifySTRef ref $ \prev t -> fn (prev t) ((t - now) / dur) - 354 wait dur - 355 - 356 -- | Create and render a variable. The rendering will be born at the current timestamp - 357 -- and will persist until the end of the scene. - 358 -- - 359 -- Example: + 319 -- Example: + 320 -- + 321 -- > do v <- newVar 0 + 322 -- > newSprite $ mkCircle <$> unVar v + 323 -- > writeVar v 1; wait 1 + 324 -- > writeVar v 2; wait 1 + 325 -- > writeVar v 3; wait 1 + 326 -- + 327 -- <<docs/gifs/doc_writeVar.gif>> + 328 writeVar :: Var s a -> a -> Scene s () + 329 writeVar var val = modifyVar var (const val) + 330 + 331 -- | Modify the value of a variable at the current timestamp and all future timestamps. + 332 modifyVar :: Var s a -> (a -> a) -> Scene s () + 333 modifyVar (Var ref) fn = do + 334 now <- queryNow + 335 liftST $ modifySTRef ref $ \prev t -> if t < now then prev t else fn (prev t) + 336 + 337 -- | Modify a variable between @now@ and @now+duration@. + 338 -- Note: The modification function is invoked for past timestamps (with a time value of 0) and + 339 -- for timestamps after @now+duration@ (with a time value of 1). See 'tweenVarUnclamped'. + 340 tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () + 341 tweenVar (Var ref) dur fn = do + 342 now <- queryNow + 343 liftST $ modifySTRef ref $ \prev t -> + 344 if t < now + 345 then prev t + 346 else fn (prev t) (max 0 (min dur $ t - now) / dur) + 347 wait dur + 348 + 349 -- | Modify a variable between @now@ and @now+duration@. + 350 -- Note: The modification function is invoked for past timestamps (with a negative time value) and + 351 -- for timestamps after @now+duration@ (with a time value greater than 1). + 352 tweenVarUnclamped :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () + 353 tweenVarUnclamped (Var ref) dur fn = do + 354 now <- queryNow + 355 liftST $ modifySTRef ref $ \prev t -> fn (prev t) ((t - now) / dur) + 356 wait dur + 357 + 358 -- | Create and render a variable. The rendering will be born at the current timestamp + 359 -- and will persist until the end of the scene. 360 -- - 361 -- > do var <- simpleVar mkCircle 0 - 362 -- > tweenVar var 2 $ \val -> fromToS val (screenHeight/2) - 363 -- - 364 -- <<docs/gifs/doc_simpleVar.gif>> - 365 simpleVar :: (a -> SVG) -> a -> Scene s (Var s a) - 366 simpleVar render def = do - 367 v <- newVar def - 368 _ <- newSprite $ render <$> unVar v - 369 return v - 370 - 371 -- | Helper function for filtering variables. - 372 findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) - 373 findVar _cond [] = error "Variable not found." - 374 findVar cond (v : vs) = do - 375 val <- readVar v - 376 if cond val then return v else findVar cond vs - 377 - 378 -- | Sprites are animations with a given time of birth as well as a time of death. - 379 -- They can be controlled using variables, tweening, and effects. - 380 data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex)))) - 381 - 382 -- | Sprite frame generator. Generates frames over time in a stateful environment. - 383 newtype Frame s a = Frame { unFrame :: ST s (Time -> Duration -> Time -> a) } - 384 - 385 instance Functor (Frame s) where - 386 fmap fn (Frame gen) = Frame $ do - 387 m <- gen - 388 return (\real_t d t -> fn $ m real_t d t) - 389 - 390 instance Applicative (Frame s) where - 391 pure v = Frame $ return (\_ _ _ -> v) - 392 Frame f <*> Frame g = Frame $ do - 393 m1 <- f - 394 m2 <- g - 395 return $ \real_t d t -> m1 real_t d t (m2 real_t d t) - 396 - 397 -- | Dereference a variable as a Sprite frame. - 398 -- - 399 -- Example: + 361 -- Example: + 362 -- + 363 -- > do var <- simpleVar mkCircle 0 + 364 -- > tweenVar var 2 $ \val -> fromToS val (screenHeight/2) + 365 -- + 366 -- <<docs/gifs/doc_simpleVar.gif>> + 367 simpleVar :: (a -> SVG) -> a -> Scene s (Var s a) + 368 simpleVar render def = do + 369 v <- newVar def + 370 _ <- newSprite $ render <$> unVar v + 371 return v + 372 + 373 -- | Helper function for filtering variables. + 374 findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) + 375 findVar _cond [] = error "Variable not found." + 376 findVar cond (v : vs) = do + 377 val <- readVar v + 378 if cond val then return v else findVar cond vs + 379 + 380 -- | Sprites are animations with a given time of birth as well as a time of death. + 381 -- They can be controlled using variables, tweening, and effects. + 382 data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex)))) + 383 + 384 -- | Sprite frame generator. Generates frames over time in a stateful environment. + 385 newtype Frame s a = Frame { unFrame :: ST s (Time -> Duration -> Time -> a) } + 386 + 387 instance Functor (Frame s) where + 388 fmap fn (Frame gen) = Frame $ do + 389 m <- gen + 390 return (\real_t d t -> fn $ m real_t d t) + 391 + 392 instance Applicative (Frame s) where + 393 pure v = Frame $ return (\_ _ _ -> v) + 394 Frame f <*> Frame g = Frame $ do + 395 m1 <- f + 396 m2 <- g + 397 return $ \real_t d t -> m1 real_t d t (m2 real_t d t) + 398 + 399 -- | Dereference a variable as a Sprite frame. 400 -- - 401 -- > do v <- newVar 0 - 402 -- > newSprite $ mkCircle <$> unVar v - 403 -- > tweenVar v 1 $ \val -> fromToS val 3 - 404 -- > tweenVar v 1 $ \val -> fromToS val 0 - 405 -- - 406 -- <<docs/gifs/doc_unVar.gif>> - 407 unVar :: Var s a -> Frame s a - 408 unVar (Var ref) = Frame $ do - 409 fn <- readSTRef ref - 410 return $ \real_t _d _t -> fn real_t - 411 - 412 - 413 -- | Dereference seconds since sprite birth. - 414 spriteT :: Frame s Time - 415 spriteT = Frame $ return (\_real_t _d t -> t) - 416 - 417 -- | Dereference duration of the current sprite. - 418 spriteDuration :: Frame s Duration - 419 spriteDuration = Frame $ return (\_real_t d _t -> d) - 420 - 421 -- | Create new sprite defined by a frame generator. Unless otherwise specified using - 422 -- 'destroySprite', the sprite will die at the end of the scene. - 423 -- - 424 -- Example: + 401 -- Example: + 402 -- + 403 -- > do v <- newVar 0 + 404 -- > newSprite $ mkCircle <$> unVar v + 405 -- > tweenVar v 1 $ \val -> fromToS val 3 + 406 -- > tweenVar v 1 $ \val -> fromToS val 0 + 407 -- + 408 -- <<docs/gifs/doc_unVar.gif>> + 409 unVar :: Var s a -> Frame s a + 410 unVar (Var ref) = Frame $ do + 411 fn <- readSTRef ref + 412 return $ \real_t _d _t -> fn real_t + 413 + 414 + 415 -- | Dereference seconds since sprite birth. + 416 spriteT :: Frame s Time + 417 spriteT = Frame $ return (\_real_t _d t -> t) + 418 + 419 -- | Dereference duration of the current sprite. + 420 spriteDuration :: Frame s Duration + 421 spriteDuration = Frame $ return (\_real_t d _t -> d) + 422 + 423 -- | Create new sprite defined by a frame generator. Unless otherwise specified using + 424 -- 'destroySprite', the sprite will die at the end of the scene. 425 -- - 426 -- > do newSprite $ mkCircle <$> spriteT -- Circle sprite where radius=time. - 427 -- > wait 2 - 428 -- - 429 -- <<docs/gifs/doc_newSprite.gif>> - 430 newSprite :: Frame s SVG -> Scene s (Sprite s) - 431 newSprite render = do - 432 now <- queryNow - 433 ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0)) - 434 addGen $ do - 435 fn <- unFrame render - 436 (spriteDur, spriteEffectGen) <- readSTRef ref - 437 spriteEffect <- spriteEffectGen - 438 return $ \d absT -> - 439 let relD = (if spriteDur < 0 then d else spriteDur) - now - 440 relT = absT - now - 441 -- Sprite is live [now;duration[ - 442 -- If we're at the end of a scene, sprites - 443 -- are live: [now;duration] - 444 -- This behavior is difficult to get right. See the 'bug_*' examples for - 445 -- automated tests. - 446 inTimeSlice = relT >= 0 && relT < relD - 447 isLastFrame = d==absT && relT == relD - 448 in if inTimeSlice || isLastFrame - 449 then spriteEffect relD relT (fn absT relD relT) - 450 else (None, 0) - 451 return $ Sprite now ref - 452 - 453 -- | Create new sprite defined by a frame generator. The sprite will die at - 454 -- the end of the scene. - 455 newSprite_ :: Frame s SVG -> Scene s () - 456 newSprite_ = void . newSprite - 457 - 458 -- | Create a new sprite from an animation. This advances the clock by the - 459 -- duration of the animation. Unless otherwise specified using - 460 -- 'destroySprite', the sprite will die at the end of the scene. - 461 -- - 462 -- Note: If the scene doesn't end immediately after the duration of the - 463 -- animation, the animation will be stretched to match the lifetime of the - 464 -- sprite. See 'newSpriteA'' and 'play'. - 465 -- - 466 -- Example: + 426 -- Example: + 427 -- + 428 -- > do newSprite $ mkCircle <$> spriteT -- Circle sprite where radius=time. + 429 -- > wait 2 + 430 -- + 431 -- <<docs/gifs/doc_newSprite.gif>> + 432 newSprite :: Frame s SVG -> Scene s (Sprite s) + 433 newSprite render = do + 434 now <- queryNow + 435 ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0)) + 436 addGen $ do + 437 fn <- unFrame render + 438 (spriteDur, spriteEffectGen) <- readSTRef ref + 439 spriteEffect <- spriteEffectGen + 440 return $ \d absT -> + 441 let relD = (if spriteDur < 0 then d else spriteDur) - now + 442 relT = absT - now + 443 -- Sprite is live [now;duration[ + 444 -- If we're at the end of a scene, sprites + 445 -- are live: [now;duration] + 446 -- This behavior is difficult to get right. See the 'bug_*' examples for + 447 -- automated tests. + 448 inTimeSlice = relT >= 0 && relT < relD + 449 isLastFrame = d==absT && relT == relD + 450 in if inTimeSlice || isLastFrame + 451 then spriteEffect relD relT (fn absT relD relT) + 452 else (None, 0) + 453 return $ Sprite now ref + 454 + 455 -- | Create new sprite defined by a frame generator. The sprite will die at + 456 -- the end of the scene. + 457 newSprite_ :: Frame s SVG -> Scene s () + 458 newSprite_ = void . newSprite + 459 + 460 -- | Create a new sprite from an animation. This advances the clock by the + 461 -- duration of the animation. Unless otherwise specified using + 462 -- 'destroySprite', the sprite will die at the end of the scene. + 463 -- + 464 -- Note: If the scene doesn't end immediately after the duration of the + 465 -- animation, the animation will be stretched to match the lifetime of the + 466 -- sprite. See 'newSpriteA'' and 'play'. 467 -- - 468 -- > do fork $ newSpriteA drawCircle - 469 -- > play drawBox - 470 -- > play $ reverseA drawBox - 471 -- - 472 -- <<docs/gifs/doc_newSpriteA.gif>> - 473 newSpriteA :: Animation -> Scene s (Sprite s) - 474 newSpriteA = newSpriteA' SyncStretch - 475 - 476 -- | Create a new sprite from an animation and specify the synchronization policy. This advances - 477 -- the clock by the duration of the animation. - 478 -- - 479 -- Example: + 468 -- Example: + 469 -- + 470 -- > do fork $ newSpriteA drawCircle + 471 -- > play drawBox + 472 -- > play $ reverseA drawBox + 473 -- + 474 -- <<docs/gifs/doc_newSpriteA.gif>> + 475 newSpriteA :: Animation -> Scene s (Sprite s) + 476 newSpriteA = newSpriteA' SyncStretch + 477 + 478 -- | Create a new sprite from an animation and specify the synchronization policy. This advances + 479 -- the clock by the duration of the animation. 480 -- - 481 -- > do fork $ newSpriteA' SyncFreeze drawCircle - 482 -- > play drawBox - 483 -- > play $ reverseA drawBox - 484 -- - 485 -- <<docs/gifs/doc_newSpriteA'.gif>> - 486 newSpriteA' :: Sync -> Animation -> Scene s (Sprite s) - 487 newSpriteA' sync animation = - 488 newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration) - 489 <* wait (duration animation) - 490 - 491 -- | Create a sprite from a static SVG image. - 492 -- - 493 -- Example: + 481 -- Example: + 482 -- + 483 -- > do fork $ newSpriteA' SyncFreeze drawCircle + 484 -- > play drawBox + 485 -- > play $ reverseA drawBox + 486 -- + 487 -- <<docs/gifs/doc_newSpriteA'.gif>> + 488 newSpriteA' :: Sync -> Animation -> Scene s (Sprite s) + 489 newSpriteA' sync animation = + 490 newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration) + 491 <* wait (duration animation) + 492 + 493 -- | Create a sprite from a static SVG image. 494 -- - 495 -- > do newSpriteSVG $ mkBackground "lightblue" - 496 -- > play drawCircle - 497 -- - 498 -- <<docs/gifs/doc_newSpriteSVG.gif>> - 499 newSpriteSVG :: SVG -> Scene s (Sprite s) - 500 newSpriteSVG = newSprite . pure - 501 - 502 -- | Create a permanent sprite from a static SVG image. Same as `newSpriteSVG` - 503 -- but the sprite isn't returned and thus cannot be destroyed. - 504 newSpriteSVG_ :: SVG -> Scene s () - 505 newSpriteSVG_ = void . newSpriteSVG - 506 - 507 -- | Change the rendering of a sprite using data from a variable. If data from several variables - 508 -- is needed, use a frame generator instead. - 509 -- - 510 -- Example: + 495 -- Example: + 496 -- + 497 -- > do newSpriteSVG $ mkBackground "lightblue" + 498 -- > play drawCircle + 499 -- + 500 -- <<docs/gifs/doc_newSpriteSVG.gif>> + 501 newSpriteSVG :: SVG -> Scene s (Sprite s) + 502 newSpriteSVG = newSprite . pure + 503 + 504 -- | Create a permanent sprite from a static SVG image. Same as `newSpriteSVG` + 505 -- but the sprite isn't returned and thus cannot be destroyed. + 506 newSpriteSVG_ :: SVG -> Scene s () + 507 newSpriteSVG_ = void . newSpriteSVG + 508 + 509 -- | Change the rendering of a sprite using data from a variable. If data from several variables + 510 -- is needed, use a frame generator instead. 511 -- - 512 -- > do s <- fork $ newSpriteA drawBox - 513 -- > v <- newVar 0 - 514 -- > applyVar v s rotate - 515 -- > tweenVar v 2 $ \val -> fromToS val 90 - 516 -- - 517 -- <<docs/gifs/doc_applyVar.gif>> - 518 applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () - 519 applyVar var sprite fn = spriteModify sprite $ do - 520 varFn <- unVar var - 521 return $ \(svg, zindex) -> (fn varFn svg, zindex) - 522 - 523 -- | Destroy a sprite, preventing it from being rendered in the future of the scene. - 524 -- If 'destroySprite' is invoked multiple times, the earliest time-of-death is used. - 525 -- - 526 -- Example: + 512 -- Example: + 513 -- + 514 -- > do s <- fork $ newSpriteA drawBox + 515 -- > v <- newVar 0 + 516 -- > applyVar v s rotate + 517 -- > tweenVar v 2 $ \val -> fromToS val 90 + 518 -- + 519 -- <<docs/gifs/doc_applyVar.gif>> + 520 applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () + 521 applyVar var sprite fn = spriteModify sprite $ do + 522 varFn <- unVar var + 523 return $ \(svg, zindex) -> (fn varFn svg, zindex) + 524 + 525 -- | Destroy a sprite, preventing it from being rendered in the future of the scene. + 526 -- If 'destroySprite' is invoked multiple times, the earliest time-of-death is used. 527 -- - 528 -- > do s <- newSpriteSVG $ withFillOpacity 1 $ mkCircle 1 - 529 -- > fork $ wait 1 >> destroySprite s - 530 -- > play drawBox - 531 -- - 532 -- <<docs/gifs/doc_destroySprite.gif>> - 533 destroySprite :: Sprite s -> Scene s () - 534 destroySprite (Sprite _ ref) = do - 535 now <- queryNow - 536 liftST $ modifySTRef ref $ \(ttl, render) -> - 537 (if ttl < 0 then now else min ttl now, render) - 538 - 539 -- | Low-level frame modifier. - 540 spriteModify :: Sprite s -> Frame s ((SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s () - 541 spriteModify (Sprite born ref) modFn = liftST $ modifySTRef ref $ \(ttl, renderGen) -> - 542 ( ttl - 543 , do - 544 render <- renderGen - 545 modRender <- unFrame modFn - 546 return $ \relD relT -> - 547 let absT = relT + born in modRender absT relD relT . render relD relT - 548 ) - 549 - 550 -- | Map the SVG output of a sprite. - 551 -- - 552 -- Example: + 528 -- Example: + 529 -- + 530 -- > do s <- newSpriteSVG $ withFillOpacity 1 $ mkCircle 1 + 531 -- > fork $ wait 1 >> destroySprite s + 532 -- > play drawBox + 533 -- + 534 -- <<docs/gifs/doc_destroySprite.gif>> + 535 destroySprite :: Sprite s -> Scene s () + 536 destroySprite (Sprite _ ref) = do + 537 now <- queryNow + 538 liftST $ modifySTRef ref $ \(ttl, render) -> + 539 (if ttl < 0 then now else min ttl now, render) + 540 + 541 -- | Low-level frame modifier. + 542 spriteModify :: Sprite s -> Frame s ((SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s () + 543 spriteModify (Sprite born ref) modFn = liftST $ modifySTRef ref $ \(ttl, renderGen) -> + 544 ( ttl + 545 , do + 546 render <- renderGen + 547 modRender <- unFrame modFn + 548 return $ \relD relT -> + 549 let absT = relT + born in modRender absT relD relT . render relD relT + 550 ) + 551 + 552 -- | Map the SVG output of a sprite. 553 -- - 554 -- > do s <- fork $ newSpriteA drawCircle - 555 -- > wait 1 - 556 -- > spriteMap s flipYAxis - 557 -- - 558 -- <<docs/gifs/doc_spriteMap.gif>> - 559 spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s () - 560 spriteMap sprite@(Sprite born _) fn = do - 561 now <- queryNow - 562 let tDelta = now - born - 563 spriteModify sprite $ do - 564 t <- spriteT - 565 return $ \(svg, zindex) -> (if (t - tDelta) < 0 then svg else fn svg, zindex) - 566 - 567 -- | Modify the output of a sprite between @now@ and @now+duration@. - 568 -- - 569 -- Example: + 554 -- Example: + 555 -- + 556 -- > do s <- fork $ newSpriteA drawCircle + 557 -- > wait 1 + 558 -- > spriteMap s flipYAxis + 559 -- + 560 -- <<docs/gifs/doc_spriteMap.gif>> + 561 spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s () + 562 spriteMap sprite@(Sprite born _) fn = do + 563 now <- queryNow + 564 let tDelta = now - born + 565 spriteModify sprite $ do + 566 t <- spriteT + 567 return $ \(svg, zindex) -> (if (t - tDelta) < 0 then svg else fn svg, zindex) + 568 + 569 -- | Modify the output of a sprite between @now@ and @now+duration@. 570 -- - 571 -- > do s <- fork $ newSpriteA drawCircle - 572 -- > spriteTween s 1 $ \val -> translate (screenWidth*0.3*val) 0 - 573 -- - 574 -- <<docs/gifs/doc_spriteTween.gif>> - 575 spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () - 576 spriteTween sprite@(Sprite born _) dur fn = do - 577 now <- queryNow - 578 let tDelta = now - born - 579 spriteModify sprite $ do - 580 t <- spriteT - 581 return $ \(svg, zindex) -> (fn (clamp 0 1 $ (t - tDelta) / dur) svg, zindex) - 582 wait dur - 583 where - 584 clamp a b v | v < a = a - 585 | v > b = b - 586 | otherwise = v - 587 - 588 -- | Create a new variable and apply it to a sprite. - 589 -- - 590 -- Example: + 571 -- Example: + 572 -- + 573 -- > do s <- fork $ newSpriteA drawCircle + 574 -- > spriteTween s 1 $ \val -> translate (screenWidth*0.3*val) 0 + 575 -- + 576 -- <<docs/gifs/doc_spriteTween.gif>> + 577 spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s () + 578 spriteTween sprite@(Sprite born _) dur fn = do + 579 now <- queryNow + 580 let tDelta = now - born + 581 spriteModify sprite $ do + 582 t <- spriteT + 583 return $ \(svg, zindex) -> (fn (clamp 0 1 $ (t - tDelta) / dur) svg, zindex) + 584 wait dur + 585 where + 586 clamp a b v | v < a = a + 587 | v > b = b + 588 | otherwise = v + 589 + 590 -- | Create a new variable and apply it to a sprite. 591 -- - 592 -- > do s <- fork $ newSpriteA drawBox - 593 -- > v <- spriteVar s 0 rotate - 594 -- > tweenVar v 2 $ \val -> fromToS val 90 - 595 -- - 596 -- <<docs/gifs/doc_spriteVar.gif>> - 597 spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) - 598 spriteVar sprite def fn = do - 599 v <- newVar def - 600 applyVar v sprite fn - 601 return v - 602 - 603 -- | Apply an effect to a sprite. - 604 -- - 605 -- Example: + 592 -- Example: + 593 -- + 594 -- > do s <- fork $ newSpriteA drawBox + 595 -- > v <- spriteVar s 0 rotate + 596 -- > tweenVar v 2 $ \val -> fromToS val 90 + 597 -- + 598 -- <<docs/gifs/doc_spriteVar.gif>> + 599 spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a) + 600 spriteVar sprite def fn = do + 601 v <- newVar def + 602 applyVar v sprite fn + 603 return v + 604 + 605 -- | Apply an effect to a sprite. 606 -- - 607 -- > do s <- fork $ newSpriteA drawCircle - 608 -- > spriteE s $ overBeginning 1 fadeInE - 609 -- > spriteE s $ overEnding 0.5 fadeOutE - 610 -- - 611 -- <<docs/gifs/doc_spriteE.gif>> - 612 spriteE :: Sprite s -> Effect -> Scene s () - 613 spriteE (Sprite born ref) effect = do - 614 now <- queryNow - 615 liftST $ modifySTRef ref $ \(ttl, renderGen) -> - 616 ( ttl - 617 , do - 618 render <- renderGen - 619 return $ \d t svg -> - 620 let (svg', z) = render d t svg - 621 in (delayE (max 0 $ now - born) effect d t svg', z) - 622 ) - 623 - 624 -- | Set new ZIndex of a sprite. - 625 -- - 626 -- Example: + 607 -- Example: + 608 -- + 609 -- > do s <- fork $ newSpriteA drawCircle + 610 -- > spriteE s $ overBeginning 1 fadeInE + 611 -- > spriteE s $ overEnding 0.5 fadeOutE + 612 -- + 613 -- <<docs/gifs/doc_spriteE.gif>> + 614 spriteE :: Sprite s -> Effect -> Scene s () + 615 spriteE (Sprite born ref) effect = do + 616 now <- queryNow + 617 liftST $ modifySTRef ref $ \(ttl, renderGen) -> + 618 ( ttl + 619 , do + 620 render <- renderGen + 621 return $ \d t svg -> + 622 let (svg', z) = render d t svg + 623 in (delayE (max 0 $ now - born) effect d t svg', z) + 624 ) + 625 + 626 -- | Set new ZIndex of a sprite. 627 -- - 628 -- > do s1 <- newSpriteSVG $ withFillOpacity 1 $ withFillColor "blue" $ mkCircle 3 - 629 -- > newSpriteSVG $ withFillOpacity 1 $ withFillColor "red" $ mkRect 8 3 - 630 -- > wait 1 - 631 -- > spriteZ s1 1 + 628 -- Example: + 629 -- + 630 -- > do s1 <- newSpriteSVG $ withFillOpacity 1 $ withFillColor "blue" $ mkCircle 3 + 631 -- > newSpriteSVG $ withFillOpacity 1 $ withFillColor "red" $ mkRect 8 3 632 -- > wait 1 - 633 -- - 634 -- <<docs/gifs/doc_spriteZ.gif>> - 635 spriteZ :: Sprite s -> ZIndex -> Scene s () - 636 spriteZ (Sprite born ref) zindex = do - 637 now <- queryNow - 638 liftST $ modifySTRef ref $ \(ttl, renderGen) -> - 639 ( ttl - 640 , do - 641 render <- renderGen - 642 return $ \d t svg -> - 643 let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex) - 644 ) - 645 - 646 -- Destroy all local sprites at the end of a scene. - 647 spriteScope :: Scene s a -> Scene s a - 648 spriteScope (M action) = M $ \t -> do - 649 (a, s, p, gens) <- action t - 650 return (a, s, p, map (genFn (t+max s p)) gens) - 651 where - 652 genFn maxT gen = do - 653 frameGen <- gen - 654 return $ \_ t -> - 655 if t < maxT - 656 then frameGen maxT t - 657 else (None, 0) - 658 - 659 asAnimation :: (forall s'. Scene s' a) -> Scene s Animation - 660 asAnimation scene = do - 661 now <- queryNow - 662 return $ dropA now (sceneAnimation (wait now >> scene)) - 663 - 664 transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s () - 665 transitionO t o a b = do - 666 aA <- asAnimation a - 667 bA <- fork $ do - 668 wait (duration aA - o) - 669 asAnimation b - 670 play $ overlapT o t aA bA - 671 - 672 + 633 -- > spriteZ s1 1 + 634 -- > wait 1 + 635 -- + 636 -- <<docs/gifs/doc_spriteZ.gif>> + 637 spriteZ :: Sprite s -> ZIndex -> Scene s () + 638 spriteZ (Sprite born ref) zindex = do + 639 now <- queryNow + 640 liftST $ modifySTRef ref $ \(ttl, renderGen) -> + 641 ( ttl + 642 , do + 643 render <- renderGen + 644 return $ \d t svg -> + 645 let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex) + 646 ) + 647 + 648 -- Destroy all local sprites at the end of a scene. + 649 spriteScope :: Scene s a -> Scene s a + 650 spriteScope (M action) = M $ \t -> do + 651 (a, s, p, gens) <- action t + 652 return (a, s, p, map (genFn (t+max s p)) gens) + 653 where + 654 genFn maxT gen = do + 655 frameGen <- gen + 656 return $ \_ t -> + 657 if t < maxT + 658 then frameGen maxT t + 659 else (None, 0) + 660 + 661 asAnimation :: (forall s'. Scene s' a) -> Scene s Animation + 662 asAnimation scene = do + 663 now <- queryNow + 664 return $ dropA now (sceneAnimation (wait now >> scene)) + 665 + 666 transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s () + 667 transitionO t o a b = do + 668 aA <- asAnimation a + 669 bA <- fork $ do + 670 wait (duration aA - o) + 671 asAnimation b + 672 play $ overlapT o t aA bA 673 674 - 675 ------------------------------------------------------- - 676 -- Objects - 677 - 678 class Renderable a where - 679 toSVG :: a -> SVG - 680 - 681 instance Renderable Tree where - 682 toSVG = id - 683 - 684 data Object s a = Object - 685 { objectSprite :: Sprite s - 686 , objectData :: Var s (ObjectData a) - 687 } - 688 data ObjectData a = ObjectData - 689 { _oTranslate :: (Double, Double) - 690 , _oValueRef :: a - 691 , _oSVG :: SVG - 692 , _oContext :: SVG -> SVG - 693 , _oMargin :: (Double, Double, Double, Double) - 694 -- ^ Top, right, bottom, left - 695 , _oBB :: (Double,Double,Double,Double) - 696 , _oOpacity :: Double - 697 , _oShown :: Bool - 698 , _oZIndex :: Int - 699 , _oEasing :: Signal - 700 , _oScale :: Double - 701 , _oScaleOrigin :: (Double, Double) - 702 } - 703 - 704 -- Basic lenses + 675 + 676 + 677 ------------------------------------------------------- + 678 -- Objects + 679 + 680 class Renderable a where + 681 toSVG :: a -> SVG + 682 + 683 instance Renderable Tree where + 684 toSVG = id + 685 + 686 data Object s a = Object + 687 { objectSprite :: Sprite s + 688 , objectData :: Var s (ObjectData a) + 689 } + 690 data ObjectData a = ObjectData + 691 { _oTranslate :: (Double, Double) + 692 , _oValueRef :: a + 693 , _oSVG :: SVG + 694 , _oContext :: SVG -> SVG + 695 , _oMargin :: (Double, Double, Double, Double) + 696 -- ^ Top, right, bottom, left + 697 , _oBB :: (Double,Double,Double,Double) + 698 , _oOpacity :: Double + 699 , _oShown :: Bool + 700 , _oZIndex :: Int + 701 , _oEasing :: Signal + 702 , _oScale :: Double + 703 , _oScaleOrigin :: (Double, Double) + 704 } 705 - 706 oTranslate :: Lens' (ObjectData a) (Double, Double) - 707 oTranslate = lens _oTranslate $ \obj val -> obj { _oTranslate = val } - 708 - 709 oSVG :: Getter (ObjectData a) SVG - 710 oSVG = to _oSVG - 711 - 712 oContext :: Lens' (ObjectData a) (SVG -> SVG) - 713 oContext = lens _oContext $ \obj val -> obj { _oContext = val } - 714 - 715 oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double) - 716 oMargin = lens _oMargin $ \obj val -> obj { _oMargin = val } - 717 - 718 oBB :: Getter (ObjectData a) (Double, Double, Double, Double) - 719 oBB = to _oBB - 720 - 721 oOpacity :: Lens' (ObjectData a) Double - 722 oOpacity = lens _oOpacity $ \obj val -> obj { _oOpacity = val } - 723 - 724 oShown :: Lens' (ObjectData a) Bool - 725 oShown = lens _oShown $ \obj val -> obj { _oShown = val } - 726 - 727 oZIndex :: Lens' (ObjectData a) Int - 728 oZIndex = lens _oZIndex $ \obj val -> obj { _oZIndex = val } - 729 - 730 oEasing :: Lens' (ObjectData a) Signal - 731 oEasing = lens _oEasing $ \obj val -> obj { _oEasing = val } - 732 - 733 oScale :: Lens' (ObjectData a) Double - 734 oScale = lens _oScale $ \obj val -> obj { _oScale = val } - 735 - 736 oScaleOrigin :: Lens' (ObjectData a) (Double, Double) - 737 oScaleOrigin = lens _oScaleOrigin $ \obj val -> obj { _oScaleOrigin = val } - 738 - 739 -- Smart lenses + 706 -- Basic lenses + 707 + 708 oTranslate :: Lens' (ObjectData a) (Double, Double) + 709 oTranslate = lens _oTranslate $ \obj val -> obj { _oTranslate = val } + 710 + 711 oSVG :: Getter (ObjectData a) SVG + 712 oSVG = to _oSVG + 713 + 714 oContext :: Lens' (ObjectData a) (SVG -> SVG) + 715 oContext = lens _oContext $ \obj val -> obj { _oContext = val } + 716 + 717 oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double) + 718 oMargin = lens _oMargin $ \obj val -> obj { _oMargin = val } + 719 + 720 oBB :: Getter (ObjectData a) (Double, Double, Double, Double) + 721 oBB = to _oBB + 722 + 723 oOpacity :: Lens' (ObjectData a) Double + 724 oOpacity = lens _oOpacity $ \obj val -> obj { _oOpacity = val } + 725 + 726 oShown :: Lens' (ObjectData a) Bool + 727 oShown = lens _oShown $ \obj val -> obj { _oShown = val } + 728 + 729 oZIndex :: Lens' (ObjectData a) Int + 730 oZIndex = lens _oZIndex $ \obj val -> obj { _oZIndex = val } + 731 + 732 oEasing :: Lens' (ObjectData a) Signal + 733 oEasing = lens _oEasing $ \obj val -> obj { _oEasing = val } + 734 + 735 oScale :: Lens' (ObjectData a) Double + 736 oScale = lens _oScale $ \obj val -> obj { _oScale = val } + 737 + 738 oScaleOrigin :: Lens' (ObjectData a) (Double, Double) + 739 oScaleOrigin = lens _oScaleOrigin $ \obj val -> obj { _oScaleOrigin = val } 740 - 741 oValue :: Renderable a => Lens' (ObjectData a) a - 742 oValue = lens _oValueRef $ \obj newVal -> - 743 let svg = toSVG newVal - 744 in obj - 745 { _oValueRef = newVal - 746 , _oSVG = svg - 747 , _oBB = boundingBox svg } - 748 - 749 oTopY :: Lens' (ObjectData a) Double - 750 oTopY = lens getter setter - 751 where - 752 getter obj = - 753 let top = obj ^. oMarginTop - 754 miny = obj ^. oBBMinY - 755 h = obj ^. oBBHeight - 756 dy = obj ^. oTranslate . _2 - 757 in dy+miny+h+top - 758 setter obj val = - 759 obj & (oTranslate . _2) +~ val-getter obj - 760 - 761 oBottomY :: Lens' (ObjectData a) Double - 762 oBottomY = lens getter setter - 763 where - 764 getter obj = - 765 let bot = obj ^. oMarginBottom - 766 miny = obj ^. oBBMinY - 767 dy = obj ^. oTranslate . _2 - 768 in dy+miny-bot - 769 setter obj val = - 770 obj & (oTranslate . _2) +~ val-getter obj - 771 - 772 oLeftX :: Lens' (ObjectData a) Double - 773 oLeftX = lens getter setter - 774 where - 775 getter obj = - 776 let left = obj ^. oMarginLeft - 777 minx = obj ^. oBBMinX - 778 dx = obj ^. oTranslate . _1 - 779 in dx+minx-left - 780 setter obj val = - 781 obj & (oTranslate . _1) +~ val-getter obj - 782 - 783 oRightX :: Lens' (ObjectData a) Double - 784 oRightX = lens getter setter - 785 where - 786 getter obj = - 787 let right = obj ^. oMarginRight - 788 minx = obj ^. oBBMinX - 789 w = obj ^. oBBWidth - 790 dx = obj ^. oTranslate . _1 - 791 in dx+minx+w+right - 792 setter obj val = - 793 obj & (oTranslate . _1) +~ val-getter obj - 794 - 795 oCenterXY :: Lens' (ObjectData a) (Double, Double) - 796 oCenterXY = lens getter setter - 797 where - 798 getter obj = - 799 let minx = obj ^. oBBMinX - 800 miny = obj ^. oBBMinY - 801 w = obj ^. oBBWidth - 802 h = obj ^. oBBHeight - 803 (dx,dy) = obj ^. oTranslate - 804 in (dx+minx+w/2, dy+miny+h/2) - 805 setter obj (dx, dy) = - 806 let (x,y) = getter obj in - 807 obj & (oTranslate . _1) +~ dx-x - 808 & (oTranslate . _2) +~ dy-y - 809 - 810 oMarginTop :: Lens' (ObjectData a) Double - 811 oMarginTop = oMargin . _1 - 812 - 813 oMarginRight :: Lens' (ObjectData a) Double - 814 oMarginRight = oMargin . _2 - 815 - 816 oMarginBottom :: Lens' (ObjectData a) Double - 817 oMarginBottom = oMargin . _3 - 818 - 819 oMarginLeft :: Lens' (ObjectData a) Double - 820 oMarginLeft = oMargin . _4 - 821 - 822 oBBMinX :: Getter (ObjectData a) Double - 823 oBBMinX = oBB . _1 - 824 - 825 oBBMinY :: Getter (ObjectData a) Double - 826 oBBMinY = oBB . _2 - 827 - 828 oBBWidth :: Getter (ObjectData a) Double - 829 oBBWidth = oBB . _3 - 830 - 831 oBBHeight :: Getter (ObjectData a) Double - 832 oBBHeight = oBB . _4 - 833 - 834 oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s () - 835 oModify o fn = modifyVar (objectData o) fn - 836 - 837 oModifyS :: Object s a -> (State (ObjectData a) b) -> Scene s () - 838 oModifyS o fn = oModify o (execState fn) - 839 - 840 oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b - 841 oRead o l = do - 842 v <- readVar (objectData o) - 843 return $ view l v - 844 - 845 oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s () - 846 oTween o d fn = do - 847 -- Read 'easing' var here instead of taking it from 'v'. - 848 -- This allows different easing functions even at the same timestamp. - 849 ease <- oRead o oEasing - 850 tweenVar (objectData o) d (\v t -> fn (ease t) v) - 851 -- tweenVar ref d (\v t -> fn t v) - 852 - 853 -- oTweenS :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s () - 854 oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s () - 855 oTweenS o d fn = oTween o d (\t -> execState (fn t)) - 856 - 857 oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s () - 858 oTweenV o d fn = oTween o d (\t -> oValue %~ fn t) - 859 - 860 oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s () - 861 oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t)) - 862 - 863 newObject :: Renderable a => a -> Scene s (Object s a) - 864 newObject val = do - 865 ref <- newVar ObjectData - 866 { _oTranslate = (0,0) - 867 , _oValueRef = val - 868 , _oSVG = svg - 869 , _oContext = id - 870 , _oMargin = (0.5,0.5,0.5,0.5) - 871 , _oBB = boundingBox svg - 872 , _oOpacity = 1 - 873 , _oShown = False - 874 , _oZIndex = 1 - 875 , _oEasing = curveS 2 - 876 , _oScale = 1 - 877 , _oScaleOrigin = (0,0) - 878 } - 879 sprite <- newSprite $ do - 880 ~ObjectData{..} <- unVar ref - 881 pure $ - 882 if _oShown - 883 then - 884 uncurry translate _oTranslate $ - 885 uncurry translate (_oScaleOrigin & both %~ negate) $ - 886 scale _oScale $ - 887 uncurry translate _oScaleOrigin $ - 888 withGroupOpacity _oOpacity $ - 889 _oContext _oSVG - 890 else None - 891 return Object - 892 { objectSprite = sprite - 893 , objectData = ref } - 894 where - 895 svg = toSVG val - 896 - 897 newtype Circle = Circle {_circleRadius :: Double} - 898 instance Renderable Circle where - 899 toSVG (Circle r) = mkCircle r - 900 - 901 data Rectangle = Rectangle { _rectWidth :: Double, _rectHeight :: Double } - 902 instance Renderable Rectangle where - 903 toSVG (Rectangle w h) = mkRect w h - 904 - 905 data Morph = Morph { _morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG } - 906 instance Renderable Morph where - 907 toSVG (Morph t src dst) = morph linear src dst t - 908 - 909 data Camera = Camera - 910 instance Renderable Camera where - 911 toSVG Camera = None - 912 - 913 cameraAttach :: Object s Camera -> Object s a -> Scene s () - 914 cameraAttach cam obj = - 915 spriteModify (objectSprite obj) $ do - 916 camData <- unVar (objectData cam) - 917 return $ \(svg,zindex) -> - 918 let (x,y) = camData^.oTranslate - 919 ctx = - 920 translate (-x) (-y) . - 921 uncurry translate (camData^.oScaleOrigin) . - 922 scale (camData^.oScale) . - 923 uncurry translate (camData^.oScaleOrigin & both %~ negate) - 924 in (ctx svg, zindex) - 925 - 926 cameraFocus :: Object s Camera -> (Double, Double) -> Scene s () - 927 cameraFocus cam (x,y) = do - 928 (ox, oy) <- oRead cam oScaleOrigin - 929 (tx, ty) <- oRead cam oTranslate - 930 s <- oRead cam oScale - 931 let newLocation = (x-((x-ox)*s+ox-tx), y-((y-oy)*s+oy-ty)) - 932 oModifyS cam $ do - 933 oTranslate .= newLocation - 934 oScaleOrigin .= (x,y) - 935 - 936 cameraSetZoom :: Object s Camera -> Double -> Scene s () - 937 cameraSetZoom cam s = - 938 oModifyS cam $ - 939 oScale .= s - 940 - 941 cameraZoom :: Object s Camera -> Duration -> Double -> Scene s () - 942 cameraZoom cam d s = - 943 oTweenS cam d $ \t -> - 944 oScale %= \v -> fromToS v s t - 945 - 946 cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s () - 947 cameraSetPan cam location = - 948 oModifyS cam $ do - 949 oTranslate .= location - 950 - 951 cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s () - 952 cameraPan cam d (x,y) = - 953 oTweenS cam d $ \t -> do - 954 oTranslate._1 %= \v -> fromToS v x t - 955 oTranslate._2 %= \v -> fromToS v y t - 956 - 957 makeLenses ''Circle - 958 makeLenses ''Rectangle - 959 makeLenses ''Morph - 960 - 961 oShow :: Object s a -> Scene s () - 962 oShow o = oModify o $ oShown .~ True - 963 - 964 oHide :: Object s a -> Scene s () - 965 oHide o = oModify o $ oShown .~ False - 966 - 967 oFadeIn :: Object s a -> Duration -> Scene s () - 968 oFadeIn o d = do - 969 oModify o $ - 970 oShown .~ True - 971 oTweenS o d $ \t -> - 972 oOpacity *= t - 973 - 974 oFadeOut :: Object s a -> Duration -> Scene s () - 975 oFadeOut o d = do - 976 oModify o $ - 977 oShown .~ True - 978 oTweenS o d $ \t -> - 979 oOpacity *= 1-t - 980 - 981 oGrow :: Object s a -> Duration -> Scene s () - 982 oGrow o d = do - 983 oModify o $ - 984 oShown .~ True - 985 oTweenS o d $ \t -> - 986 oScale *= t - 987 - 988 oShrink :: Object s a -> Duration -> Scene s () - 989 oShrink o d = - 990 oTweenS o d $ \t -> - 991 oScale *= 1-t - 992 - 993 -- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'. - 994 oTransform :: Object s a -> Object s b -> Duration -> Scene s () - 995 oTransform src dst d = do - 996 srcSvg <- oRead src oSVG - 997 srcCtx <- oRead src oContext - 998 srcEase <- oRead src oEasing - 999 srcLoc <- oRead src oTranslate - 1000 oModify src $ oShown .~ False - 1001 - 1002 dstSvg <- oRead dst oSVG - 1003 dstCtx <- oRead dst oContext - 1004 dstLoc <- oRead dst oTranslate - 1005 - 1006 m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg) - 1007 oModifyS m $ do - 1008 oShown .= True - 1009 oEasing .= srcEase - 1010 oTranslate .= srcLoc - 1011 fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc - 1012 oTweenV m d $ \t -> morphDelta .~ t - 1013 oModify m $ oShown .~ False - 1014 oModify dst $ oShown .~ True - 1015 where - 1016 moveTo t (dstX, dstY) (srcX, srcY) = - 1017 (fromToS srcX dstX t, fromToS srcY dstY t) + 741 -- Smart lenses + 742 + 743 oValue :: Renderable a => Lens' (ObjectData a) a + 744 oValue = lens _oValueRef $ \obj newVal -> + 745 let svg = toSVG newVal + 746 in obj + 747 { _oValueRef = newVal + 748 , _oSVG = svg + 749 , _oBB = boundingBox svg } + 750 + 751 oTopY :: Lens' (ObjectData a) Double + 752 oTopY = lens getter setter + 753 where + 754 getter obj = + 755 let top = obj ^. oMarginTop + 756 miny = obj ^. oBBMinY + 757 h = obj ^. oBBHeight + 758 dy = obj ^. oTranslate . _2 + 759 in dy+miny+h+top + 760 setter obj val = + 761 obj & (oTranslate . _2) +~ val-getter obj + 762 + 763 oBottomY :: Lens' (ObjectData a) Double + 764 oBottomY = lens getter setter + 765 where + 766 getter obj = + 767 let bot = obj ^. oMarginBottom + 768 miny = obj ^. oBBMinY + 769 dy = obj ^. oTranslate . _2 + 770 in dy+miny-bot + 771 setter obj val = + 772 obj & (oTranslate . _2) +~ val-getter obj + 773 + 774 oLeftX :: Lens' (ObjectData a) Double + 775 oLeftX = lens getter setter + 776 where + 777 getter obj = + 778 let left = obj ^. oMarginLeft + 779 minx = obj ^. oBBMinX + 780 dx = obj ^. oTranslate . _1 + 781 in dx+minx-left + 782 setter obj val = + 783 obj & (oTranslate . _1) +~ val-getter obj + 784 + 785 oRightX :: Lens' (ObjectData a) Double + 786 oRightX = lens getter setter + 787 where + 788 getter obj = + 789 let right = obj ^. oMarginRight + 790 minx = obj ^. oBBMinX + 791 w = obj ^. oBBWidth + 792 dx = obj ^. oTranslate . _1 + 793 in dx+minx+w+right + 794 setter obj val = + 795 obj & (oTranslate . _1) +~ val-getter obj + 796 + 797 oCenterXY :: Lens' (ObjectData a) (Double, Double) + 798 oCenterXY = lens getter setter + 799 where + 800 getter obj = + 801 let minx = obj ^. oBBMinX + 802 miny = obj ^. oBBMinY + 803 w = obj ^. oBBWidth + 804 h = obj ^. oBBHeight + 805 (dx,dy) = obj ^. oTranslate + 806 in (dx+minx+w/2, dy+miny+h/2) + 807 setter obj (dx, dy) = + 808 let (x,y) = getter obj in + 809 obj & (oTranslate . _1) +~ dx-x + 810 & (oTranslate . _2) +~ dy-y + 811 + 812 oMarginTop :: Lens' (ObjectData a) Double + 813 oMarginTop = oMargin . _1 + 814 + 815 oMarginRight :: Lens' (ObjectData a) Double + 816 oMarginRight = oMargin . _2 + 817 + 818 oMarginBottom :: Lens' (ObjectData a) Double + 819 oMarginBottom = oMargin . _3 + 820 + 821 oMarginLeft :: Lens' (ObjectData a) Double + 822 oMarginLeft = oMargin . _4 + 823 + 824 oBBMinX :: Getter (ObjectData a) Double + 825 oBBMinX = oBB . _1 + 826 + 827 oBBMinY :: Getter (ObjectData a) Double + 828 oBBMinY = oBB . _2 + 829 + 830 oBBWidth :: Getter (ObjectData a) Double + 831 oBBWidth = oBB . _3 + 832 + 833 oBBHeight :: Getter (ObjectData a) Double + 834 oBBHeight = oBB . _4 + 835 + 836 oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s () + 837 oModify o fn = modifyVar (objectData o) fn + 838 + 839 oModifyS :: Object s a -> (State (ObjectData a) b) -> Scene s () + 840 oModifyS o fn = oModify o (execState fn) + 841 + 842 oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b + 843 oRead o l = do + 844 v <- readVar (objectData o) + 845 return $ view l v + 846 + 847 oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s () + 848 oTween o d fn = do + 849 -- Read 'easing' var here instead of taking it from 'v'. + 850 -- This allows different easing functions even at the same timestamp. + 851 ease <- oRead o oEasing + 852 tweenVar (objectData o) d (\v t -> fn (ease t) v) + 853 -- tweenVar ref d (\v t -> fn t v) + 854 + 855 -- oTweenS :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s () + 856 oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s () + 857 oTweenS o d fn = oTween o d (\t -> execState (fn t)) + 858 + 859 oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s () + 860 oTweenV o d fn = oTween o d (\t -> oValue %~ fn t) + 861 + 862 oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s () + 863 oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t)) + 864 + 865 newObject :: Renderable a => a -> Scene s (Object s a) + 866 newObject val = do + 867 ref <- newVar ObjectData + 868 { _oTranslate = (0,0) + 869 , _oValueRef = val + 870 , _oSVG = svg + 871 , _oContext = id + 872 , _oMargin = (0.5,0.5,0.5,0.5) + 873 , _oBB = boundingBox svg + 874 , _oOpacity = 1 + 875 , _oShown = False + 876 , _oZIndex = 1 + 877 , _oEasing = curveS 2 + 878 , _oScale = 1 + 879 , _oScaleOrigin = (0,0) + 880 } + 881 sprite <- newSprite $ do + 882 ~ObjectData{..} <- unVar ref + 883 pure $ + 884 if _oShown + 885 then + 886 uncurry translate _oTranslate $ + 887 uncurry translate (_oScaleOrigin & both %~ negate) $ + 888 scale _oScale $ + 889 uncurry translate _oScaleOrigin $ + 890 withGroupOpacity _oOpacity $ + 891 _oContext _oSVG + 892 else None + 893 return Object + 894 { objectSprite = sprite + 895 , objectData = ref } + 896 where + 897 svg = toSVG val + 898 + 899 newtype Circle = Circle {_circleRadius :: Double} + 900 instance Renderable Circle where + 901 toSVG (Circle r) = mkCircle r + 902 + 903 data Rectangle = Rectangle { _rectWidth :: Double, _rectHeight :: Double } + 904 instance Renderable Rectangle where + 905 toSVG (Rectangle w h) = mkRect w h + 906 + 907 data Morph = Morph { _morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG } + 908 instance Renderable Morph where + 909 toSVG (Morph t src dst) = morph linear src dst t + 910 + 911 data Camera = Camera + 912 instance Renderable Camera where + 913 toSVG Camera = None + 914 + 915 cameraAttach :: Object s Camera -> Object s a -> Scene s () + 916 cameraAttach cam obj = + 917 spriteModify (objectSprite obj) $ do + 918 camData <- unVar (objectData cam) + 919 return $ \(svg,zindex) -> + 920 let (x,y) = camData^.oTranslate + 921 ctx = + 922 translate (-x) (-y) . + 923 uncurry translate (camData^.oScaleOrigin) . + 924 scale (camData^.oScale) . + 925 uncurry translate (camData^.oScaleOrigin & both %~ negate) + 926 in (ctx svg, zindex) + 927 + 928 cameraFocus :: Object s Camera -> (Double, Double) -> Scene s () + 929 cameraFocus cam (x,y) = do + 930 (ox, oy) <- oRead cam oScaleOrigin + 931 (tx, ty) <- oRead cam oTranslate + 932 s <- oRead cam oScale + 933 let newLocation = (x-((x-ox)*s+ox-tx), y-((y-oy)*s+oy-ty)) + 934 oModifyS cam $ do + 935 oTranslate .= newLocation + 936 oScaleOrigin .= (x,y) + 937 + 938 cameraSetZoom :: Object s Camera -> Double -> Scene s () + 939 cameraSetZoom cam s = + 940 oModifyS cam $ + 941 oScale .= s + 942 + 943 cameraZoom :: Object s Camera -> Duration -> Double -> Scene s () + 944 cameraZoom cam d s = + 945 oTweenS cam d $ \t -> + 946 oScale %= \v -> fromToS v s t + 947 + 948 cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s () + 949 cameraSetPan cam location = + 950 oModifyS cam $ do + 951 oTranslate .= location + 952 + 953 cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s () + 954 cameraPan cam d (x,y) = + 955 oTweenS cam d $ \t -> do + 956 oTranslate._1 %= \v -> fromToS v x t + 957 oTranslate._2 %= \v -> fromToS v y t + 958 + 959 makeLenses ''Circle + 960 makeLenses ''Rectangle + 961 makeLenses ''Morph + 962 + 963 oShow :: Object s a -> Scene s () + 964 oShow o = oModify o $ oShown .~ True + 965 + 966 oHide :: Object s a -> Scene s () + 967 oHide o = oModify o $ oShown .~ False + 968 + 969 oFadeIn :: Object s a -> Duration -> Scene s () + 970 oFadeIn o d = do + 971 oModify o $ + 972 oShown .~ True + 973 oTweenS o d $ \t -> + 974 oOpacity *= t + 975 + 976 oFadeOut :: Object s a -> Duration -> Scene s () + 977 oFadeOut o d = do + 978 oModify o $ + 979 oShown .~ True + 980 oTweenS o d $ \t -> + 981 oOpacity *= 1-t + 982 + 983 oGrow :: Object s a -> Duration -> Scene s () + 984 oGrow o d = do + 985 oModify o $ + 986 oShown .~ True + 987 oTweenS o d $ \t -> + 988 oScale *= t + 989 + 990 oShrink :: Object s a -> Duration -> Scene s () + 991 oShrink o d = + 992 oTweenS o d $ \t -> + 993 oScale *= 1-t + 994 + 995 -- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'. + 996 oTransform :: Object s a -> Object s b -> Duration -> Scene s () + 997 oTransform src dst d = do + 998 srcSvg <- oRead src oSVG + 999 srcCtx <- oRead src oContext + 1000 srcEase <- oRead src oEasing + 1001 srcLoc <- oRead src oTranslate + 1002 oModify src $ oShown .~ False + 1003 + 1004 dstSvg <- oRead dst oSVG + 1005 dstCtx <- oRead dst oContext + 1006 dstLoc <- oRead dst oTranslate + 1007 + 1008 m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg) + 1009 oModifyS m $ do + 1010 oShown .= True + 1011 oEasing .= srcEase + 1012 oTranslate .= srcLoc + 1013 fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc + 1014 oTweenV m d $ \t -> morphDelta .~ t + 1015 oModify m $ oShown .~ False + 1016 oModify dst $ oShown .~ True + 1017 where + 1018 moveTo t (dstX, dstY) (srcX, srcY) = + 1019 (fromToS srcX dstX t, fromToS srcY dstY t) diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox.hs.html index 29e05e8..76ff596 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Svg.BoundingBox.hs.html @@ -17,119 +17,135 @@ span.spaces { background: white } never executed always true always false 
-    1 module Reanimate.Svg.BoundingBox where
-    2 
-    3 import           Control.Arrow             ((***))
-    4 import           Control.Lens              ((^.))
-    5 import           Data.List
-    6 import           Data.Maybe                (mapMaybe)
-    7 import           Graphics.SvgTree          hiding (height, line, path, use,
-    8                                             width)
-    9 import           Linear.V2                 hiding (angle)
-   10 import           Linear.Vector
-   11 import           Reanimate.Constants
-   12 import           Reanimate.Svg.LineCommand
-   13 import qualified Reanimate.Transform       as Transform
-   14 -- import qualified Geom2D.CubicBezier           as Bezier
-   15 
-   16 -- | Return bounding box of SVG tree.
-   17 --  The four numbers returned are (minimal X-coordinate, minimal Y-coordinate, width, height)
-   18 --
-   19 --  Note: Bounding boxes are computed on a best-effort basis and will not work
-   20 --        in all cases. The only supported SVG nodes are: path, circle, polyline,
-   21 --        ellipse, line, rectangle, image. All other nodes return (0,0,0,0).
-   22 boundingBox :: Tree -> (Double, Double, Double, Double)
-   23 boundingBox t =
-   24     case svgBoundingPoints t of
-   25       [] -> (0,0,0,0)
-   26       (V2 x y:rest) ->
-   27         let (minx, miny, maxx, maxy) = foldl' worker (x, y, x, y) rest
-   28         in (minx, miny, maxx-minx, maxy-miny)
-   29   where
-   30     worker (minx, miny, maxx, maxy) (V2 x y) =
-   31       (min minx x, min miny y, max maxx x, max maxy y)
-   32 
-   33 svgHeight :: Tree -> Double
-   34 svgHeight t = h
-   35   where
-   36     (_x, _y, _w, h) = boundingBox t
-   37 
-   38 svgWidth :: Tree -> Double
-   39 svgWidth t = w
-   40   where
-   41     (_x, _y, w, _h) = boundingBox t
-   42 
-   43 linePoints :: [LineCommand] -> [RPoint]
-   44 linePoints = worker zero
-   45   where
-   46     worker _from [] = []
-   47     worker from (x:xs) =
-   48       case x of
-   49         LineMove to     -> worker to xs
-   50         -- LineDraw to     -> from:to:worker to xs
-   51         LineBezier [p] ->
-   52           p : worker p xs
-   53         LineBezier ctrl -> -- approximation
-   54           [ last (partialBezierPoints (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++
-   55           worker (last ctrl) xs
-   56         LineEnd p -> p : worker p xs
-   57     chunks = 10
-   58 
-   59 svgBoundingPoints :: Tree -> [RPoint]
-   60 svgBoundingPoints t = map (Transform.transformPoint m) $
-   61     case t of
-   62       None            -> []
-   63       UseTree{}       -> []
-   64       GroupTree g     -> concatMap svgBoundingPoints (g^.groupChildren)
-   65       SymbolTree (Symbol g) -> concatMap svgBoundingPoints (g^.groupChildren)
-   66       FilterTree{}    -> []
-   67       DefinitionTree{} -> []
-   68       PathTree p      -> linePoints $ toLineCommands (p^.pathDefinition)
-   69       CircleTree c    -> circleBoundingPoints c
-   70       PolyLineTree pl -> pl ^. polyLinePoints
-   71       EllipseTree e   -> ellipseBoundingPoints e
-   72       LineTree line   -> map pointToRPoint [line^.linePoint1, line^.linePoint2]
-   73       RectangleTree rect ->
-   74         case pointToRPoint (rect^.rectUpperLeftCorner) of
-   75           V2 x y -> V2 x y :
-   76             case mapTuple (fmap $ toUserUnit defaultDPI) (rect^.rectWidth, rect^.rectHeight) of
-   77               (Just (Num w), Just (Num h)) -> [V2 (x+w) (y+h)]
-   78               _                            -> []
-   79       TextTree{}      -> []
-   80       ImageTree img   ->
-   81         case (img^.imageCornerUpperLeft, img^.imageWidth, img^.imageHeight) of
-   82           ((Num x, Num y), Num w, Num h) ->
-   83             [V2 x y, V2 (x+w) (y+h)]
-   84           _ -> []
-   85       MeshGradientTree{} -> []
-   86       _ -> []
-   87   where
-   88     m = Transform.mkMatrix (t^.transform)
-   89     mapTuple f = f *** f
-   90     pointToRPoint p =
-   91       case mapTuple (toUserUnit defaultDPI) p of
-   92         (Num x, Num y) -> V2 x y
-   93         _ -> error "Reanimate.Svg.svgBoundingPoints: Unrecognized number format."
-   94 
-   95     circleBoundingPoints circ =
-   96       let (xnum, ynum) = circ ^. circleCenter
-   97           rnum = circ ^. circleRadius
-   98       in case mapMaybe unpackNumber [xnum, ynum, rnum] of
-   99         [x, y, r] -> [ V2 (x + r * cos angle) (y + r * sin angle) | angle <- [0, pi/10 .. 2 * pi]]
-  100         _  -> []
-  101 
-  102     ellipseBoundingPoints e =
-  103       let (xnum,ynum) = e ^. ellipseCenter
-  104           xrnum = e ^. ellipseXRadius
-  105           yrnum = e ^. ellipseYRadius
-  106       in case mapMaybe unpackNumber [xnum, ynum, xrnum, yrnum] of
-  107         [x,y,xr,yr] -> [V2 (x + xr * cos angle) (y + yr * sin angle) | angle <- [0, pi/10 .. 2 * pi]]
-  108         _ -> []
-  109 
-  110     unpackNumber n =
-  111       case toUserUnit defaultDPI n of
-  112         Num d -> Just d
-  113         _     -> Nothing
+    1 {-|
+    2   Bounding-boxes can be immensely useful for aligning objects
+    3   but they are not part of the SVG specification and cannot be
+    4   computed for all SVG nodes. In particular, you'll get bad results
+    5   when asking for the bounding boxes of Text nodes (because fonts
+    6   are difficult), clipped nodes, and filtered nodes.
+    7 -}
+    8 module Reanimate.Svg.BoundingBox
+    9   ( boundingBox
+   10   , svgHeight
+   11   , svgWidth
+   12   ) where
+   13 
+   14 import           Control.Arrow             ((***))
+   15 import           Control.Lens              ((^.))
+   16 import           Data.List
+   17 import           Data.Maybe                (mapMaybe)
+   18 import           Graphics.SvgTree          hiding (height, line, path, use,
+   19                                             width)
+   20 import           Linear.V2                 hiding (angle)
+   21 import           Linear.Vector
+   22 import           Reanimate.Constants
+   23 import           Reanimate.Svg.LineCommand
+   24 import qualified Reanimate.Transform       as Transform
+   25 -- import qualified Geom2D.CubicBezier           as Bezier
+   26 
+   27 -- | Return bounding box of SVG tree.
+   28 --  The four numbers returned are (minimal X-coordinate, minimal Y-coordinate, width, height)
+   29 --
+   30 --  Note: Bounding boxes are computed on a best-effort basis and will not work
+   31 --        in all cases. The only supported SVG nodes are: path, circle, polyline,
+   32 --        ellipse, line, rectangle, image. All other nodes return (0,0,0,0).
+   33 boundingBox :: Tree -> (Double, Double, Double, Double)
+   34 boundingBox t =
+   35     case svgBoundingPoints t of
+   36       [] -> (0,0,0,0)
+   37       (V2 x y:rest) ->
+   38         let (minx, miny, maxx, maxy) = foldl' worker (x, y, x, y) rest
+   39         in (minx, miny, maxx-minx, maxy-miny)
+   40   where
+   41     worker (minx, miny, maxx, maxy) (V2 x y) =
+   42       (min minx x, min miny y, max maxx x, max maxy y)
+   43 
+   44 -- | Height of SVG node in local units (not pixels). Computed on best-effort basis
+   45 --   and will not give accurate results for all SVG nodes.
+   46 svgHeight :: Tree -> Double
+   47 svgHeight t = h
+   48   where
+   49     (_x, _y, _w, h) = boundingBox t
+   50 
+   51 -- | Width of SVG node in local units (not pixels). Computed on best-effort basis
+   52 --   and will not give accurate results for all SVG nodes.
+   53 svgWidth :: Tree -> Double
+   54 svgWidth t = w
+   55   where
+   56     (_x, _y, w, _h) = boundingBox t
+   57 
+   58 -- | Sampling of points in a line path.
+   59 linePoints :: [LineCommand] -> [RPoint]
+   60 linePoints = worker zero
+   61   where
+   62     worker _from [] = []
+   63     worker from (x:xs) =
+   64       case x of
+   65         LineMove to     -> worker to xs
+   66         -- LineDraw to     -> from:to:worker to xs
+   67         LineBezier [p] ->
+   68           p : worker p xs
+   69         LineBezier ctrl -> -- approximation
+   70           [ last (partialBezierPoints (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++
+   71           worker (last ctrl) xs
+   72         LineEnd p -> p : worker p xs
+   73     chunks = 10
+   74 
+   75 svgBoundingPoints :: Tree -> [RPoint]
+   76 svgBoundingPoints t = map (Transform.transformPoint m) $
+   77     case t of
+   78       None            -> []
+   79       UseTree{}       -> []
+   80       GroupTree g     -> concatMap svgBoundingPoints (g^.groupChildren)
+   81       SymbolTree (Symbol g) -> concatMap svgBoundingPoints (g^.groupChildren)
+   82       FilterTree{}    -> []
+   83       DefinitionTree{} -> []
+   84       PathTree p      -> linePoints $ toLineCommands (p^.pathDefinition)
+   85       CircleTree c    -> circleBoundingPoints c
+   86       PolyLineTree pl -> pl ^. polyLinePoints
+   87       EllipseTree e   -> ellipseBoundingPoints e
+   88       LineTree line   -> map pointToRPoint [line^.linePoint1, line^.linePoint2]
+   89       RectangleTree rect ->
+   90         case pointToRPoint (rect^.rectUpperLeftCorner) of
+   91           V2 x y -> V2 x y :
+   92             case mapTuple (fmap $ toUserUnit defaultDPI) (rect^.rectWidth, rect^.rectHeight) of
+   93               (Just (Num w), Just (Num h)) -> [V2 (x+w) (y+h)]
+   94               _                            -> []
+   95       TextTree{}      -> []
+   96       ImageTree img   ->
+   97         case (img^.imageCornerUpperLeft, img^.imageWidth, img^.imageHeight) of
+   98           ((Num x, Num y), Num w, Num h) ->
+   99             [V2 x y, V2 (x+w) (y+h)]
+  100           _ -> []
+  101       MeshGradientTree{} -> []
+  102       _ -> []
+  103   where
+  104     m = Transform.mkMatrix (t^.transform)
+  105     mapTuple f = f *** f
+  106     pointToRPoint p =
+  107       case mapTuple (toUserUnit defaultDPI) p of
+  108         (Num x, Num y) -> V2 x y
+  109         _ -> error "Reanimate.Svg.svgBoundingPoints: Unrecognized number format."
+  110 
+  111     circleBoundingPoints circ =
+  112       let (xnum, ynum) = circ ^. circleCenter
+  113           rnum = circ ^. circleRadius
+  114       in case mapMaybe unpackNumber [xnum, ynum, rnum] of
+  115         [x, y, r] -> [ V2 (x + r * cos angle) (y + r * sin angle) | angle <- [0, pi/10 .. 2 * pi]]
+  116         _  -> []
+  117 
+  118     ellipseBoundingPoints e =
+  119       let (xnum,ynum) = e ^. ellipseCenter
+  120           xrnum = e ^. ellipseXRadius
+  121           yrnum = e ^. ellipseYRadius
+  122       in case mapMaybe unpackNumber [xnum, ynum, xrnum, yrnum] of
+  123         [x,y,xr,yr] -> [V2 (x + xr * cos angle) (y + yr * sin angle) | angle <- [0, pi/10 .. 2 * pi]]
+  124         _ -> []
+  125 
+  126     unpackNumber n =
+  127       case toUserUnit defaultDPI n of
+  128         Num d -> Just d
+  129         _     -> Nothing
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Svg.Constructors.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Svg.Constructors.hs.html index c2377f2..5838236 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Svg.Constructors.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Svg.Constructors.hs.html @@ -127,309 +127,317 @@ span.spaces { background: white } 108 offsetY = -y-h/2 109 (x,y,w,h) = boundingBox t 110 - 111 aroundCenterY :: (Tree -> Tree) -> Tree -> Tree - 112 aroundCenterY fn t = - 113 translate 0 (-offsetY) $ fn $ translate 0 offsetY t - 114 where - 115 offsetY = -y-h/2 - 116 (_x,y,_w,h) = boundingBox t - 117 - 118 aroundCenterX :: (Tree -> Tree) -> Tree -> Tree - 119 aroundCenterX fn t = - 120 translate (-offsetX) 0 $ fn $ translate offsetX 0 t - 121 where - 122 offsetX = -x-w/2 - 123 (x,_y,w,_h) = boundingBox t - 124 - 125 -- | Scale the image uniformly by given factor along both X and Y axes. - 126 -- For example @scale 2 image@ makes the image twice as large, while @scale 0.5 image@ makes it - 127 -- half the original size. Negative values are also allowed, and lead to flipping the image along - 128 -- both X and Y axes. - 129 scale :: Double -> Tree -> Tree - 130 scale a = withTransformations [Scale a Nothing] - 131 - 132 -- | @scaleToSize width height@ resizes the image so that its bounding box has corresponding @width@ - 133 -- and @height@. - 134 scaleToSize :: Double -> Double -> Tree -> Tree - 135 scaleToSize w h t = - 136 scaleXY (w/w') (h/h') t - 137 where - 138 (_x, _y, w', h') = boundingBox t - 139 - 140 -- | @scaleToWidth width@ scales the image so that the width of its bounding box ends up having - 141 -- given @width@. - 142 scaleToWidth :: Double -> Tree -> Tree - 143 scaleToWidth w t = - 144 scale (w/w') t - 145 where - 146 (_x, _y, w', _h') = boundingBox t - 147 - 148 -- | @scaleToHeight height@ scales the image so that the height of its bounding box ends up having - 149 -- given @height@. - 150 scaleToHeight :: Double -> Tree -> Tree - 151 scaleToHeight h t = - 152 scale (h/h') t - 153 where - 154 (_x, _y, _w', h') = boundingBox t - 155 - 156 -- | Similar to 'scale', except scale factors for X and Y axes are specified separately. - 157 scaleXY :: Double -> Double -> Tree -> Tree - 158 scaleXY x y = withTransformations [Scale x (Just y)] - 159 - 160 - 161 -- | Flip the image along vertical axis so that what was on the right will end up on left and vice - 162 -- versa. - 163 flipXAxis :: Tree -> Tree - 164 flipXAxis = scaleXY (-1) 1 - 165 - 166 -- | Flip the image along horizontal so that what was on the top will end up in the bottom and vice - 167 -- versa. - 168 flipYAxis :: Tree -> Tree - 169 flipYAxis = scaleXY 1 (-1) - 170 - 171 -- | Translate given image so that the center of its bouding box coincides with coordinates - 172 -- @(0, 0)@. - 173 center :: Tree -> Tree - 174 center t = centerUsing t t - 175 - 176 -- | Translate given image so that the X-coordinate of the center of its bouding box is 0. - 177 centerX :: Tree -> Tree - 178 centerX t = translate (-x-w/2) 0 t - 179 where - 180 (x, _y, w, _h) = boundingBox t - 181 - 182 -- | Translate given image so that the Y-coordinate of the center of its bouding box is 0. - 183 centerY :: Tree -> Tree - 184 centerY t = translate 0 (-y-h/2) t - 185 where - 186 (_x, y, _w, h) = boundingBox t - 187 - 188 centerUsing :: Tree -> Tree -> Tree - 189 centerUsing a = translate (-x-w/2) (-y-h/2) - 190 where - 191 (x, y, w, h) = boundingBox a - 192 - 193 -- | Create 'Texture' based on SVG color name. - 194 -- See <https://en.wikipedia.org/wiki/Web_colors#X11_color_names> for the list of available names. - 195 -- If the provided name doesn't correspond to valid SVG color name, white-ish color is used. - 196 mkColor :: String -> Texture - 197 mkColor name = - 198 case Map.lookup (T.pack name) svgNamedColors of - 199 Nothing -> ColorRef (PixelRGBA8 240 248 255 255) - 200 Just c -> ColorRef c - 201 - 202 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke> - 203 withStrokeColor :: String -> Tree -> Tree - 204 withStrokeColor color = strokeColor .~ pure (mkColor color) - 205 - 206 withStrokeColorPixel :: PixelRGBA8 -> Tree -> Tree - 207 withStrokeColorPixel color = strokeColor .~ pure (ColorRef color) + 111 -- | Same as 'aroundCenter' but only for the Y-axis. + 112 aroundCenterY :: (Tree -> Tree) -> Tree -> Tree + 113 aroundCenterY fn t = + 114 translate 0 (-offsetY) $ fn $ translate 0 offsetY t + 115 where + 116 offsetY = -y-h/2 + 117 (_x,y,_w,h) = boundingBox t + 118 + 119 -- | Same as 'aroundCenter' but only for the X-axis. + 120 aroundCenterX :: (Tree -> Tree) -> Tree -> Tree + 121 aroundCenterX fn t = + 122 translate (-offsetX) 0 $ fn $ translate offsetX 0 t + 123 where + 124 offsetX = -x-w/2 + 125 (x,_y,w,_h) = boundingBox t + 126 + 127 -- | Scale the image uniformly by given factor along both X and Y axes. + 128 -- For example @scale 2 image@ makes the image twice as large, while @scale 0.5 image@ makes it + 129 -- half the original size. Negative values are also allowed, and lead to flipping the image along + 130 -- both X and Y axes. + 131 scale :: Double -> Tree -> Tree + 132 scale a = withTransformations [Scale a Nothing] + 133 + 134 -- | @scaleToSize width height@ resizes the image so that its bounding box has corresponding @width@ + 135 -- and @height@. + 136 scaleToSize :: Double -> Double -> Tree -> Tree + 137 scaleToSize w h t = + 138 scaleXY (w/w') (h/h') t + 139 where + 140 (_x, _y, w', h') = boundingBox t + 141 + 142 -- | @scaleToWidth width@ scales the image so that the width of its bounding box ends up having + 143 -- given @width@. + 144 scaleToWidth :: Double -> Tree -> Tree + 145 scaleToWidth w t = + 146 scale (w/w') t + 147 where + 148 (_x, _y, w', _h') = boundingBox t + 149 + 150 -- | @scaleToHeight height@ scales the image so that the height of its bounding box ends up having + 151 -- given @height@. + 152 scaleToHeight :: Double -> Tree -> Tree + 153 scaleToHeight h t = + 154 scale (h/h') t + 155 where + 156 (_x, _y, _w', h') = boundingBox t + 157 + 158 -- | Similar to 'scale', except scale factors for X and Y axes are specified separately. + 159 scaleXY :: Double -> Double -> Tree -> Tree + 160 scaleXY x y = withTransformations [Scale x (Just y)] + 161 + 162 + 163 -- | Flip the image along vertical axis so that what was on the right will end up on left and vice + 164 -- versa. + 165 flipXAxis :: Tree -> Tree + 166 flipXAxis = scaleXY (-1) 1 + 167 + 168 -- | Flip the image along horizontal so that what was on the top will end up in the bottom and vice + 169 -- versa. + 170 flipYAxis :: Tree -> Tree + 171 flipYAxis = scaleXY 1 (-1) + 172 + 173 -- | Translate given image so that the center of its bouding box coincides with coordinates + 174 -- @(0, 0)@. + 175 center :: Tree -> Tree + 176 center t = centerUsing t t + 177 + 178 -- | Translate given image so that the X-coordinate of the center of its bouding box is 0. + 179 centerX :: Tree -> Tree + 180 centerX t = translate (-x-w/2) 0 t + 181 where + 182 (x, _y, w, _h) = boundingBox t + 183 + 184 -- | Translate given image so that the Y-coordinate of the center of its bouding box is 0. + 185 centerY :: Tree -> Tree + 186 centerY t = translate 0 (-y-h/2) t + 187 where + 188 (_x, y, _w, h) = boundingBox t + 189 + 190 -- | Center the second argument using the bounding-box of the first. + 191 centerUsing :: Tree -> Tree -> Tree + 192 centerUsing a = translate (-x-w/2) (-y-h/2) + 193 where + 194 (x, y, w, h) = boundingBox a + 195 + 196 -- | Create 'Texture' based on SVG color name. + 197 -- See <https://en.wikipedia.org/wiki/Web_colors#X11_color_names> for the list of available names. + 198 -- If the provided name doesn't correspond to valid SVG color name, white-ish color is used. + 199 mkColor :: String -> Texture + 200 mkColor name = + 201 case Map.lookup (T.pack name) svgNamedColors of + 202 Nothing -> ColorRef (PixelRGBA8 240 248 255 255) + 203 Just c -> ColorRef c + 204 + 205 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke> + 206 withStrokeColor :: String -> Tree -> Tree + 207 withStrokeColor color = strokeColor .~ pure (mkColor color) 208 - 209 withStrokeDashArray :: [Double] -> Tree -> Tree - 210 withStrokeDashArray arr = strokeDashArray .~ pure (map Num arr) - 211 - 212 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke-linejoin> - 213 withStrokeLineJoin :: LineJoin -> Tree -> Tree - 214 withStrokeLineJoin ljoin = strokeLineJoin .~ pure ljoin - 215 - 216 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/fill> - 217 withFillColor :: String -> Tree -> Tree - 218 withFillColor color = fillColor .~ pure (mkColor color) - 219 - 220 withFillColorPixel :: PixelRGBA8 -> Tree -> Tree - 221 withFillColorPixel color = fillColor .~ pure (ColorRef color) - 222 - 223 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/fill-opacity> - 224 withFillOpacity :: Double -> Tree -> Tree - 225 withFillOpacity opacity = fillOpacity ?~ realToFrac opacity - 226 - 227 withGroupOpacity :: Double -> Tree -> Tree - 228 withGroupOpacity opacity = groupOpacity ?~ realToFrac opacity - 229 - 230 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke-width> - 231 withStrokeWidth :: Double -> Tree -> Tree - 232 withStrokeWidth width = strokeWidth .~ pure (Num width) - 233 - 234 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/clip-path> - 235 withClipPathRef :: ElementRef -- ^ Reference to clip path defined previously (e.g. by 'mkClipPath') - 236 -> Tree -- ^ Image that will be clipped by the referenced clip path - 237 -> Tree - 238 withClipPathRef ref sub = mkGroup [sub] & clipPathRef .~ pure ref - 239 - 240 -- | Assigns ID attribute to given image. - 241 withId :: String -> Tree -> Tree - 242 withId idTag = attrId ?~ idTag - 243 - 244 -- | @mkRect width height@ creates a rectangle with given @with@ and @height@, centered at @(0, 0)@. - 245 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/rect> - 246 mkRect :: Double -> Double -> Tree - 247 mkRect width height = translate (-width/2) (-height/2) $ RectangleTree $ defaultSvg - 248 & rectUpperLeftCorner .~ (Num 0, Num 0) - 249 & rectWidth ?~ Num width - 250 & rectHeight ?~ Num height - 251 - 252 -- | Create a circle with given radius, centered at @(0, 0)@. - 253 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/circle> - 254 mkCircle :: Double -> Tree - 255 mkCircle radius = CircleTree $ defaultSvg - 256 & circleCenter .~ (Num 0, Num 0) - 257 & circleRadius .~ Num radius + 209 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke> + 210 withStrokeColorPixel :: PixelRGBA8 -> Tree -> Tree + 211 withStrokeColorPixel color = strokeColor .~ pure (ColorRef color) + 212 + 213 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke-dasharray> + 214 withStrokeDashArray :: [Double] -> Tree -> Tree + 215 withStrokeDashArray arr = strokeDashArray .~ pure (map Num arr) + 216 + 217 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke-linejoin> + 218 withStrokeLineJoin :: LineJoin -> Tree -> Tree + 219 withStrokeLineJoin ljoin = strokeLineJoin .~ pure ljoin + 220 + 221 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/fill> + 222 withFillColor :: String -> Tree -> Tree + 223 withFillColor color = fillColor .~ pure (mkColor color) + 224 + 225 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/fill> + 226 withFillColorPixel :: PixelRGBA8 -> Tree -> Tree + 227 withFillColorPixel color = fillColor .~ pure (ColorRef color) + 228 + 229 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/fill-opacity> + 230 withFillOpacity :: Double -> Tree -> Tree + 231 withFillOpacity opacity = fillOpacity ?~ realToFrac opacity + 232 + 233 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/opacity> + 234 withGroupOpacity :: Double -> Tree -> Tree + 235 withGroupOpacity opacity = groupOpacity ?~ realToFrac opacity + 236 + 237 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke-width> + 238 withStrokeWidth :: Double -> Tree -> Tree + 239 withStrokeWidth width = strokeWidth .~ pure (Num width) + 240 + 241 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/clip-path> + 242 withClipPathRef :: ElementRef -- ^ Reference to clip path defined previously (e.g. by 'mkClipPath') + 243 -> Tree -- ^ Image that will be clipped by the referenced clip path + 244 -> Tree + 245 withClipPathRef ref sub = mkGroup [sub] & clipPathRef .~ pure ref + 246 + 247 -- | Assigns ID attribute to given image. + 248 withId :: String -> Tree -> Tree + 249 withId idTag = attrId ?~ idTag + 250 + 251 -- | @mkRect width height@ creates a rectangle with given @with@ and @height@, centered at @(0, 0)@. + 252 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/rect> + 253 mkRect :: Double -> Double -> Tree + 254 mkRect width height = translate (-width/2) (-height/2) $ RectangleTree $ defaultSvg + 255 & rectUpperLeftCorner .~ (Num 0, Num 0) + 256 & rectWidth ?~ Num width + 257 & rectHeight ?~ Num height 258 - 259 -- | Create an ellipse given X-axis radius, and Y-axis radius, with center at @(0, 0)@. - 260 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/ellipse> - 261 mkEllipse :: Double -> Double -> Tree - 262 mkEllipse rx ry = EllipseTree $ defaultSvg - 263 & ellipseCenter .~ (Num 0, Num 0) - 264 & ellipseXRadius .~ Num rx - 265 & ellipseYRadius .~ Num ry - 266 - 267 -- | Create a line segment between two points given by their @(x, y)@ coordinates. - 268 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/line> - 269 mkLine :: (Double,Double) -> (Double, Double) -> Tree - 270 mkLine (x1,y1) (x2,y2) = LineTree $ defaultSvg - 271 & linePoint1 .~ (Num x1, Num y1) - 272 & linePoint2 .~ (Num x2, Num y2) + 259 -- | Create a circle with given radius, centered at @(0, 0)@. + 260 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/circle> + 261 mkCircle :: Double -> Tree + 262 mkCircle radius = CircleTree $ defaultSvg + 263 & circleCenter .~ (Num 0, Num 0) + 264 & circleRadius .~ Num radius + 265 + 266 -- | Create an ellipse given X-axis radius, and Y-axis radius, with center at @(0, 0)@. + 267 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/ellipse> + 268 mkEllipse :: Double -> Double -> Tree + 269 mkEllipse rx ry = EllipseTree $ defaultSvg + 270 & ellipseCenter .~ (Num 0, Num 0) + 271 & ellipseXRadius .~ Num rx + 272 & ellipseYRadius .~ Num ry 273 - 274 -- | Merges multiple images into one. - 275 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/g> - 276 mkGroup :: [Tree] -> Tree - 277 mkGroup forest = GroupTree $ defaultSvg - 278 & groupChildren .~ forest - 279 - 280 -- | Create definition of graphical objects that can be used at later time. - 281 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/defs> - 282 mkDefinitions :: [Tree] -> Tree - 283 mkDefinitions forest = DefinitionTree $ defaultSvg - 284 & groupChildren .~ forest - 285 - 286 -- | Create an element by referring to existing element defined previously. - 287 -- For example you can create a graphical element, assign ID to it using 'withId', wrap it in - 288 -- 'mkDefinitions' and then use it via @use "myId"@. - 289 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/use> - 290 mkUse :: String -> Tree - 291 mkUse name = UseTree (defaultSvg & useName .~ name) Nothing + 274 -- | Create a line segment between two points given by their @(x, y)@ coordinates. + 275 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/line> + 276 mkLine :: (Double,Double) -> (Double, Double) -> Tree + 277 mkLine (x1,y1) (x2,y2) = LineTree $ defaultSvg + 278 & linePoint1 .~ (Num x1, Num y1) + 279 & linePoint2 .~ (Num x2, Num y2) + 280 + 281 -- | Merges multiple images into one. + 282 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/g> + 283 mkGroup :: [Tree] -> Tree + 284 mkGroup forest = GroupTree $ defaultSvg + 285 & groupChildren .~ forest + 286 + 287 -- | Create definition of graphical objects that can be used at later time. + 288 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/defs> + 289 mkDefinitions :: [Tree] -> Tree + 290 mkDefinitions forest = DefinitionTree $ defaultSvg + 291 & groupChildren .~ forest 292 - 293 -- | A clip path restricts the region to which paint can be applied. - 294 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/clipPath> - 295 mkClipPath :: String -- ^ ID of the clip path, which can then be referred to by other elements - 296 -- using 'withClipPathRef'. - 297 -> [Tree] -- ^ List of shapes that will determine the final shape of the clipping region - 298 -> Tree - 299 mkClipPath idTag forest = withId idTag $ ClipPathTree $ defaultSvg - 300 & clipPathContent .~ forest - 301 - 302 -- | Create a path from the list of path commands. - 303 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d#Path_commands> - 304 mkPath :: [PathCommand] -> Tree - 305 mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds - 306 - 307 -- | Similar to 'mkPathText', but taking SVG path command as a String. - 308 mkPathString :: String -> Tree - 309 mkPathString = mkPathText . T.pack - 310 - 311 -- | Create path from textual representation of SVG path command. - 312 -- If the text doesn't represent valid path command, this function fails with 'Prelude.error'. - 313 -- Use 'mkPath' for type safe way of creating paths. - 314 mkPathText :: T.Text -> Tree - 315 mkPathText str = - 316 case parseOnly pathParser str of - 317 Left err -> error err - 318 Right cmds -> mkPath cmds - 319 - 320 -- | Create a path from a list of @(x, y)@ coordinates of points along the path. - 321 mkLinePath :: [(Double, Double)] -> Tree - 322 mkLinePath [] = mkGroup [] - 323 mkLinePath ((startX, startY):rest) = - 324 PathTree $ defaultSvg & pathDefinition .~ cmds - 325 where - 326 cmds = [ MoveTo OriginAbsolute [V2 startX startY] - 327 , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ] ] - 328 - 329 -- | Create a path from a list of @(x, y)@ coordinates of points along the path. - 330 mkLinePathClosed :: [(Double, Double)] -> Tree - 331 mkLinePathClosed [] = mkGroup [] - 332 mkLinePathClosed ((startX, startY):rest) = - 333 PathTree $ defaultSvg & pathDefinition .~ cmds - 334 where - 335 cmds = [ MoveTo OriginAbsolute [V2 startX startY] - 336 , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ] - 337 , EndPath ] - 338 - 339 -- | Rectangle with a uniform color and the same size as the screen. - 340 -- - 341 -- Example: - 342 -- - 343 -- > animate $ const $ mkBackground "yellow" - 344 -- - 345 -- <<docs/gifs/doc_mkBackground.gif>> - 346 mkBackground :: String -> Tree - 347 mkBackground color = withFillOpacity 1 $ withStrokeWidth 0 $ - 348 withFillColor color $ mkRect screenWidth screenHeight - 349 - 350 mkBackgroundPixel :: PixelRGBA8 -> Tree - 351 mkBackgroundPixel pixel = - 352 withFillOpacity 1 $ withStrokeWidth 0 $ - 353 withFillColorPixel pixel $ mkRect screenWidth screenHeight - 354 - 355 -- | Take list of rows, where each row consists of number of images and display them in regular - 356 -- grid structure. - 357 -- All rows will get equal amount of vertical space. - 358 -- The images within each row will get equal amount of horizontal space, independent of the other - 359 -- rows. Each row can contain different number of cells. - 360 gridLayout :: [[Tree]] -> Tree - 361 gridLayout rows = mkGroup - 362 [ translate (-screenWidth/2+colSep*nCol + colSep*0.5) - 363 (screenHeight/2-rowSep*nRow - rowSep*0.5) - 364 elt - 365 | (nRow, row) <- zip [0..] rows - 366 , let nCols = length row - 367 colSep = screenWidth / fromIntegral nCols - 368 , (nCol, elt) <- zip [0..] row ] - 369 where - 370 rowSep = screenHeight / fromIntegral nRows - 371 nRows = length rows - 372 - 373 -- | Insert a native text object anchored at the middle. - 374 -- - 375 -- Example: - 376 -- - 377 -- > mkAnimation 2 $ \t -> scale 2 $ withStrokeWidth 0.05 $ mkText (T.take (round $ t*15) "text") - 378 -- - 379 -- <<docs/gifs/doc_mkText.gif>> - 380 mkText :: T.Text -> Tree - 381 mkText str = - 382 flipYAxis - 383 (TextTree Nothing $ defaultSvg - 384 & textRoot .~ span_ - 385 & fontSize .~ pure (Num 2)) - 386 & textAnchor .~ pure TextAnchorMiddle - 387 -- Note: TextAnchorMiddle is placed on the 'flipYAxis' group such that it can easily - 388 -- be overwritten by the user. - 389 where - 390 span_ = defaultSvg & spanContent .~ [SpanText str] - 391 - 392 -- | Switch from the default viewbox to a custom viewbox. Nesting custom viewboxes is - 393 -- unlikely to give good results. If you need nested custom viewboxes, you will have - 394 -- to configure them by hand. - 395 -- - 396 -- The viewbox argument is (min-x, min-y, width, height). - 397 -- - 398 -- Example: - 399 -- - 400 -- > withViewBox (0,0,1,1) $ mkBackground "yellow" - 401 -- - 402 -- <<docs/gifs/doc_withViewBox.gif>> - 403 withViewBox :: (Double, Double, Double, Double) -> Tree -> Tree - 404 withViewBox vbox child = translate (-screenWidth/2) (-screenHeight/2) $ - 405 SvgTree $ Document - 406 { _viewBox = Just vbox - 407 , _width = Just (Num screenWidth) - 408 , _height = Just (Num screenHeight) - 409 , _elements = [child] - 410 , _description = "" - 411 , _documentLocation = "" - 412 , _documentAspectRatio = PreserveAspectRatio False AlignNone Nothing - 413 } + 293 -- | Create an element by referring to existing element defined previously. + 294 -- For example you can create a graphical element, assign ID to it using 'withId', wrap it in + 295 -- 'mkDefinitions' and then use it via @use "myId"@. + 296 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/use> + 297 mkUse :: String -> Tree + 298 mkUse name = UseTree (defaultSvg & useName .~ name) Nothing + 299 + 300 -- | A clip path restricts the region to which paint can be applied. + 301 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/clipPath> + 302 mkClipPath :: String -- ^ ID of the clip path, which can then be referred to by other elements + 303 -- using 'withClipPathRef'. + 304 -> [Tree] -- ^ List of shapes that will determine the final shape of the clipping region + 305 -> Tree + 306 mkClipPath idTag forest = withId idTag $ ClipPathTree $ defaultSvg + 307 & clipPathContent .~ forest + 308 + 309 -- | Create a path from the list of path commands. + 310 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d#Path_commands> + 311 mkPath :: [PathCommand] -> Tree + 312 mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds + 313 + 314 -- | Similar to 'mkPathText', but taking SVG path command as a String. + 315 mkPathString :: String -> Tree + 316 mkPathString = mkPathText . T.pack + 317 + 318 -- | Create path from textual representation of SVG path command. + 319 -- If the text doesn't represent valid path command, this function fails with 'Prelude.error'. + 320 -- Use 'mkPath' for type safe way of creating paths. + 321 mkPathText :: T.Text -> Tree + 322 mkPathText str = + 323 case parseOnly pathParser str of + 324 Left err -> error err + 325 Right cmds -> mkPath cmds + 326 + 327 -- | Create a path from a list of @(x, y)@ coordinates of points along the path. + 328 mkLinePath :: [(Double, Double)] -> Tree + 329 mkLinePath [] = mkGroup [] + 330 mkLinePath ((startX, startY):rest) = + 331 PathTree $ defaultSvg & pathDefinition .~ cmds + 332 where + 333 cmds = [ MoveTo OriginAbsolute [V2 startX startY] + 334 , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ] ] + 335 + 336 -- | Create a path from a list of @(x, y)@ coordinates of points along the path. + 337 mkLinePathClosed :: [(Double, Double)] -> Tree + 338 mkLinePathClosed [] = mkGroup [] + 339 mkLinePathClosed ((startX, startY):rest) = + 340 PathTree $ defaultSvg & pathDefinition .~ cmds + 341 where + 342 cmds = [ MoveTo OriginAbsolute [V2 startX startY] + 343 , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ] + 344 , EndPath ] + 345 + 346 -- | Rectangle with a uniform color and the same size as the screen. + 347 -- + 348 -- Example: + 349 -- + 350 -- > animate $ const $ mkBackground "yellow" + 351 -- + 352 -- <<docs/gifs/doc_mkBackground.gif>> + 353 mkBackground :: String -> Tree + 354 mkBackground color = withFillOpacity 1 $ withStrokeWidth 0 $ + 355 withFillColor color $ mkRect screenWidth screenHeight + 356 + 357 -- | Rectangle with a uniform color and the same size as the screen. + 358 mkBackgroundPixel :: PixelRGBA8 -> Tree + 359 mkBackgroundPixel pixel = + 360 withFillOpacity 1 $ withStrokeWidth 0 $ + 361 withFillColorPixel pixel $ mkRect screenWidth screenHeight + 362 + 363 -- | Take list of rows, where each row consists of number of images and display them in regular + 364 -- grid structure. + 365 -- All rows will get equal amount of vertical space. + 366 -- The images within each row will get equal amount of horizontal space, independent of the other + 367 -- rows. Each row can contain different number of cells. + 368 gridLayout :: [[Tree]] -> Tree + 369 gridLayout rows = mkGroup + 370 [ translate (-screenWidth/2+colSep*nCol + colSep*0.5) + 371 (screenHeight/2-rowSep*nRow - rowSep*0.5) + 372 elt + 373 | (nRow, row) <- zip [0..] rows + 374 , let nCols = length row + 375 colSep = screenWidth / fromIntegral nCols + 376 , (nCol, elt) <- zip [0..] row ] + 377 where + 378 rowSep = screenHeight / fromIntegral nRows + 379 nRows = length rows + 380 + 381 -- | Insert a native text object anchored at the middle. + 382 -- + 383 -- Example: + 384 -- + 385 -- > mkAnimation 2 $ \t -> scale 2 $ withStrokeWidth 0.05 $ mkText (T.take (round $ t*15) "text") + 386 -- + 387 -- <<docs/gifs/doc_mkText.gif>> + 388 mkText :: T.Text -> Tree + 389 mkText str = + 390 flipYAxis + 391 (TextTree Nothing $ defaultSvg + 392 & textRoot .~ span_ + 393 & fontSize .~ pure (Num 2)) + 394 & textAnchor .~ pure TextAnchorMiddle + 395 -- Note: TextAnchorMiddle is placed on the 'flipYAxis' group such that it can easily + 396 -- be overwritten by the user. + 397 where + 398 span_ = defaultSvg & spanContent .~ [SpanText str] + 399 + 400 -- | Switch from the default viewbox to a custom viewbox. Nesting custom viewboxes is + 401 -- unlikely to give good results. If you need nested custom viewboxes, you will have + 402 -- to configure them by hand. + 403 -- + 404 -- The viewbox argument is (min-x, min-y, width, height). + 405 -- + 406 -- Example: + 407 -- + 408 -- > withViewBox (0,0,1,1) $ mkBackground "yellow" + 409 -- + 410 -- <<docs/gifs/doc_withViewBox.gif>> + 411 withViewBox :: (Double, Double, Double, Double) -> Tree -> Tree + 412 withViewBox vbox child = translate (-screenWidth/2) (-screenHeight/2) $ + 413 SvgTree $ Document + 414 { _viewBox = Just vbox + 415 , _width = Just (Num screenWidth) + 416 , _height = Just (Num screenHeight) + 417 , _elements = [child] + 418 , _description = "" + 419 , _documentLocation = "" + 420 , _documentAspectRatio = PreserveAspectRatio False AlignNone Nothing + 421 } diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse.hs.html index f639431..5226910 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse.hs.html @@ -30,53 +30,56 @@ span.spaces { background: white } 11 import Reanimate.Constants 12 import Reanimate.Svg.Constructors 13 - 14 replaceUses :: Document -> Document - 15 replaceUses doc = doc & elements %~ map (mapTree replace) - 16 where - 17 replaceDefinition PathTree{} = None - 18 replaceDefinition t = t - 19 - 20 replace t@DefinitionTree{} = mapTree replaceDefinition t - 21 replace (UseTree _ Just{}) = error "replaceUses: subtree in use?" - 22 replace (UseTree use Nothing) = - 23 case Map.lookup (use^.useName) idMap of - 24 Nothing -> error $ "Unknown id: " ++ (use^.useName) - 25 Just tree -> mapTree replace $ - 26 GroupTree $ - 27 defaultSvg & groupChildren .~ [tree] - 28 & transform ?~ - 29 fromMaybe [] (use^.transform) ++ - 30 [baseToTransformation (use^.useBase)] - 31 replace x = x - 32 baseToTransformation (x,y) = - 33 case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of - 34 (Num a, Num b) -> Translate a b - 35 _ -> TransformUnknown - 36 docTree = mkGroup (doc^.elements) - 37 idMap = foldTree updMap Map.empty docTree - 38 updMap m tree = - 39 case tree^.attrId of - 40 Nothing -> m - 41 Just tid -> Map.insert tid tree m - 42 - 43 -- FIXME: the viewbox is ignored. Can we use the viewbox as a mask? - 44 -- Transform out viewbox. defs and CSS rules are discarded. - 45 unbox :: Document -> Tree - 46 unbox doc@Document{_viewBox = Just (_minx, _minw, _width, _height)} = - 47 GroupTree $ defaultSvg - 48 & groupChildren .~ doc^.elements - 49 unbox doc = - 50 GroupTree $ defaultSvg - 51 & groupChildren .~ doc^.elements - 52 - 53 embedDocument :: Document -> Tree - 54 embedDocument doc = - 55 translate (-screenWidth/2) (screenHeight/2) $ - 56 withFillOpacity 1 $ - 57 withStrokeWidth 0 $ - 58 flipYAxis $ - 59 SvgTree $ doc & width .~ Nothing - 60 & height .~ Nothing + 14 -- | Replace all @<use>@ nodes with their definition. + 15 replaceUses :: Document -> Document + 16 replaceUses doc = doc & elements %~ map (mapTree replace) + 17 where + 18 replaceDefinition PathTree{} = None + 19 replaceDefinition t = t + 20 + 21 replace t@DefinitionTree{} = mapTree replaceDefinition t + 22 replace (UseTree _ Just{}) = error "replaceUses: subtree in use?" + 23 replace (UseTree use Nothing) = + 24 case Map.lookup (use^.useName) idMap of + 25 Nothing -> error $ "Unknown id: " ++ (use^.useName) + 26 Just tree -> mapTree replace $ + 27 GroupTree $ + 28 defaultSvg & groupChildren .~ [tree] + 29 & transform ?~ + 30 fromMaybe [] (use^.transform) ++ + 31 [baseToTransformation (use^.useBase)] + 32 replace x = x + 33 baseToTransformation (x,y) = + 34 case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of + 35 (Num a, Num b) -> Translate a b + 36 _ -> TransformUnknown + 37 docTree = mkGroup (doc^.elements) + 38 idMap = foldTree updMap Map.empty docTree + 39 updMap m tree = + 40 case tree^.attrId of + 41 Nothing -> m + 42 Just tid -> Map.insert tid tree m + 43 + 44 -- FIXME: the viewbox is ignored. Can we use the viewbox as a mask? + 45 -- | Transform out viewbox. Definitions and CSS rules are discarded. + 46 unbox :: Document -> Tree + 47 unbox doc@Document{_viewBox = Just (_minx, _minw, _width, _height)} = + 48 GroupTree $ defaultSvg + 49 & groupChildren .~ doc^.elements + 50 unbox doc = + 51 GroupTree $ defaultSvg + 52 & groupChildren .~ doc^.elements + 53 + 54 -- | Embed 'Document'. This keeps the entire document intact but makes + 55 -- it more difficult to use, say, `Reanimate.Svg.pathify` on it. + 56 embedDocument :: Document -> Tree + 57 embedDocument doc = + 58 translate (-screenWidth/2) (screenHeight/2) $ + 59 withFillOpacity 1 $ + 60 withStrokeWidth 0 $ + 61 flipYAxis $ + 62 SvgTree $ doc & width .~ Nothing + 63 & height .~ Nothing diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html index da1e4ff..513c397 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Svg.hs.html @@ -39,297 +39,312 @@ span.spaces { background: white } 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 + 23 -- | Remove transformations (such as translations, rotations, scaling) + 24 -- and apply them directly to the SVG nodes. Note, this function + 25 -- may convert nodes (such as Circle or Rect) to paths. Also note + 26 -- that /does/ change how the SVG is rendered. Particularly, stroke + 27 -- width is affected by directly applying scaling. + 28 -- + 29 -- @lowerTransformations (scale 2 (mkCircle 1)) = mkCircle 2@ + 30 lowerTransformations :: Tree -> Tree + 31 lowerTransformations = worker False Transform.identity + 32 where + 33 updLineCmd m cmd = + 34 case cmd of + 35 LineMove p -> LineMove $ Transform.transformPoint m p + 36 -- LineDraw p -> LineDraw $ Transform.transformPoint m p + 37 LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps + 38 LineEnd p -> LineEnd $ Transform.transformPoint m p + 39 updPath m = lineToPath . map (updLineCmd m) . toLineCommands + 40 updPoint m (Num a,Num b) = + 41 case Transform.transformPoint m (V2 a b) of + 42 V2 x y -> (Num x, Num y) + 43 updPoint _ other = other -- XXX: Can we do better here? + 44 worker hasPathified m t = + 45 let m' = m * Transform.mkMatrix (t^.transform) in + 46 case t of + 47 PathTree path -> PathTree $ + 48 path & pathDefinition %~ updPath m' + 49 & transform .~ Nothing + 50 GroupTree g -> GroupTree $ + 51 g & groupChildren %~ map (worker hasPathified m') + 52 & transform .~ Nothing + 53 LineTree line -> + 54 LineTree $ + 55 line & linePoint1 %~ updPoint m + 56 & linePoint2 %~ updPoint m + 57 ClipPathTree{} -> t + 58 -- If we encounter an unknown node and we've already tried to convert + 59 -- to paths, give up and insert an explicit transformation. + 60 _ | hasPathified -> + 61 mkGroup [t] & transform ?~ [ Transform.toTransformation m ] + 62 -- If we haven't tried to pathify, run pathify only once. + 63 _ -> worker True m (pathify 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)] + 65 -- | Remove all @id@ attributes. + 66 lowerIds :: Tree -> Tree + 67 lowerIds = mapTree worker + 68 where + 69 worker t@GroupTree{} = t & attrId .~ Nothing + 70 worker t@PathTree{} = t & attrId .~ Nothing + 71 worker t = t + 72 + 73 -- | Optimize SVG tree without affecting how it is rendered. + 74 simplify :: Tree -> Tree + 75 simplify root = + 76 case worker root of + 77 [] -> None + 78 [x] -> x + 79 xs -> mkGroup xs + 80 where + 81 worker None = [] + 82 worker (DefinitionTree d) = + 83 concatMap dropNulls + 84 [DefinitionTree $ d & groupChildren %~ concatMap worker] + 85 worker (GroupTree g) + 86 | g ^. drawAttributes == defaultSvg = + 87 concatMap dropNulls $ + 88 concatMap worker (g^.groupChildren) + 89 | otherwise = + 90 dropNulls $ + 91 GroupTree $ g & groupChildren %~ concatMap worker + 92 worker t = dropNulls t + 93 + 94 dropNulls None = [] + 95 dropNulls (DefinitionTree d) + 96 | null (d^.groupChildren) = [] + 97 dropNulls (GroupTree g) + 98 | null (g^.groupChildren) = [] + 99 dropNulls t = [t] + 100 + 101 -- | Separate grouped items. This is required by clip nodes. + 102 -- + 103 -- @removeGroups (withFillColor "blue" $ mkGroup [mkCircle 1, mkRect 1 1]) + 104 -- = [ withFillColor "blue" $ mkCircle 1 + 105 -- , withFillColor "blue" $ mkRect 1 1 ]@ + 106 removeGroups :: Tree -> [Tree] + 107 removeGroups = worker defaultSvg + 108 where + 109 worker _attr None = [] + 110 worker _attr (DefinitionTree d) = + 111 concatMap dropNulls + 112 [DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)] + 113 worker attr (GroupTree g) + 114 | g ^. drawAttributes == defaultSvg = + 115 concatMap dropNulls $ + 116 concatMap (worker attr) (g^.groupChildren) + 117 | otherwise = + 118 concatMap (worker (attr <> g ^. drawAttributes)) (g^.groupChildren) + 119 worker attr t = dropNulls (t & drawAttributes .~ attr) + 120 + 121 dropNulls None = [] + 122 dropNulls (DefinitionTree d) + 123 | null (d^.groupChildren) = [] + 124 dropNulls (GroupTree g) + 125 | null (g^.groupChildren) = [] + 126 dropNulls t = [t] + 127 + 128 -- | Extract all path commands from a node (and its children) and concatenate them. + 129 extractPath :: Tree -> [PathCommand] + 130 extractPath = worker . simplify . lowerTransformations . pathify + 131 where + 132 worker (GroupTree g) = concatMap worker (g^.groupChildren) + 133 worker (PathTree p) = p^.pathDefinition + 134 worker _ = [] + 135 + 136 withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree + 137 withSubglyphs target fn = \t -> evalState (worker t) 0 + 138 where + 139 worker :: Tree -> State Int Tree + 140 worker t = + 141 case t of + 142 GroupTree g -> do + 143 cs <- mapM worker (g ^. groupChildren) + 144 return $ GroupTree $ g & groupChildren .~ cs + 145 PathTree{} -> handleGlyph t + 146 CircleTree{} -> handleGlyph t + 147 PolyLineTree{} -> handleGlyph t + 148 PolygonTree{} -> handleGlyph t + 149 EllipseTree{} -> handleGlyph t + 150 LineTree{} -> handleGlyph t + 151 RectangleTree{} -> handleGlyph t + 152 _ -> return t + 153 handleGlyph :: Tree -> State Int Tree + 154 handleGlyph svg = do + 155 n <- get <* modify (+1) + 156 if n `elem` target + 157 then return $ fn svg + 158 else return svg + 159 + 160 splitGlyphs :: [Int] -> Tree -> (Tree, Tree) + 161 splitGlyphs target = \t -> + 162 let (_, l, r) = execState (worker id t) (0, [], []) + 163 in (mkGroup l, mkGroup r) + 164 where + 165 handleGlyph :: Tree -> State (Int, [Tree], [Tree]) () + 166 handleGlyph t = do + 167 (n, l, r) <- get + 168 if n `elem` target + 169 then put (n+1, l, t:r) + 170 else put (n+1, t:l, r) + 171 worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) () + 172 worker acc t = + 173 case t of + 174 GroupTree g -> do + 175 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub]) + 176 mapM_ (worker acc') (g ^. groupChildren) + 177 PathTree{} -> handleGlyph $ acc t + 178 CircleTree{} -> handleGlyph $ acc t + 179 PolyLineTree{} -> handleGlyph $ acc t + 180 PolygonTree{} -> handleGlyph $ acc t + 181 EllipseTree{} -> handleGlyph $ acc t + 182 LineTree{} -> handleGlyph $ acc t + 183 RectangleTree{} -> handleGlyph $ acc t + 184 DefinitionTree{} -> return () + 185 _ -> + 186 modify $ \(n, l, r) -> (n, acc t:l, r) + 187 {- + 188 <g transform="translate(10,10)"> + 189 <g transform="scale(2)"> + 190 <circle/> + 191 </g> + 192 <g transform="scale(0.5)"> + 193 <rect/> + 194 </g> + 195 </g> 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 + 197 [ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>) + 198 , (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)] + 199 -} + 200 svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)] + 201 svgGlyphs = worker id defaultSvg + 202 where + 203 worker acc attr = + 204 \case + 205 None -> [] + 206 GroupTree g -> + 207 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub]) + 208 attr' = (g^.drawAttributes) `mappend` attr + 209 in concatMap (worker acc' attr') (g ^. groupChildren) + 210 t -> [(acc, (t^.drawAttributes) `mappend` attr, t)] + 211 + 212 {-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or + 213 'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being + 214 drawn progressively with 'partialSvg'. + 215 + 216 Example: + 217 + 218 > pathifyExample :: Animation + 219 > pathifyExample = animate $ \t -> gridLayout + 220 > [ [ partialSvg t $ pathify $ mkCircle 1 + 221 > , partialSvg t $ pathify $ mkRect 2 2 + 222 > ] + 223 > , [ partialSvg t $ pathify $ mkEllipse 1 0.5 + 224 > , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1) + 225 > ] + 226 > ] + 227 + 228 <<docs/gifs/doc_pathify.gif>> + 229 -} + 230 pathify :: Tree -> Tree + 231 pathify = mapTree worker + 232 where + 233 worker = + 234 \case + 235 RectangleTree rect | Just (x,y,w,h) <- unpackRect rect -> + 236 PathTree $ defaultSvg + 237 & drawAttributes .~ rect ^. drawAttributes + 238 & strokeLineCap .~ pure CapSquare 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) + 240 [MoveTo OriginAbsolute [V2 x y] + 241 ,HorizontalTo OriginRelative [w] + 242 ,VerticalTo OriginRelative [h] + 243 ,HorizontalTo OriginRelative [-w] + 244 ,EndPath ] + 245 LineTree line | Just (x1,y1, x2, y2) <- unpackLine line -> + 246 PathTree $ defaultSvg + 247 & drawAttributes .~ line ^. drawAttributes + 248 & pathDefinition .~ + 249 [MoveTo OriginAbsolute [V2 x1 y1] + 250 ,LineTo OriginAbsolute [V2 x2 y2] ] + 251 CircleTree circ | Just (x, y, r) <- unpackCircle circ -> + 252 PathTree $ defaultSvg + 253 & drawAttributes .~ circ ^. drawAttributes + 254 & pathDefinition .~ + 255 [MoveTo OriginAbsolute [V2 (x-r) y] + 256 ,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0) + 257 ,(r, r, 0,True,False,V2 (-r*2) 0)]] + 258 PolyLineTree pl -> + 259 let points = pl ^. polyLinePoints + 260 in PathTree $ defaultSvg + 261 & drawAttributes .~ pl ^. drawAttributes + 262 & pathDefinition .~ pointsToPathCommands points + 263 PolygonTree pg -> + 264 let points = pg ^. polygonPoints + 265 in PathTree $ defaultSvg + 266 & drawAttributes .~ pg ^. drawAttributes + 267 -- Polygon automatically connects the last point to the first. For path we must do + 268 -- it explicitly + 269 & pathDefinition .~ (pointsToPathCommands points ++ [EndPath]) + 270 EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip -> + 271 PathTree $ defaultSvg + 272 & drawAttributes .~ elip ^. drawAttributes + 273 & pathDefinition .~ + 274 [ MoveTo OriginAbsolute [V2 (cx-rx) cy] + 275 , EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0) + 276 ,(rx, ry, 0,True,False,V2 (-rx*2) 0)]] + 277 t -> t + 278 unpackCircle circ = do + 279 let (x,y) = circ ^. circleCenter + 280 liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius) + 281 unpackEllipse elip = do + 282 let (x,y) = elip ^. ellipseCenter + 283 liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius) + 284 (unpackNumber $ elip ^. ellipseYRadius) + 285 unpackLine line = do + 286 let (x1,y1) = line ^. linePoint1 + 287 (x2,y2) = line ^. linePoint2 + 288 liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2) + 289 unpackRect rect = do + 290 let (x', y') = rect ^. rectUpperLeftCorner + 291 x <- unpackNumber x' + 292 y <- unpackNumber y' + 293 w <- unpackNumber =<< rect ^. rectWidth + 294 h <- unpackNumber =<< rect ^. rectHeight + 295 return (x,y,w,h) + 296 pointsToPathCommands points = case points of + 297 [] -> [] + 298 (p:ps) -> [ MoveTo OriginAbsolute [p] + 299 , LineTo OriginAbsolute ps ] + 300 unpackNumber n = + 301 case toUserUnit defaultDPI n of + 302 Num d -> Just d + 303 _ -> Nothing + 304 + 305 mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG + 306 mapSvgPaths fn = mapTree worker + 307 where + 308 worker = + 309 \case + 310 PathTree path -> PathTree $ + 311 path & pathDefinition %~ fn + 312 t -> t + 313 + 314 mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG + 315 mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands) + 316 + 317 -- Only maps points in paths + 318 mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG + 319 mapSvgPoints fn = mapSvgLines (map worker) + 320 where + 321 worker (LineMove p) = LineMove (fn p) + 322 worker (LineBezier ps) = LineBezier (map fn ps) + 323 worker (LineEnd p) = LineEnd (fn p) + 324 + 325 svgPointsToRadians :: SVG -> SVG + 326 svgPointsToRadians = mapSvgPoints worker + 327 where + 328 worker (V2 x y) = V2 (x/180*pi) (y/180*pi) diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Transform.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Transform.hs.html index c9a8505..f830464 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Transform.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Transform.hs.html @@ -18,66 +18,76 @@ span.spaces { background: white } 
     1 {-# LANGUAGE BangPatterns   #-}
-    2 {-# LANGUAGE PackageImports #-}
-    3 module Reanimate.Transform
-    4   ( identity
-    5   , transformPoint
-    6   , mkMatrix
-    7   , toTransformation
-    8   ) where
-    9 
-   10 -- XXX: Use Linear.Matrix instead of Data.Matrix to drop the 'matrix' dependency.
-   11 import           Data.List
-   12 import           "matrix" Data.Matrix (Matrix)
-   13 import qualified "matrix" Data.Matrix as M
-   14 import           Data.Maybe
-   15 import           Graphics.SvgTree
-   16 import           Linear.V2
-   17 
-   18 type TMatrix = Matrix Coord
-   19 
-   20 identity :: TMatrix
-   21 identity = M.identity 3
+    2 {-|
+    3   2D transformation matrices capable of translating, scaling,
+    4   rotating, and skewing.
+    5 -}
+    6 module Reanimate.Transform
+    7   ( identity
+    8   , transformPoint
+    9   , mkMatrix
+   10   , toTransformation
+   11   ) where
+   12 
+   13 -- XXX: Use Linear.Matrix instead of Data.Matrix to drop the 'matrix' dependency.
+   14 import           Data.List
+   15 import           Data.Matrix (Matrix)
+   16 import qualified Data.Matrix as M
+   17 import           Data.Maybe
+   18 import           Graphics.SvgTree
+   19 import           Linear.V2
+   20 
+   21 type TMatrix = Matrix Coord
    22 
-   23 fromList :: [Coord] -> TMatrix
-   24 fromList [a,b,c,d,e,f] = M.fromList 3 3 [a,c,e,b,d,f,0,0,1]
-   25 fromList _             = error "Reanimate.Transform.fromList: bad input"
-   26 
-   27 transformPoint :: TMatrix -> RPoint -> RPoint
-   28 transformPoint m (V2 x y) = V2 (a*x +c*y + e) (b*x + d*y +f)
-   29   where
-   30     !a = M.unsafeGet 1 1 m
-   31     !c = M.unsafeGet 1 2 m
-   32     !e = M.unsafeGet 1 3 m
-   33     !b = M.unsafeGet 2 1 m
-   34     !d = M.unsafeGet 2 2 m
-   35     !f = M.unsafeGet 2 3 m
-   36     -- (a:c:e:b:d:f:_) = M.toList m
-   37 
-   38 mkMatrix :: Maybe [Transformation] -> TMatrix
-   39 mkMatrix Nothing   = identity
-   40 mkMatrix (Just ts) = foldl' (*) identity (map transformationMatrix ts)
-   41 
-   42 transformationMatrix :: Transformation -> TMatrix
-   43 transformationMatrix transformation =
-   44   case transformation of
-   45     TransformMatrix a b c d e f -> fromList [a,b,c,d,e,f]
-   46     Translate x y               -> translate x y
-   47     Scale sx mbSy               -> fromList [sx,0,0,fromMaybe sx mbSy,0,0]
-   48     Rotate a Nothing            -> rotate a
-   49     Rotate a (Just (x,y))       -> translate x y * rotate a * translate (-x) (-y)
-   50     SkewX a                     -> fromList [1,0,tan (a*pi/180),1,0,0]
-   51     SkewY a                     -> fromList [1,tan (a*pi/180),0,1,0,0]
-   52     TransformUnknown            -> identity
-   53   where
-   54     translate x y = fromList [1,0,0,1,x,y]
-   55     rotate a = fromList [cos r,sin r,-sin r,cos r,0,0]
-   56       where r = a * pi / 180
-   57 
-   58 toTransformation :: TMatrix -> Transformation
-   59 toTransformation m = TransformMatrix a b c d e f
-   60   where
-   61     [a,c,e,b,d,f,_,_,_] = M.toList m
+   23 -- | Identity matrix.
+   24 --
+   25 --   @transformPoints identity x = x@
+   26 identity :: TMatrix
+   27 identity = M.identity 3
+   28 
+   29 fromList :: [Coord] -> TMatrix
+   30 fromList [a,b,c,d,e,f] = M.fromList 3 3 [a,c,e,b,d,f,0,0,1]
+   31 fromList _             = error "Reanimate.Transform.fromList: bad input"
+   32 
+   33 -- | Apply a transformation matrix to a 2D point.
+   34 transformPoint :: TMatrix -> RPoint -> RPoint
+   35 transformPoint m (V2 x y) = V2 (a*x +c*y + e) (b*x + d*y +f)
+   36   where
+   37     !a = M.unsafeGet 1 1 m
+   38     !c = M.unsafeGet 1 2 m
+   39     !e = M.unsafeGet 1 3 m
+   40     !b = M.unsafeGet 2 1 m
+   41     !d = M.unsafeGet 2 2 m
+   42     !f = M.unsafeGet 2 3 m
+   43     -- (a:c:e:b:d:f:_) = M.toList m
+   44 
+   45 -- | Convert multiple SVG transformations into a single transformation matrix.
+   46 mkMatrix :: Maybe [Transformation] -> TMatrix
+   47 mkMatrix Nothing   = identity
+   48 mkMatrix (Just ts) = foldl' (*) identity (map transformationMatrix ts)
+   49 
+   50 -- | Convert an SVG transformation into a transformation matrix.
+   51 transformationMatrix :: Transformation -> TMatrix
+   52 transformationMatrix transformation =
+   53   case transformation of
+   54     TransformMatrix a b c d e f -> fromList [a,b,c,d,e,f]
+   55     Translate x y               -> translate x y
+   56     Scale sx mbSy               -> fromList [sx,0,0,fromMaybe sx mbSy,0,0]
+   57     Rotate a Nothing            -> rotate a
+   58     Rotate a (Just (x,y))       -> translate x y * rotate a * translate (-x) (-y)
+   59     SkewX a                     -> fromList [1,0,tan (a*pi/180),1,0,0]
+   60     SkewY a                     -> fromList [1,tan (a*pi/180),0,1,0,0]
+   61     TransformUnknown            -> identity
+   62   where
+   63     translate x y = fromList [1,0,0,1,x,y]
+   64     rotate a = fromList [cos r,sin r,-sin r,cos r,0,0]
+   65       where r = a * pi / 180
+   66 
+   67 -- | Convert a transformation matrix back into an SVG transformation.
+   68 toTransformation :: TMatrix -> Transformation
+   69 toTransformation m = TransformMatrix a b c d e f
+   70   where
+   71     [a,c,e,b,d,f,_,_,_] = M.toList m