reanimate 0.4.3.0 → 0.5.0.0
raw patch · 55 files changed
+2166/−1660 lines, 55 filesdep +fingertreedep +tasty-expected-failuredep +unordered-containersdep ~hashabledep ~reanimate-svgbinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: fingertree, tasty-expected-failure, unordered-containers
Dependency ranges changed: hashable, reanimate-svg
API changes (from Hackage documentation)
- Geom2D.CubicBezier.Linear: data ClosedMetaPath a
- Geom2D.CubicBezier.Linear: data ClosedPath a
- Geom2D.CubicBezier.Linear: instance Geom2D.CubicBezier.Linear.Cast Graphics.SvgTree.Types.FillRule Geom2D.CubicBezier.Overlap.FillRule
- Reanimate: tweenVarUnclamped :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()
- Reanimate.Scene: instance Control.Monad.Fix.MonadFix (Reanimate.Scene.Scene s)
- Reanimate.Scene: instance GHC.Base.Applicative (Reanimate.Scene.Frame s)
- Reanimate.Scene: instance GHC.Base.Applicative (Reanimate.Scene.Scene s)
- Reanimate.Scene: instance GHC.Base.Functor (Reanimate.Scene.Frame s)
- Reanimate.Scene: instance GHC.Base.Functor (Reanimate.Scene.Scene s)
- Reanimate.Scene: instance GHC.Base.Monad (Reanimate.Scene.Scene s)
- Reanimate.Scene: instance Reanimate.Scene.Renderable Graphics.SvgTree.Types.Tree
- Reanimate.Scene: instance Reanimate.Scene.Renderable Reanimate.Scene.Camera
- Reanimate.Scene: instance Reanimate.Scene.Renderable Reanimate.Scene.Circle
- Reanimate.Scene: instance Reanimate.Scene.Renderable Reanimate.Scene.Morph
- Reanimate.Scene: instance Reanimate.Scene.Renderable Reanimate.Scene.Rectangle
- Reanimate.Scene: tweenVarUnclamped :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()
+ Geom2D.CubicBezier.Linear: instance Geom2D.CubicBezier.Linear.Cast Graphics.SvgTree.Types.Basic.FillRule Geom2D.CubicBezier.Overlap.FillRule
+ Geom2D.CubicBezier.Linear: newtype ClosedMetaPath a
+ Geom2D.CubicBezier.Linear: newtype ClosedPath a
+ Reanimate.Scene: oDraw :: SVG -> Animation
+ Reanimate.Scene: oHideWith :: Object s a -> (SVG -> Animation) -> Scene s ()
+ Reanimate.Scene: oScaleIn :: SVG -> Animation
+ Reanimate.Scene: oScaleIn' :: Signal -> Origin -> SVG -> Animation
+ Reanimate.Scene: oScaleOut :: SVG -> Animation
+ Reanimate.Scene: oScaleOut' :: Signal -> Origin -> SVG -> Animation
+ Reanimate.Scene: oShowWith :: Object s a -> (SVG -> Animation) -> Scene s ()
+ Reanimate.Scene: oSim :: (SVG -> Animation) -> SVG -> Animation
+ Reanimate.Scene: oStagger :: (SVG -> Animation) -> SVG -> Animation
+ Reanimate.Scene: oStagger' :: Duration -> (SVG -> Animation) -> SVG -> Animation
+ Reanimate.Scene: oStaggerRev :: (SVG -> Animation) -> SVG -> Animation
+ Reanimate.Scene: oStaggerRev' :: Duration -> (SVG -> Animation) -> SVG -> Animation
+ Reanimate.Scene: type Origin = (Double, Double)
- Reanimate.Scene: oFadeIn :: Object s a -> Duration -> Scene s ()
+ Reanimate.Scene: oFadeIn :: SVG -> Animation
- Reanimate.Scene: oFadeOut :: Object s a -> Duration -> Scene s ()
+ Reanimate.Scene: oFadeOut :: SVG -> Animation
- Reanimate.Scene: oGrow :: Object s a -> Duration -> Scene s ()
+ Reanimate.Scene: oGrow :: SVG -> Animation
- Reanimate.Scene: oShrink :: Object s a -> Duration -> Scene s ()
+ Reanimate.Scene: oShrink :: SVG -> Animation
- Reanimate.Svg: extractPath :: Tree -> [PathCommand]
+ Reanimate.Svg: extractPath :: SVG -> [PathCommand]
- Reanimate.Svg: lowerIds :: Tree -> Tree
+ Reanimate.Svg: lowerIds :: SVG -> SVG
- Reanimate.Svg: lowerTransformations :: Tree -> Tree
+ Reanimate.Svg: lowerTransformations :: SVG -> SVG
- Reanimate.Svg: pathify :: Tree -> Tree
+ Reanimate.Svg: pathify :: SVG -> SVG
- Reanimate.Svg: removeGroups :: Tree -> [Tree]
+ Reanimate.Svg: removeGroups :: SVG -> [SVG]
- Reanimate.Svg: simplify :: Tree -> Tree
+ Reanimate.Svg: simplify :: SVG -> SVG
- Reanimate.Svg: splitGlyphs :: [Int] -> Tree -> (Tree, Tree)
+ Reanimate.Svg: splitGlyphs :: [Int] -> SVG -> (SVG, SVG)
- Reanimate.Svg: svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)]
+ Reanimate.Svg: svgGlyphs :: SVG -> [(SVG -> SVG, DrawAttributes, SVG)]
- Reanimate.Svg: withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree
+ Reanimate.Svg: withSubglyphs :: [Int] -> (SVG -> SVG) -> SVG -> SVG
Files
- ChangeLog.md +23/−1
- docs/gifs/doc_oDraw.gif binary
- docs/gifs/doc_oScaleIn.gif binary
- docs/gifs/doc_oScaleOut.gif binary
- examples/bug_quad.golden +2/−2
- examples/demo_stars.hs +9/−2
- examples/demo_tangent.hs +1/−2
- examples/doc_drawCircle.hs +6/−2
- examples/doc_oDraw.hs +20/−0
- examples/doc_oHideWith.hs +16/−0
- examples/doc_oScaleIn.hs +15/−0
- examples/doc_oScaleOut.hs +15/−0
- examples/knock_knock.hs +10/−16
- examples/obj_intro.hs +49/−0
- examples/obj_replace.hs +23/−0
- examples/tut_glue_blender.hs +1/−1
- examples/tut_glue_keyframe.hs +7/−2
- examples/tut_glue_povray.hs +1/−1
- examples/tut_glue_povray_ortho.hs +1/−1
- reanimate.cabal +13/−6
- src/Geom2D/CubicBezier/Linear.hs +10/−11
- src/Reanimate.hs +0/−1
- src/Reanimate/Animation.hs +6/−9
- src/Reanimate/Blender.hs +1/−1
- src/Reanimate/Builtin/CirclePlot.hs +1/−1
- src/Reanimate/Cache.hs +2/−2
- src/Reanimate/Driver.hs +1/−1
- src/Reanimate/Driver/CLI.hs +5/−0
- src/Reanimate/Driver/Magick.hs +1/−0
- src/Reanimate/Driver/Server.hs +11/−9
- src/Reanimate/GeoProjection.hs +18/−16
- src/Reanimate/LaTeX.hs +1/−1
- src/Reanimate/Math/Balloon.hs +1/−1
- src/Reanimate/Math/Polygon.hs +7/−28
- src/Reanimate/Math/SSSP.hs +95/−71
- src/Reanimate/Math/Visibility.hs +0/−117
- src/Reanimate/Morph/Common.hs +2/−2
- src/Reanimate/PolyShape.hs +27/−38
- src/Reanimate/Povray.hs +1/−1
- src/Reanimate/Raster.hs +3/−4
- src/Reanimate/Render.hs +3/−3
- src/Reanimate/Scene.hs +156/−1226
- src/Reanimate/Scene/Core.hs +163/−0
- src/Reanimate/Scene/Object.hs +612/−0
- src/Reanimate/Scene/Sprite.hs +416/−0
- src/Reanimate/Scene/Var.hs +170/−0
- src/Reanimate/Svg.hs +15/−16
- src/Reanimate/Svg/BoundingBox.hs +2/−2
- src/Reanimate/Svg/Constructors.hs +18/−19
- src/Reanimate/Svg/LineCommand.hs +2/−2
- src/Reanimate/Svg/Unuse.hs +14/−15
- test/Properties.hs +6/−0
- test/Spec.hs +2/−1
- test/TimeVarTests.hs +166/−0
- test/UnitTests.hs +16/−26
ChangeLog.md view
@@ -1,6 +1,28 @@ # Revision history for reanimate -## 0.4.4.0+## 0.5.0.0 -- 2020-09-09++### Added++* Hashable instance for SVG.++### Changed++* Improve efficiency of time variables (thanks to ).+* Major refactoring of SVG interface.+* Haddock improvements.+* Improve consistency of object bounding-box calculations.+* Rewrite object transitions in terms of Animations.++### Removed++* Reanimate.Scene.tweenVarUnclamped+* Reanimate.Math.SSSP.pdual++### Contributors++ * Shaurya Gupta (@sureyeaah)+ * Jan Hrček (@jhrcek) ## 0.4.3.0 -- 2020-08-29
+ docs/gifs/doc_oDraw.gif view
binary file changed (absent → 88844 bytes)
+ docs/gifs/doc_oScaleIn.gif view
binary file changed (absent → 70224 bytes)
+ docs/gifs/doc_oScaleOut.gif view
binary file changed (absent → 84826 bytes)
examples/bug_quad.golden view
@@ -1,4 +1,4 @@-0<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><path d="M2,0 L1.9375,0.060547 1.875,0.117187 1.8125,0.169922 1.75,0.21875 1.6875,0.263672 1.625,0.304688 1.5625,0.341797 1.5,0.375 1.4375,0.404297 1.375,0.429688 1.3125,0.451172 1.25,0.46875 1.1875,0.482422 1.125,0.492188 1.0625,0.498047 1,0.5 0.9375,0.498047 0.875,0.492188 0.8125,0.482422 0.75,0.46875 0.6875,0.451172 0.625,0.429688 0.5625,0.404297 0.5,0.375 0.4375,0.341797 0.375,0.304688 0.3125,0.263672 0.25,0.21875 0.1875,0.169922 0.125,0.117187 0.0625,0.060547 0,0 Z" /></g></g></g></g></g></svg>+0<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><path d="M0,0 Q1,1 2,0 Z" /></g></g></g></g></svg> 1<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><path d="M2,0 L1.9375,0.067274 1.875,0.130208 1.8125,0.188802 1.75,0.243056 1.6875,0.292969 1.625,0.338542 1.5625,0.379774 1.5,0.416667 1.4375,0.449219 1.375,0.477431 1.3125,0.501302 1.25,0.520833 1.1875,0.536024 1.125,0.546875 1.0625,0.553385 1,0.555556 0.9375,0.553385 0.875,0.546875 0.8125,0.536024 0.75,0.520833 0.6875,0.501302 0.625,0.477431 0.5625,0.449219 0.5,0.416667 0.4375,0.379774 0.375,0.338542 0.3125,0.292969 0.25,0.243056 0.1875,0.188802 0.125,0.130208 0.0625,0.067274 0,0 Z" /></g></g></g></g></g></svg> 2<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><path d="M2,0 L1.9375,0.074002 1.875,0.143229 1.8125,0.207682 1.75,0.267361 1.6875,0.322266 1.625,0.372396 1.5625,0.417752 1.5,0.458333 1.4375,0.494141 1.375,0.525174 1.3125,0.551432 1.25,0.572917 1.1875,0.589627 1.125,0.601563 1.0625,0.608724 1,0.611111 0.9375,0.608724 0.875,0.601563 0.8125,0.589627 0.75,0.572917 0.6875,0.551432 0.625,0.525174 0.5625,0.494141 0.5,0.458333 0.4375,0.417752 0.375,0.372396 0.3125,0.322266 0.25,0.267361 0.1875,0.207682 0.125,0.143229 0.0625,0.074002 0,0 Z" /></g></g></g></g></g></svg> 3<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><path d="M2,0 L1.9375,0.080729 1.875,0.15625 1.8125,0.226563 1.75,0.291667 1.6875,0.351563 1.625,0.40625 1.5625,0.455729 1.5,0.5 1.4375,0.539063 1.375,0.572917 1.3125,0.601563 1.25,0.625 1.1875,0.643229 1.125,0.65625 1.0625,0.664063 1,0.666667 0.9375,0.664063 0.875,0.65625 0.8125,0.643229 0.75,0.625 0.6875,0.601563 0.625,0.572917 0.5625,0.539063 0.5,0.5 0.4375,0.455729 0.375,0.40625 0.3125,0.351563 0.25,0.291667 0.1875,0.226563 0.125,0.15625 0.0625,0.080729 0,0 Z" /></g></g></g></g></g></svg>@@ -7,4 +7,4 @@ 6<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><path d="M2,0 L1.9375,0.100911 1.875,0.195312 1.8125,0.283203 1.75,0.364583 1.6875,0.439453 1.625,0.507813 1.5625,0.569661 1.5,0.625 1.4375,0.673828 1.375,0.716146 1.3125,0.751953 1.25,0.78125 1.1875,0.804036 1.125,0.820313 1.0625,0.830078 1,0.833333 0.9375,0.830078 0.875,0.820313 0.8125,0.804036 0.75,0.78125 0.6875,0.751953 0.625,0.716146 0.5625,0.673828 0.5,0.625 0.4375,0.569661 0.375,0.507813 0.3125,0.439453 0.25,0.364583 0.1875,0.283203 0.125,0.195312 0.0625,0.100911 0,0 Z" /></g></g></g></g></g></svg> 7<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><path d="M2,0 L1.9375,0.107639 1.875,0.208333 1.8125,0.302083 1.75,0.388889 1.6875,0.46875 1.625,0.541667 1.5625,0.607639 1.5,0.666667 1.4375,0.71875 1.375,0.763889 1.3125,0.802083 1.25,0.833333 1.1875,0.857639 1.125,0.875 1.0625,0.885417 1,0.888889 0.9375,0.885417 0.875,0.875 0.8125,0.857639 0.75,0.833333 0.6875,0.802083 0.625,0.763889 0.5625,0.71875 0.5,0.666667 0.4375,0.607639 0.375,0.541667 0.3125,0.46875 0.25,0.388889 0.1875,0.302083 0.125,0.208333 0.0625,0.107639 0,0 Z" /></g></g></g></g></g></svg> 8<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><path d="M2,0 L1.9375,0.114366 1.875,0.221354 1.8125,0.320964 1.75,0.413194 1.6875,0.498047 1.625,0.575521 1.5625,0.645616 1.5,0.708333 1.4375,0.763672 1.375,0.811632 1.3125,0.852214 1.25,0.885417 1.1875,0.911241 1.125,0.929688 1.0625,0.940755 1,0.944444 0.9375,0.940755 0.875,0.929688 0.8125,0.911241 0.75,0.885417 0.6875,0.852214 0.625,0.811632 0.5625,0.763672 0.5,0.708333 0.4375,0.645616 0.375,0.575521 0.3125,0.498047 0.25,0.413194 0.1875,0.320964 0.125,0.221354 0.0625,0.114366 0,0 Z" /></g></g></g></g></g></svg>-9<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><g><path d="M2,0 L1.9375,0.121094 1.875,0.234375 1.8125,0.339844 1.75,0.4375 1.6875,0.527344 1.625,0.609375 1.5625,0.683594 1.5,0.75 1.4375,0.808594 1.375,0.859375 1.3125,0.902344 1.25,0.9375 1.1875,0.964844 1.125,0.984375 1.0625,0.996094 1,1 0.9375,0.996094 0.875,0.984375 0.8125,0.964844 0.75,0.9375 0.6875,0.902344 0.625,0.859375 0.5625,0.808594 0.5,0.75 0.4375,0.683594 0.375,0.609375 0.3125,0.527344 0.25,0.4375 0.1875,0.339844 0.125,0.234375 0.0625,0.121094 0,0 Z" /></g></g></g></g></g></svg>+9<svg viewBox="-8 -4.5 16 9" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" preserveAspectRatio="none"><g stroke-width="0.05" transform="scale(1, -1)"><g><g stroke-width="0" fill="#FFFFFF" transform="translate(-8, -4.5)" fill-opacity="1"><rect width="16" height="9" /></g><g stroke-width="0.1" stroke="#000000" fill-opacity="0"><g><path d="M0,0 Q1,2 2,0 Z" /></g></g></g></g></svg>
examples/demo_stars.hs view
@@ -1,5 +1,12 @@-#!/usr/bin/env stack--- stack runghc --package reanimate+#!/usr/bin/env cabal+{- cabal:+build-depends: base+ , reanimate+ , reanimate-svg+ , vector+ , random+ , JuicyPixels+-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ParallelListComp #-} module Main
examples/demo_tangent.hs view
@@ -6,8 +6,7 @@ import Control.Lens ((^.)) import Control.Monad.State import qualified Data.Vector.Unboxed as V-import Graphics.SvgTree (Coord, Tree (..), mapTree,- pathDefinition)+import Graphics.SvgTree import Linear.Metric import Linear.V2 (V2 (..)) import Linear.Vector
examples/doc_drawCircle.hs view
@@ -1,5 +1,9 @@-#!/usr/bin/env stack--- stack runghc --package reanimate+#!/usr/bin/env cabal+{- cabal:+build-depends: base+ , reanimate+ , reanimate-svg+-} module Main(main) where import Reanimate
+ examples/doc_oDraw.hs view
@@ -0,0 +1,20 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import Reanimate+import Reanimate.Scene+import Reanimate.Builtin.Documentation+import Control.Lens++main :: IO ()+-- main = reanimate $ docEnv $ oDraw $+-- withFillOpacity 1 $ withStrokeWidth (defaultStrokeWidth*0) $ center $ scale 2 $ latex "oDraw"+main = reanimate $ docEnv $ scene $ do+ txt <- oNew $ withStrokeWidth 0 $ withFillOpacity 1 $+ center $ scale 4 $ latex "oDraw"+ oModify txt $ oEasing .~ id+ oShowWith txt oDraw+ wait 1+ oHideWith txt oFadeOut
+ examples/doc_oHideWith.hs view
@@ -0,0 +1,16 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import Reanimate+import Reanimate.Scene+import Reanimate.Builtin.Documentation++main :: IO ()+main = reanimate $ docEnv $ scene $ do+ txt <- oNew $ withStrokeWidth 0 $ withFillOpacity 1 $+ center $ scale 3 $ latex "oScaleIn"+ oShowWith txt oFadeIn+ -- oShowWith txt $ adjustDuration (*2) . oScaleIn+ -- wait 1; oHideWith txt oFadeOut
+ examples/doc_oScaleIn.hs view
@@ -0,0 +1,15 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import Reanimate+import Reanimate.Scene+import Reanimate.Builtin.Documentation++main :: IO ()+main = reanimate $ docEnv $ scene $ do+ txt <- oNew $ withStrokeWidth 0 $ withFillOpacity 1 $+ center $ scale 3 $ latex "oScaleIn"+ oShowWith txt $ adjustDuration (*2) . oScaleIn+ wait 1; oHideWith txt oFadeOut
+ examples/doc_oScaleOut.hs view
@@ -0,0 +1,15 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import Reanimate+import Reanimate.Scene+import Reanimate.Builtin.Documentation++main :: IO ()+main = reanimate $ docEnv $ scene $ do+ txt <- oNew $ withStrokeWidth 0 $ withFillOpacity 1 $+ center $ scale 3 $ latex "oScaleOut"+ oShowWith txt oFadeIn+ oHideWith txt $ adjustDuration (*2) . oScaleOut
examples/knock_knock.hs view
@@ -17,34 +17,34 @@ oModifyMany line1 $ oTopY .~ screenTop - oFadeIn (line1!!0) 1+ oShowWith (line1!!0) oFadeIn oShow (line1!!1); wait 0.3 oShow (line1!!3); wait 0.6 line2 <- newLaTeX ["$>$ ", "who's there?"] mapM_ (`placeBelow` head line1) line2 - oFadeIn (line2!!0) 1- oDraw (line2!!1) 1+ oShowWith (line2!!0) oFadeIn + oShowWith (line2!!1) oDraw line3 <- newLaTeX ["$>$ ", "$(\\lambda x . x)$"] mapM_ (`placeBelow` head line2) line3 - oFadeIn (line3!!0) 1- oFadeIn (line3!!1) 1+ oShowWith (line3!!0) oFadeIn+ oShowWith (line3!!1) oFadeIn line4 <- newLaTeX ["$>$ ", "$(\\lambda x . x)$", " ", "who?"] mapM_ (`placeBelow` head line3) line4 - oFadeIn (line4!!0) 1- oFadeIn (line4!!1) 1- oDraw (line4!!3) 1+ oShowWith (line4!!0) oFadeIn+ oShowWith (line4!!1) oFadeIn+ oShowWith (line4!!3) oDraw line5 <- newLaTeX ["$>$ ", "who?"] mapM_ (`placeBelow` head line4) line5 - oFadeIn (line5!!0) 1- oDraw (line5!!1) 1+ oShowWith (line5!!0) oFadeIn+ oShowWith (line5!!1) oDraw wait 1 @@ -59,9 +59,3 @@ newLaTeX :: [Text] -> Scene s [Object s SVG] newLaTeX chunks = mapM newObject $ map (translate (-4) 0) $ latexChunks chunks--oDraw :: Object s a -> Duration -> Scene s ()-oDraw o d = do- oShow o- oTweenS o d $ \t ->- oContext .= withFillOpacity (max 0 $ t*10-9) . partialSvg t
+ examples/obj_intro.hs view
@@ -0,0 +1,49 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import Reanimate+import Reanimate.Scene+import Control.Lens++main :: IO ()+main = reanimate $ scene $ do+ newSpriteSVG_ $ mkBackground "white"+ logo <- oNew $ center $ latex "Reanimate"+ oModify logo $ oScale .~ 3++ oShowWith logo oFadeIn+ oTweenS logo 1 $ \t -> do+ oScale %= \prev -> fromToS prev 2 t+ oTopY %= \prev -> fromToS prev screenTop t++ haskell <- oNew $ center $ withStrokeColor "black" $ latex "Haskell"+ oModify haskell $ oScale .~ 3+ oShowWith haskell oDraw+ oTweenS haskell 1 $ \t -> do+ oScale %= \prev -> fromToS prev 2 t+ oBottomY %= \prev -> fromToS prev screenBottom t++ features <- mapM (oNew . scale 3 . center . latex)+ ["SVG", "\\LaTeX", "Animation", "Windows", "Linux", "MacOS", "Browsers"]+ oShowWith (head features) $ adjustDuration (*3) . oScaleIn+ featureChain features++ wait (-1)+ fork $ oHideWith logo oFadeOut+ fork $ oHideWith haskell oFadeOut++replace :: Object s a -> Object s b -> Scene s ()+replace a b = do+ fork $ oHideWith a $ adjustDuration (*3) . oScaleOut+ wait 0.2+ oShowWith b $ adjustDuration (*3) . oScaleIn++featureChain :: [Object s a] -> Scene s ()+featureChain (x:y:xs) = do+ replace x y+ featureChain (y:xs)+featureChain [x] = do+ oHideWith x $ adjustDuration (*3) . oScaleOut+featureChain [] = return ()
+ examples/obj_replace.hs view
@@ -0,0 +1,23 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+module Main(main) where++import Reanimate+import Reanimate.Scene++main :: IO ()+main = reanimate $ scene $ do+ newSpriteSVG_ $ mkBackground "white"+ t1 <- oNew $ centerX $ scale 3 $ latex "reanimate"+ t2 <- oNew $ centerX $ scale 3 $ latex "and \\LaTeX"+ + oShow t1+ replace t1 t2; wait 1+ replace t2 t1; wait 1++replace :: Object s a -> Object s b -> Scene s ()+replace a b = do+ fork $ oHideWith a $ adjustDuration (*3) . oScaleOut+ wait 0.2+ oShowWith b $ adjustDuration (*3) . oScaleIn
examples/tut_glue_blender.hs view
@@ -14,7 +14,7 @@ import Control.Monad import Data.Monoid import qualified Data.Text as T-import Graphics.SvgTree hiding (text)+import Graphics.SvgTree import NeatInterpolation import System.Random import "random-shuffle" System.Random.Shuffle
examples/tut_glue_keyframe.hs view
@@ -1,5 +1,10 @@-#!/usr/bin/env stack--- stack runghc --package reanimate+#!/usr/bin/env cabal+{- cabal:+build-depends: base+ , reanimate+ , reanimate-svg+ , JuicyPixels+-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-} module Main (main) where
examples/tut_glue_povray.hs view
@@ -16,7 +16,7 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as T-import Graphics.SvgTree hiding (Text, text)+import Graphics.SvgTree hiding (Text) import NeatInterpolation import System.Random import "random-shuffle" System.Random.Shuffle
examples/tut_glue_povray_ortho.hs view
@@ -16,7 +16,7 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as T-import Graphics.SvgTree hiding (Text,text)+import Graphics.SvgTree hiding (Text) import NeatInterpolation import System.Random import "random-shuffle" System.Random.Shuffle
reanimate.cabal view
@@ -3,7 +3,7 @@ -- see http://haskell.org/cabal/users-guide/ name: reanimate-version: 0.4.3.0+version: 0.5.0.0 -- synopsis: -- description: license: PublicDomain@@ -40,7 +40,7 @@ library hs-source-dirs: src default-language: Haskell2010- default-extensions: PackageImports+ default-extensions: PackageImports, PatternSynonyms exposed-modules: Reanimate Reanimate.Animation Reanimate.Ease@@ -93,7 +93,10 @@ Reanimate.Driver.Compile Reanimate.Misc Paths_reanimate- Reanimate.Math.Visibility+ Reanimate.Scene.Core+ Reanimate.Scene.Var+ Reanimate.Scene.Sprite+ Reanimate.Scene.Object build-depends: base >=4.10 && <5, JuicyPixels >=3.3.3,@@ -111,10 +114,11 @@ directory >=1.3.1.0, filelock >=0.1.1.2, filepath >=1.4.2,+ fingertree, fsnotify >=0.3.0.1, geojson >=3.0.4, ghcid >=0.7,- hashable >=1.2.7.0,+ hashable >=1.3.0.0, hgeometry >=0.11.0.0, hgeometry-combinatorial >=0.11.0.0, lens >=4.16.1,@@ -128,11 +132,12 @@ process >=1.6.3.0, random >=1.1, random-shuffle >=0.0.4,- reanimate-svg >=0.10.0.0,+ reanimate-svg >=0.11.0.0, split >=0.2.3.3, temporary >=1.3, text >=1.2.3.0, time >=1.8.0.0,+ unordered-containers, vector >=0.12.0.0, vector-space >=0.13, websockets >=0.12.7.0,@@ -145,6 +150,7 @@ default-language: Haskell2010 other-modules: UnitTests+ TimeVarTests Properties Helpers hs-source-dirs: test@@ -159,4 +165,5 @@ QuickCheck >= 2.1.0, text, temporary, tasty, tasty-golden, tasty-hunit,- tasty-quickcheck, tasty-rerun >= 1.1.17+ tasty-quickcheck, tasty-rerun >= 1.1.17,+ tasty-expected-failure
src/Geom2D/CubicBezier/Linear.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-| Module : Geom2D.CubicBezier.Linear@@ -84,7 +83,7 @@ deriving (Show, Eq) -- | Closed cubicbezier path.-data ClosedPath a = ClosedPath [(V2 a, PathJoin a)]+newtype ClosedPath a = ClosedPath [(V2 a, PathJoin a)] deriving (Show, Eq) -- | Join two points with either a straight line or a bezier@@ -95,7 +94,7 @@ deriving (Show, Eq) -- | Closed meta path.-data ClosedMetaPath a = ClosedMetaPath [(V2 a, MetaJoin a)]+newtype ClosedMetaPath a = ClosedMetaPath [(V2 a, MetaJoin a)] deriving (Show, Eq) -- | Open meta path@@ -108,11 +107,11 @@ -- doesn't allow values below 3/4. data Tension a = Tension- { tensionValue :: a }+ { tensionValue :: a } | TensionAtLeast -- ^ Like Tension, but keep the segment inside the -- bounding triangle defined by the control points, -- if there is one.- { tensionValue :: a }+ { tensionValue :: a } deriving (Functor, Foldable, Traversable, Eq, Show) -- | Join two meta points with either a bezier curve or tension@@ -144,16 +143,16 @@ -- | @arcLength c t tol@ finds the arclength of the bezier @c@ at @t@, -- within given tolerance @tol@. arcLength :: CubicBezier Double -> Double -> Double -> Double-arcLength bezier t tol = C.arcLength (downCast bezier) t tol+arcLength bezier = C.arcLength (downCast bezier) -- | @arcLengthParam c len tol@ finds the parameter where the curve @c@ -- has the arclength @len@, within tolerance @tol@. arcLengthParam :: CubicBezier Double -> Double -> Double -> Double-arcLengthParam bezier t tol = C.arcLengthParam (downCast bezier) t tol+arcLengthParam bezier = C.arcLengthParam (downCast bezier) -- | Return @False@ if some points fall outside a line with a thickness of the given tolerance. colinear :: CubicBezier Double -> Double -> Bool-colinear bezier tol = C.colinear (downCast bezier) tol+colinear bezier = C.colinear (downCast bezier) -- | Calculate a value on the bezier curve. evalBezier :: (C.GenericBezier b, V.Unbox a, Fractional a) => b a -> a -> V2 a@@ -187,12 +186,12 @@ -- | Find the intersections between two Bezier curves, using the Bezier Clip algorithm. -- Returns the parameters for both curves. bezierIntersection :: CubicBezier Double -> CubicBezier Double -> Double -> [(Double, Double)]-bezierIntersection a b t = C.bezierIntersection (downCast a) (downCast b) t+bezierIntersection a b = C.bezierIntersection (downCast a) (downCast b) -- | Find the closest value on the bezier to the given point, within tolerance. -- Return the first value found. closest :: CubicBezier Double -> V2 Double -> Double -> Double-closest c p t = C.closest (downCast c) (downCast p) t+closest c p = C.closest (downCast c) (downCast p) -- | Return the closed path as a list of curves. closedPathCurves :: Fractional a => ClosedPath a -> [CubicBezier a]@@ -281,7 +280,7 @@ downCast (AnyBezier arr) = C.AnyBezier $ V.map (\(V2 a b) -> (a,b)) arr upCast (C.AnyBezier arr) = AnyBezier $- V.map (\(a, b) -> V2 a b) arr+ V.map (uncurry V2) arr instance Cast (MetaNodeType a) (C.MetaNodeType a) where downCast Open = C.Open
src/Reanimate.hs view
@@ -93,7 +93,6 @@ , writeVar -- :: Var s a -> a -> Scene s () , modifyVar -- :: Var s a -> (a -> a) -> Scene s () , tweenVar -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()- , tweenVarUnclamped -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () , simpleVar -- :: (a -> SVG) -> a -> Scene s (Var s a) , findVar -- :: (a -> Bool) -> [Var s a] -> Scene s (Var s a) -- *** Sprites
src/Reanimate/Animation.hs view
@@ -55,10 +55,7 @@ import Control.Arrow () import Data.Fixed (mod')-import Graphics.SvgTree (Alignment (..), Document (..),- Number (..),- PreserveAspectRatio (..),- Tree (..), xmlOfTree)+import Graphics.SvgTree import Graphics.SvgTree.Printer import Reanimate.Constants import Reanimate.Ease@@ -210,11 +207,11 @@ width = 16 height = 9 doc = Document- { _viewBox = Just (-width/2, -height/2, width, height)- , _width = w- , _height = h- , _elements = [withStrokeWidth defaultStrokeWidth $ scaleXY 1 (-1) t]- , _description = ""+ { _documentViewBox = Just (-width/2, -height/2, width, height)+ , _documentWidth = w+ , _documentHeight = h+ , _documentElements = [withStrokeWidth defaultStrokeWidth $ scaleXY 1 (-1) t]+ , _documentDescription = "" , _documentLocation = "" , _documentAspectRatio = PreserveAspectRatio False AlignNone Nothing }
src/Reanimate/Blender.hs view
@@ -39,7 +39,7 @@ import Data.Hashable import Data.Text (Text) import qualified Data.Text.IO as T-import Graphics.SvgTree (Tree (..))+import Graphics.SvgTree (Tree) import Reanimate.Animation import Reanimate.Cache import Reanimate.Constants
src/Reanimate/Builtin/CirclePlot.hs view
@@ -22,7 +22,7 @@ -- Example: -- -- @--- 'circlePlot' 500 $ \ang r ->+-- 'circlePlot' 500 $ \\ang r -> -- 'Codec.Picture.Types.promotePixel' $ toRGB8 $ uncurryRGB sRGB $ hsv (ang/pi*180) r 1 -- @ --
src/Reanimate/Cache.hs view
@@ -18,7 +18,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T-import Graphics.SvgTree (Tree (..), unparse)+import Graphics.SvgTree (Tree, unparse, pattern None) import Reanimate.Animation (renderTree) import Reanimate.Misc (renameOrCopyFile) import System.Directory@@ -96,7 +96,7 @@ case svg of -- None usually indicates that latex or another tool was misconfigured. In this case, -- don't store the result.- None -> pure None+ None -> pure svg _ -> atomicModifyIORef cache (\m -> (Map.insert key svg m, svg)) encodeInt :: Int -> String
src/Reanimate/Driver.hs view
@@ -156,7 +156,7 @@ else do raster <- selectRaster RasterAuto when (raster == RasterNone) $ do- hPutStrLn stderr $+ hPutStrLn stderr "Error: your FFmpeg was built without SVG support and no raster engines \ \are available. Please install either inkscape, imagemagick, or rsvg." exitWith (ExitFailure 1)
src/Reanimate/Driver/CLI.hs view
@@ -44,6 +44,7 @@ , renderPreset :: Maybe Preset , renderRaster :: Raster , renderPartial :: Bool+ , renderHash :: Bool } deriving (Show) @@ -211,6 +212,10 @@ (long "partial" <> help "Produce partial animation even if frame generation was \ \interrupted by ctrl-c")+ <*> flag True False+ (long "disable-hashing"+ <> help "Disable SVG dedup via hashing. This might improve performance \+ \if all your frames are unique.") opts :: ParserInfo Options opts = info (options <**> helper )
src/Reanimate/Driver/Magick.hs view
@@ -5,6 +5,7 @@ import System.IO.Unsafe (unsafePerformIO) import System.Directory (findExecutable) +{-# NOINLINE magickCmd #-} -- |The name of the ImageMagick command. On Unix-like operating systems, the -- command \'convert\' does not conflict with the name of other commands. On -- Windows, ImageMagick version 7 is readily available, the command \'magick\'
src/Reanimate/Driver/Server.hs view
@@ -125,7 +125,7 @@ first <- readIORef firstFrame writeIORef firstFrame False if first- then do+ then modifyMVar_ sentFrameCount $ \sent -> do unless sent $ sendWebMessage conn $ WebFrameCount frameIdx@@ -177,18 +177,20 @@ case T.decimal frame of Left err -> do hPutStrLn stderr (T.unpack frame)- hPutStrLn stderr $ "expectFrame: " ++ err- sendWebMessage conn $ WebError err- exitWith (ExitFailure 1)+ raiseError conn err Right (frameNumber, "") -> pure frameNumber Right {} -> do let err = "Unexpected output" hPutStrLn stderr (T.unpack frame)- hPutStrLn stderr $ "expectFrame: " ++ err- sendWebMessage conn $ WebError err- exitWith (ExitFailure 1)+ raiseError conn err +raiseError :: Connection -> String -> IO a+raiseError conn err = do+ hPutStrLn stderr $ "expectFrame: " ++ err+ sendWebMessage conn $ WebError err+ exitWith (ExitFailure 1)+ watchFile :: WatchManager -> FilePath -> IO () -> IO StopListening watchFile watch file action = watchTree watch (takeDirectory file) check (const action) where@@ -249,7 +251,7 @@ -- cabal -- raw -- none?-data GhciBackend = GhciBackend (MVar Ghci)+newtype GhciBackend = GhciBackend (MVar Ghci) ghciBackend :: Maybe FilePath -> FilePath -> IO GhciBackend ghciBackend mbGHCPath self = do@@ -270,7 +272,7 @@ void $ reload ghci ghciGenerate :: GhciBackend -> FilePath -> (Int -> IO ()) -> IO ()-ghciGenerate (GhciBackend ref) target cb = withMVar ref $ \ghci -> do+ghciGenerate (GhciBackend ref) target cb = withMVar ref $ \ghci -> execStream ghci (":main raw --output=" ++ target ++ " --offset=1") $ \_ msg -> case reads msg of
src/Reanimate/GeoProjection.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-} {-| Module : Reanimate.GeoProjection Copyright : Written by David Himmelstrup@@ -74,7 +75,7 @@ import Foreign import GHC.Exts (Double (..), cosDouble#, sinDouble#, (*##), (+##), (-##), (/##))-import Graphics.SvgTree (Tree (None))+import Graphics.SvgTree (pattern None) import Linear (distance, lerp) import Linear.V2 hiding (angle) import Reanimate@@ -126,12 +127,12 @@ interpP :: Image PixelRGBA8 -> Projection -> Projection -> Double -> Image PixelRGBA8 interpP src p1 _ 0 = project src p1 interpP src _ p2 1 = project src p2-interpP !src (Projection _label1 p1 p1_inv) !(Projection _label2 p2 p2_inv) !t = runST $ do+interpP !src (Projection _label1 p1 p1_inv) (Projection _label2 p2 p2_inv) !t = runST $ do !img <- newMutableImage w h let factor = 2- let l1 = do- loopTo (w*factor) $ \x -> do+ let l1 =+ loopTo (w*factor) $ \x -> loopTo (h*factor) $ \y -> do let !x1' = fromIntegral x / (wMax*fromIntegral factor) !y1' = fromIntegral y / (hMax*fromIntegral factor)@@ -146,7 +147,7 @@ !y3 = round $ (1 - fromToS y1 y2 t) * hMax when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ writePixel img x3 y3 p- l2 = do+ l2 = loopTo (w*factor) $ \x -> loopTo (h*factor) $ \y -> do let !x2' = fromIntegral x / (wMax*fromIntegral factor)@@ -159,7 +160,7 @@ XYCoord x1 y1 = p1 lonlat !x3 = round $ fromToS x1 x2 t * wMax !y3 = round $ (1 - fromToS y1 y2 t) * hMax- when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ do+ when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ writePixel img x3 y3 p if t < 0.5 then l1 >> l2@@ -181,11 +182,11 @@ -- are undefined. interpBBP :: Image PixelRGBA8 -> Projection -> Projection -> (Double,Double,Double,Double) -> (Double,Double,Double,Double) -> Double -> Image PixelRGBA8-interpBBP !src (Projection _ p1 p1_inv) !(Projection _ p2 p2_inv) (fx,fy,fw,fh) (tx, ty, tw, th) !t = runST $ do+interpBBP !src (Projection _ p1 p1_inv) (Projection _ p2 p2_inv) (fx,fy,fw,fh) (tx, ty, tw, th) !t = runST $ do !img <- newMutableImage w h let factor = 2 let l1 =- loopTo (w*factor) $ \x -> do+ loopTo (w*factor) $ \x -> loopTo (h*factor) $ \y -> do let !x1' = fromIntegral x / (wMax*fromIntegral factor) !y1' = fromIntegral y / (hMax*fromIntegral factor)@@ -215,7 +216,7 @@ XYCoord x1 y1 = p1 lonlat !x3 = round $ fromToS x1 x2 t * wMax !y3 = round $ (1 - fromToS y1 y2 t) * hMax- when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ do+ when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ writePixel img x3 y3 p if t < 0.5 then l1 >> l2@@ -354,8 +355,9 @@ let LonLat lon1 lat1 = projectionInverse p1 coord LonLat lon2 lat2 = projectionInverse p2 coord in- if | oob lon1 lat1 && oob lon2 lat2 -> LonLat (0/0) (0/0)- | otherwise -> LonLat (fromToS lon1 lon2 t) (fromToS lat1 lat2 t)+ if oob lon1 lat1 && oob lon2 lat2+ then LonLat (0/0) (0/0)+ else LonLat (fromToS lon1 lon2 t) (fromToS lat1 lat2 t) oob lon lat = lon < (-pi) || lon > pi || lat < (-pi/2) || lat > pi/2 -- | <<docs/gifs/doc_equirectangularP.gif>>@@ -374,7 +376,7 @@ where forward (LonLat lam phi) = XYCoord ((lam+pi)/tau)- (min 1 $ max (0) $ (((log(tan(pi/4+phi/2))) + pi)/tau))+ (min 1 $ max 0 $ ((log(tan(pi/4+phi/2))) + pi)/tau) inverse (XYCoord x y) = LonLat xPi (atan (sinh yPi)) where xPi = fromToS (-pi) pi x@@ -421,7 +423,7 @@ find_theta_fast :: Double -> Double find_theta_fast !phi | abs phi == pi/2 = signum phi * halfPi-find_theta_fast !(D# phi) = go phi+find_theta_fast (D# phi) = go phi where !(D# pi#) = pi go acc =@@ -429,7 +431,7 @@ s = sinDouble# (acc +## acc) next = acc -##- (acc +## acc +## s -## pi# *## (sinDouble# phi))+ (acc +## acc +## s -## pi# *## sinDouble# phi) /## (2.0## +## c +## c) in if abs (D# (next -## acc)) < epsilon then D# next@@ -876,10 +878,10 @@ start _ = [] worker a (LineEnd b : rest) = let (x:xs) = reverse $ drop 1 $ mkChunks a b- in map (\v -> LineBezier [v]) (map proj $ reverse xs) ++ LineEnd (proj x) : start rest+ in map (\v -> LineBezier [proj v]) (reverse xs) ++ LineEnd (proj x) : start rest worker a (LineBezier [b] : rest) = let (x:xs) = reverse $ drop 1 $ mkChunks a b- in map (\v -> LineBezier [v]) (map proj $ reverse xs) ++ LineBezier [proj x] : worker x rest+ in map (\v -> LineBezier [proj v]) (reverse xs) ++ LineBezier [proj x] : worker x rest worker _ (LineBezier ps : rest) = LineBezier (map proj ps) : worker (last ps) rest worker _ (LineMove x:rest) = LineMove (proj x) : worker x rest
src/Reanimate/LaTeX.hs view
@@ -23,7 +23,7 @@ import Data.Text ( Text ) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import Graphics.SvgTree ( Tree(..)+import Graphics.SvgTree ( Tree , parseSvgFile ) import Reanimate.Cache
src/Reanimate/Math/Balloon.hs view
@@ -73,7 +73,7 @@ worker a = let b = pNext p a in if nodeVisible a && nodeVisible b- then (pAccess p a : pAccess p b : [])+ then [pAccess p a, pAccess p b] else chunkRight a b (pAccess p a) (pAccess p b) (fst $ getFunnel a b) ++ chunkCenter a b ++
src/Reanimate/Math/Polygon.hs view
@@ -49,8 +49,6 @@ -- * Single-Source-Shortest-Path , ssspVisibility -- :: Polygon -> Polygon , ssspWindows -- :: Polygon -> [(V2 Rational, V2 Rational)]- -- * Duals- , pdualPolygons -- :: Polygon -> PDual -> [Polygon] -- * Built-in shapes for testing , triangle -- :: Polygon , triangle' -- :: [P]@@ -587,21 +585,7 @@ -- Add points by splitting the longest lines in half repeatedly. pAddPoints :: PolyCtx a => Int -> APolygon a -> APolygon a-pAddPoints n p | n <= 0 = p-pAddPoints n p = pAddPoints (n-1) $- mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]- where- worker idx- | idx == longestEdge =- let start = pAccess p idx- end = pAccess p $ idx+1- middle = lerp 0.5 end start- in [start, middle]- | otherwise = [pAccess p idx]- longestEdge = maximumBy cmpLength [0 .. pSize p-1]- cmpLength a b =- distSquared (pAccess p a) (pAccess p $ a+1) `compare`- distSquared (pAccess p b) (pAccess p $ b+1)+pAddPoints = pAddPointsRestricted [] pAddPointsRestricted :: PolyCtx a => [(V2 a, V2 a)] -> Int -> APolygon a -> APolygon a pAddPointsRestricted _immutableEdges n p | n <= 0 = p@@ -613,10 +597,7 @@ (pAccess p $ idx+1, pAccess p idx) `elem` immutableEdges worker idx | idx == longestEdge && not (isImmutable idx) =- let start = pAccess p idx- end = pAccess p $ idx+1- middle = lerp 0.5 end start- in [start, middle]+ [pAccess p idx, pMiddlePoint p idx] | otherwise = [pAccess p idx] longestEdge = maximumBy cmpLength [0 .. pSize p-1] cmpLength a _ | isImmutable a = LT@@ -625,6 +606,10 @@ distSquared (pAccess p a) (pAccess p $ a+1) `compare` distSquared (pAccess p b) (pAccess p $ b+1) +pMiddlePoint :: PolyCtx a => APolygon a -> Int -> V2 a+pMiddlePoint p idx+ = lerp 0.5 (pAccess p $ idx+1) (pAccess p idx)+ pAddPointsBetween :: PolyCtx a => (Int, Int) -> Int -> APolygon a -> APolygon a pAddPointsBetween _ n p | n <= 0 = p pAddPointsBetween (i,l) n p = pAddPointsBetween (i,l+1) (n-1) $@@ -632,10 +617,7 @@ where worker idx | idx == longestEdge =- let start = pAccess p idx- end = pAccess p $ idx+1- middle = lerp 0.5 end start- in [start, middle]+ [pAccess p idx, pMiddlePoint p idx] | otherwise = [pAccess p idx] longestEdge = maximumBy cmpLength [i .. i+l-1] cmpLength a b =@@ -796,6 +778,3 @@ in if a /= b then (l, a) : (b, pAccess p yO) : go (pAccess p yO) (y:xs) else go l (y:xs)--pdualPolygons :: Polygon -> PDual -> [Polygon]-pdualPolygons p pdual = map mkPolygonFromRing (pdualRings (pRing p) pdual)
src/Reanimate/Math/SSSP.hs view
@@ -1,20 +1,18 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} module Reanimate.Math.SSSP ( -- * Single-Source-Shortest-Path SSSP , sssp -- :: (Fractional a, Ord a) => Ring a -> Dual -> SSSP+ , ssspFinger , dual -- :: Int -> Triangulation -> Dual , Dual(..) , DualTree(..)- , PDual- , toPDual -- :: Ring Rational -> Dual -> PDual- , pdualRings -- :: Ring Rational -> PDual -> [Ring Rational] -- * Misc , dualToTriangulation -- :: Ring Rational -> Dual -> Triangulation- , pdualReduce -- :: Ring Rational -> PDual -> Int -> PDual , visibilityArray -- :: Ring Rational -> V.Vector [Int] , naive -- :: Ring Rational -> SSSP , naive2 -- :: Ring Rational -> SSSP@@ -22,15 +20,12 @@ ) where import Control.Monad--- import Control.Exception import Control.Monad.ST--- import Data.FingerTree (SearchResult (..), (|>))--- import qualified Data.FingerTree as F+import qualified Data.FingerTree as F import Data.Foldable import Data.List import qualified Data.Map as Map import Data.Maybe-import Data.Ord import Data.STRef import Data.Tree import qualified Data.Vector as V@@ -138,54 +133,6 @@ where visibility = visibilityArray p -data PDual = PDual (V.Vector Int) Rational [PDual]- deriving (Show)--toPDual :: Ring Rational -> Dual -> PDual-toPDual p d =- case d of- Dual (a,b,c) l r ->- PDual (V.fromList [a,b,c])- (area2X (ringAccess p a) (ringAccess p b) (ringAccess p c))- (catMaybes [ worker c a l, worker b c r])- where- worker _ _ EmptyDual = Nothing- worker a b (NodeDual x l r) = Just $- PDual (V.fromList [a,x,b])- (area2X (ringAccess p a) (ringAccess p x) (ringAccess p b))- (catMaybes [ worker x b l, worker a x r])--pdualSize :: PDual -> Int-pdualSize (PDual _ _ children) = 1 + sum (map pdualSize children)--pdualArea :: PDual -> Rational-pdualArea (PDual _ faceArea _) = faceArea---- FIXME: 'origin' isn't used. Remove.-pdualReduce :: Ring Rational -> PDual -> Int -> PDual-pdualReduce origin pdual n- | pdualSize pdual <= n = pdual- | otherwise =- let smallest = minimum $ pAreas pdual- in pdualReduce origin (merge smallest pdual) n- where- merge _s (PDual p faceArea []) = PDual p faceArea []- merge s (PDual p faceArea children)- | faceArea == s =- let (PDual p2 area2 children2:xs) = sortBy (comparing pdualArea) children- in PDual (joinP p p2) (faceArea+area2) (children2++xs)- | otherwise =- let (PDual p2 area2 children2:xs) = sortBy (comparing pdualArea) children- in if area2 == s- then PDual (joinP p p2) (faceArea+area2) (children2++xs)- else PDual p faceArea (map (merge s) children)- pAreas (PDual _ faceArea children) = faceArea : concatMap pAreas children- joinP a b = V.fromList (sort (V.toList a ++ V.toList b))--pdualRings :: Ring Rational -> PDual -> [Ring Rational]-pdualRings p (PDual pts _area children) =- ringPack (V.map (ringAccess p) pts) : concatMap (pdualRings p) children- -- Dual of triangulated polygon data Dual = Dual (Int,Int,Int) -- (a,b,c) DualTree -- borders ca@@ -248,7 +195,7 @@ dualTree t (a,b) e = -- simplifyDual $ case hasTriangle of [] -> EmptyDual- [(ab)] ->+ [ab] -> NodeDual ab (dualTree t (ab,b) a) (dualTree t (a,ab) b)@@ -260,18 +207,6 @@ next x = (x+1) `mod` n prev x = (x-1) `mod` n --- data MinMax = MinMax Int Int | MinMaxEmpty deriving (Show)--- instance Semigroup MinMax where--- MinMaxEmpty <> b = b--- a <> MinMaxEmpty = a--- MinMax a b <> MinMax c d--- = MinMax (min a c) (max b d)--- -- = MinMax c b--- instance Monoid MinMax where--- mempty = MinMaxEmpty------ instance F.Measured MinMax Int where--- measure i = MinMax i i -- dualRoot :: Dual -> Int -- dualRoot (Dual (a,_,_) _ _) = a@@ -287,8 +222,8 @@ worker [c] [b] a r ++ loopLeft a c l where- toSSSP edges =- (V.fromList . map snd . sortOn fst) edges+ toSSSP =+ V.fromList . map snd . sortOn fst loopLeft a outer l = case l of EmptyDual -> []@@ -341,3 +276,92 @@ (x, cusp::Int) : worker f1 [x] cusp l ++ worker [x] f2 cusp r++data MinMax = MinMax Int Int | MinMaxEmpty deriving (Show)+instance Semigroup MinMax where+ MinMaxEmpty <> b = b+ a <> MinMaxEmpty = a+ MinMax a _b <> MinMax _c d+ = MinMax a d+instance Monoid MinMax where+ mempty = MinMaxEmpty++type Chain = F.FingerTree MinMax Int+data Funnel = Funnel+ { funnelLeft :: Chain+ , funnelCusp :: Int+ , funnelRight :: Chain+ }++instance F.Measured MinMax Int where+ measure i = MinMax i i++splitFunnel :: (Epsilon a, Fractional a, Ord a) => Ring a -> Int -> Funnel -> (Int, Funnel, Funnel)+splitFunnel p x Funnel{..}+ | isOnLeftChain =+ case doSearch isRightTurn funnelLeft of+ (lower, t, upper) ->+ ( t+ , Funnel upper t (F.singleton x)+ , Funnel (lower F.|> t F.|> x) funnelCusp funnelRight)+ | isOnRightChain =+ case doSearch isLeftTurn funnelRight of+ (lower, t, upper) ->+ ( t+ , Funnel funnelLeft funnelCusp (lower F.|> t F.|> x)+ , Funnel (F.singleton x) t upper)+ | otherwise =+ ( funnelCusp+ , Funnel funnelLeft funnelCusp (F.singleton x)+ , Funnel (F.singleton x) funnelCusp funnelRight)+ where+ isOnLeftChain = fromMaybe False $+ isLeftTurnOrLinear cuspElt <$> leftElt <*> pure targetElt+ isOnRightChain = fromMaybe False $+ isRightTurnOrLinear cuspElt <$> rightElt <*> pure targetElt+ doSearch fn chain =+ case F.search (searchChain fn) (chain::Chain) of+ F.Position lower t upper -> (lower, t, upper)+ F.OnLeft -> error "cannot happen"+ F.OnRight -> error "cannot happen"+ F.Nowhere -> error "cannot happen"+ searchChain _ MinMaxEmpty _ = False+ searchChain _ _ MinMaxEmpty = True+ searchChain check (MinMax _ l) (MinMax r _) =+ check (ringAccess p l) (ringAccess p r) targetElt+ cuspElt = ringAccess p funnelCusp+ targetElt = ringAccess p x+ leftElt = ringAccess p <$> chainLeft funnelLeft+ rightElt = ringAccess p <$> chainLeft funnelRight+ chainLeft chain =+ case F.viewl chain of+ F.EmptyL -> Nothing+ elt F.:< _ -> Just elt++-- O(n)+ssspFinger :: (Epsilon a, Fractional a, Ord a) => Ring a -> Dual -> SSSP+ssspFinger p d = toSSSP $+ case d of+ Dual (a,b,c) l r ->+ (a, a) :+ (b, a) :+ (c, a) :+ worker (Funnel (F.singleton c) a (F.singleton b)) r +++ loopLeft a c l+ where+ toSSSP =+ V.fromList . map snd . sortOn fst+ loopLeft a outer l =+ case l of+ EmptyDual -> []+ NodeDual x l' r' ->+ (x,a) :+ worker (Funnel (F.singleton x) a (F.singleton outer)) r' +++ loopLeft a x l'+ worker _ EmptyDual = []+ worker f (NodeDual x l r) =+ case splitFunnel p x f of+ (v, fL, fR) ->+ (x, v) :+ worker fL l +++ worker fR r
− src/Reanimate/Math/Visibility.hs
@@ -1,117 +0,0 @@-module Reanimate.Math.Visibility where---- import qualified Data.Set as Set-import Data.Maybe-import Linear.V2-import Reanimate.Math.Common-import Reanimate.Math.Polygon---- import Debug.Trace--visibility :: [P] -> [P]-visibility (z:v:vs) = reverse $ go z [v,z] vs-visibility _ = undefined---- visibility (z:v0:v1:rest)--- | isLeftTurn z v0 v1 = left z [v1,v0] rest--- | otherwise = scanA---- Three cases:--- v is visible: zsv is a left-turn--- v moves in front of the stack: s'sv is right turn--- v moves behind stack:-go :: (Ord a, Fractional a, Epsilon a) => V2 a -> [V2 a] -> [V2 a] -> [V2 a]-go _z stack [] = stack-go z stack@(s:s':_ss) (v:vs)- | isLeftTurn z s v = {-trace ("Left: " ++ show (z,s,v)) $ -}go z (v:stack) vs- | isLeftTurn s' s v = {-trace ("Right: " ++ show (s',s,v,vs)) $ -}rightTurn z stack v vs- | otherwise = {-trace ("FF: " ++ show (z,s,s',v)) $ -}fastForward z stack s (v:vs)-go _ _ _ = undefined--{--z: 2,2-stack: [1,1 2,6]-v: 0,1--}--rightTurn :: (Ord a, Fractional a, Epsilon a) => V2 a -> [V2 a] -> V2 a -> [V2 a] -> [V2 a]-rightTurn z stack' v (v1:vs)- | isRightTurn z v v1 = {-trace ("Double right: " ++ show (v,v1)) $ -}rightTurn z stack v1 vs- | isLeftTurn z v v1 && isRightTurn (head stack') v v1- = {-trace ("Right->Left: " ++ show (v,v1)) $ -}go z (v:stack) (v1:vs)- | otherwise- = {-trace ("Scan: " ++ show (v, stack')) $ -}scanc z stack v (v1:vs)- where- stack@(_s1:_ss) = unwindStack z stack' v (v1:vs)-rightTurn z stack v [] = unwindStack z stack v []---- scan forwards until edge intersects zv ray-scanc :: (Ord a, Fractional a, Epsilon a) => V2 a -> [V2 a] -> V2 a -> [V2 a] -> [V2 a]-scanc z stack v (v1:v2:vs)- | isBetween u (v1,v2) = -- trace ("Found: " ++ show (u, stack)) $- go z (u:stack) (v2:vs)- --rightTurn z stack u (v2:vs)- | otherwise = scanc z stack v (v2:vs)- where- Just u = rayIntersect (z,v) (v1,v2)-scanc _z stack _v _vs = stack--unwindStack :: (Ord a, Fractional a, Epsilon a) => V2 a -> [V2 a] -> V2 a -> t -> [V2 a]-unwindStack z (s1:s2:ss) v vs- | isRightTurn z s1 v && isLeftTurn z s2 v = (u:s2:ss)- | otherwise = unwindStack z (s2:ss) v vs- where- Just u = rayIntersect (z,v) (s1,s2)-unwindStack _z stack _v _vs = stack---- We've moved into shadow. There are three ways out:--- 1. Find edge that crosses zv from right to left.--- In this case, push intersection point to the stack and continue as normal.--- 2. Find edge that crosses zv from left to right and is above v--- unwind stack--- 3. Find edge that crosses zv from left to right and is below v--fastForward :: (Ord a, Fractional a, Epsilon a) => V2 a -> [V2 a] -> V2 a -> [V2 a] -> [V2 a]-fastForward z stack v (v1:v2:vs)- | isNothing i || not (isBetween u (v1, v2)) = {-trace ("FF past: " ++ show (z,v,v1,v2)) $ -}fastForward z stack v (v2:vs)- | distSquared v u > distSquared z u = {-trace ("FF skip: " ++ show (z,v,v1,v2)) $ -}fastForward z stack v (v2:vs)- | isLeftTurn z u v2 = {-trace ("FF to: " ++ show u) $ -}go z (v2:u:stack) vs- | distSquared z v < distSquared z u = {-trace ("FF unwind: " ++ show (z,v,v1,v2,u)) $ -}unwindStack z stack v2 (vs)- | otherwise = fastForward z stack v (v2:vs)- where- i = rayIntersect (z, v) (v1, v2)- Just u = rayIntersect (z, v) (v1, v2)-fastForward _z stack _v _vs = stack--{--v2: 2,1-v1: 1,1-v: 1,0--}--{--left z [] [] = finish-left z stack@(s1:s2:ss) (v1:vs)- | isLeftTurn z s1 v1- = left z (v1:stack) rest- | isRightTurn z s1 v1 && isRightTurn s2 s1 v1- = scanA- | otherwise- = right---- We've made a right turn and need to find the edge in the stack that--- intersects the zv ray.--- zv intersects the segment ab iff zav is right-turn and zbv is a left-turn.-right z [] v vs = []-right z (s1:s2:ss) v1 (v2:vs)- | isRightTurn z s1 v1 && isLeftTurn z s2 v1- = let u = lineIntersect (z,v) (s1,s2)- in if isRightTurn z v1 v2- then right- else if isLeftTurn z v1 v2 && isRightTurn- -}---- Joe and Simpson.--- vispol (z:v0:v1:vs)--- | isLeftTurn z v0 v1 = left z [v1,v0] vs--- | otherwise = scana z [v0] (v1:vs)
src/Reanimate/Morph/Common.hs view
@@ -82,8 +82,8 @@ morph :: Morph -> SVG -> SVG -> Double -> SVG morph Morph{..} src dst = \t -> case t of- -- 0 -> lowerTransformations src- -- 1 -> lowerTransformations dst+ 0 -> lowerTransformations src+ 1 -> lowerTransformations dst _ -> mkGroup [ render (genPoints t) & drawAttributes .~ genAttrs t
src/Reanimate/PolyShape.hs view
@@ -41,26 +41,35 @@ ) where import Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate')-import Control.Lens ((&), (.~), (^.))+import Control.Lens ((&), (.~), (^.)) import Data.Ext-import Data.Geometry.PlanarSubdivision (PolygonFaceData (..))-import qualified Data.Geometry.Point as Geo-import qualified Data.Geometry.Polygon as Geo-import Data.List (nub, partition, sortOn)-import qualified Data.PlaneGraph as Geo+import Data.Geometry.PlanarSubdivision (PolygonFaceData (..))+import qualified Data.Geometry.Point as Geo+import qualified Data.Geometry.Polygon as Geo+import Data.List (nub, partition, sortOn)+import qualified Data.PlaneGraph as Geo import Data.Proxy-import qualified Data.Vector as V-import Geom2D.CubicBezier.Linear (ClosedPath (..), CubicBezier (..), FillRule (..),- PathJoin (..), QuadBezier (..), arcLength,- arcLengthParam, bezierIntersection, bezierSubsegment,- closedPathCurves, closest, colinear, curvesToClosed,- evalBezier, quadToCubic, reorient, splitBezier, union,- vectorDistance)-import Graphics.SvgTree (PathCommand (..), RPoint, Tree (..), defaultSvg, pathDefinition)+import qualified Data.Vector as V+import Geom2D.CubicBezier.Linear (ClosedPath (..),+ CubicBezier (..),+ FillRule (..), PathJoin (..),+ QuadBezier (..), arcLength,+ arcLengthParam,+ bezierIntersection,+ bezierSubsegment,+ closedPathCurves, closest,+ colinear, curvesToClosed,+ evalBezier, quadToCubic,+ reorient, splitBezier, union,+ vectorDistance)+import Graphics.SvgTree (PathCommand (..), RPoint,+ Tree, defaultSvg,+ pathDefinition, pathTree) import Linear.V2 import Reanimate.Animation import Reanimate.Constants-import Reanimate.Math.Polygon (Polygon, mkPolygon, pArea, pIsCCW)+import Reanimate.Math.Polygon (Polygon, mkPolygon, pArea,+ pIsCCW) import Reanimate.Svg -- | Shape drawn by continuous line. May have overlap, may be convex.@@ -77,12 +86,12 @@ -- | Render a set of polyshapes as a single SVG path. renderPolyShapes :: [PolyShape] -> Tree renderPolyShapes pls =- PathTree $ defaultSvg & pathDefinition .~ concatMap plPathCommands pls+ pathTree $ defaultSvg & pathDefinition .~ concatMap plPathCommands pls -- | Render a polyshape as a single SVG path. renderPolyShape :: PolyShape -> Tree renderPolyShape pl =- PathTree $ defaultSvg & pathDefinition .~ plPathCommands pl+ pathTree $ defaultSvg & pathDefinition .~ plPathCommands pl -- | Render control-points of a polyshape as circles. renderPolyShapePoints :: PolyShape -> Tree@@ -138,26 +147,6 @@ then [bezierSubsegment c 0 (arcLengthParam c l polyShapeTolerance)] else c : takeLen (l-cLen) cs --- earClip :: Polygon -> Triangulation--- dual :: Triangulation -> Dual--- toPDual :: Polygon -> Dual -> PDual--- pdualReduce :: Polygon -> PDual -> Int -> PDual--- pdualPolygons :: Polygon -> PDual -> [Polygon]--- splitPolyShape :: Double -> Int -> PolyShape -> [PolyShape]--- splitPolyShape tol n poly =--- let polygon = toPolygon (plPolygonify tol poly)--- trig = triangulate $ pRing polygon--- d = dual 0 trig--- pd = toPDual (pRing polygon) d--- reduced = pdualReduce (pRing polygon) pd n--- polygons = pdualPolygons polygon reduced--- in map toPolyShape polygons--- where--- toPolygon :: [RPoint] -> Polygon--- toPolygon = mkPolygon . V.fromList . nub . map (fmap realToFrac)--- toPolyShape :: Polygon -> PolyShape--- toPolyShape = plFromPolygon . map (fmap realToFrac) . V.toList . polygonPoints- -- plPartial' :: Double -> ([RPoint], PolyShape) -> PolyShape -- plPartial' delta (seen', PolyShape (ClosedPath lst)) = -- case lst of@@ -215,7 +204,7 @@ decomposePolygon poly = [ [ V2 x y | v <- V.toList (Geo.boundaryVertices f pg)- , let Geo.Point2 x y =(pg^.Geo.vertexDataOf v) ^. Geo.location ]+ , let Geo.Point2 x y = pg^.Geo.vertexDataOf v . Geo.location ] | (f, Inside) <- V.toList (Geo.internalFaces pg) ] where
src/Reanimate/Povray.hs view
@@ -18,7 +18,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T-import Graphics.SvgTree (Tree (..))+import Graphics.SvgTree (Tree) import Reanimate.Cache import Reanimate.Constants import Reanimate.Misc
src/Reanimate/Raster.hs view
@@ -37,7 +37,6 @@ import Data.Hashable import qualified Data.Text as T import Graphics.SvgTree ( Number(..)- , Tree(..) , defaultSvg , parseSvgFile )@@ -94,7 +93,7 @@ let imgData = LBS.unpack $ Base64.encode inp return $ flipYAxis- $ ImageTree+ $ Svg.imageTree $ defaultSvg & Svg.imageWidth .~ Svg.Num width@@ -116,7 +115,7 @@ unless exists $ copyFile path target return $ flipYAxis- $ ImageTree+ $ Svg.imageTree $ defaultSvg & Svg.imageWidth .~ Svg.Num width@@ -194,7 +193,7 @@ -- path = "/tmp" </> show (hash png) <.> "png" embedPng w h png = flipYAxis- $ ImageTree+ $ Svg.imageTree $ defaultSvg & Svg.imageCornerUpperLeft .~ (Svg.Num (-w / 2), Svg.Num (-h / 2))
src/Reanimate/Render.hs view
@@ -63,15 +63,15 @@ renderSvgs folder offset _prettyPrint ani = do print frameCount lock <- newMVar ()- handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do let nth = (nth'+offset) `mod` frameCount now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth frame = frameAt (if frameCount <= 1 then 0 else now) ani- svg = renderSvg Nothing Nothing frame path = folder </> show nth <.> "svg"+ ~svg = renderSvg Nothing Nothing frame - idempotentFile path $ writeFile path svg+ idempotentFile path $+ writeFile path svg withMVar lock $ \_ -> do print nth hFlush stdout
src/Reanimate/Scene.hs view
@@ -1,1226 +1,156 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-|-Module : Reanimate.Scene-Copyright : Written by David Himmelstrup-License : Unlicense-Maintainer : lemmih@gmail.com-Stability : experimental-Portability : POSIX--Scenes are an imperative way of defining animations.---}-module Reanimate.Scene- ( -- * Scenes- Scene- , ZIndex- , scene -- :: (forall s. Scene s a) -> Animation- , sceneAnimation -- :: (forall s. Scene s a) -> Animation- , play -- :: Animation -> Scene s ()- , fork -- :: Scene s a -> Scene s a- , queryNow -- :: Scene s Time- , wait -- :: Duration -> Scene s ()- , waitUntil -- :: Time -> Scene s ()- , waitOn -- :: Scene s a -> Scene s a- , adjustZ -- :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a- , withSceneDuration -- :: Scene s () -> Scene s Duration- -- * Variables- , Var- , newVar -- :: a -> Scene s (Var s a)- , readVar -- :: Var s a -> Scene s a- , writeVar -- :: Var s a -> a -> Scene s ()- , modifyVar -- :: Var s a -> (a -> a) -> Scene s ()- , tweenVar -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()- , tweenVarUnclamped -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()- , simpleVar -- :: (a -> SVG) -> a -> Scene s (Var s a)- , findVar -- :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)- -- * Sprites- , Sprite- , Frame- , unVar -- :: Var s a -> Frame s a- , spriteT -- :: Frame s Time- , spriteDuration -- :: Frame s Duration- , newSprite -- :: Frame s SVG -> Scene s (Sprite s)- , newSprite_ -- :: Frame s SVG -> Scene s ()- , newSpriteA -- :: Animation -> Scene s (Sprite s)- , newSpriteA' -- :: Sync -> Animation -> Scene s (Sprite s)- , newSpriteSVG -- :: SVG -> Scene s (Sprite s)- , newSpriteSVG_ -- :: SVG -> Scene s ()- , destroySprite -- :: Sprite s -> Scene s ()- , applyVar -- :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s ()- , spriteModify -- :: Sprite s -> Frame s ((SVG,ZIndex) -> (SVG, ZIndex)) -> Scene s ()- , spriteMap -- :: Sprite s -> (SVG -> SVG) -> Scene s ()- , spriteTween -- :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()- , spriteVar -- :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)- , spriteE -- :: Sprite s -> Effect -> Scene s ()- , spriteZ -- :: Sprite s -> ZIndex -> Scene s ()- , spriteScope -- :: Scene s a -> Scene s a-- -- * Object API- , Object- , ObjectData- , oNew- , newObject- , oModify- , oModifyS- , oRead- , oTween- , oTweenS- , oTweenV- , oTweenVS- , Renderable(..)- -- ** Object Properties- , oTranslate- , oSVG- , oContext- , oMargin- , oMarginTop- , oMarginRight- , oMarginBottom- , oMarginLeft- , oBB- , oBBMinX- , oBBMinY- , oBBWidth- , oBBHeight- , oOpacity- , oShown- , oZIndex- , oEasing- , oScale- , oScaleOrigin- , oTopY- , oBottomY- , oLeftX- , oRightX- , oCenterXY- , oValue-- -- ** Graphics object methods- , oShow- , oHide- , oFadeIn- , oFadeOut- , oGrow- , oShrink- , oTransform-- -- ** Pre-defined objects- , Circle(..)- , circleRadius- , Rectangle(..)- , rectWidth- , rectHeight- , Morph(..)- , morphDelta- , morphSrc- , morphDst- , Camera(..)- , cameraAttach- , cameraFocus- , cameraSetZoom- , cameraZoom- , cameraSetPan- , cameraPan-- -- * ST internals- , liftST- , transitionO- , evalScene- )-where--import Control.Lens-import Control.Monad (void)-import Control.Monad.Fix-import Control.Monad.ST-import Control.Monad.State (execState, State)-import Data.List-import Data.STRef-import Graphics.SvgTree (Tree (None))-import Reanimate.Animation-import Reanimate.Ease (Signal, curveS, fromToS)-import Reanimate.Effect-import Reanimate.Svg.Constructors-import Reanimate.Svg.BoundingBox-import Reanimate.Transition-import Reanimate.Morph.Common (morph)-import Reanimate.Morph.Linear (linear)---- | The ZIndex property specifies the stack order of sprites and animations. Elements--- with a higher ZIndex will be drawn on top of elements with a lower index.-type ZIndex = Int----- (seq duration, par duration)--- [(Time, Animation, ZIndex)]--- Map Time [(Animation, ZIndex)]-type Gen s = ST s (Duration -> Time -> (SVG, ZIndex))--- | A 'Scene' represents a sequence of animations and variables--- that change over time.-newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, [Gen s]) }--instance Functor (Scene s) where- fmap f action = M $ \t -> do- (a, d1, d2, gens) <- unM action t- return (f a, d1, d2, gens)--instance Applicative (Scene s) where- pure a = M $ \_ -> return (a, 0, 0, [])- f <*> g = M $ \t -> do- (f', s1, p1, gen1) <- unM f t- (g', s2, p2, gen2) <- unM g (t + s1)- return (f' g', s1 + s2, max p1 (s1 + p2), gen1 ++ gen2)--instance Monad (Scene s) where- return = pure- f >>= g = M $ \t -> do- (a, s1, p1, gen1) <- unM f t- (b, s2, p2, gen2) <- unM (g a) (t + s1)- return (b, s1 + s2, max p1 (s1 + p2), gen1 ++ gen2)--instance MonadFix (Scene s) where- mfix fn = M $ \t -> mfix (\v -> let (a, _s, _p, _gens) = v in unM (fn a) t)---- | Lift an ST action into the Scene monad.-liftST :: ST s a -> Scene s a-liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, [])---- | Evaluate the value of a scene.-evalScene :: (forall s . Scene s a) -> a-evalScene action = runST $ do- (val, _, _ , _) <- unM action 0- return val---- | Render a 'Scene' to an 'Animation'.-scene :: (forall s . Scene s a) -> Animation-scene = sceneAnimation---- | Render a 'Scene' to an 'Animation'.-sceneAnimation :: (forall s . Scene s a) -> Animation-sceneAnimation action = runST- (do- (_, s, p, gens) <- unM action 0- let dur = max s p- genFns <- sequence gens- return $ mkAnimation- dur- (\t -> mkGroup $ map fst $ sortOn- snd- [ spriteRender dur (t * dur) | spriteRender <- genFns ]- )- )---- | Execute actions in a scene without advancing the clock. Note that scenes do not end before--- all forked actions have completed.------ Example:------ @--- do 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'--- 'play' 'Reanimate.Builtin.Documentation.drawCircle'--- @------ <<docs/gifs/doc_fork.gif>>-fork :: Scene s a -> Scene s a-fork (M action) = M $ \t -> do- (a, s, p, gens) <- action t- return (a, 0, max s p, gens)---- | Play an animation once and then remove it. This advances the clock by the duration of the--- animation.------ Example:------ @--- do 'play' 'Reanimate.Builtin.Documentation.drawBox'--- 'play' 'Reanimate.Builtin.Documentation.drawCircle'--- @------ <<docs/gifs/doc_play.gif>>-play :: Animation -> Scene s ()-play ani = newSpriteA ani >>= destroySprite---- | Query the current clock timestamp.------ Example:------ @--- do now \<- 'play' 'Reanimate.Builtin.Documentation.drawCircle' *\> 'queryNow'--- 'play' $ 'staticFrame' 1 $ 'scale' 2 $ 'withStrokeWidth' 0.05 $--- 'mkText' $ "Now=" <> T.pack (show now)--- @------ <<docs/gifs/doc_queryNow.gif>>-queryNow :: Scene s Time-queryNow = M $ \t -> return (t, 0, 0, [])---- | Advance the clock by a given number of seconds.------ Example:------ @--- do 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'--- 'wait' 1--- 'play' 'Reanimate.Builtin.Documentation.drawCircle'--- @------ <<docs/gifs/doc_wait.gif>>-wait :: Duration -> Scene s ()-wait d = M $ \_ -> return ((), d, 0, [])---- | Wait until the clock is equal to the given timestamp.-waitUntil :: Time -> Scene s ()-waitUntil tNew = do- now <- queryNow- wait (max 0 (tNew - now))---- | Wait until all forked and sequential animations have finished.------ Example:------ @--- do 'waitOn' $ 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'--- 'play' 'Reanimate.Builtin.Documentation.drawCircle'--- @------ <<docs/gifs/doc_waitOn.gif>>-waitOn :: Scene s a -> Scene s a-waitOn (M action) = M $ \t -> do- (a, s, p, gens) <- action t- return (a, max s p, 0, gens)---- | Change the ZIndex of a scene.-adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a-adjustZ fn (M action) = M $ \t -> do- (a, s, p, gens) <- action t- return (a, s, p, map genFn gens)- where- genFn gen = do- frameGen <- gen- return $ \d t -> let (svg, z) = frameGen d t in (svg, fn z)---- | Query the duration of a scene.-withSceneDuration :: Scene s () -> Scene s Duration-withSceneDuration s = do- t1 <- queryNow- s- t2 <- queryNow- return (t2 - t1)--addGen :: Gen s -> Scene s ()-addGen gen = M $ \_ -> return ((), 0, 0, [gen])---- | Time dependent variable.-newtype Var s a = Var (STRef s (Time -> a))---- | Create a new variable with a default value.--- Variables always have a defined value even if they are read at a timestamp that is--- earlier than when the variable was created. For example:------ @--- do v \<- 'fork' ('wait' 10 \>\> 'newVar' 0) -- Create a variable at timestamp '10'.--- 'readVar' v -- Read the variable at timestamp '0'.--- -- The value of the variable will be '0'.--- @-newVar :: a -> Scene s (Var s a)-newVar def = Var <$> liftST (newSTRef (const def))---- | Read the value of a variable at the current timestamp.-readVar :: Var s a -> Scene s a-readVar (Var ref) = liftST (readSTRef ref) <*> queryNow---- | Write the value of a variable at the current timestamp.------ Example:------ @--- do v \<- 'newVar' 0--- 'newSprite' $ 'mkCircle' \<$\> 'unVar' v--- 'writeVar' v 1; 'wait' 1--- 'writeVar' v 2; 'wait' 1--- 'writeVar' v 3; 'wait' 1--- @------ <<docs/gifs/doc_writeVar.gif>>-writeVar :: Var s a -> a -> Scene s ()-writeVar var val = modifyVar var (const val)---- | Modify the value of a variable at the current timestamp and all future timestamps.-modifyVar :: Var s a -> (a -> a) -> Scene s ()-modifyVar (Var ref) fn = do- now <- queryNow- liftST $ modifySTRef ref $ \prev t -> if t < now then prev t else fn (prev t)---- | Modify a variable between @now@ and @now+duration@.--- Note: The modification function is invoked for past timestamps (with a time value of 0) and--- for timestamps after @now+duration@ (with a time value of 1). See 'tweenVarUnclamped'.-tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()-tweenVar (Var ref) dur fn = do- now <- queryNow- liftST $ modifySTRef ref $ \prev t ->- if t < now- then prev t- else fn (prev t) (max 0 (min dur $ t - now) / dur)- wait dur---- | Modify a variable between @now@ and @now+duration@.--- Note: The modification function is invoked for past timestamps (with a negative time value) and--- for timestamps after @now+duration@ (with a time value greater than 1).-tweenVarUnclamped :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()-tweenVarUnclamped (Var ref) dur fn = do- now <- queryNow- liftST $ modifySTRef ref $ \prev t -> fn (prev t) ((t - now) / dur)- wait dur---- | Create and render a variable. The rendering will be born at the current timestamp--- and will persist until the end of the scene.------ Example:------ @--- do var \<- 'simpleVar' 'mkCircle' 0--- 'tweenVar' var 2 $ \val -> 'fromToS' val ('Reanimate.Constants.screenHeight'/2)--- @------ <<docs/gifs/doc_simpleVar.gif>>-simpleVar :: (a -> SVG) -> a -> Scene s (Var s a)-simpleVar render def = do- v <- newVar def- _ <- newSprite $ render <$> unVar v- return v---- | Helper function for filtering variables.-findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)-findVar _cond [] = error "Variable not found."-findVar cond (v : vs) = do- val <- readVar v- if cond val then return v else findVar cond vs---- | Sprites are animations with a given time of birth as well as a time of death.--- They can be controlled using variables, tweening, and effects.-data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex))))---- | Sprite frame generator. Generates frames over time in a stateful environment.-newtype Frame s a = Frame { unFrame :: ST s (Time -> Duration -> Time -> a) }--instance Functor (Frame s) where- fmap fn (Frame gen) = Frame $ do- m <- gen- return (\real_t d t -> fn $ m real_t d t)--instance Applicative (Frame s) where- pure v = Frame $ return (\_ _ _ -> v)- Frame f <*> Frame g = Frame $ do- m1 <- f- m2 <- g- return $ \real_t d t -> m1 real_t d t (m2 real_t d t)---- | Dereference a variable as a Sprite frame.------ Example:------ @--- do v \<- 'newVar' 0--- 'newSprite' $ 'mkCircle' \<$\> 'unVar' v--- 'tweenVar' v 1 $ \val -> 'fromToS' val 3--- 'tweenVar' v 1 $ \val -> 'fromToS' val 0--- @------ <<docs/gifs/doc_unVar.gif>>-unVar :: Var s a -> Frame s a-unVar (Var ref) = Frame $ do- fn <- readSTRef ref- return $ \real_t _d _t -> fn real_t----- | Dereference seconds since sprite birth.-spriteT :: Frame s Time-spriteT = Frame $ return (\_real_t _d t -> t)---- | Dereference duration of the current sprite.-spriteDuration :: Frame s Duration-spriteDuration = Frame $ return (\_real_t d _t -> d)---- | Create new sprite defined by a frame generator. Unless otherwise specified using--- 'destroySprite', the sprite will die at the end of the scene.------ Example:------ @--- do 'newSprite' $ 'mkCircle' \<$\> 'spriteT' -- Circle sprite where radius=time.--- 'wait' 2--- @------ <<docs/gifs/doc_newSprite.gif>>-newSprite :: Frame s SVG -> Scene s (Sprite s)-newSprite render = do- now <- queryNow- ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0))- addGen $ do- fn <- unFrame render- (spriteDur, spriteEffectGen) <- readSTRef ref- spriteEffect <- spriteEffectGen- return $ \d absT ->- let relD = (if spriteDur < 0 then d else spriteDur) - now- relT = absT - now- -- Sprite is live [now;duration[- -- If we're at the end of a scene, sprites- -- are live: [now;duration]- -- This behavior is difficult to get right. See the 'bug_*' examples for- -- automated tests.- inTimeSlice = relT >= 0 && relT < relD- isLastFrame = d==absT && relT == relD- in if inTimeSlice || isLastFrame- then spriteEffect relD relT (fn absT relD relT)- else (None, 0)- return $ Sprite now ref---- | Create new sprite defined by a frame generator. The sprite will die at--- the end of the scene.-newSprite_ :: Frame s SVG -> Scene s ()-newSprite_ = void . newSprite---- | Create a new sprite from an animation. This advances the clock by the--- duration of the animation. Unless otherwise specified using--- 'destroySprite', the sprite will die at the end of the scene.------ Note: If the scene doesn't end immediately after the duration of the--- animation, the animation will be stretched to match the lifetime of the--- sprite. See 'newSpriteA'' and 'play'.------ Example:------ @--- do 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'--- 'play' 'Reanimate.Builtin.Documentation.drawBox'--- 'play' $ 'reverseA' 'Reanimate.Builtin.Documentation.drawBox'--- @------ <<docs/gifs/doc_newSpriteA.gif>>-newSpriteA :: Animation -> Scene s (Sprite s)-newSpriteA = newSpriteA' SyncStretch---- | Create a new sprite from an animation and specify the synchronization policy. This advances--- the clock by the duration of the animation.------ Example:------ @--- do 'fork' $ 'newSpriteA'' 'SyncFreeze' 'Reanimate.Builtin.Documentation.drawCircle'--- 'play' 'Reanimate.Builtin.Documentation.drawBox'--- 'play' $ 'reverseA' 'Reanimate.Builtin.Documentation.drawBox'--- @------ <<docs/gifs/doc_newSpriteA'.gif>>-newSpriteA' :: Sync -> Animation -> Scene s (Sprite s)-newSpriteA' sync animation =- newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration)- <* wait (duration animation)---- | Create a sprite from a static SVG image.------ Example:------ @--- do 'newSpriteSVG' $ 'mkBackground' "lightblue"--- 'play' 'Reanimate.Builtin.Documentation.drawCircle'--- @------ <<docs/gifs/doc_newSpriteSVG.gif>>-newSpriteSVG :: SVG -> Scene s (Sprite s)-newSpriteSVG = newSprite . pure---- | Create a permanent sprite from a static SVG image. Same as `newSpriteSVG`--- but the sprite isn't returned and thus cannot be destroyed.-newSpriteSVG_ :: SVG -> Scene s ()-newSpriteSVG_ = void . newSpriteSVG---- | Change the rendering of a sprite using data from a variable. If data from several variables--- is needed, use a frame generator instead.------ Example:------ @--- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawBox'--- v \<- 'newVar' 0--- 'applyVar' v s 'rotate'--- 'tweenVar' v 2 $ \val -> 'fromToS' val 90--- @------ <<docs/gifs/doc_applyVar.gif>>-applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s ()-applyVar var sprite fn = spriteModify sprite $ do- varFn <- unVar var- return $ \(svg, zindex) -> (fn varFn svg, zindex)---- | Destroy a sprite, preventing it from being rendered in the future of the scene.--- If 'destroySprite' is invoked multiple times, the earliest time-of-death is used.------ Example:------ @--- do s <- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'mkCircle' 1--- 'fork' $ 'wait' 1 \>\> 'destroySprite' s--- 'play' 'Reanimate.Builtin.Documentation.drawBox'--- @------ <<docs/gifs/doc_destroySprite.gif>>-destroySprite :: Sprite s -> Scene s ()-destroySprite (Sprite _ ref) = do- now <- queryNow- liftST $ modifySTRef ref $ \(ttl, render) ->- (if ttl < 0 then now else min ttl now, render)---- | Low-level frame modifier.-spriteModify :: Sprite s -> Frame s ((SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s ()-spriteModify (Sprite born ref) modFn = liftST $ modifySTRef ref $ \(ttl, renderGen) ->- ( ttl- , do- render <- renderGen- modRender <- unFrame modFn- return $ \relD relT ->- let absT = relT + born in modRender absT relD relT . render relD relT- )---- | Map the SVG output of a sprite.------ Example:------ @--- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'--- 'wait' 1--- 'spriteMap' s 'flipYAxis'--- @------ <<docs/gifs/doc_spriteMap.gif>>-spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s ()-spriteMap sprite@(Sprite born _) fn = do- now <- queryNow- let tDelta = now - born- spriteModify sprite $ do- t <- spriteT- return $ \(svg, zindex) -> (if (t - tDelta) < 0 then svg else fn svg, zindex)---- | Modify the output of a sprite between @now@ and @now+duration@.------ Example:------ @--- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'--- 'spriteTween' s 1 $ \val -> 'translate' ('Reanimate.Constants.screenWidth'*0.3*val) 0--- @------ <<docs/gifs/doc_spriteTween.gif>>-spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()-spriteTween sprite@(Sprite born _) dur fn = do- now <- queryNow- let tDelta = now - born- spriteModify sprite $ do- t <- spriteT- return $ \(svg, zindex) -> (fn (clamp 0 1 $ (t - tDelta) / dur) svg, zindex)- wait dur- where- clamp a b v | v < a = a- | v > b = b- | otherwise = v---- | Create a new variable and apply it to a sprite.------ Example:------ @--- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawBox'--- v \<- 'spriteVar' s 0 'rotate'--- 'tweenVar' v 2 $ \val -> 'fromToS' val 90--- @------ <<docs/gifs/doc_spriteVar.gif>>-spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)-spriteVar sprite def fn = do- v <- newVar def- applyVar v sprite fn- return v---- | Apply an effect to a sprite.------ Example:------ @--- do s <- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'--- 'spriteE' s $ 'overBeginning' 1 'fadeInE'--- 'spriteE' s $ 'overEnding' 0.5 'fadeOutE'--- @------ <<docs/gifs/doc_spriteE.gif>>-spriteE :: Sprite s -> Effect -> Scene s ()-spriteE (Sprite born ref) effect = do- now <- queryNow- liftST $ modifySTRef ref $ \(ttl, renderGen) ->- ( ttl- , do- render <- renderGen- return $ \d t svg ->- let (svg', z) = render d t svg- in (delayE (max 0 $ now - born) effect d t svg', z)- )---- | Set new ZIndex of a sprite.------ Example:------ @--- do s1 \<- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'withFillColor' "blue" $ 'mkCircle' 3--- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'withFillColor' "red" $ 'mkRect' 8 3--- 'wait' 1--- 'spriteZ' s1 1--- 'wait' 1--- @------ <<docs/gifs/doc_spriteZ.gif>>-spriteZ :: Sprite s -> ZIndex -> Scene s ()-spriteZ (Sprite born ref) zindex = do- now <- queryNow- liftST $ modifySTRef ref $ \(ttl, renderGen) ->- ( ttl- , do- render <- renderGen- return $ \d t svg ->- let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex)- )---- | Destroy all local sprites at the end of a scene.------ Example:------ @--- do -- the rect lives through the entire 3s animation--- 'newSpriteSVG_' $ 'translate' (-3) 0 $ 'mkRect' 4 4--- 'wait' 1--- 'spriteScope' $ do--- -- the circle only lives for 1 second.--- local \<- 'newSpriteSVG' $ 'translate' 3 0 $ 'mkCircle' 2--- 'spriteE' local $ 'overBeginning' 0.3 'fadeInE'--- 'spriteE' local $ 'overEnding' 0.3 'fadeOutE'--- 'wait' 1--- 'wait' 1--- @------ <<docs/gifs/doc_spriteScope.gif>>-spriteScope :: Scene s a -> Scene s a-spriteScope (M action) = M $ \t -> do- (a, s, p, gens) <- action t- return (a, s, p, map (genFn (t+max s p)) gens)- where- genFn maxT gen = do- frameGen <- gen- return $ \_ t ->- if t < maxT- then frameGen maxT t- else (None, 0)--asAnimation :: (forall s'. Scene s' a) -> Scene s Animation-asAnimation s = do- now <- queryNow- return $ dropA now (sceneAnimation (wait now >> s))---- | Apply a transformation with a given overlap. This makes sure--- to keep timestamps intact such that events can still be timed--- by transcripts.-transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s ()-transitionO t o a b = do- aA <- asAnimation a- bA <- fork $ do- wait (duration aA - o)- asAnimation b- play $ overlapT o t aA bA--------------------------------------------------------------- Objects---- | Objects can be any Haskell structure as long as it can be rendered to SVG.-class Renderable a where- toSVG :: a -> SVG--instance Renderable Tree where- toSVG = id---- | Objects are SVG nodes (represented as Haskell values) with--- identity, location, and several other properties that can--- change over time.-data Object s a = Object- { objectSprite :: Sprite s- , objectData :: Var s (ObjectData a)- }---- | Container for object properties.-data ObjectData a = ObjectData- { _oTranslate :: (Double, Double)- , _oValueRef :: a- , _oSVG :: SVG- , _oContext :: SVG -> SVG- , _oMargin :: (Double, Double, Double, Double)- -- ^ Top, right, bottom, left- , _oBB :: (Double,Double,Double,Double)- , _oOpacity :: Double- , _oShown :: Bool- , _oZIndex :: Int- , _oEasing :: Signal- , _oScale :: Double- , _oScaleOrigin :: (Double, Double)- }---- Basic lenses---- FIXME: Maybe 'position' is a better name.--- | Object position. Default: \<0,0\>-oTranslate :: Lens' (ObjectData a) (Double, Double)-oTranslate = lens _oTranslate $ \obj val -> obj { _oTranslate = val }---- | Rendered SVG node of an object. Does not include context--- or object properties. Read-only.-oSVG :: Getter (ObjectData a) SVG-oSVG = to _oSVG---- | Custom render context. Is applied to the object for every--- frame that it is shown.-oContext :: Lens' (ObjectData a) (SVG -> SVG)-oContext = lens _oContext $ \obj val -> obj { _oContext = val }---- | Object margins (top, right, bottom, left) in local units.-oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double)-oMargin = lens _oMargin $ \obj val -> obj { _oMargin = val }---- | Object bounding-box (minimal X-coordinate, minimal Y-coordinate,--- width, height). Uses `Reanimate.Svg.BoundingBox.boundingBox`--- and has the same limitations.-oBB :: Getter (ObjectData a) (Double, Double, Double, Double)-oBB = to _oBB---- | Object opacity. Default: 1-oOpacity :: Lens' (ObjectData a) Double-oOpacity = lens _oOpacity $ \obj val -> obj { _oOpacity = val }---- | Toggle for whether or not the object should be rendered.--- Default: False-oShown :: Lens' (ObjectData a) Bool-oShown = lens _oShown $ \obj val -> obj { _oShown = val }---- | Object's z-index.-oZIndex :: Lens' (ObjectData a) Int-oZIndex = lens _oZIndex $ \obj val -> obj { _oZIndex = val }---- | Easing function used when modifying object properties.--- Default: @'Reanimate.Ease.curveS' 2@-oEasing :: Lens' (ObjectData a) Signal-oEasing = lens _oEasing $ \obj val -> obj { _oEasing = val }---- | Object's scale. Default: 1-oScale :: Lens' (ObjectData a) Double-oScale = lens _oScale $ \obj val -> obj { _oScale = val }---- | Origin point for scaling. Default: \<0,0\>-oScaleOrigin :: Lens' (ObjectData a) (Double, Double)-oScaleOrigin = lens _oScaleOrigin $ \obj val -> obj { _oScaleOrigin = val }---- Smart lenses---- | Lens for the source value contained in an object.-oValue :: Renderable a => Lens' (ObjectData a) a-oValue = lens _oValueRef $ \obj newVal ->- let svg = toSVG newVal- in obj- { _oValueRef = newVal- , _oSVG = svg- , _oBB = boundingBox svg }---- | Derived location of the top-most point of an object + margin.-oTopY :: Lens' (ObjectData a) Double-oTopY = lens getter setter- where- getter obj = - let top = obj ^. oMarginTop- miny = obj ^. oBBMinY- h = obj ^. oBBHeight- dy = obj ^. oTranslate . _2- in dy+miny+h+top- setter obj val =- obj & (oTranslate . _2) +~ val-getter obj---- | Derived location of the bottom-most point of an object + margin.-oBottomY :: Lens' (ObjectData a) Double-oBottomY = lens getter setter- where- getter obj = - let bot = obj ^. oMarginBottom- miny = obj ^. oBBMinY- dy = obj ^. oTranslate . _2- in dy+miny-bot- setter obj val = - obj & (oTranslate . _2) +~ val-getter obj---- | Derived location of the left-most point of an object + margin.-oLeftX :: Lens' (ObjectData a) Double-oLeftX = lens getter setter- where- getter obj =- let left = obj ^. oMarginLeft- minx = obj ^. oBBMinX- dx = obj ^. oTranslate . _1- in dx+minx-left- setter obj val =- obj & (oTranslate . _1) +~ val-getter obj---- | Derived location of the right-most point of an object + margin.-oRightX :: Lens' (ObjectData a) Double-oRightX = lens getter setter- where- getter obj =- let right = obj ^. oMarginRight- minx = obj ^. oBBMinX- w = obj ^. oBBWidth- dx = obj ^. oTranslate . _1- in dx+minx+w+right- setter obj val =- obj & (oTranslate . _1) +~ val-getter obj---- | Derived location of an object's center point.-oCenterXY :: Lens' (ObjectData a) (Double, Double)-oCenterXY = lens getter setter- where- getter obj =- let minx = obj ^. oBBMinX- miny = obj ^. oBBMinY- w = obj ^. oBBWidth- h = obj ^. oBBHeight- (dx,dy) = obj ^. oTranslate- in (dx+minx+w/2, dy+miny+h/2)- setter obj (dx, dy) =- let (x,y) = getter obj in- obj & (oTranslate . _1) +~ dx-x- & (oTranslate . _2) +~ dy-y---- | Object's top margin.-oMarginTop :: Lens' (ObjectData a) Double-oMarginTop = oMargin . _1---- | Object's right margin.-oMarginRight :: Lens' (ObjectData a) Double-oMarginRight = oMargin . _2---- | Object's bottom margin.-oMarginBottom :: Lens' (ObjectData a) Double-oMarginBottom = oMargin . _3---- | Object's left margin.-oMarginLeft :: Lens' (ObjectData a) Double-oMarginLeft = oMargin . _4---- | Object's minimal X-coordinate..-oBBMinX :: Getter (ObjectData a) Double-oBBMinX = oBB . _1---- | Object's minimal Y-coordinate..-oBBMinY :: Getter (ObjectData a) Double-oBBMinY = oBB . _2---- | Object's width without margin.-oBBWidth :: Getter (ObjectData a) Double-oBBWidth = oBB . _3---- | Object's height without margin.-oBBHeight :: Getter (ObjectData a) Double-oBBHeight = oBB . _4------------------------------------------------------------------------------------ Object modifiers---- | Modify object properties.-oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s ()-oModify o fn = modifyVar (objectData o) fn---- | Modify object properties using a stateful API.-oModifyS :: Object s a -> (State (ObjectData a) b) -> Scene s ()-oModifyS o fn = oModify o (execState fn)---- | Query object property.-oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b-oRead o l = view l <$> readVar (objectData o)---- | Modify object properties over a set duration.-oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s ()-oTween o d fn = do- -- Read 'easing' var here instead of taking it from 'v'.- -- This allows different easing functions even at the same timestamp.- ease <- oRead o oEasing- tweenVar (objectData o) d (\v t -> fn (ease t) v)---- | Modify object properties over a set duration using a stateful API.-oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s ()-oTweenS o d fn = oTween o d (\t -> execState (fn t))---- | Modify object value over a set duration. This is a convenience function--- for modifying `oValue`.-oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s ()-oTweenV o d fn = oTween o d (\t -> oValue %~ fn t)---- | Modify object value over a set duration using a stateful API. This is a--- convenience function for modifying `oValue`.-oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s ()-oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t))---- | Create new object.-oNew :: Renderable a => a -> Scene s (Object s a)-oNew = newObject---- | Create new object.-newObject :: Renderable a => a -> Scene s (Object s a)-newObject val = do- ref <- newVar ObjectData- { _oTranslate = (0,0)- , _oValueRef = val- , _oSVG = svg- , _oContext = id- , _oMargin = (0.5,0.5,0.5,0.5)- , _oBB = boundingBox svg- , _oOpacity = 1- , _oShown = False- , _oZIndex = 1- , _oEasing = curveS 2- , _oScale = 1- , _oScaleOrigin = (0,0)- }- sprite <- newSprite $ do- ~ObjectData{..} <- unVar ref- pure $- if _oShown- then- uncurry translate _oTranslate $- uncurry translate (_oScaleOrigin & both %~ negate) $- scale _oScale $- uncurry translate _oScaleOrigin $- withGroupOpacity _oOpacity $- _oContext _oSVG- else None- spriteModify sprite $ do- ~ObjectData{_oZIndex=z} <- unVar ref- pure $ \(img,_) -> (img,z)- return Object- { objectSprite = sprite- , objectData = ref }- where- svg = toSVG val------------------------------------------------------------------------------------ Graphical transformations---- | Instantly show object.-oShow :: Object s a -> Scene s ()-oShow o = oModify o $ oShown .~ True---- | Instantly hide object.-oHide :: Object s a -> Scene s ()-oHide o = oModify o $ oShown .~ False---- | Fade in object over a set duration.-oFadeIn :: Object s a -> Duration -> Scene s ()-oFadeIn o d = do- oModify o $ - oShown .~ True- oTweenS o d $ \t ->- oOpacity *= t---- | Fade out object over a set duration.-oFadeOut :: Object s a -> Duration -> Scene s ()-oFadeOut o d = do- oModify o $ - oShown .~ True- oTweenS o d $ \t ->- oOpacity *= 1-t---- | Scale in object over a set duration.-oGrow :: Object s a -> Duration -> Scene s ()-oGrow o d = do- oModify o $ - oShown .~ True- oTweenS o d $ \t ->- oScale *= t---- | Scale out object over a set duration.-oShrink :: Object s a -> Duration -> Scene s ()-oShrink o d =- oTweenS o d $ \t ->- oScale *= 1-t---- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'.--- | Morph source object into target object over a set duration.-oTransform :: Object s a -> Object s b -> Duration -> Scene s ()-oTransform src dst d = do- srcSvg <- oRead src oSVG- srcCtx <- oRead src oContext- srcEase <- oRead src oEasing- srcLoc <- oRead src oTranslate- oModify src $ oShown .~ False- - dstSvg <- oRead dst oSVG- dstCtx <- oRead dst oContext- dstLoc <- oRead dst oTranslate-- m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg)- oModifyS m $ do- oShown .= True- oEasing .= srcEase- oTranslate .= srcLoc- fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc- oTweenV m d $ \t -> morphDelta .~ t- oModify m $ oShown .~ False- oModify dst $ oShown .~ True- where- moveTo t (dstX, dstY) (srcX, srcY) =- (fromToS srcX dstX t, fromToS srcY dstY t)------------------------------------------------------------------------------------- Built-in objects---- | Basic object mapping to \<circle\/\> in SVG.-newtype Circle = Circle {_circleRadius :: Double}---- | Circle radius in local units.-circleRadius :: Lens' Circle Double-circleRadius = iso _circleRadius Circle--instance Renderable Circle where- toSVG (Circle r) = mkCircle r---- | Basic object mapping to \<rect\/\> in SVG.-data Rectangle = Rectangle { _rectWidth :: Double, _rectHeight :: Double }---- | Rectangle width in local units.-rectWidth :: Lens' Rectangle Double-rectWidth = lens _rectWidth $ \obj val -> obj{_rectWidth=val}---- | Rectangle height in local units.-rectHeight :: Lens' Rectangle Double-rectHeight = lens _rectHeight $ \obj val -> obj{_rectHeight=val}--instance Renderable Rectangle where- toSVG (Rectangle w h) = mkRect w h---- | Object representing an interpolation between SVG nodes.-data Morph = Morph { _morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG }---- | Control variable for the interpolation. A value of 0 gives the--- source SVG and 1 gives the target svg.-morphDelta :: Lens' Morph Double-morphDelta = lens _morphDelta $ \obj val -> obj{_morphDelta = val}---- | Source shape.-morphSrc :: Lens' Morph SVG-morphSrc = lens _morphSrc $ \obj val -> obj{_morphSrc = val}---- | Target shape.-morphDst :: Lens' Morph SVG-morphDst = lens _morphDst $ \obj val -> obj{_morphDst = val}--instance Renderable Morph where- toSVG (Morph t src dst) = morph linear src dst t---- | Cameras can take control of objects and manipulate them--- with convenient pan and zoom operations.-data Camera = Camera-instance Renderable Camera where- toSVG Camera = None---- | Connect an object to a camera such that--- camera settings (position, zoom, and rotation) is--- applied to the object.------ Example------ @--- do cam \<- 'newObject' 'Camera'--- circ \<- 'newObject' $ 'Circle' 2--- 'oModifyS' circ $--- 'oContext' .= 'withFillOpacity' 1 . 'withFillColor' "blue"--- 'oShow' circ--- 'cameraAttach' cam circ--- 'cameraZoom' cam 1 2--- 'cameraZoom' cam 1 1--- @------ <<docs/gifs/doc_cameraAttach.gif>>-cameraAttach :: Object s Camera -> Object s a -> Scene s ()-cameraAttach cam obj =- spriteModify (objectSprite obj) $ do- camData <- unVar (objectData cam)- return $ \(svg,zindex) ->- let (x,y) = camData^.oTranslate- ctx =- translate (-x) (-y) .- uncurry translate (camData^.oScaleOrigin) .- scale (camData^.oScale) .- uncurry translate (camData^.oScaleOrigin & both %~ negate)- in (ctx svg, zindex)---- |------ Example------ @--- do cam \<- 'newObject' 'Camera'--- circ \<- 'newObject' $ 'Circle' 2; 'oShow' circ--- 'oModify' circ $ 'oTranslate' .~ (-3,0)--- box \<- 'newObject' $ 'Rectangle' 4 4; 'oShow' box--- 'oModify' box $ 'oTranslate' .~ (3,0)--- 'cameraAttach' cam circ--- 'cameraAttach' cam box--- 'cameraFocus' cam (-3,0)--- 'cameraZoom' cam 2 2 -- Zoom in--- 'cameraZoom' cam 2 1 -- Zoom out--- 'cameraFocus' cam (3,0)--- 'cameraZoom' cam 2 2 -- Zoom in--- 'cameraZoom' cam 2 1 -- Zoom out--- @------ <<docs/gifs/doc_cameraFocus.gif>>-cameraFocus :: Object s Camera -> (Double, Double) -> Scene s ()-cameraFocus cam (x,y) = do- (ox, oy) <- oRead cam oScaleOrigin- (tx, ty) <- oRead cam oTranslate- s <- oRead cam oScale- let newLocation = (x-((x-ox)*s+ox-tx), y-((y-oy)*s+oy-ty))- oModifyS cam $ do- oTranslate .= newLocation- oScaleOrigin .= (x,y)---- | Instantaneously set camera zoom level.-cameraSetZoom :: Object s Camera -> Double -> Scene s ()-cameraSetZoom cam s =- oModifyS cam $- oScale .= s---- | Change camera zoom level over a set duration.-cameraZoom :: Object s Camera -> Duration -> Double -> Scene s ()-cameraZoom cam d s =- oTweenS cam d $ \t ->- oScale %= \v -> fromToS v s t---- | Instantaneously set camera location.-cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s ()-cameraSetPan cam location =- oModifyS cam $ do- oTranslate .= location---- | Change camera location over a set duration.-cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s ()-cameraPan cam d (x,y) =- oTweenS cam d $ \t -> do- oTranslate._1 %= \v -> fromToS v x t- oTranslate._2 %= \v -> fromToS v y t+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Module : Reanimate.Scene+-- Copyright : Written by David Himmelstrup+-- License : Unlicense+-- Maintainer : lemmih@gmail.com+-- Stability : experimental+-- Portability : POSIX+--+-- Scenes are an imperative way of defining animations.+module Reanimate.Scene+ ( -- * Scenes+ Scene,+ ZIndex,+ scene, -- :: (forall s. Scene s a) -> Animation+ sceneAnimation, -- :: (forall s. Scene s a) -> Animation+ play, -- :: Animation -> Scene s ()+ fork, -- :: Scene s a -> Scene s a+ queryNow, -- :: Scene s Time+ wait, -- :: Duration -> Scene s ()+ waitUntil, -- :: Time -> Scene s ()+ waitOn, -- :: Scene s a -> Scene s a+ adjustZ, -- :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a+ withSceneDuration, -- :: Scene s () -> Scene s Duration++ -- * Variables+ Var,+ newVar, -- :: a -> Scene s (Var s a)+ readVar, -- :: Var s a -> Scene s a+ writeVar, -- :: Var s a -> a -> Scene s ()+ modifyVar, -- :: Var s a -> (a -> a) -> Scene s ()+ tweenVar, -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()+ simpleVar, -- :: (a -> SVG) -> a -> Scene s (Var s a)+ findVar, -- :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)++ -- * Sprites+ Sprite,+ Frame,+ unVar, -- :: Var s a -> Frame s a+ spriteT, -- :: Frame s Time+ spriteDuration, -- :: Frame s Duration+ newSprite, -- :: Frame s SVG -> Scene s (Sprite s)+ newSprite_, -- :: Frame s SVG -> Scene s ()+ newSpriteA, -- :: Animation -> Scene s (Sprite s)+ newSpriteA', -- :: Sync -> Animation -> Scene s (Sprite s)+ newSpriteSVG, -- :: SVG -> Scene s (Sprite s)+ newSpriteSVG_, -- :: SVG -> Scene s ()+ destroySprite, -- :: Sprite s -> Scene s ()+ applyVar, -- :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s ()+ spriteModify, -- :: Sprite s -> Frame s ((SVG,ZIndex) -> (SVG, ZIndex)) -> Scene s ()+ spriteMap, -- :: Sprite s -> (SVG -> SVG) -> Scene s ()+ spriteTween, -- :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()+ spriteVar, -- :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)+ spriteE, -- :: Sprite s -> Effect -> Scene s ()+ spriteZ, -- :: Sprite s -> ZIndex -> Scene s ()+ spriteScope, -- :: Scene s a -> Scene s a++ -- * Object API+ Object,+ ObjectData,+ oNew,+ newObject,+ oModify,+ oModifyS,+ oRead,+ oTween,+ oTweenS,+ oTweenV,+ oTweenVS,+ Renderable (..),++ -- ** Object Properties+ oTranslate,+ oSVG,+ oContext,+ oMargin,+ oMarginTop,+ oMarginRight,+ oMarginBottom,+ oMarginLeft,+ oBB,+ oBBMinX,+ oBBMinY,+ oBBWidth,+ oBBHeight,+ oOpacity,+ oShown,+ oZIndex,+ oEasing,+ oScale,+ oScaleOrigin,+ oTopY,+ oBottomY,+ oLeftX,+ oRightX,+ oCenterXY,+ oValue,++ -- ** Graphics object methods+ oShow,+ oHide,+ oFadeIn,+ oFadeOut,+ oGrow,+ oShrink,+ oTransform,+ oShowWith,+ oHideWith,+ Origin,+ oScaleIn,+ oScaleIn',+ oScaleOut,+ oScaleOut',+ oSim,+ oStagger,+ oStaggerRev,+ oStagger',+ oStaggerRev',+ oDraw,+ -- , oBalloon++ -- ** Pre-defined objects+ Circle (..),+ circleRadius,+ Rectangle (..),+ rectWidth,+ rectHeight,+ Morph (..),+ morphDelta,+ morphSrc,+ morphDst,+ Camera (..),+ cameraAttach,+ cameraFocus,+ cameraSetZoom,+ cameraZoom,+ cameraSetPan,+ cameraPan,++ -- * ST internals+ liftST,+ transitionO,+ evalScene,+ )+where++import Reanimate.Scene.Core+import Reanimate.Scene.Object+import Reanimate.Scene.Sprite+import Reanimate.Scene.Var
+ src/Reanimate/Scene/Core.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE RankNTypes #-}++module Reanimate.Scene.Core where++import Control.Monad.Fix (MonadFix (..))+import Control.Monad.ST+import Data.List+import Reanimate.Animation+import Reanimate.Svg.Constructors++-- | The ZIndex property specifies the stack order of sprites and animations. Elements+-- with a higher ZIndex will be drawn on top of elements with a lower index.+type ZIndex = Int++-- (seq duration, par duration)+-- [(Time, Animation, ZIndex)]+-- Map Time [(Animation, ZIndex)]+type Gen s = ST s (Duration -> Time -> (SVG, ZIndex))++-- | A 'Scene' represents a sequence of animations and variables+-- that change over time.+newtype Scene s a = M {unM :: Time -> ST s (a, Duration, Duration, [Gen s])}++instance Functor (Scene s) where+ fmap f action = M $ \t -> do+ (a, d1, d2, gens) <- unM action t+ return (f a, d1, d2, gens)++instance Applicative (Scene s) where+ pure a = M $ \_ -> return (a, 0, 0, [])+ f <*> g = M $ \t -> do+ (f', s1, p1, gen1) <- unM f t+ (g', s2, p2, gen2) <- unM g (t + s1)+ return (f' g', s1 + s2, max p1 (s1 + p2), gen1 ++ gen2)++instance Monad (Scene s) where+ return = pure+ f >>= g = M $ \t -> do+ (a, s1, p1, gen1) <- unM f t+ (b, s2, p2, gen2) <- unM (g a) (t + s1)+ return (b, s1 + s2, max p1 (s1 + p2), gen1 ++ gen2)++instance MonadFix (Scene s) where+ mfix fn = M $ \t -> mfix (\v -> let (a, _s, _p, _gens) = v in unM (fn a) t)++liftST :: ST s a -> Scene s a+liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, [])++-- | Evaluate the value of a scene.+evalScene :: (forall s. Scene s a) -> a+evalScene action = runST $ do+ (val, _, _, _) <- unM action 0+ return val++-- | Render a 'Scene' to an 'Animation'.+scene :: (forall s. Scene s a) -> Animation+scene = sceneAnimation++-- | Render a 'Scene' to an 'Animation'.+sceneAnimation :: (forall s. Scene s a) -> Animation+sceneAnimation action =+ runST+ ( do+ (_, s, p, gens) <- unM action 0+ let dur = max s p+ genFns <- sequence gens+ return $+ mkAnimation+ dur+ ( \t ->+ mkGroup $+ map fst $+ sortOn+ snd+ [spriteRender dur (t * dur) | spriteRender <- genFns]+ )+ )++-- | Execute actions in a scene without advancing the clock. Note that scenes do not end before+-- all forked actions have completed.+--+-- Example:+--+-- @+-- do 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'+-- 'play' 'Reanimate.Builtin.Documentation.drawCircle'+-- @+--+-- <<docs/gifs/doc_fork.gif>>+fork :: Scene s a -> Scene s a+fork (M action) = M $ \t -> do+ (a, s, p, gens) <- action t+ return (a, 0, max s p, gens)++-- | Query the current clock timestamp.+--+-- Example:+--+-- @+-- do now \<- 'play' 'Reanimate.Builtin.Documentation.drawCircle' *\> 'queryNow'+-- 'play' $ 'staticFrame' 1 $ 'scale' 2 $ 'withStrokeWidth' 0.05 $+-- 'mkText' $ "Now=" <> T.pack (show now)+-- @+--+-- <<docs/gifs/doc_queryNow.gif>>+queryNow :: Scene s Time+queryNow = M $ \t -> return (t, 0, 0, [])++-- | Advance the clock by a given number of seconds.+--+-- Example:+--+-- @+-- do 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'+-- 'wait' 1+-- 'play' 'Reanimate.Builtin.Documentation.drawCircle'+-- @+--+-- <<docs/gifs/doc_wait.gif>>+wait :: Duration -> Scene s ()+wait d = M $ \_ -> return ((), d, 0, [])++-- | Wait until the clock is equal to the given timestamp.+waitUntil :: Time -> Scene s ()+waitUntil tNew = do+ now <- queryNow+ wait (max 0 (tNew - now))++-- | Wait until all forked and sequential animations have finished.+--+-- Example:+--+-- @+-- do 'waitOn' $ 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'+-- 'play' 'Reanimate.Builtin.Documentation.drawCircle'+-- @+--+-- <<docs/gifs/doc_waitOn.gif>>+waitOn :: Scene s a -> Scene s a+waitOn (M action) = M $ \t -> do+ (a, s, p, gens) <- action t+ return (a, max s p, 0, gens)++-- | Change the ZIndex of a scene.+adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a+adjustZ fn (M action) = M $ \t -> do+ (a, s, p, gens) <- action t+ return (a, s, p, map genFn gens)+ where+ genFn gen = do+ frameGen <- gen+ return $ \d t -> let (svg, z) = frameGen d t in (svg, fn z)++-- | Query the duration of a scene.+withSceneDuration :: Scene s () -> Scene s Duration+withSceneDuration s = do+ t1 <- queryNow+ s+ t2 <- queryNow+ return (t2 - t1)++addGen :: Gen s -> Scene s ()+addGen gen = M $ \_ -> return ((), 0, 0, [gen])
+ src/Reanimate/Scene/Object.hs view
@@ -0,0 +1,612 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE RecordWildCards #-}+module Reanimate.Scene.Object where++import Control.Lens+import Control.Monad (forM_, void)+import Control.Monad.State (State, execState)+import Data.Monoid ( Last(getLast) )+import Graphics.SvgTree+ ( Number (..),+ Tree,+ strokeWidth,+ toUserUnit,+ pattern None,+ )+import Reanimate.Animation+import Reanimate.Constants (defaultDPI, defaultStrokeWidth)+import Reanimate.Ease (Signal, curveS, fromToS)+import Reanimate.Effect ( applyE, fadeLineOutE, overEnding )+import Reanimate.Math.Balloon ( balloon )+import Reanimate.Morph.Common (morph)+import Reanimate.Morph.Linear (linear)+import Reanimate.Svg++import Reanimate.Scene.Core+import Reanimate.Scene.Sprite+import Reanimate.Scene.Var++-------------------------------------------------------+-- Objects++-- | Objects can be any Haskell structure as long as it can be rendered to SVG.+class Renderable a where+ toSVG :: a -> SVG++instance Renderable Tree where+ toSVG = id++-- | Objects are SVG nodes (represented as Haskell values) with+-- identity, location, and several other properties that can+-- change over time.+data Object s a = Object+ { objectSprite :: Sprite s,+ objectData :: Var s (ObjectData a)+ }++-- | Container for object properties.+data ObjectData a = ObjectData+ { _oTranslate :: (Double, Double),+ _oValueRef :: a,+ _oSVG :: SVG,+ _oContext :: SVG -> SVG,+ -- | Top, right, bottom, left+ _oMargin :: (Double, Double, Double, Double),+ _oBB :: (Double, Double, Double, Double),+ _oOpacity :: Double,+ _oShown :: Bool,+ _oZIndex :: Int,+ _oEasing :: Signal,+ _oScale :: Double,+ _oScaleOrigin :: (Double, Double)+ }++-- Basic lenses++-- FIXME: Maybe 'position' is a better name.++-- | Object position. Default: \<0,0\>+oTranslate :: Lens' (ObjectData a) (Double, Double)+oTranslate = lens _oTranslate $ \obj val -> obj {_oTranslate = val}++-- | Rendered SVG node of an object. Does not include context+-- or object properties. Read-only.+oSVG :: Getter (ObjectData a) SVG+oSVG = to _oSVG++-- | Custom render context. Is applied to the object for every+-- frame that it is shown.+oContext :: Lens' (ObjectData a) (SVG -> SVG)+oContext = lens _oContext $ \obj val -> obj {_oContext = val}++-- | Object margins (top, right, bottom, left) in local units.+oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double)+oMargin = lens _oMargin $ \obj val -> obj {_oMargin = val}++-- | Object bounding-box (minimal X-coordinate, minimal Y-coordinate,+-- width, height). Uses `Reanimate.Svg.BoundingBox.boundingBox`+-- and has the same limitations.+oBB :: Getter (ObjectData a) (Double, Double, Double, Double)+oBB = to _oBB++-- | Object opacity. Default: 1+oOpacity :: Lens' (ObjectData a) Double+oOpacity = lens _oOpacity $ \obj val -> obj {_oOpacity = val}++-- | Toggle for whether or not the object should be rendered.+-- Default: False+oShown :: Lens' (ObjectData a) Bool+oShown = lens _oShown $ \obj val -> obj {_oShown = val}++-- | Object's z-index.+oZIndex :: Lens' (ObjectData a) Int+oZIndex = lens _oZIndex $ \obj val -> obj {_oZIndex = val}++-- | Easing function used when modifying object properties.+-- Default: @'Reanimate.Ease.curveS' 2@+oEasing :: Lens' (ObjectData a) Signal+oEasing = lens _oEasing $ \obj val -> obj {_oEasing = val}++-- | Object's scale. Default: 1+oScale :: Lens' (ObjectData a) Double+oScale = lens _oScale $ \obj val -> oComputeBB obj {_oScale = val}++-- | Origin point for scaling. Default: \<0,0\>+oScaleOrigin :: Lens' (ObjectData a) (Double, Double)+oScaleOrigin = lens _oScaleOrigin $ \obj val -> oComputeBB obj {_oScaleOrigin = val}++-- Smart lenses++-- | Lens for the source value contained in an object.+oValue :: Renderable a => Lens' (ObjectData a) a+oValue = lens _oValueRef $ \obj newVal ->+ let svg = toSVG newVal+ in oComputeBB+ obj+ { _oValueRef = newVal,+ _oSVG = svg+ }++oComputeBB :: ObjectData a -> ObjectData a+oComputeBB obj =+ obj+ { _oBB = boundingBox $ oScaleApply obj (_oSVG obj)+ }++-- | Derived location of the top-most point of an object + margin.+oTopY :: Lens' (ObjectData a) Double+oTopY = lens getter setter+ where+ getter obj =+ let top = obj ^. oMarginTop+ miny = obj ^. oBBMinY+ h = obj ^. oBBHeight+ dy = obj ^. oTranslate . _2+ in dy + miny + h + top+ setter obj val =+ obj & (oTranslate . _2) +~ val - getter obj++-- | Derived location of the bottom-most point of an object + margin.+oBottomY :: Lens' (ObjectData a) Double+oBottomY = lens getter setter+ where+ getter obj =+ let bot = obj ^. oMarginBottom+ miny = obj ^. oBBMinY+ dy = obj ^. oTranslate . _2+ in dy + miny - bot+ setter obj val =+ obj & (oTranslate . _2) +~ val - getter obj++-- | Derived location of the left-most point of an object + margin.+oLeftX :: Lens' (ObjectData a) Double+oLeftX = lens getter setter+ where+ getter obj =+ let left = obj ^. oMarginLeft+ minx = obj ^. oBBMinX+ dx = obj ^. oTranslate . _1+ in dx + minx - left+ setter obj val =+ obj & (oTranslate . _1) +~ val - getter obj++-- | Derived location of the right-most point of an object + margin.+oRightX :: Lens' (ObjectData a) Double+oRightX = lens getter setter+ where+ getter obj =+ let right = obj ^. oMarginRight+ minx = obj ^. oBBMinX+ w = obj ^. oBBWidth+ dx = obj ^. oTranslate . _1+ in dx + minx + w + right+ setter obj val =+ obj & (oTranslate . _1) +~ val - getter obj++-- | Derived location of an object's center point.+oCenterXY :: Lens' (ObjectData a) (Double, Double)+oCenterXY = lens getter setter+ where+ getter obj =+ let minx = obj ^. oBBMinX+ miny = obj ^. oBBMinY+ w = obj ^. oBBWidth+ h = obj ^. oBBHeight+ (dx, dy) = obj ^. oTranslate+ in (dx + minx + w / 2, dy + miny + h / 2)+ setter obj (dx, dy) =+ let (x, y) = getter obj+ in obj & (oTranslate . _1) +~ dx - x+ & (oTranslate . _2) +~ dy - y++-- | Object's top margin.+oMarginTop :: Lens' (ObjectData a) Double+oMarginTop = oMargin . _1++-- | Object's right margin.+oMarginRight :: Lens' (ObjectData a) Double+oMarginRight = oMargin . _2++-- | Object's bottom margin.+oMarginBottom :: Lens' (ObjectData a) Double+oMarginBottom = oMargin . _3++-- | Object's left margin.+oMarginLeft :: Lens' (ObjectData a) Double+oMarginLeft = oMargin . _4++-- | Object's minimal X-coordinate..+oBBMinX :: Getter (ObjectData a) Double+oBBMinX = oBB . _1++-- | Object's minimal Y-coordinate..+oBBMinY :: Getter (ObjectData a) Double+oBBMinY = oBB . _2++-- | Object's width without margin.+oBBWidth :: Getter (ObjectData a) Double+oBBWidth = oBB . _3++-- | Object's height without margin.+oBBHeight :: Getter (ObjectData a) Double+oBBHeight = oBB . _4++-------------------------------------------------------------------------------+-- Object modifiers++-- | Modify object properties.+oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s ()+oModify o = modifyVar (objectData o)++-- | Modify object properties using a stateful API.+oModifyS :: Object s a -> State (ObjectData a) b -> Scene s ()+oModifyS o = oModify o . execState++-- | Query object property.+oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b+oRead o l = view l <$> readVar (objectData o)++-- | Modify object properties over a set duration.+oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s ()+oTween o d fn = do+ -- Read 'easing' var here instead of taking it from 'v'.+ -- This allows different easing functions even at the same timestamp.+ ease <- oRead o oEasing+ tweenVar (objectData o) d (\v t -> fn (ease t) v)++-- | Modify object properties over a set duration using a stateful API.+oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s ()+oTweenS o d fn = oTween o d (execState . fn)++-- | Modify object value over a set duration. This is a convenience function+-- for modifying `oValue`.+oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s ()+oTweenV o d fn = oTween o d (\t -> oValue %~ fn t)++-- | Modify object value over a set duration using a stateful API. This is a+-- convenience function for modifying `oValue`.+oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s ()+oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t))++-- | Create new object.+oNew :: Renderable a => a -> Scene s (Object s a)+oNew = newObject++-- | Create new object.+newObject :: Renderable a => a -> Scene s (Object s a)+newObject val = do+ ref <-+ newVar+ ObjectData+ { _oTranslate = (0, 0),+ _oValueRef = val,+ _oSVG = svg,+ _oContext = id,+ _oMargin = (0.5, 0.5, 0.5, 0.5),+ _oBB = boundingBox svg,+ _oOpacity = 1,+ _oShown = False,+ _oZIndex = 1,+ _oEasing = curveS 2,+ _oScale = 1,+ _oScaleOrigin = (0, 0)+ }+ sprite <- newSprite $ do+ ~obj@ObjectData {..} <- unVar ref+ pure $+ if _oShown+ then+ uncurry translate _oTranslate $+ oScaleApply obj $+ withGroupOpacity _oOpacity $+ mkGroup [_oContext _oSVG]+ else None+ spriteModify sprite $ do+ ~ObjectData {_oZIndex = z} <- unVar ref+ pure $ \(img, _) -> (img, z)+ return+ Object+ { objectSprite = sprite,+ objectData = ref+ }+ where+ svg = toSVG val++oScaleApply :: ObjectData a -> (SVG -> SVG)+oScaleApply ObjectData {..} =+ uncurry translate (_oScaleOrigin & both %~ negate)+ . scale _oScale+ . uncurry translate _oScaleOrigin++-------------------------------------------------------------------------------+-- Graphical transformations++-- | Instantly show object.+oShow :: Object s a -> Scene s ()+oShow o = oModify o $ oShown .~ True++-- | Instantly hide object.+oHide :: Object s a -> Scene s ()+oHide o = oModify o $ oShown .~ False++oShowWith :: Object s a -> (SVG -> Animation) -> Scene s ()+oShowWith o fn = do+ oModify o $ oShown .~ True+ initSVG <- oRead o oSVG+ let ani = fn initSVG+ oTween o (duration ani) $ \t obj ->+ obj {_oSVG = getAnimationFrame SyncStretch ani t 1}+ oModify o $ \obj -> obj {_oSVG = initSVG}++oHideWith :: Object s a -> (SVG -> Animation) -> Scene s ()+oHideWith o fn = do+ initSVG <- oRead o oSVG+ let ani = fn initSVG+ oTween o (duration ani) $ \t obj ->+ obj {_oSVG = getAnimationFrame SyncStretch ani t 1}+ oModify o $ \obj -> obj {_oSVG = initSVG}+ oModify o $ oShown .~ False++-- | Fade in object over a set duration.+oFadeIn :: SVG -> Animation+oFadeIn svg = animate $ \t -> withGroupOpacity t svg++-- | Fade out object over a set duration.+oFadeOut :: SVG -> Animation+oFadeOut = reverseA . oFadeIn++-- | Scale in object over a set duration.+oGrow :: SVG -> Animation+oGrow svg = animate $ \t -> scale t svg++-- | Scale out object over a set duration.+oShrink :: SVG -> Animation+oShrink = reverseA . oGrow++type Origin = (Double, Double)++svgOrigin :: SVG -> Origin -> (Double, Double)+svgOrigin svg (originX, originY) =+ case boundingBox svg of+ (polyX, polyY, polyWidth, polyHeight) ->+ ( polyX + polyWidth * originX,+ polyY + polyHeight * originY+ )++oScaleIn :: SVG -> Animation+oScaleIn = oScaleIn' (curveS 2) (0.5, 1)++oScaleIn' :: Signal -> Origin -> SVG -> Animation+oScaleIn' easing origin = oStagger' 0.05 $ \svg ->+ let (cx, cy) = svgOrigin svg origin+ in signalA easing $+ mkAnimation 0.3 $ \t ->+ translate cx cy $+ scale t $+ translate+ (- cx)+ (- cy)+ svg++oScaleOut :: SVG -> Animation+oScaleOut = reverseA . oStaggerRev' 0.05 (oScaleIn' (curveS 2) (0.5, 0))++oScaleOut' :: Signal -> Origin -> SVG -> Animation+oScaleOut' easing origin = reverseA . oStaggerRev' 0.05 (oScaleIn' easing origin)++oSim :: (SVG -> Animation) -> SVG -> Animation+oSim = oStagger' 0++-- oSim (oStagger fn) = oSim fn+-- oStagger (oStagger fn) = oStagger fn+oStagger :: (SVG -> Animation) -> SVG -> Animation+oStagger = oStagger' 0.2++oStaggerRev :: (SVG -> Animation) -> SVG -> Animation+oStaggerRev = oStaggerRev' 0.2++oStagger' :: Duration -> (SVG -> Animation) -> SVG -> Animation+oStagger' staggerDelay fn svg = scene $+ forM_ (svgGlyphs svg) $ \(ctx, _attr, node) -> do+ void $ fork $ newSpriteA' SyncFreeze (fn $ ctx node)+ wait staggerDelay++oStaggerRev' :: Duration -> (SVG -> Animation) -> SVG -> Animation+oStaggerRev' staggerDelay fn svg = scene $+ forM_ (reverse $ svgGlyphs svg) $ \(ctx, _attr, node) -> do+ void $ fork $ newSpriteA' SyncFreeze (fn $ ctx node)+ wait staggerDelay++oDraw :: SVG -> Animation+oDraw = oStagger $ \svg -> scene $+ forM_ (svgGlyphs $ pathify svg) $ \(ctx, attr, node) -> do+ let sWidth =+ case toUserUnit defaultDPI <$> getLast (attr ^. strokeWidth) of+ Just (Num d) -> max defaultStrokeWidth d+ _ -> defaultStrokeWidth+ -- wait 1+ play $+ mapA ctx $+ applyE (overEnding fillDur $ fadeLineOutE sWidth) $+ animate $ \t ->+ withStrokeWidth sWidth $+ mkGroup+ [withFillOpacity 0 $ partialSvg t node]+ wait (- fillDur)+ newSpriteA' SyncFreeze $+ mkAnimation fillDur $ \t ->+ withGroupOpacity t $+ mkGroup [ctx node]+ where+ fillDur = 0.3++_oBalloon :: SVG -> Animation+_oBalloon = animate . balloon++-- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'.++-- | Morph source object into target object over a set duration.+oTransform :: Object s a -> Object s b -> Duration -> Scene s ()+oTransform src dst d = do+ srcSvg <- oRead src oSVG+ srcCtx <- oRead src oContext+ srcEase <- oRead src oEasing+ srcLoc <- oRead src oTranslate+ oModify src $ oShown .~ False++ dstSvg <- oRead dst oSVG+ dstCtx <- oRead dst oContext+ dstLoc <- oRead dst oTranslate++ m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg)+ oModifyS m $ do+ oShown .= True+ oEasing .= srcEase+ oTranslate .= srcLoc+ fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc+ oTweenV m d $ \t -> morphDelta .~ t+ oModify m $ oShown .~ False+ oModify dst $ oShown .~ True+ where+ moveTo t (dstX, dstY) (srcX, srcY) =+ (fromToS srcX dstX t, fromToS srcY dstY t)++-------------------------------------------------------------------------------+-- Built-in objects++-- | Basic object mapping to \<circle\/\> in SVG.+newtype Circle = Circle {_circleRadius :: Double}++-- | Circle radius in local units.+circleRadius :: Lens' Circle Double+circleRadius = iso _circleRadius Circle++instance Renderable Circle where+ toSVG (Circle r) = mkCircle r++-- | Basic object mapping to \<rect\/\> in SVG.+data Rectangle = Rectangle {_rectWidth :: Double, _rectHeight :: Double}++-- | Rectangle width in local units.+rectWidth :: Lens' Rectangle Double+rectWidth = lens _rectWidth $ \obj val -> obj {_rectWidth = val}++-- | Rectangle height in local units.+rectHeight :: Lens' Rectangle Double+rectHeight = lens _rectHeight $ \obj val -> obj {_rectHeight = val}++instance Renderable Rectangle where+ toSVG (Rectangle w h) = mkRect w h++-- | Object representing an interpolation between SVG nodes.+data Morph = Morph {_morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG}++-- | Control variable for the interpolation. A value of 0 gives the+-- source SVG and 1 gives the target svg.+morphDelta :: Lens' Morph Double+morphDelta = lens _morphDelta $ \obj val -> obj {_morphDelta = val}++-- | Source shape.+morphSrc :: Lens' Morph SVG+morphSrc = lens _morphSrc $ \obj val -> obj {_morphSrc = val}++-- | Target shape.+morphDst :: Lens' Morph SVG+morphDst = lens _morphDst $ \obj val -> obj {_morphDst = val}++instance Renderable Morph where+ toSVG (Morph t src dst) = morph linear src dst t++-- | Cameras can take control of objects and manipulate them+-- with convenient pan and zoom operations.+data Camera = Camera++instance Renderable Camera where+ toSVG Camera = None++-- | Connect an object to a camera such that+-- camera settings (position, zoom, and rotation) is+-- applied to the object.+--+-- Example+--+-- @+-- do cam \<- 'newObject' 'Camera'+-- circ \<- 'newObject' $ 'Circle' 2+-- 'oModifyS' circ $+-- 'oContext' .= 'withFillOpacity' 1 . 'withFillColor' "blue"+-- 'oShow' circ+-- 'cameraAttach' cam circ+-- 'cameraZoom' cam 1 2+-- 'cameraZoom' cam 1 1+-- @+--+-- <<docs/gifs/doc_cameraAttach.gif>>+cameraAttach :: Object s Camera -> Object s a -> Scene s ()+cameraAttach cam obj =+ spriteModify (objectSprite obj) $ do+ camData <- unVar (objectData cam)+ return $ \(svg, zindex) ->+ let (x, y) = camData ^. oTranslate+ ctx =+ translate (- x) (- y)+ . uncurry translate (camData ^. oScaleOrigin)+ . scale (camData ^. oScale)+ . uncurry translate (camData ^. oScaleOrigin & both %~ negate)+ in (ctx svg, zindex)++-- |+--+-- Example+--+-- @+-- do cam \<- 'newObject' 'Camera'+-- circ \<- 'newObject' $ 'Circle' 2; 'oShow' circ+-- 'oModify' circ $ 'oTranslate' .~ (-3,0)+-- box \<- 'newObject' $ 'Rectangle' 4 4; 'oShow' box+-- 'oModify' box $ 'oTranslate' .~ (3,0)+-- 'cameraAttach' cam circ+-- 'cameraAttach' cam box+-- 'cameraFocus' cam (-3,0)+-- 'cameraZoom' cam 2 2 -- Zoom in+-- 'cameraZoom' cam 2 1 -- Zoom out+-- 'cameraFocus' cam (3,0)+-- 'cameraZoom' cam 2 2 -- Zoom in+-- 'cameraZoom' cam 2 1 -- Zoom out+-- @+--+-- <<docs/gifs/doc_cameraFocus.gif>>+cameraFocus :: Object s Camera -> (Double, Double) -> Scene s ()+cameraFocus cam (x, y) = do+ (ox, oy) <- oRead cam oScaleOrigin+ (tx, ty) <- oRead cam oTranslate+ s <- oRead cam oScale+ let newLocation = (x - ((x - ox) * s + ox - tx), y - ((y - oy) * s + oy - ty))+ oModifyS cam $ do+ oTranslate .= newLocation+ oScaleOrigin .= (x, y)++-- | Instantaneously set camera zoom level.+cameraSetZoom :: Object s Camera -> Double -> Scene s ()+cameraSetZoom cam s =+ oModifyS cam $+ oScale .= s++-- | Change camera zoom level over a set duration.+cameraZoom :: Object s Camera -> Duration -> Double -> Scene s ()+cameraZoom cam d s =+ oTweenS cam d $ \t ->+ oScale %= \v -> fromToS v s t++-- | Instantaneously set camera location.+cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s ()+cameraSetPan cam location =+ oModifyS cam $+ oTranslate .= location++-- | Change camera location over a set duration.+cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s ()+cameraPan cam d (x, y) =+ oTweenS cam d $ \t -> do+ oTranslate . _1 %= \v -> fromToS v x t+ oTranslate . _2 %= \v -> fromToS v y t
+ src/Reanimate/Scene/Sprite.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}++module Reanimate.Scene.Sprite where++import Control.Monad (void)+import Control.Monad.ST (ST)+import Data.Bifunctor (Bifunctor (first))+import Data.STRef (STRef, modifySTRef, newSTRef, readSTRef)+import Graphics.SvgTree+ ( pattern None,+ )+import Reanimate.Animation+ ( Animation,+ Duration,+ SVG,+ Sync (SyncStretch),+ Time,+ dropA,+ duration,+ getAnimationFrame,+ )+import Reanimate.Effect (Effect, delayE)+import Reanimate.Scene.Core+ ( Scene (M),+ ZIndex,+ addGen,+ fork,+ liftST,+ queryNow,+ sceneAnimation,+ wait,+ )+import Reanimate.Scene.Var (unpackVar, Var (..), newVar, readVar)+import Reanimate.Transition (Transition, overlapT)++-- | Create and render a variable. The rendering will be born at the current timestamp+-- and will persist until the end of the scene.+--+-- Example:+--+-- @+-- do var \<- 'simpleVar' 'mkCircle' 0+-- 'tweenVar' var 2 $ \\val -> 'fromToS' val ('Reanimate.Constants.screenHeight'/2)+-- @+--+-- <<docs/gifs/doc_simpleVar.gif>>+simpleVar :: (a -> SVG) -> a -> Scene s (Var s a)+simpleVar render def = do+ v <- newVar def+ _ <- newSprite $ render <$> unVar v+ return v++-- | Helper function for filtering variables.+findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)+findVar _cond [] = error "Variable not found."+findVar cond (v : vs) = do+ val <- readVar v+ if cond val then return v else findVar cond vs++-- | Play an animation once and then remove it. This advances the clock by the duration of the+-- animation.+--+-- Example:+--+-- @+-- do 'play' 'Reanimate.Builtin.Documentation.drawBox'+-- 'play' 'Reanimate.Builtin.Documentation.drawCircle'+-- @+--+-- <<docs/gifs/doc_play.gif>>+play :: Animation -> Scene s ()+play ani = newSpriteA ani >>= destroySprite++-- | Sprites are animations with a given time of birth as well as a time of death.+-- They can be controlled using variables, tweening, and effects.+data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex))))++-- | Sprite frame generator. Generates frames over time in a stateful environment.+newtype Frame s a = Frame {unFrame :: ST s (Time -> Duration -> Time -> a)}++instance Functor (Frame s) where+ fmap fn (Frame gen) = Frame $ do+ m <- gen+ return (\real_t d t -> fn $ m real_t d t)++instance Applicative (Frame s) where+ pure v = Frame $ return (\_ _ _ -> v)+ Frame f <*> Frame g = Frame $ do+ m1 <- f+ m2 <- g+ return $ \real_t d t -> m1 real_t d t (m2 real_t d t)++-- | Dereference a variable as a Sprite frame.+--+-- Example:+--+-- @+-- do v \<- 'newVar' 0+-- 'newSprite' $ 'mkCircle' \<$\> 'unVar' v+-- 'tweenVar' v 1 $ \\val -> 'fromToS' val 3+-- 'tweenVar' v 1 $ \\val -> 'fromToS' val 0+-- @+--+-- <<docs/gifs/doc_unVar.gif>>+unVar :: Var s a -> Frame s a+unVar var = Frame $ do+ fn <- unpackVar var+ return $ \real_t _d _t -> fn real_t++-- | Dereference seconds since sprite birth.+spriteT :: Frame s Time+spriteT = Frame $ return (\_real_t _d t -> t)++-- | Dereference duration of the current sprite.+spriteDuration :: Frame s Duration+spriteDuration = Frame $ return (\_real_t d _t -> d)++-- | Create new sprite defined by a frame generator. Unless otherwise specified using+-- 'destroySprite', the sprite will die at the end of the scene.+--+-- Example:+--+-- @+-- do 'newSprite' $ 'mkCircle' \<$\> 'spriteT' -- Circle sprite where radius=time.+-- 'wait' 2+-- @+--+-- <<docs/gifs/doc_newSprite.gif>>+newSprite :: Frame s SVG -> Scene s (Sprite s)+newSprite render = do+ now <- queryNow+ ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0))+ addGen $ do+ fn <- unFrame render+ (spriteDur, spriteEffectGen) <- readSTRef ref+ spriteEffect <- spriteEffectGen+ return $ \d absT ->+ let relD = (if spriteDur < 0 then d else spriteDur) - now+ relT = absT - now+ -- Sprite is live [now;duration[+ -- If we're at the end of a scene, sprites+ -- are live: [now;duration]+ -- This behavior is difficult to get right. See the 'bug_*' examples for+ -- automated tests.+ inTimeSlice = relT >= 0 && relT < relD+ isLastFrame = d == absT && relT == relD+ in if inTimeSlice || isLastFrame+ then spriteEffect relD relT (fn absT relD relT)+ else (None, 0)+ return $ Sprite now ref++-- | Create new sprite defined by a frame generator. The sprite will die at+-- the end of the scene.+newSprite_ :: Frame s SVG -> Scene s ()+newSprite_ = void . newSprite++-- | Create a new sprite from an animation. This advances the clock by the+-- duration of the animation. Unless otherwise specified using+-- 'destroySprite', the sprite will die at the end of the scene.+--+-- Note: If the scene doesn't end immediately after the duration of the+-- animation, the animation will be stretched to match the lifetime of the+-- sprite. See 'newSpriteA'' and 'play'.+--+-- Example:+--+-- @+-- do 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'+-- 'play' 'Reanimate.Builtin.Documentation.drawBox'+-- 'play' $ 'reverseA' 'Reanimate.Builtin.Documentation.drawBox'+-- @+--+-- <<docs/gifs/doc_newSpriteA.gif>>+newSpriteA :: Animation -> Scene s (Sprite s)+newSpriteA = newSpriteA' SyncStretch++-- | Create a new sprite from an animation and specify the synchronization policy. This advances+-- the clock by the duration of the animation.+--+-- Example:+--+-- @+-- do 'fork' $ 'newSpriteA'' 'SyncFreeze' 'Reanimate.Builtin.Documentation.drawCircle'+-- 'play' 'Reanimate.Builtin.Documentation.drawBox'+-- 'play' $ 'reverseA' 'Reanimate.Builtin.Documentation.drawBox'+-- @+--+-- <<docs/gifs/doc_newSpriteA'.gif>>+newSpriteA' :: Sync -> Animation -> Scene s (Sprite s)+newSpriteA' sync animation =+ newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration)+ <* wait (duration animation)++-- | Create a sprite from a static SVG image.+--+-- Example:+--+-- @+-- do 'newSpriteSVG' $ 'mkBackground' "lightblue"+-- 'play' 'Reanimate.Builtin.Documentation.drawCircle'+-- @+--+-- <<docs/gifs/doc_newSpriteSVG.gif>>+newSpriteSVG :: SVG -> Scene s (Sprite s)+newSpriteSVG = newSprite . pure++-- | Create a permanent sprite from a static SVG image. Same as `newSpriteSVG`+-- but the sprite isn't returned and thus cannot be destroyed.+newSpriteSVG_ :: SVG -> Scene s ()+newSpriteSVG_ = void . newSpriteSVG++-- | Change the rendering of a sprite using data from a variable. If data from several variables+-- is needed, use a frame generator instead.+--+-- Example:+--+-- @+-- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawBox'+-- v \<- 'newVar' 0+-- 'applyVar' v s 'rotate'+-- 'tweenVar' v 2 $ \\val -> 'fromToS' val 90+-- @+--+-- <<docs/gifs/doc_applyVar.gif>>+applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s ()+applyVar var sprite fn = spriteModify sprite $ do+ varFn <- unVar var+ return $ first $ fn varFn++-- | Destroy a sprite, preventing it from being rendered in the future of the scene.+-- If 'destroySprite' is invoked multiple times, the earliest time-of-death is used.+--+-- Example:+--+-- @+-- do s <- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'mkCircle' 1+-- 'fork' $ 'wait' 1 \>\> 'destroySprite' s+-- 'play' 'Reanimate.Builtin.Documentation.drawBox'+-- @+--+-- <<docs/gifs/doc_destroySprite.gif>>+destroySprite :: Sprite s -> Scene s ()+destroySprite (Sprite _ ref) = do+ now <- queryNow+ liftST $+ modifySTRef ref $ \(ttl, render) ->+ (if ttl < 0 then now else min ttl now, render)++-- | Low-level frame modifier.+spriteModify :: Sprite s -> Frame s ((SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s ()+spriteModify (Sprite born ref) modFn = liftST $+ modifySTRef ref $ \(ttl, renderGen) ->+ ( ttl,+ do+ render <- renderGen+ modRender <- unFrame modFn+ return $ \relD relT ->+ let absT = relT + born in modRender absT relD relT . render relD relT+ )++-- | Map the SVG output of a sprite.+--+-- Example:+--+-- @+-- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'+-- 'wait' 1+-- 'spriteMap' s 'flipYAxis'+-- @+--+-- <<docs/gifs/doc_spriteMap.gif>>+spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s ()+spriteMap sprite@(Sprite born _) fn = do+ now <- queryNow+ let tDelta = now - born+ spriteModify sprite $ do+ t <- spriteT+ return $ \(svg, zindex) -> (if (t - tDelta) < 0 then svg else fn svg, zindex)++-- | Modify the output of a sprite between @now@ and @now+duration@.+--+-- Example:+--+-- @+-- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'+-- 'spriteTween' s 1 $ \\val -> 'translate' ('Reanimate.Constants.screenWidth'*0.3*val) 0+-- @+--+-- <<docs/gifs/doc_spriteTween.gif>>+spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()+spriteTween sprite@(Sprite born _) dur fn = do+ now <- queryNow+ let tDelta = now - born+ spriteModify sprite $ do+ t <- spriteT+ return $ first $ \svg -> fn (clamp 0 1 $ (t - tDelta) / dur) svg+ wait dur+ where+ clamp a b v+ | v < a = a+ | v > b = b+ | otherwise = v++-- | Create a new variable and apply it to a sprite.+--+-- Example:+--+-- @+-- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawBox'+-- v \<- 'spriteVar' s 0 'rotate'+-- 'tweenVar' v 2 $ \\val -> 'fromToS' val 90+-- @+--+-- <<docs/gifs/doc_spriteVar.gif>>+spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)+spriteVar sprite def fn = do+ v <- newVar def+ applyVar v sprite fn+ return v++-- | Apply an effect to a sprite.+--+-- Example:+--+-- @+-- do s <- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'+-- 'spriteE' s $ 'overBeginning' 1 'fadeInE'+-- 'spriteE' s $ 'overEnding' 0.5 'fadeOutE'+-- @+--+-- <<docs/gifs/doc_spriteE.gif>>+spriteE :: Sprite s -> Effect -> Scene s ()+spriteE (Sprite born ref) effect = do+ now <- queryNow+ liftST $+ modifySTRef ref $ \(ttl, renderGen) ->+ ( ttl,+ do+ render <- renderGen+ return $ \d t svg ->+ let (svg', z) = render d t svg+ in (delayE (max 0 $ now - born) effect d t svg', z)+ )++-- | Set new ZIndex of a sprite.+--+-- Example:+--+-- @+-- do s1 \<- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'withFillColor' "blue" $ 'mkCircle' 3+-- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'withFillColor' "red" $ 'mkRect' 8 3+-- 'wait' 1+-- 'spriteZ' s1 1+-- 'wait' 1+-- @+--+-- <<docs/gifs/doc_spriteZ.gif>>+spriteZ :: Sprite s -> ZIndex -> Scene s ()+spriteZ (Sprite born ref) zindex = do+ now <- queryNow+ liftST $+ modifySTRef ref $ \(ttl, renderGen) ->+ ( ttl,+ do+ render <- renderGen+ return $ \d t svg ->+ let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex)+ )++-- | Destroy all local sprites at the end of a scene.+--+-- Example:+--+-- @+-- do -- the rect lives through the entire 3s animation+-- 'newSpriteSVG_' $ 'translate' (-3) 0 $ 'mkRect' 4 4+-- 'wait' 1+-- 'spriteScope' $ do+-- -- the circle only lives for 1 second.+-- local \<- 'newSpriteSVG' $ 'translate' 3 0 $ 'mkCircle' 2+-- 'spriteE' local $ 'overBeginning' 0.3 'fadeInE'+-- 'spriteE' local $ 'overEnding' 0.3 'fadeOutE'+-- 'wait' 1+-- 'wait' 1+-- @+--+-- <<docs/gifs/doc_spriteScope.gif>>+spriteScope :: Scene s a -> Scene s a+spriteScope (M action) = M $ \t -> do+ (a, s, p, gens) <- action t+ return (a, s, p, map (genFn (t + max s p)) gens)+ where+ genFn maxT gen = do+ frameGen <- gen+ return $ \_ t ->+ if t < maxT+ then frameGen maxT t+ else (None, 0)++asAnimation :: (forall s'. Scene s' a) -> Scene s Animation+asAnimation s = do+ now <- queryNow+ return $ dropA now (sceneAnimation (wait now >> s))++-- | Apply a transformation with a given overlap. This makes sure+-- to keep timestamps intact such that events can still be timed+-- by transcripts.+transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s ()+transitionO t o a b = do+ aA <- asAnimation a+ bA <- fork $ do+ wait (duration aA - o)+ asAnimation b+ play $ overlapT o t aA bA
+ src/Reanimate/Scene/Var.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Reanimate.Scene.Var where++import Control.Monad.ST (ST)+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.STRef+import Reanimate.Animation (Duration, Time)+import Reanimate.Scene.Core (Scene, liftST, queryNow, wait)++-- | Time dependent variable.+newtype Var s a = Var (STRef s (VarData a))++-- Note: We must ensure that upon transforming an VarData,+-- 1. evarDefault old == evarDefault new+-- 2. isNothing (evarLastTime old) || isJust (evarLastTime new) i.e. once evarLastValue has a Just value,+-- it shouldn't be Nothing again.+-- 3. isNothing (evarLastTime var) => M.null (evarTimeline var)+data VarData a = VarData+ { evarDefault :: a,+ evarTimeline :: Timeline a,+ evarLastTime :: Maybe Time,+ evarLastValue :: a+ }++data Modifier a = StaticValue a | TweenValue Duration (a -> Time -> a)++type Timeline a = M.Map Time (Modifier a)++-- | Create a new variable with a default value.+-- Variables always have a defined value even if they are read at a timestamp that is+-- earlier than when the variable was created. For example:+--+-- @+-- do v \<- 'fork' ('wait' 10 \>\> 'newVar' 0) -- Create a variable at timestamp '10'.+-- 'readVar' v -- Read the variable at timestamp '0'.+-- -- The value of the variable will be '0'.+-- @+newVar :: a -> Scene s (Var s a)+newVar def = Var <$> liftST (newSTRef $ VarData def M.empty Nothing def)++-- | Read the value of a variable at the current timestamp.+readVar :: Var s a -> Scene s a+readVar (Var ref) = readVarData <$> liftST (readSTRef ref) <*> queryNow++unpackVar :: Var s a -> ST s (Time -> a)+unpackVar (Var ref) = readVarData <$> readSTRef ref++-- | Write the value of a variable at the current timestamp.+--+-- Example:+--+-- @+-- do v \<- 'newVar' 0+-- 'newSprite' $ 'mkCircle' \<$\> 'unVar' v+-- 'writeVar' v 1; 'wait' 1+-- 'writeVar' v 2; 'wait' 1+-- 'writeVar' v 3; 'wait' 1+-- @+--+-- <<docs/gifs/doc_writeVar.gif>>+writeVar :: Var s a -> a -> Scene s ()+writeVar (Var ref) val = do+ now <- queryNow+ liftST $ modifySTRef ref $ writeVarData now val++-- | Modify the value of a variable at the current timestamp and all future timestamps.+modifyVar :: Var s a -> (a -> a) -> Scene s ()+modifyVar (Var ref) fn = do+ now <- queryNow+ liftST $ modifySTRef ref $ modifyVarData now fn++-- | Modify a variable between @now@ and @now+duration@.+tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()+tweenVar _ dur _ | dur < 0 = error "Reanimate.tweenVar: durations must be non-negative"+tweenVar (Var ref) dur fn = do+ now <- queryNow+ liftST $ modifySTRef ref $ tweenVarData now dur fn+ wait dur++readVarData :: VarData a -> Time -> a+readVarData (VarData def _ Nothing _) _ = def+readVarData (VarData def timeline (Just lastTime) lastValue) now+ | now < lastTime = lookupTimeline timeline def now+ | otherwise = lastValue++lookupTimeline :: Timeline a -> a -> Time -> a+lookupTimeline timeline def now = case M.lookupLE now timeline of+ Just (_, StaticValue sVal) -> sVal+ Just (t, TweenValue dur f)+ | t + dur > now -> f def now+ _ -> def++writeVarData :: Time -> a -> VarData a -> VarData a+writeVarData now x var =+ let before = keepBefore now var+ after = VarData (evarDefault var) M.empty (Just now) x+ in after `elseVar` before++modifyVarData :: Time -> (a -> a) -> VarData a -> VarData a+modifyVarData now fn var =+ let before = keepBefore now var+ after = keepFrom now var+ timeline = flip M.map (evarTimeline after) $ \case+ StaticValue s -> StaticValue $ fn s+ TweenValue dur f -> TweenValue dur $ \a t -> fn (f a t)+ in after {evarTimeline = timeline, evarLastValue = fn $ evarLastValue after} `elseVar` before++-- Note: The function passed here takes time on the scale 0 to 1+-- while the function in `TweenValue` takes time on an absolute scale.+tweenVarData :: Time -> Duration -> (a -> Time -> a) -> VarData a -> VarData a+tweenVarData st dur fn var@VarData {..} =+ let nd = st + dur+ before = keepBefore st var+ during = keepInRange (Just st) (Just nd) var+ tweenFn a t =+ let idx = (t - st) / dur+ idx' = if isNaN idx then 1 else idx+ in fn (readVarData (during {evarDefault = a}) t) idx'+ valueTweenEnd = tweenFn evarDefault nd -- we'll never use the def here, replace with error?+ after = VarData evarDefault (M.singleton st $ TweenValue dur tweenFn) (Just nd) valueTweenEnd+ in after `elseVar` before++-- Returns the union of two vars such that we use the second var if first var doesn't have a value.+-- Assumes both vars have same default value.+elseVar :: VarData a -> VarData a -> VarData a+elseVar var1 var2+ | Just t <- evarLastTime var1 =+ let afterTimeline = evarTimeline var1+ joinAt = fromMaybe t . fmap fst $ M.lookupMin afterTimeline+ beforeTimeline = case keepBefore joinAt var2 of+ x+ | Just lastTime <- evarLastTime x, lastTime < joinAt -> M.insert lastTime (StaticValue $ evarLastValue x) $ evarTimeline x+ | otherwise -> evarTimeline x+ in var1 {evarTimeline = M.union afterTimeline beforeTimeline}+ | otherwise = var2++-- Restrict a var to a given time interval.+keepInRange :: Maybe Time -> Maybe Time -> VarData a -> VarData a+keepInRange st nd = fromMaybe id (keepFrom <$> st) . fromMaybe id (keepBefore <$> nd)++-- Restrict a var to start at given timestamp.+keepFrom :: Time -> VarData a -> VarData a+keepFrom st VarData {..} =+ let timeline' = M.dropWhileAntitone (< st) evarTimeline+ -- if there is no modifier in timeline starting at st,+ -- we must get the modifier that starts before and truncate it to start at st.+ timeline'' = case M.lookupLE st evarTimeline of+ Just (t, val@(StaticValue _))+ | t < st -> M.insert st val timeline'+ Just (t, TweenValue dur fn)+ | t < st, t + dur > st -> M.insert st (TweenValue (t + dur - st) fn) timeline'+ _ -> timeline'+ in VarData evarDefault timeline'' (max evarLastTime $ Just st) evarLastValue++-- Restrict a var to end(clamp) at given timestamp.+keepBefore :: Time -> VarData a -> VarData a+keepBefore nd var@VarData {..} =+ let timeline' = M.takeWhileAntitone (< nd) evarTimeline+ lastModifier = M.lookupMax timeline'+ timeline'' = case lastModifier of+ Just (t, TweenValue dur fn)+ | t + dur > nd -> M.insert t (TweenValue (nd - t) fn) timeline'+ _ -> timeline'+ lastTime = case lastModifier of+ Just (t, TweenValue dur _) -> Just $ min nd (t + dur)+ _ -> min nd <$> evarLastTime+ in VarData evarDefault timeline'' lastTime (fromMaybe evarDefault $ fmap (readVarData var) lastTime)
src/Reanimate/Svg.hs view
@@ -16,8 +16,7 @@ import Control.Lens ((%~), (&), (.~), (^.), (?~)) import Control.Monad.State-import Graphics.SvgTree hiding (height, line, path, use,- width)+import Graphics.SvgTree import Linear.V2 hiding (angle) import Reanimate.Constants import Reanimate.Animation (SVG)@@ -34,7 +33,7 @@ -- width is affected by directly applying scaling. -- -- @lowerTransformations (scale 2 (mkCircle 1)) = mkCircle 2@-lowerTransformations :: Tree -> Tree+lowerTransformations :: SVG -> SVG lowerTransformations = worker False Transform.identity where updLineCmd m cmd =@@ -70,7 +69,7 @@ _ -> worker True m (pathify t) -- | Remove all @id@ attributes.-lowerIds :: Tree -> Tree+lowerIds :: SVG -> SVG lowerIds = mapTree worker where worker t@GroupTree{} = t & attrId .~ Nothing@@ -78,7 +77,7 @@ worker t = t -- | Optimize SVG tree without affecting how it is rendered.-simplify :: Tree -> Tree+simplify :: SVG -> SVG simplify root = case worker root of [] -> None@@ -90,7 +89,7 @@ concatMap dropNulls [DefinitionTree $ d & groupChildren %~ concatMap worker] worker (GroupTree g)- | g ^. drawAttributes == defaultSvg =+ | g^.drawAttributes == defaultSvg = concatMap dropNulls $ concatMap worker (g^.groupChildren) | otherwise =@@ -110,7 +109,7 @@ -- @removeGroups (withFillColor "blue" $ mkGroup [mkCircle 1, mkRect 1 1]) -- = [ withFillColor "blue" $ mkCircle 1 -- , withFillColor "blue" $ mkRect 1 1 ]@-removeGroups :: Tree -> [Tree]+removeGroups :: SVG -> [SVG] removeGroups = worker defaultSvg where worker _attr None = []@@ -118,11 +117,11 @@ concatMap dropNulls [DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)] worker attr (GroupTree g)- | g ^. drawAttributes == defaultSvg =+ | g^.drawAttributes == defaultSvg = concatMap dropNulls $ concatMap (worker attr) (g^.groupChildren) | otherwise =- concatMap (worker (attr <> g ^. drawAttributes)) (g^.groupChildren)+ concatMap (worker (attr <> g^.drawAttributes)) (g^.groupChildren) worker attr t = dropNulls (t & drawAttributes .~ attr) dropNulls None = []@@ -133,7 +132,7 @@ dropNulls t = [t] -- | Extract all path commands from a node (and its children) and concatenate them.-extractPath :: Tree -> [PathCommand]+extractPath :: SVG -> [PathCommand] extractPath = worker . simplify . lowerTransformations . pathify where worker (GroupTree g) = concatMap worker (g^.groupChildren)@@ -144,7 +143,7 @@ -- -- @withSubglyphs [0,2] (scale 2) (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2]) -- = mkGroup [scale 2 (mkCircle 1), mkRect 2, scale 2 (mkEllipse 1 2)]@-withSubglyphs :: [Int] -> (Tree -> Tree) -> Tree -> Tree+withSubglyphs :: [Int] -> (SVG -> SVG) -> SVG -> SVG withSubglyphs target fn = \t -> evalState (worker t) 0 where worker :: Tree -> State Int Tree@@ -172,18 +171,18 @@ -- -- @splitGlyphs [0,2] (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2]) -- = ([mkRect 2], [mkCircle 1, mkEllipse 1 2])@-splitGlyphs :: [Int] -> Tree -> (Tree, Tree)+splitGlyphs :: [Int] -> SVG -> (SVG, SVG) splitGlyphs target = \t -> let (_, l, r) = execState (worker id t) (0, [], []) in (mkGroup l, mkGroup r) where- handleGlyph :: Tree -> State (Int, [Tree], [Tree]) ()+ handleGlyph :: SVG -> State (Int, [SVG], [SVG]) () handleGlyph t = do (n, l, r) <- get if n `elem` target then put (n+1, l, t:r) else put (n+1, t:l, r)- worker :: (Tree -> Tree) -> Tree -> State (Int, [Tree], [Tree]) ()+ worker :: (SVG -> SVG) -> SVG -> State (Int, [SVG], [SVG]) () worker acc t = case t of GroupTree g -> do@@ -213,7 +212,7 @@ , (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)] -} -- | Split symbols and include their context and drawing attributes.-svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)]+svgGlyphs :: SVG -> [(SVG -> SVG, DrawAttributes, SVG)] svgGlyphs = worker id defaultSvg where worker acc attr =@@ -243,7 +242,7 @@ <<docs/gifs/doc_pathify.gif>> -}-pathify :: Tree -> Tree+pathify :: SVG -> SVG pathify = mapTree worker where worker =
src/Reanimate/Svg/BoundingBox.hs view
@@ -17,7 +17,7 @@ import Data.Maybe (mapMaybe) import qualified Data.Vector.Unboxed as V import qualified Geom2D.CubicBezier.Linear as Bezier-import Graphics.SvgTree hiding (height, line, path, use, width)+import Graphics.SvgTree import Linear.V2 hiding (angle) import Linear.Vector import Reanimate.Constants@@ -79,7 +79,7 @@ None -> [] UseTree{} -> [] GroupTree g -> concatMap svgBoundingPoints (g^.groupChildren)- SymbolTree (Symbol g) -> concatMap svgBoundingPoints (g^.groupChildren)+ SymbolTree g -> concatMap svgBoundingPoints (g^.groupChildren) FilterTree{} -> [] DefinitionTree{} -> [] PathTree p -> linePoints $ toLineCommands (p^.pathDefinition)
src/Reanimate/Svg/Constructors.hs view
@@ -62,8 +62,7 @@ import Data.Attoparsec.Text (parseOnly) import qualified Data.Map as Map import qualified Data.Text as T-import Graphics.SvgTree hiding (height, line, path, use,- width)+import Graphics.SvgTree import Graphics.SvgTree.NamedColors import Graphics.SvgTree.PathParser import Linear.V2 hiding (angle)@@ -251,7 +250,7 @@ -- | @mkRect width height@ creates a rectangle with given @with@ and @height@, centered at @(0, 0)@. -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/rect> mkRect :: Double -> Double -> Tree-mkRect width height = translate (-width/2) (-height/2) $ RectangleTree $ defaultSvg+mkRect width height = translate (-width/2) (-height/2) $ rectangleTree $ defaultSvg & rectUpperLeftCorner .~ (Num 0, Num 0) & rectWidth ?~ Num width & rectHeight ?~ Num height@@ -259,14 +258,14 @@ -- | Create a circle with given radius, centered at @(0, 0)@. -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/circle> mkCircle :: Double -> Tree-mkCircle radius = CircleTree $ defaultSvg+mkCircle radius = circleTree $ defaultSvg & circleCenter .~ (Num 0, Num 0) & circleRadius .~ Num radius -- | Create an ellipse given X-axis radius, and Y-axis radius, with center at @(0, 0)@. -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/ellipse> mkEllipse :: Double -> Double -> Tree-mkEllipse rx ry = EllipseTree $ defaultSvg+mkEllipse rx ry = ellipseTree $ defaultSvg & ellipseCenter .~ (Num 0, Num 0) & ellipseXRadius .~ Num rx & ellipseYRadius .~ Num ry@@ -274,20 +273,20 @@ -- | Create a line segment between two points given by their @(x, y)@ coordinates. -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/line> mkLine :: (Double,Double) -> (Double, Double) -> Tree-mkLine (x1,y1) (x2,y2) = LineTree $ defaultSvg+mkLine (x1,y1) (x2,y2) = lineTree $ defaultSvg & linePoint1 .~ (Num x1, Num y1) & linePoint2 .~ (Num x2, Num y2) -- | Merges multiple images into one. -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/g> mkGroup :: [Tree] -> Tree-mkGroup forest = GroupTree $ defaultSvg+mkGroup forest = groupTree $ defaultSvg & groupChildren .~ forest -- | Create definition of graphical objects that can be used at later time. -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/defs> mkDefinitions :: [Tree] -> Tree-mkDefinitions forest = DefinitionTree $ defaultSvg+mkDefinitions forest = definitionTree $ defaultSvg & groupChildren .~ forest -- | Create an element by referring to existing element defined previously.@@ -295,7 +294,7 @@ -- 'mkDefinitions' and then use it via @use "myId"@. -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/use> mkUse :: String -> Tree-mkUse name = UseTree (defaultSvg & useName .~ name) Nothing+mkUse name = useTree (defaultSvg & useName .~ name) -- | A clip path restricts the region to which paint can be applied. -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/clipPath>@@ -303,13 +302,13 @@ -- using 'withClipPathRef'. -> [Tree] -- ^ List of shapes that will determine the final shape of the clipping region -> Tree-mkClipPath idTag forest = withId idTag $ ClipPathTree $ defaultSvg+mkClipPath idTag forest = withId idTag $ clipPathTree $ defaultSvg & clipPathContent .~ forest -- | Create a path from the list of path commands. -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d#Path_commands> mkPath :: [PathCommand] -> Tree-mkPath cmds = PathTree $ defaultSvg & pathDefinition .~ cmds+mkPath cmds = pathTree $ defaultSvg & pathDefinition .~ cmds -- | Similar to 'mkPathText', but taking SVG path command as a String. mkPathString :: String -> Tree@@ -328,7 +327,7 @@ mkLinePath :: [(Double, Double)] -> Tree mkLinePath [] = mkGroup [] mkLinePath ((startX, startY):rest) =- PathTree $ defaultSvg & pathDefinition .~ cmds+ pathTree $ defaultSvg & pathDefinition .~ cmds where cmds = [ MoveTo OriginAbsolute [V2 startX startY] , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ] ]@@ -337,7 +336,7 @@ mkLinePathClosed :: [(Double, Double)] -> Tree mkLinePathClosed [] = mkGroup [] mkLinePathClosed ((startX, startY):rest) =- PathTree $ defaultSvg & pathDefinition .~ cmds+ pathTree $ defaultSvg & pathDefinition .~ cmds where cmds = [ MoveTo OriginAbsolute [V2 startX startY] , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ]@@ -416,12 +415,12 @@ -- <<docs/gifs/doc_withViewBox.gif>> withViewBox :: (Double, Double, Double, Double) -> Tree -> Tree withViewBox vbox child = translate (-screenWidth/2) (-screenHeight/2) $- SvgTree $ Document- { _viewBox = Just vbox- , _width = Just (Num screenWidth)- , _height = Just (Num screenHeight)- , _elements = [child]- , _description = ""+ svgTree Document+ { _documentViewBox = Just vbox+ , _documentWidth = Just (Num screenWidth)+ , _documentHeight = Just (Num screenHeight)+ , _documentElements = [child]+ , _documentDescription = "" , _documentLocation = "" , _documentAspectRatio = PreserveAspectRatio False AlignNone Nothing }
src/Reanimate/Svg/LineCommand.hs view
@@ -21,7 +21,7 @@ import Data.Functor import qualified Data.Vector.Unboxed as V import qualified Geom2D.CubicBezier.Linear as Bezier-import Graphics.SvgTree hiding (height, line, path, use, width)+import Graphics.SvgTree import Linear.Metric import Linear.V2 hiding (angle) import Linear.Vector@@ -275,5 +275,5 @@ partialSvg alpha = mapTree worker where worker (PathTree path) =- PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands+ PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands worker t = t
src/Reanimate/Svg/Unuse.hs view
@@ -14,13 +14,13 @@ import Control.Lens ((%~), (&), (.~), (?~), (^.)) import qualified Data.Map as Map import Data.Maybe-import Graphics.SvgTree hiding (line, path, use)+import Graphics.SvgTree import Reanimate.Constants import Reanimate.Svg.Constructors -- | Replace all @<use>@ nodes with their definition. replaceUses :: Document -> Document-replaceUses doc = doc & elements %~ map (mapTree replace)+replaceUses doc = doc & documentElements %~ map (mapTree replace) where replaceDefinition PathTree{} = None replaceDefinition t = t@@ -31,17 +31,16 @@ case Map.lookup (use^.useName) idMap of Nothing -> error $ "Unknown id: " ++ (use^.useName) Just tree -> mapTree replace $- GroupTree $- defaultSvg & groupChildren .~ [tree]- & transform ?~- fromMaybe [] (use^.transform) ++- [baseToTransformation (use^.useBase)]+ groupTree (defaultSvg & groupChildren .~ [tree])+ & transform ?~+ fromMaybe [] (use^.transform) +++ [baseToTransformation (use^.useBase)] replace x = x baseToTransformation (x,y) = case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of (Num a, Num b) -> Translate a b _ -> TransformUnknown- docTree = mkGroup (doc^.elements)+ docTree = mkGroup (doc^.documentElements) idMap = foldTree updMap Map.empty docTree updMap m tree = case tree^.attrId of@@ -51,12 +50,12 @@ -- FIXME: the viewbox is ignored. Can we use the viewbox as a mask? -- | Transform out viewbox. Definitions and CSS rules are discarded. unbox :: Document -> Tree-unbox doc@Document{_viewBox = Just (_minx, _minw, _width, _height)} =- GroupTree $ defaultSvg- & groupChildren .~ doc^.elements+unbox doc@Document{_documentViewBox = Just (_minx, _minw, _width, _height)} =+ groupTree $ defaultSvg+ & groupChildren .~ doc^.documentElements unbox doc =- GroupTree $ defaultSvg- & groupChildren .~ doc^.elements+ groupTree $ defaultSvg+ & groupChildren .~ doc^.documentElements -- | Embed 'Document'. This keeps the entire document intact but makes -- it more difficult to use, say, `Reanimate.Svg.pathify` on it.@@ -66,5 +65,5 @@ withFillOpacity 1 $ withStrokeWidth 0 $ flipYAxis $- SvgTree $ doc & width .~ Nothing- & height .~ Nothing+ svgTree $ doc & documentWidth .~ Nothing+ & documentHeight .~ Nothing
test/Properties.hs view
@@ -62,6 +62,12 @@ pSize p < 20 ==> naive (pRing p) == polygonSSSP p V.! 0 +prop_ssspEq2 :: Polygon -> Bool+prop_ssspEq2 p =+ let t = polygonTriangulation p+ d = dual (polygonOffset p) t+ in sssp (pRing p) d == ssspFinger (pRing p) d+ prop_ssspSize :: Polygon -> Bool prop_ssspSize p = length (sssp (pRing p) (dual 0 $ polygonTriangulation p)) == pSize p
test/Spec.hs view
@@ -5,10 +5,11 @@ import Properties import UnitTests+import TimeVarTests main :: IO () main = do tests1 <- unitTestFolder "examples/" tests2 <- compileTestFolder "examples/" tests3 <- compileVideoFolder "videos/"- defaultMainWithRerun $ testGroup "tests" [tests1, tests2, tests3, all_props]+ defaultMainWithRerun $ testGroup "tests" [tests1, tests2, tests3, all_props, timeVarTests]
+ test/TimeVarTests.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE RankNTypes #-}+module TimeVarTests+ ( timeVarTests+ ) where++import Control.Exception+import Control.Monad.ST.Unsafe+import Data.IORef+import System.IO.Unsafe+import Test.Tasty+import Test.Tasty.ExpectedFailure+import Test.Tasty.HUnit++import Reanimate+import Reanimate.Scene++timeVarTests :: TestTree+timeVarTests =+ testGroup "Time variables"+ [ expectFail $ tc "Error check1" $ do+ v <- newVar (0::Double)+ checkAt v+ [ (0,0), (0.25, 0.25), (0.5, 0.5), (1,0) ]+ , expectFail $ tc "Error check2" $ do+ io $ True @?= False+ , tc "Default value" $ do+ v <- newVar True+ checkAt v+ [ (-1, True), (0, True), (1, True) ]+ , tc "Modified value" $ do+ v <- newVar False+ writeVar v True+ checkAt v+ [(-1, False), (0, True), (1, True)]+ , tc "Modified value" $ do+ v <- newVar False+ writeVar v True+ writeVar v False+ checkAt v+ [(-1, False), (0, False), (1, False)]+ , tc "Overwrite future" $ do+ v <- newVar "def"+ fork $ do+ wait 1+ writeVar v "written in the future"+ writeVar v "overwrite"+ checkAt v+ [ (-1, "def"), (0, "overwrite"), (1, "overwrite") ]++ , tc "Interrupt tween" $ do+ v <- newVar 0+ fork $ tweenVar v 1 $ \prev t -> fromToS prev 1 t+ checkAt v+ [ (0,0), (0.25, 0.25), (0.5, 0.5), (1,1) ]+ fork $ do+ wait 0.5+ writeVar v 0.5+ checkAt v+ [ (0,0), (0.25, 0.25), (0.5, 0.5), (1,0.5) ]+ , tc "Double tween" $ do+ v <- newVar 0+ fork $ tweenVar v 1 $ \prev t -> fromToS prev 1 t+ fork $ tweenVar v 1 $ \prev t -> fromToS prev 0 t+ checkAt v+ [ (0,0), (0.25, 0.25*0.75), (0.5, 0.5*0.5), (1,1*0) ]+ , expectFail $ tc "Negative tween duration" $ do+ v <- newVar 0+ tweenVar v (-1) $ \prev t -> fromToS prev 1 t+ , tc "Tween 1" $ do+ v <- newVar 0+ wait 1+ tweenVar v 1 $ \prev t -> fromToS prev 1 t+ checkAt v+ [ (0,0), (1,0), (1.5,0.5), (2,1), (3,1) ]+ , tc "Tween 2" $ do+ v <- newVar (0::Int)+ wait 1+ tweenVar v 1 $ \_prev _t -> 1+ checkAt v+ [ (0,0), (1,1), (1.5,1), (2,1), (3,1) ]+ , tc "Tween 3" $ do+ v <- newVar (0::Int)+ wait 1+ tweenVar v 0 $ \_prev _t -> 1+ checkAt v+ [ (0,0), (1,1), (2,1)]+ , tc "Tween 4" $ do+ v <- newVar (0::Double)+ tweenVar v 1 $ \prev t -> fromToS prev 1 t+ tweenVar v 1 $ \prev t -> fromToS prev 0 t+ checkAt v+ [ (0,0), (0.5,0.5), (1,1), (1.5,0.5), (2,0)]+ , tc "Tween 5" $ do+ v <- newVar (0::Double)+ tweenVar v 1 $ \prev t -> fromToS prev 1 t+ tweenVar v 1 $ \prev t -> fromToS prev 0 t+ wait (-1)+ writeVar v 2+ checkAt v+ [ (0,0), (0.5,0.5), (1,2), (1.5,2), (2,2)]+ , tc "Tween zero duration" $ do+ v <- newVar 0+ wait 1+ tweenVar v 0 $ \_prev t -> t+ checkAt v+ [ (0,0), (1,1), (2,1)]+ , tc "Performance/writeVar" $ do+ v <- newVar (0::Int)+ ref <- io $ newIORef (0::Int)+ modifyVar v $ \old -> unsafePerformIO (modifyIORef ref (+1) >> return 1) + old+ at0 <- readVar v+ wait 1+ at1 <- readVar v+ io $ at0+at1 @?= 2+ counter <- io $ readIORef ref+ io $ counter @?= 1+ , tc "Performance/tweenVar" $ do+ v <- newVar (0::Double)+ ref <- io $ newIORef (0::Int)+ let expensive prev t = unsafePerformIO $ do+ modifyIORef ref (+1)+ evaluate (fromToS prev 1 t)+ tweenVar v 1 expensive+ -- Reading at 0.5 and 1 should call the expensive function.+ -- Reading at 2 and 3 should reuse the result from 1.+ -- The count should therefore be 2 and not 4.+ checkAt v+ [ (0.5,0.5), (1,1), (2,1), (3,1) ]+ counter <- io $ readIORef ref+ io $ counter @?= 2+ , tc "Performance/tweenVar 2" $ do+ v <- newVar (0::Double)+ fork $ wait 10 >> writeVar v 1+ ref <- io $ newIORef (0::Int)+ let expensive prev t = unsafePerformIO $ do+ modifyIORef ref (+1)+ evaluate (fromToS prev 1 t)+ tweenVar v 1 expensive+ wait 2+ writeVar v 2+ -- Reading at 0.5 and 1 should call the expensive function.+ -- Reading at 2 should reuse the result from 1.+ -- The count should therefore be 2 and not 4.+ checkAt v+ [ (0.5,0.5), (1,1), (2,1), (3,2), (4,2) ]+ counter <- io $ readIORef ref+ io $ counter @?= 2+ ]++checkAt :: (Eq a, Show a) => Var s a -> [(Time, a)] -> Scene s ()+checkAt _ [] = pure ()+checkAt v ((d,expected):xs) = do+ fork $ do+ now <- queryNow+ wait (d-now)+ val <- readVar v+ io $ val @?= expected+ checkAt v xs++tc :: TestName -> (forall s. Scene s ()) -> TestTree+tc name action = testCase name $+ (evalScene action @?= ())+ `catch` \(ErrorCall err) -> assertFailure err++io :: IO a -> Scene s a+io action = liftST (unsafeIOToST action)
test/UnitTests.hs view
@@ -14,7 +14,6 @@ import System.Exit import System.FilePath import System.IO-import System.IO.Temp import System.IO.Unsafe import System.Process import Test.Tasty@@ -49,30 +48,21 @@ ] genGolden :: FilePath -> IO LBS.ByteString-genGolden path =- withTempDir $ \tmpDir ->- withTempFile tmpDir "reanimate.exe" $ \tmpExecutable hd -> do- hClose hd- let ghcOpts = ["-rtsopts", "--make", "-O0", "-Werror", "-Wall"] ++- ["-odir", tmpDir, "-hidir", tmpDir, "-o", tmpExecutable] ++- ["-v0"]- runOpts = ["+RTS", "-M1G"]- -- XXX: Check for errors.- case buildSystem of- Stack -> callProcess "stack" $ ["ghc","--", path] ++ ghcOpts- Cabal -> callProcess "cabal" $ ["v2-exec", "ghc","--", "-package", "reanimate", path] ++ ghcOpts-- (inh, outh, errh, pid) <- runInteractiveProcess tmpExecutable (["test"] ++ runOpts)+genGolden path = do+ (inh, outh, errh, pid) <- case buildSystem of+ Stack -> runInteractiveProcess "stack" ["runhaskell", path, "test"] Nothing Nothing- -- hSetBinaryMode outh True- -- hSetNewlineMode outh universalNewlineMode- hClose inh- out <- BS.hGetContents outh- err <- T.hGetContents errh- code <- waitForProcess pid- case code of- ExitSuccess -> return $ LBS.fromChunks [out]- ExitFailure{} -> error $ "Failed to run: " ++ T.unpack err+ Cabal -> runInteractiveProcess "cabal" ["v2-exec", "runhaskell", path, "test"]+ Nothing Nothing+ -- hSetBinaryMode outh True+ -- hSetNewlineMode outh universalNewlineMode+ hClose inh+ out <- BS.hGetContents outh+ err <- T.hGetContents errh+ code <- waitForProcess pid+ case code of+ ExitSuccess -> return $ LBS.fromChunks [out]+ ExitFailure{} -> error $ "Failed to run: " ++ T.unpack err compileTestFolder :: FilePath -> IO TestTree compileTestFolder path = do@@ -144,5 +134,5 @@ -- assertMaybe _ (Just a) = return a -- assertMaybe msg Nothing = assertFailure msg -withTempDir :: (FilePath -> IO a) -> IO a-withTempDir = withSystemTempDirectory "reanimate"+-- withTempDir :: (FilePath -> IO a) -> IO a+-- withTempDir = withSystemTempDirectory "reanimate"