| Program Coverage Total |
diff --git a/playground/snippets.js b/playground/snippets.js
index 6c939db..1377c59 100644
--- a/playground/snippets.js
+++ b/playground/snippets.js
@@ -9,4 +9,4 @@ const snippets = [{"title": "Hello World","url": "https://reanimate.clozecards.c
,{"title": "Object Positions","url": "https://reanimate.clozecards.com/Mf4zcImo+I7/195.svg","code": "env =\n addStatic (mkBackground \"white\") .\n mapA (withStrokeColor \"black\")\n\nanimation :: Animation\nanimation = env $\n sceneAnimation $ do\n -- Configure objects\n txt <- newText \"Center\"\n top <- newText \"Top\"\n oModifyS top $ \n oTopY .= screenTop\n topR <- newText \"Top right\"\n oModifyS topR $ do\n oTopY .= screenTop\n oRightX .= screenRight\n botR <- newText \"Bottom right\"\n oModifyS botR $ do\n oTranslate .= (0, screenBottom+0.5)\n oRightX .= screenRight\n botL <- newText \"Bottom left\"\n oModifyS botL $ do\n oTranslate .= (0, screenBottom+0.5)\n oLeftX .= screenLeft\n topL <- newText \"Top left\"\n oModifyS topL $ do\n oTopY .= screenTop\n oLeftX .= screenLeft\n -- Show objects\n oShow txt\n wait 1\n switchTo txt top\n switchTo top topR\n switchTo topR botR\n switchTo botR botL\n switchTo botL topL\n switchTo topL txt\n\nswitchTo src dst = do\n fork $ oHideWith src oFadeOut\n oShowWith dst oFadeIn\n wait 1\n\nnewText txt =\n newObject $ scale 1.5 $ centerX $ latex txt\n"}
,{"title": "Camera","url": "https://reanimate.clozecards.com/Hcx00P+aeph/150.svg","code": "animation :: Animation\nanimation = docEnv $ mapA (withFillOpacity 1) $ sceneAnimation $ do\n cam <- newObject Camera\n\n txt <- newObject $ center $ latex \"Fixed (non-cam)\"\n oModifyS txt $ do\n oTopY .= screenTop \n oZIndex .= 2\n\n circle <- newObject $ withFillColor \"blue\" $ mkCircle 1\n cameraAttach cam circle\n circleRight <- oRead circle oRightX\n\n box <- newObject $ withFillColor \"green\" $ mkRect 2 2\n cameraAttach cam box\n oModify box $ oLeftX .~ circleRight\n boxCenter <- oRead box oCenterXY\n\n small <- newObject $ center $ latex \"This text is very small\"\n cameraAttach cam small\n oModifyS small $ do\n oCenterXY .= boxCenter\n oScale .= 0.1\n \n oShow txt\n oShow small\n oShow circle\n oShow box\n\n wait 1\n\n cameraFocus cam boxCenter\n waitOn $ do\n fork $ cameraPan cam 3 boxCenter\n fork $ cameraZoom cam 3 15\n \n wait 2\n cameraZoom cam 3 1\n cameraPan cam 1 (0,0)\n"}
];
-const playgroundVersion = "2020-09-09 (9d239)";
+const playgroundVersion = "2020-09-09 (29d17)";
diff --git a/reanimate-0.5.0.1-inplace/Geom2D.CubicBezier.Linear.hs.html b/reanimate-0.5.0.1-inplace/Geom2D.CubicBezier.Linear.hs.html
new file mode 100644
index 0000000..b70cf26
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Geom2D.CubicBezier.Linear.hs.html
@@ -0,0 +1,366 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE DeriveFoldable #-}
+ 2 {-# LANGUAGE DeriveFunctor #-}
+ 3 {-# LANGUAGE DeriveTraversable #-}
+ 4 {-# LANGUAGE FunctionalDependencies #-}
+ 5 {-# LANGUAGE UndecidableInstances #-}
+ 6 {-|
+ 7 Module : Geom2D.CubicBezier.Linear
+ 8 Copyright : Written by David Himmelstrup
+ 9 License : Unlicense
+ 10 Maintainer : lemmih@gmail.com
+ 11 Stability : experimental
+ 12 Portability : POSIX
+ 13
+ 14 Convenience wrapper around 'Geom2D.CubicBezier'
+ 15
+ 16 -}
+ 17 module Geom2D.CubicBezier.Linear
+ 18 ( AnyBezier(..)
+ 19 , CubicBezier(..)
+ 20 , QuadBezier(..)
+ 21 , OpenPath(..)
+ 22 , ClosedPath(..)
+ 23 , PathJoin(..)
+ 24 , ClosedMetaPath(..)
+ 25 , OpenMetaPath(..)
+ 26 , MetaJoin(..)
+ 27 , MetaNodeType(..)
+ 28 , FillRule(..)
+ 29 , Tension(..)
+ 30 , quadToCubic
+ 31 , arcLength
+ 32 , arcLengthParam
+ 33 , C.splitBezier
+ 34 , colinear
+ 35 , evalBezier
+ 36 , evalBezierDeriv
+ 37 , bezierHoriz
+ 38 , bezierVert
+ 39 , C.bezierSubsegment
+ 40 , C.reorient
+ 41 , closedPathCurves
+ 42 , openPathCurves
+ 43 , curvesToClosed
+ 44 , closest
+ 45 , unmetaOpen
+ 46 , unmetaClosed
+ 47 , union
+ 48 , bezierIntersection
+ 49 , interpolateVector
+ 50 , vectorDistance
+ 51 , findBezierInflection
+ 52 , findBezierCusp
+ 53 ) where
+ 54
+ 55 import qualified Data.Vector.Unboxed as V
+ 56 import qualified Geom2D.CubicBezier as C
+ 57 import Graphics.SvgTree (FillRule (..))
+ 58 import Linear.V2
+ 59
+ 60 ------------------------------------------------------------
+ 61 -- Data types
+ 62
+ 63 -- | A bezier curve of any degree.
+ 64 newtype AnyBezier a = AnyBezier (V.Vector (V2 a))
+ 65
+ 66 -- | A cubic bezier curve.
+ 67 data CubicBezier a = CubicBezier
+ 68 { cubicC0 :: !(V2 a)
+ 69 , cubicC1 :: !(V2 a)
+ 70 , cubicC2 :: !(V2 a)
+ 71 , cubicC3 :: !(V2 a)
+ 72 } deriving (Show, Eq)
+ 73
+ 74 -- | A quadratic bezier curve.
+ 75 data QuadBezier a = QuadBezier
+ 76 { quadC0 :: !(V2 a)
+ 77 , quadC1 :: !(V2 a)
+ 78 , quadC2 :: !(V2 a)
+ 79 } deriving (Show, Eq)
+ 80
+ 81 -- | Open cubicbezier path.
+ 82 data OpenPath a = OpenPath [(V2 a, PathJoin a)] (V2 a)
+ 83 deriving (Show, Eq)
+ 84
+ 85 -- | Closed cubicbezier path.
+ 86 newtype ClosedPath a = ClosedPath [(V2 a, PathJoin a)]
+ 87 deriving (Show, Eq)
+ 88
+ 89 -- | Join two points with either a straight line or a bezier
+ 90 -- curve with two control points.
+ 91 data PathJoin a
+ 92 = JoinLine
+ 93 | JoinCurve (V2 a) (V2 a)
+ 94 deriving (Show, Eq)
+ 95
+ 96 -- | Closed meta path.
+ 97 newtype ClosedMetaPath a = ClosedMetaPath [(V2 a, MetaJoin a)]
+ 98 deriving (Show, Eq)
+ 99
+ 100 -- | Open meta path
+ 101 data OpenMetaPath a = OpenMetaPath [(V2 a, MetaJoin a)] (V2 a)
+ 102 deriving (Show, Eq)
+ 103
+ 104 -- | The tension value specifies how /tense/ the curve is.
+ 105 -- A higher value means the curve approaches a line segment,
+ 106 -- while a lower value means the curve is more round. Metafont
+ 107 -- doesn't allow values below 3/4.
+ 108 data Tension a
+ 109 = Tension
+ 110 { tensionValue :: a }
+ 111 | TensionAtLeast -- ^ Like Tension, but keep the segment inside the
+ 112 -- bounding triangle defined by the control points,
+ 113 -- if there is one.
+ 114 { tensionValue :: a }
+ 115 deriving (Functor, Foldable, Traversable, Eq, Show)
+ 116
+ 117 -- | Join two meta points with either a bezier curve or tension
+ 118 -- contraints.
+ 119 data MetaJoin a
+ 120 = MetaJoin
+ 121 { metaTypeL :: MetaNodeType a
+ 122 , tensionL :: Tension a
+ 123 , tensionR :: Tension a
+ 124 , metaTypeR :: MetaNodeType a
+ 125 }
+ 126 | Controls (V2 a) (V2 a)
+ 127 deriving (Show, Eq)
+ 128
+ 129 -- | Node constraint type.
+ 130 data MetaNodeType a
+ 131 = Open
+ 132 | Curl { curlgamma :: a }
+ 133 | Direction { nodedir :: V2 a }
+ 134 deriving (Show, Eq)
+ 135
+ 136 ------------------------------------------------------------
+ 137 -- Methods
+ 138
+ 139 -- | Convert a quadratic bezier to a cubic bezier.
+ 140 quadToCubic :: Fractional a => QuadBezier a -> CubicBezier a
+ 141 quadToCubic = upCast . C.quadToCubic . downCast
+ 142
+ 143 -- | @arcLength c t tol@ finds the arclength of the bezier @c@ at @t@,
+ 144 -- within given tolerance @tol@.
+ 145 arcLength :: CubicBezier Double -> Double -> Double -> Double
+ 146 arcLength bezier = C.arcLength (downCast bezier)
+ 147
+ 148 -- | @arcLengthParam c len tol@ finds the parameter where the curve @c@
+ 149 -- has the arclength @len@, within tolerance @tol@.
+ 150 arcLengthParam :: CubicBezier Double -> Double -> Double -> Double
+ 151 arcLengthParam bezier = C.arcLengthParam (downCast bezier)
+ 152
+ 153 -- | Return @False@ if some points fall outside a line with a thickness of the given tolerance.
+ 154 colinear :: CubicBezier Double -> Double -> Bool
+ 155 colinear bezier = C.colinear (downCast bezier)
+ 156
+ 157 -- | Calculate a value on the bezier curve.
+ 158 evalBezier :: (C.GenericBezier b, V.Unbox a, Fractional a) => b a -> a -> V2 a
+ 159 evalBezier c p = upCast $ C.evalBezier c p
+ 160
+ 161 -- | Calculate a value and the first derivative on the curve.
+ 162 evalBezierDeriv :: (V.Unbox a, Fractional a,C.GenericBezier b) => b a -> a -> (V2 a, V2 a)
+ 163 evalBezierDeriv c p = upCast $ C.evalBezierDeriv c p
+ 164
+ 165 -- | Find the parameter where the bezier curve is horizontal.
+ 166 bezierHoriz :: CubicBezier Double -> [Double]
+ 167 bezierHoriz = C.bezierHoriz . downCast
+ 168
+ 169 -- | Find the parameter where the bezier curve is vertical.
+ 170 bezierVert :: CubicBezier Double -> [Double]
+ 171 bezierVert = C.bezierVert . downCast
+ 172
+ 173 -- | Create a normal path from a metapath.
+ 174 unmetaOpen :: OpenMetaPath Double -> OpenPath Double
+ 175 unmetaOpen = upCast . C.unmetaOpen . downCast
+ 176
+ 177 -- | Create a normal path from a metapath.
+ 178 unmetaClosed :: ClosedMetaPath Double -> ClosedPath Double
+ 179 unmetaClosed = upCast . C.unmetaClosed . downCast
+ 180
+ 181 -- | `O((n+m)*log(n+m))`, for n segments and m intersections.
+ 182 -- Union of paths, removing overlap and rounding to the given tolerance.
+ 183 union :: [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
+ 184 union p fill tol = upCast (C.union (downCast p) (downCast fill) tol)
+ 185
+ 186 -- | Find the intersections between two Bezier curves, using the Bezier Clip algorithm.
+ 187 -- Returns the parameters for both curves.
+ 188 bezierIntersection :: CubicBezier Double -> CubicBezier Double -> Double -> [(Double, Double)]
+ 189 bezierIntersection a b = C.bezierIntersection (downCast a) (downCast b)
+ 190
+ 191 -- | Find the closest value on the bezier to the given point, within tolerance.
+ 192 -- Return the first value found.
+ 193 closest :: CubicBezier Double -> V2 Double -> Double -> Double
+ 194 closest c p = C.closest (downCast c) (downCast p)
+ 195
+ 196 -- | Return the closed path as a list of curves.
+ 197 closedPathCurves :: Fractional a => ClosedPath a -> [CubicBezier a]
+ 198 closedPathCurves = upCast . C.closedPathCurves . downCast
+ 199
+ 200 -- | Return the open path as a list of curves.
+ 201 openPathCurves :: Fractional a => OpenPath a -> [CubicBezier a]
+ 202 openPathCurves = upCast . C.openPathCurves . downCast
+ 203
+ 204 -- | Make an open path from a list of curves. The last control point of each curve is ignored.
+ 205 curvesToClosed :: [CubicBezier a] -> ClosedPath a
+ 206 curvesToClosed = upCast . C.curvesToClosed . downCast
+ 207
+ 208 -- | Interpolate between two vectors.
+ 209 interpolateVector :: Num a => V2 a -> V2 a -> a -> V2 a
+ 210 interpolateVector a b p = upCast $ C.interpolateVector (downCast a) (downCast b) p
+ 211
+ 212 -- | Distance between two vectors.
+ 213 vectorDistance :: Floating a => V2 a -> V2 a -> a
+ 214 vectorDistance a b = C.vectorDistance (downCast a) (downCast b)
+ 215
+ 216 -- | Find inflection points on the curve.
+ 217 findBezierInflection :: CubicBezier Double -> [Double]
+ 218 findBezierInflection = C.findBezierInflection . downCast
+ 219
+ 220 -- | Find the cusps of a bezier.
+ 221 findBezierCusp :: CubicBezier Double -> [Double]
+ 222 findBezierCusp = C.findBezierCusp . downCast
+ 223
+ 224 ------------------------------------------------------------
+ 225 -- Instances
+ 226
+ 227 instance C.GenericBezier QuadBezier where
+ 228 degree = C.degree . downCast
+ 229 toVector = C.toVector . downCast
+ 230 unsafeFromVector = upCast . C.unsafeFromVector
+ 231
+ 232 instance C.GenericBezier CubicBezier where
+ 233 degree = C.degree . downCast
+ 234 toVector = C.toVector . downCast
+ 235 unsafeFromVector = upCast . C.unsafeFromVector
+ 236
+ 237 instance C.GenericBezier AnyBezier where
+ 238 degree = C.degree . downCast
+ 239 toVector = C.toVector . downCast
+ 240 unsafeFromVector = upCast . C.unsafeFromVector
+ 241
+ 242 ------------------------------------------------------------
+ 243 -- Casting
+ 244
+ 245 class Cast a b | a -> b, b -> a where
+ 246 downCast :: a -> b
+ 247 upCast :: b -> a
+ 248
+ 249 instance Cast a b => Cast [a] [b] where
+ 250 downCast = map downCast
+ 251 upCast = map upCast
+ 252
+ 253 instance (Cast a a', Cast b b') => Cast (a,b) (a',b') where
+ 254 downCast (a, b) = (downCast a, downCast b)
+ 255 upCast (a, b) = (upCast a, upCast b)
+ 256
+ 257 instance Cast (V2 a) (C.Point a) where
+ 258 downCast (V2 a b) = C.Point a b
+ 259 upCast (C.Point a b) = V2 a b
+ 260
+ 261 instance Cast FillRule C.FillRule where
+ 262 downCast FillEvenOdd = C.EvenOdd
+ 263 downCast FillNonZero = C.NonZero
+ 264 upCast C.EvenOdd = FillEvenOdd
+ 265 upCast C.NonZero = FillNonZero
+ 266
+ 267 instance Cast (CubicBezier a) (C.CubicBezier a) where
+ 268 downCast (CubicBezier a b c d) = C.CubicBezier
+ 269 (downCast a) (downCast b) (downCast c) (downCast d)
+ 270 upCast (C.CubicBezier a b c d) = CubicBezier
+ 271 (upCast a) (upCast b) (upCast c) (upCast d)
+ 272
+ 273 instance Cast (QuadBezier a) (C.QuadBezier a) where
+ 274 downCast (QuadBezier a b c) = C.QuadBezier
+ 275 (downCast a) (downCast b) (downCast c)
+ 276 upCast (C.QuadBezier a b c)= QuadBezier
+ 277 (upCast a) (upCast b) (upCast c)
+ 278
+ 279 instance V.Unbox a => Cast (AnyBezier a) (C.AnyBezier a) where
+ 280 downCast (AnyBezier arr) = C.AnyBezier $
+ 281 V.map (\(V2 a b) -> (a,b)) arr
+ 282 upCast (C.AnyBezier arr) = AnyBezier $
+ 283 V.map (uncurry V2) arr
+ 284
+ 285 instance Cast (MetaNodeType a) (C.MetaNodeType a) where
+ 286 downCast Open = C.Open
+ 287 downCast (Curl gamma) = C.Curl gamma
+ 288 downCast (Direction dir) = C.Direction (downCast dir)
+ 289 upCast C.Open = Open
+ 290 upCast (C.Curl gamma) = Curl gamma
+ 291 upCast (C.Direction dir) = Direction (upCast dir)
+ 292
+ 293 instance Cast (Tension a) (C.Tension a) where
+ 294 downCast (Tension v) = C.Tension v
+ 295 downCast (TensionAtLeast v) = C.TensionAtLeast v
+ 296 upCast (C.Tension v) = Tension v
+ 297 upCast (C.TensionAtLeast v) = TensionAtLeast v
+ 298
+ 299 instance Cast (MetaJoin a) (C.MetaJoin a) where
+ 300 downCast (MetaJoin tyL tL tR tyR) =
+ 301 C.MetaJoin (downCast tyL) (downCast tL) (downCast tR) (downCast tyR)
+ 302 downCast (Controls p1 p2) = C.Controls (downCast p1) (downCast p2)
+ 303 upCast (C.MetaJoin tyL tL tR tyR) =
+ 304 MetaJoin (upCast tyL) (upCast tL) (upCast tR) (upCast tyR)
+ 305 upCast (C.Controls p1 p2) = Controls (upCast p1) (upCast p2)
+ 306
+ 307 instance Cast (PathJoin a) (C.PathJoin a) where
+ 308 downCast JoinLine = C.JoinLine
+ 309 downCast (JoinCurve a b) = C.JoinCurve (downCast a) (downCast b)
+ 310 upCast C.JoinLine = JoinLine
+ 311 upCast (C.JoinCurve a b) = JoinCurve (upCast a) (upCast b)
+ 312
+ 313 instance Cast (OpenMetaPath a) (C.OpenMetaPath a) where
+ 314 downCast (OpenMetaPath lst end) = C.OpenMetaPath
+ 315 [ (downCast p, downCast j)
+ 316 | (p, j) <- lst ] (downCast end)
+ 317 upCast (C.OpenMetaPath lst end) = OpenMetaPath
+ 318 [ (upCast p, upCast j)
+ 319 | (p, j) <- lst ] (upCast end)
+ 320
+ 321 instance Cast (ClosedMetaPath a) (C.ClosedMetaPath a) where
+ 322 downCast (ClosedMetaPath lst) = C.ClosedMetaPath
+ 323 [ (downCast p, downCast j)
+ 324 | (p, j) <- lst ]
+ 325 upCast (C.ClosedMetaPath lst) = ClosedMetaPath
+ 326 [ (upCast p, upCast j)
+ 327 | (p, j) <- lst ]
+ 328
+ 329 instance Cast (OpenPath a) (C.OpenPath a) where
+ 330 downCast (OpenPath lst end) = C.OpenPath
+ 331 [ (downCast p, downCast j)
+ 332 | (p, j) <- lst ] (downCast end)
+ 333 upCast (C.OpenPath lst end) = OpenPath
+ 334 [ (upCast p, upCast j)
+ 335 | (p, j) <- lst ] (upCast end)
+ 336
+ 337 instance Cast (ClosedPath a) (C.ClosedPath a) where
+ 338 downCast (ClosedPath lst) = C.ClosedPath
+ 339 [ (downCast p, downCast j)
+ 340 | (p, j) <- lst ]
+ 341 upCast (C.ClosedPath lst) = ClosedPath
+ 342 [ (upCast p, upCast j)
+ 343 | (p, j) <- lst ]
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Paths_reanimate.hs.html b/reanimate-0.5.0.1-inplace/Paths_reanimate.hs.html
new file mode 100644
index 0000000..103ac25
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Paths_reanimate.hs.html
@@ -0,0 +1,73 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE CPP #-}
+ 2 {-# LANGUAGE NoRebindableSyntax #-}
+ 3 {-# OPTIONS_GHC -fno-warn-missing-import-lists #-}
+ 4 module Paths_reanimate (
+ 5 version,
+ 6 getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,
+ 7 getDataFileName, getSysconfDir
+ 8 ) where
+ 9
+ 10 import qualified Control.Exception as Exception
+ 11 import Data.Version (Version(..))
+ 12 import System.Environment (getEnv)
+ 13 import Prelude
+ 14
+ 15 #if defined(VERSION_base)
+ 16
+ 17 #if MIN_VERSION_base(4,0,0)
+ 18 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+ 19 #else
+ 20 catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a
+ 21 #endif
+ 22
+ 23 #else
+ 24 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+ 25 #endif
+ 26 catchIO = Exception.catch
+ 27
+ 28 version :: Version
+ 29 version = Version [0,5,0,1] []
+ 30 bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath
+ 31
+ 32 bindir = "/home/runner/.cabal/bin"
+ 33 libdir = "/home/runner/.cabal/lib/x86_64-linux-ghc-8.8.3/reanimate-0.5.0.1-inplace"
+ 34 dynlibdir = "/home/runner/.cabal/lib/x86_64-linux-ghc-8.8.3"
+ 35 datadir = "/home/runner/.cabal/share/x86_64-linux-ghc-8.8.3/reanimate-0.5.0.1"
+ 36 libexecdir = "/home/runner/.cabal/libexec/x86_64-linux-ghc-8.8.3/reanimate-0.5.0.1"
+ 37 sysconfdir = "/home/runner/.cabal/etc"
+ 38
+ 39 getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath
+ 40 getBinDir = catchIO (getEnv "reanimate_bindir") (\_ -> return bindir)
+ 41 getLibDir = catchIO (getEnv "reanimate_libdir") (\_ -> return libdir)
+ 42 getDynLibDir = catchIO (getEnv "reanimate_dynlibdir") (\_ -> return dynlibdir)
+ 43 getDataDir = catchIO (getEnv "reanimate_datadir") (\_ -> return datadir)
+ 44 getLibexecDir = catchIO (getEnv "reanimate_libexecdir") (\_ -> return libexecdir)
+ 45 getSysconfDir = catchIO (getEnv "reanimate_sysconfdir") (\_ -> return sysconfdir)
+ 46
+ 47 getDataFileName :: FilePath -> IO FilePath
+ 48 getDataFileName name = do
+ 49 dir <- getDataDir
+ 50 return (dir ++ "/" ++ name)
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Animation.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Animation.hs.html
new file mode 100644
index 0000000..87c86ed
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Animation.hs.html
@@ -0,0 +1,414 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Module : Reanimate.Animation
+ 3 Copyright : Written by David Himmelstrup
+ 4 License : Unlicense
+ 5 Maintainer : lemmih@gmail.com
+ 6 Stability : experimental
+ 7 Portability : POSIX
+ 8
+ 9 Declarative animation API based on combinators. For a higher-level interface,
+ 10 see 'Reanimate.Scene'.
+ 11
+ 12 -}
+ 13 module Reanimate.Animation
+ 14 ( Duration
+ 15 , Time
+ 16 , SVG
+ 17 , Animation
+ 18 -- * Creating animations
+ 19 , mkAnimation
+ 20 , animate
+ 21 , staticFrame
+ 22 , pause
+ 23 -- * Querying animations
+ 24 , duration
+ 25 , frameAt
+ 26 -- * Composing animations
+ 27 , seqA
+ 28 , andThen
+ 29 , parA
+ 30 , parLoopA
+ 31 , parDropA
+ 32 -- * Modifying animations
+ 33 , setDuration
+ 34 , adjustDuration
+ 35 , mapA
+ 36 , takeA
+ 37 , dropA
+ 38 , lastA
+ 39 , pauseAtEnd
+ 40 , pauseAtBeginning
+ 41 , pauseAround
+ 42 , repeatA
+ 43 , reverseA
+ 44 , playThenReverseA
+ 45 , signalA
+ 46 , freezeAtPercentage
+ 47 , addStatic
+ 48 -- * Misc
+ 49 , getAnimationFrame
+ 50 , Sync(..)
+ 51 -- * Rendering
+ 52 , renderTree
+ 53 , renderSvg
+ 54 ) where
+ 55
+ 56 import Control.Arrow ()
+ 57 import Data.Fixed (mod')
+ 58 import Graphics.SvgTree
+ 59 import Graphics.SvgTree.Printer
+ 60 import Reanimate.Constants
+ 61 import Reanimate.Ease
+ 62 import Reanimate.Svg.Constructors
+ 63 import Text.XML.Light.Output
+ 64
+ 65 -- | Duration of an animation or effect. Usually measured in seconds.
+ 66 type Duration = Double
+ 67 -- | Time signal. Goes from 0 to 1, inclusive.
+ 68 type Time = Double
+ 69
+ 70 -- | SVG node.
+ 71 type SVG = Tree
+ 72
+ 73 -- | Animations are SVGs over a finite time.
+ 74 data Animation = Animation Duration (Time -> SVG)
+ 75
+ 76 -- | Construct an animation with a given duration.
+ 77 mkAnimation :: Duration -> (Time -> SVG) -> Animation
+ 78 mkAnimation = Animation
+ 79
+ 80 -- | Construct an animation with a duration of @1@.
+ 81 animate :: (Time -> SVG) -> Animation
+ 82 animate = Animation 1
+ 83
+ 84 -- | Create an animation with provided @duration@, which consists of stationary frame displayed for its entire duration.
+ 85 staticFrame :: Duration -> SVG -> Animation
+ 86 staticFrame d svg = Animation d (const svg)
+ 87
+ 88 -- | Query the duration of an animation.
+ 89 duration :: Animation -> Duration
+ 90 duration (Animation d _) = d
+ 91
+ 92 -- | Play animations in sequence. The @lhs@ animation is removed after it has
+ 93 -- completed. New animation duration is '@duration lhs + duration rhs@'.
+ 94 --
+ 95 -- Example:
+ 96 --
+ 97 -- @'Reanimate.Builtin.Documentation.drawBox' `'seqA'` 'Reanimate.Builtin.Documentation.drawCircle'@
+ 98 --
+ 99 -- <<docs/gifs/doc_seqA.gif>>
+ 100 seqA :: Animation -> Animation -> Animation
+ 101 seqA (Animation d1 f1) (Animation d2 f2) =
+ 102 Animation totalD $ \t ->
+ 103 if t < d1/totalD
+ 104 then f1 (t * totalD/d1)
+ 105 else f2 ((t-d1/totalD) * totalD/d2)
+ 106 where
+ 107 totalD = d1+d2
+ 108
+ 109 -- | Play two animation concurrently. Shortest animation freezes on last frame.
+ 110 -- New animation duration is '@max (duration lhs) (duration rhs)@'.
+ 111 --
+ 112 -- Example:
+ 113 --
+ 114 -- @'Reanimate.Builtin.Documentation.drawBox' `'parA'` 'adjustDuration' (*2) 'Reanimate.Builtin.Documentation.drawCircle'@
+ 115 --
+ 116 -- <<docs/gifs/doc_parA.gif>>
+ 117 parA :: Animation -> Animation -> Animation
+ 118 parA (Animation d1 f1) (Animation d2 f2) =
+ 119 Animation (max d1 d2) $ \t ->
+ 120 let t1 = t * totalD/d1
+ 121 t2 = t * totalD/d2 in
+ 122 mkGroup
+ 123 [ f1 (min 1 t1)
+ 124 , f2 (min 1 t2) ]
+ 125 where
+ 126 totalD = max d1 d2
+ 127
+ 128 -- | Play two animation concurrently. Shortest animation loops.
+ 129 -- New animation duration is '@max (duration lhs) (duration rhs)@'.
+ 130 --
+ 131 -- Example:
+ 132 --
+ 133 -- @'Reanimate.Builtin.Documentation.drawBox' `'parLoopA'` 'adjustDuration' (*2) 'Reanimate.Builtin.Documentation.drawCircle'@
+ 134 --
+ 135 -- <<docs/gifs/doc_parLoopA.gif>>
+ 136 parLoopA :: Animation -> Animation -> Animation
+ 137 parLoopA (Animation d1 f1) (Animation d2 f2) =
+ 138 Animation totalD $ \t ->
+ 139 let t1 = t * totalD/d1
+ 140 t2 = t * totalD/d2 in
+ 141 mkGroup
+ 142 [ f1 (t1 `mod'` 1)
+ 143 , f2 (t2 `mod'` 1) ]
+ 144 where
+ 145 totalD = max d1 d2
+ 146
+ 147 -- | Play two animation concurrently. Animations disappear after playing once.
+ 148 -- New animation duration is '@max (duration lhs) (duration rhs)@'.
+ 149 --
+ 150 -- Example:
+ 151 --
+ 152 -- @'Reanimate.Builtin.Documentation.drawBox' `'parLoopA'` 'adjustDuration' (*2) 'Reanimate.Builtin.Documentation.drawCircle'@
+ 153 --
+ 154 -- <<docs/gifs/doc_parDropA.gif>>
+ 155 parDropA :: Animation -> Animation -> Animation
+ 156 parDropA (Animation d1 f1) (Animation d2 f2) =
+ 157 Animation totalD $ \t ->
+ 158 let t1 = t * totalD/d1
+ 159 t2 = t * totalD/d2 in
+ 160 mkGroup
+ 161 [ if t1>1 then None else f1 t1
+ 162 , if t2>1 then None else f2 t2 ]
+ 163 where
+ 164 totalD = max d1 d2
+ 165
+ 166 -- | Empty animation (no SVG output) with a fixed duration.
+ 167 --
+ 168 -- Example:
+ 169 --
+ 170 -- @'pause' 1 `'seqA'` 'Reanimate.Builtin.Documentation.drawProgress'@
+ 171 --
+ 172 -- <<docs/gifs/doc_pause.gif>>
+ 173 pause :: Duration -> Animation
+ 174 pause d = Animation d (const None)
+ 175
+ 176 -- | Play left animation and freeze on the last frame, then play the right
+ 177 -- animation. New duration is '@duration lhs + duration rhs@'.
+ 178 --
+ 179 -- Example:
+ 180 --
+ 181 -- @'Reanimate.Builtin.Documentation.drawBox' `'andThen'` 'Reanimate.Builtin.Documentation.drawCircle'@
+ 182 --
+ 183 -- <<docs/gifs/doc_andThen.gif>>
+ 184 andThen :: Animation -> Animation -> Animation
+ 185 andThen a b = a `parA` (pause (duration a) `seqA` b)
+ 186
+ 187 -- | Calculate the frame that would be displayed at given point in @time@ of running @animation@.
+ 188 --
+ 189 -- The provided time parameter is clamped between 0 and animation duration.
+ 190 frameAt :: Time -> Animation -> SVG
+ 191 frameAt t (Animation d f) = f t'
+ 192 where
+ 193 t' = clamp 0 1 (t/d)
+ 194
+ 195 -- | Helper function for pretty-printing SVG nodes.
+ 196 renderTree :: SVG -> String
+ 197 renderTree t = maybe "" ppElement $ xmlOfTree t
+ 198
+ 199 -- | Helper function for pretty-printing SVG nodes as SVG documents.
+ 200 renderSvg :: Maybe Number -- ^ The number to use as value of the @width@ attribute of the resulting top-level svg element. If @Nothing@, the width attribute won't be rendered.
+ 201 -> Maybe Number -- ^ Similar to previous argument, but for @height@ attribute.
+ 202 -> SVG -- ^ SVG to render
+ 203 -> String -- ^ String representation of SVG XML markup
+ 204 renderSvg w h t = ppDocument doc
+ 205 -- renderSvg w h t = ppFastElement (xmlOfDocument doc)
+ 206 where
+ 207 width = 16
+ 208 height = 9
+ 209 doc = Document
+ 210 { _documentViewBox = Just (-width/2, -height/2, width, height)
+ 211 , _documentWidth = w
+ 212 , _documentHeight = h
+ 213 , _documentElements = [withStrokeWidth defaultStrokeWidth $ scaleXY 1 (-1) t]
+ 214 , _documentDescription = ""
+ 215 , _documentLocation = ""
+ 216 , _documentAspectRatio = PreserveAspectRatio False AlignNone Nothing
+ 217 }
+ 218
+ 219 -- | Map over the SVG produced by an animation at every frame.
+ 220 --
+ 221 -- Example:
+ 222 --
+ 223 -- @'mapA' ('scale' 0.5) 'Reanimate.Builtin.Documentation.drawCircle'@
+ 224 --
+ 225 -- <<docs/gifs/doc_mapA.gif>>
+ 226
+ 227 mapA :: (SVG -> SVG) -> Animation -> Animation
+ 228 mapA fn (Animation d f) = Animation d (fn . f)
+ 229
+ 230 -- | Freeze the last frame for @t@ seconds at the end of the animation.
+ 231 --
+ 232 -- Example:
+ 233 --
+ 234 -- @'pauseAtEnd' 1 'Reanimate.Builtin.Documentation.drawProgress'@
+ 235 --
+ 236 -- <<docs/gifs/doc_pauseAtEnd.gif>>
+ 237 pauseAtEnd :: Duration -> Animation -> Animation
+ 238 pauseAtEnd t a = a `andThen` pause t
+ 239
+ 240 -- | Freeze the first frame for @t@ seconds at the beginning of the animation.
+ 241 --
+ 242 -- Example:
+ 243 --
+ 244 -- @'pauseAtBeginning' 1 'Reanimate.Builtin.Documentation.drawProgress'@
+ 245 --
+ 246 -- <<docs/gifs/doc_pauseAtBeginning.gif>>
+ 247 pauseAtBeginning :: Duration -> Animation -> Animation
+ 248 pauseAtBeginning t a =
+ 249 Animation t (freezeFrame 0 a) `seqA` a
+ 250
+ 251 -- | Freeze the first and the last frame of the animation for a specified duration.
+ 252 --
+ 253 -- Example:
+ 254 --
+ 255 -- @'pauseAround' 1 1 'Reanimate.Builtin.Documentation.drawProgress'@
+ 256 --
+ 257 -- <<docs/gifs/doc_pauseAround.gif>>
+ 258 pauseAround :: Duration -> Duration -> Animation -> Animation
+ 259 pauseAround start end = pauseAtEnd end . pauseAtBeginning start
+ 260
+ 261 -- Freeze frame at time @t@.
+ 262 freezeFrame :: Time -> Animation -> (Time -> SVG)
+ 263 freezeFrame t (Animation d f) = const $ f (t/d)
+ 264
+ 265 -- | Change the duration of an animation. Animates are stretched or squished
+ 266 -- (rather than truncated) to fit the new duration.
+ 267 adjustDuration :: (Duration -> Duration) -> Animation -> Animation
+ 268 adjustDuration fn (Animation d gen) =
+ 269 Animation (fn d) gen
+ 270
+ 271 -- | Set the duration of an animation by adjusting its playback rate. The
+ 272 -- animation is still played from start to finish without being cropped.
+ 273 setDuration :: Duration -> Animation -> Animation
+ 274 setDuration newD = adjustDuration (const newD)
+ 275
+ 276 -- | Play an animation in reverse. Duration remains unchanged. Shorthand for:
+ 277 -- @'signalA' 'reverseS'@.
+ 278 --
+ 279 -- Example:
+ 280 --
+ 281 -- @'reverseA' 'Reanimate.Builtin.Documentation.drawCircle'@
+ 282 --
+ 283 -- <<docs/gifs/doc_reverseA.gif>>
+ 284 reverseA :: Animation -> Animation
+ 285 reverseA = signalA reverseS
+ 286
+ 287 -- | Play animation before playing it again in reverse. Duration is twice
+ 288 -- the duration of the input.
+ 289 --
+ 290 -- Example:
+ 291 --
+ 292 -- @'playThenReverseA' 'Reanimate.Builtin.Documentation.drawCircle'@
+ 293 --
+ 294 -- <<docs/gifs/doc_playThenReverseA.gif>>
+ 295 playThenReverseA :: Animation -> Animation
+ 296 playThenReverseA a = a `seqA` reverseA a
+ 297
+ 298 -- | Loop animation @n@ number of times. This number may be fractional and it
+ 299 -- may be less than 1. It must be greater than or equal to 0, though.
+ 300 -- New duration is @n*duration input@.
+ 301 --
+ 302 -- Example:
+ 303 --
+ 304 -- @'repeatA' 1.5 'Reanimate.Builtin.Documentation.drawCircle'@
+ 305 --
+ 306 -- <<docs/gifs/doc_repeatA.gif>>
+ 307 repeatA :: Double -> Animation -> Animation
+ 308 repeatA n (Animation d f) = Animation (d*n) $ \t ->
+ 309 f ((t*n) `mod'` 1)
+ 310
+ 311
+ 312 -- | @freezeAtPercentage time animation@ creates an animation consisting of stationary frame,
+ 313 -- that would be displayed in the provided @animation@ at given @time@.
+ 314 -- The duration of the new animation is the same as the duration of provided @animation@.
+ 315 freezeAtPercentage :: Time -- ^ value between 0 and 1. The frame displayed at this point in the original animation will be displayed for the duration of the new animation
+ 316 -> Animation -- ^ original animation, from which the frame will be taken
+ 317 -> Animation -- ^ new animation consisting of static frame displayed for the duration of the original animation
+ 318 freezeAtPercentage frac (Animation d genFrame) =
+ 319 Animation d $ const $ genFrame frac
+ 320
+ 321 -- | Overlay animation on top of static SVG image.
+ 322 --
+ 323 -- Example:
+ 324 --
+ 325 -- @'addStatic' ('mkBackground' "lightblue") 'Reanimate.Builtin.Documentation.drawCircle'@
+ 326 --
+ 327 -- <<docs/gifs/doc_addStatic.gif>>
+ 328 addStatic :: SVG -> Animation -> Animation
+ 329 addStatic static = mapA (\frame -> mkGroup [static, frame])
+ 330
+ 331 -- | Modify the time component of an animation. Animation duration is unchanged.
+ 332 --
+ 333 -- Example:
+ 334 --
+ 335 -- @'signalA' ('fromToS' 0.25 0.75) 'Reanimate.Builtin.Documentation.drawCircle'@
+ 336 --
+ 337 -- <<docs/gifs/doc_signalA.gif>>
+ 338 signalA :: Signal -> Animation -> Animation
+ 339 signalA fn (Animation d gen) = Animation d $ gen . fn
+ 340
+ 341 -- | @takeA duration animation@ creates a new animation consisting of initial segment of
+ 342 -- @animation@ of given @duration@, played at the same rate as the original animation.
+ 343 --
+ 344 -- The @duration@ parameter is clamped to be between 0 and @animation@'s duration.
+ 345 -- New animation duration is equal to (eventually clamped) @duration@.
+ 346 takeA :: Duration -> Animation -> Animation
+ 347 takeA len (Animation d gen) = Animation len' $ \t ->
+ 348 gen (t * len'/d)
+ 349 where
+ 350 len' = clamp 0 d len
+ 351
+ 352 -- | @dropA duration animation@ creates a new animation by dropping initial segment
+ 353 -- of length @duration@ from the provided @animation@, played at the same rate as the original animation.
+ 354 --
+ 355 -- The @duration@ parameter is clamped to be between 0 and @animation@'s duration.
+ 356 -- The duration of the resulting animation is duration of provided @animation@ minus (eventually clamped) @duration@.
+ 357 dropA :: Duration -> Animation -> Animation
+ 358 dropA len (Animation d gen) = Animation len' $ \t ->
+ 359 gen (t * len'/d + len/d)
+ 360 where
+ 361 len' = d - clamp 0 d len
+ 362
+ 363 -- | @lastA duration animation@ return the last @duration@ seconds of the animation.
+ 364 lastA :: Duration -> Animation -> Animation
+ 365 lastA len a = dropA (duration a - len) a
+ 366
+ 367 clamp :: Double -> Double -> Double -> Double
+ 368 clamp a b number
+ 369 | a < b = max a (min b number)
+ 370 | otherwise = max b (min a number)
+ 371
+ 372 -- (#) :: a -> (a -> b) -> b
+ 373 -- o # f = f o
+ 374
+ 375 -- | Ask for an animation frame using a given synchronization policy.
+ 376 getAnimationFrame :: Sync -> Animation -> Time -> Duration -> SVG
+ 377 getAnimationFrame sync (Animation aDur aGen) t d =
+ 378 case sync of
+ 379 SyncStretch -> aGen (t/d)
+ 380 SyncLoop -> aGen (takeFrac $ t/aDur)
+ 381 SyncDrop -> if t > aDur then None else aGen (t/aDur)
+ 382 SyncFreeze -> aGen (min 1 $ t/aDur)
+ 383 where
+ 384 takeFrac f = snd (properFraction f :: (Int, Double))
+ 385
+ 386 -- | Animation synchronization policies.
+ 387 data Sync
+ 388 = SyncStretch
+ 389 | SyncLoop
+ 390 | SyncDrop
+ 391 | SyncFreeze
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Builtin.Documentation.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Builtin.Documentation.hs.html
new file mode 100644
index 0000000..d6a0692
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Builtin.Documentation.hs.html
@@ -0,0 +1,86 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Module : Reanimate.Builtin.Documentation
+ 3 Copyright : Written by David Himmelstrup
+ 4 License : Unlicense
+ 5 Maintainer : lemmih@gmail.com
+ 6 Stability : experimental
+ 7 Portability : POSIX
+ 8
+ 9 This module contains convenience functions used in documention
+ 10 GIFs for a consistent look and feel.
+ 11
+ 12 -}
+ 13 module Reanimate.Builtin.Documentation where
+ 14
+ 15 import Reanimate.Animation
+ 16 import Reanimate.Svg
+ 17 import Reanimate.Raster
+ 18 import Reanimate.Constants
+ 19 import Codec.Picture
+ 20
+ 21 -- | Default environment for API documentation GIFs.
+ 22 docEnv :: Animation -> Animation
+ 23 docEnv = mapA $ \svg -> mkGroup
+ 24 [ mkBackground "white"
+ 25 , withFillOpacity 0 $
+ 26 withStrokeWidth 0.1 $
+ 27 withStrokeColor "black" (mkGroup [svg]) ]
+ 28
+ 29 -- | <<docs/gifs/doc_drawBox.gif>>
+ 30 drawBox :: Animation
+ 31 drawBox = mkAnimation 2 $ \t ->
+ 32 partialSvg t $ pathify $
+ 33 mkRect (screenWidth/2) (screenHeight/2)
+ 34
+ 35 -- | <<docs/gifs/doc_drawCircle.gif>>
+ 36 drawCircle :: Animation
+ 37 drawCircle = mkAnimation 2 $ \t ->
+ 38 partialSvg t $ pathify $
+ 39 mkCircle (screenHeight/3)
+ 40
+ 41 -- | <<docs/gifs/doc_drawProgress.gif>>
+ 42 drawProgress :: Animation
+ 43 drawProgress = mkAnimation 2 $ \t ->
+ 44 mkGroup
+ 45 [ mkLine (-screenWidth/2*widthP,0)
+ 46 (screenWidth/2*widthP,0)
+ 47 , translate (-screenWidth/2*widthP + screenWidth*widthP*t) 0 $
+ 48 withFillOpacity 1 $ mkCircle 0.5 ]
+ 49 where
+ 50 widthP = 0.8
+ 51
+ 52 -- | Render a full-screen view of a color-map.
+ 53 showColorMap :: (Double -> PixelRGB8) -> SVG
+ 54 showColorMap f = center $ scaleToSize screenWidth screenHeight $ embedImage img
+ 55 where
+ 56 width = 256
+ 57 height = 1
+ 58 img = generateImage pixelRenderer width height
+ 59 pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1))
+ 60
+ 61 -- | Default background color for videos on reanimate.rtfd.io
+ 62 rtfdBackgroundColor :: PixelRGBA8
+ 63 rtfdBackgroundColor = PixelRGBA8 252 252 252 0xFF
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Builtin.Images.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Builtin.Images.hs.html
new file mode 100644
index 0000000..5be7e8b
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Builtin.Images.hs.html
@@ -0,0 +1,91 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Module : Reanimate.Builtin.Images
+ 3 Copyright : Written by David Himmelstrup
+ 4 License : Unlicense
+ 5 Maintainer : lemmih@gmail.com
+ 6 Stability : experimental
+ 7 Portability : POSIX
+ 8
+ 9 Collection of built-in images.
+ 10
+ 11 -}
+ 12 module Reanimate.Builtin.Images
+ 13 ( svgLogo
+ 14 , haskellLogo
+ 15 , githubIcon
+ 16 , githubWhiteIcon
+ 17 , smallEarth
+ 18 ) where
+ 19
+ 20 import Codec.Picture
+ 21 import qualified Data.ByteString as B
+ 22 import Graphics.SvgTree (parseSvgFile)
+ 23 import Paths_reanimate
+ 24 import Reanimate.Animation
+ 25 import Reanimate.Svg
+ 26 import System.IO.Unsafe
+ 27
+ 28 embedImage :: FilePath -> IO SVG
+ 29 embedImage key = do
+ 30 svg_file <- getDataFileName key
+ 31 svg_data <- B.readFile svg_file
+ 32 case parseSvgFile svg_file svg_data of
+ 33 Nothing -> error "Malformed svg"
+ 34 Just svg -> return $ embedDocument svg
+ 35
+ 36 loadJPG :: FilePath -> Image PixelRGBA8
+ 37 loadJPG key = unsafePerformIO $ do
+ 38 jpg_file <- getDataFileName key
+ 39 dat <- B.readFile jpg_file
+ 40 case decodeJpeg dat of
+ 41 Left err -> error err
+ 42 Right img -> return $ convertRGBA8 img
+ 43
+ 44 {- HLINT ignore svgLogo -}
+ 45 -- | <<docs/gifs/doc_svgLogo.gif>>
+ 46 svgLogo :: SVG
+ 47 svgLogo = unsafePerformIO $ embedImage "data/svg-logo.svg"
+ 48
+ 49 {- HLINT ignore haskellLogo -}
+ 50 -- | <<docs/gifs/doc_haskellLogo.gif>>
+ 51 haskellLogo :: SVG
+ 52 haskellLogo = unsafePerformIO $ embedImage "data/haskell.svg"
+ 53
+ 54 {- HLINT ignore githubIcon -}
+ 55 -- | <<docs/gifs/doc_githubIcon.gif>>
+ 56 githubIcon :: SVG
+ 57 githubIcon = unsafePerformIO $ embedImage "data/github-icon.svg"
+ 58
+ 59 {-# NOINLINE githubWhiteIcon #-}
+ 60 -- | <<docs/gifs/doc_githubWhiteIcon.gif>>
+ 61 githubWhiteIcon :: SVG
+ 62 githubWhiteIcon = unsafePerformIO $ embedImage "data/github-icon-white.svg"
+ 63
+ 64 -- | 300x150 equirectangular earth
+ 65 --
+ 66 -- <<docs/gifs/doc_smallEarth.gif>>
+ 67 smallEarth :: Image PixelRGBA8
+ 68 smallEarth = loadJPG "data/small_earth.jpg"
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Builtin.Slide.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Builtin.Slide.hs.html
new file mode 100644
index 0000000..9e8a6c2
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Builtin.Slide.hs.html
@@ -0,0 +1,60 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Copyright : Written by David Himmelstrup
+ 3 License : Unlicense
+ 4 Maintainer : lemmih@gmail.com
+ 5 Stability : experimental
+ 6 Portability : POSIX
+ 7 -}
+ 8 module Reanimate.Builtin.Slide where
+ 9
+ 10 import Reanimate.Transition
+ 11 import Reanimate.Constants
+ 12 import Reanimate.Svg
+ 13 import Reanimate.Effect
+ 14
+ 15 -- | <<docs/gifs/doc_slideLeftT.gif>>
+ 16 slideLeftT :: Transition
+ 17 slideLeftT = effectT slideLeft (andE slideLeft moveRight)
+ 18 where
+ 19 slideLeft = translateE (-screenWidth) 0
+ 20 moveRight = constE (translate screenWidth 0)
+ 21 andE a b d t = a d t . b d t
+ 22
+ 23 -- | <<docs/gifs/doc_slideDownT.gif>>
+ 24 slideDownT :: Transition
+ 25 slideDownT = effectT slideDown (andE slideDown moveUp)
+ 26 where
+ 27 slideDown = translateE 0 (-screenHeight)
+ 28 moveUp = constE (translate 0 screenHeight)
+ 29 andE a b d t = a d t . b d t
+ 30
+ 31 -- | <<docs/gifs/doc_slideUpT.gif>>
+ 32 slideUpT :: Transition
+ 33 slideUpT = effectT slideUp (andE slideUp moveDown)
+ 34 where
+ 35 slideUp = translateE 0 screenHeight
+ 36 moveDown = constE (translate 0 (-screenHeight))
+ 37 andE a b d t = a d t . b d t
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Cache.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Cache.hs.html
new file mode 100644
index 0000000..2690749
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Cache.hs.html
@@ -0,0 +1,134 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 module Reanimate.Cache
+ 2 ( cacheFile -- :: FilePath -> (FilePath -> IO ()) -> IO FilePath
+ 3 , cacheMem
+ 4 , cacheDisk
+ 5 , cacheDiskSvg
+ 6 , cacheDiskKey
+ 7 , cacheDiskLines
+ 8 , encodeInt
+ 9 ) where
+ 10
+ 11 import Control.Exception
+ 12 import Control.Monad (unless)
+ 13 import Data.Bits
+ 14 import Data.Hashable
+ 15 import Data.IORef
+ 16 import Data.Map (Map)
+ 17 import qualified Data.Map as Map
+ 18 import Data.Text (Text)
+ 19 import qualified Data.Text as T
+ 20 import qualified Data.Text.IO as T
+ 21 import Graphics.SvgTree (Tree, unparse, pattern None)
+ 22 import Reanimate.Animation (renderTree)
+ 23 import Reanimate.Misc (renameOrCopyFile)
+ 24 import System.Directory
+ 25 import System.FilePath
+ 26 import System.IO
+ 27 import System.IO.Temp
+ 28 import System.IO.Unsafe
+ 29 import Text.XML.Light (Content (..), parseXML)
+ 30
+ 31 -- Memory cache and disk cache
+ 32
+ 33 cacheFile :: FilePath -> (FilePath -> IO ()) -> IO FilePath
+ 34 cacheFile template gen = do
+ 35 root <- getXdgDirectory XdgCache "reanimate"
+ 36 createDirectoryIfMissing True root
+ 37 let path = root </> template
+ 38 hit <- doesFileExist path
+ 39 unless hit $ withSystemTempFile template $ \tmp h -> do
+ 40 hClose h
+ 41 gen tmp
+ 42 renameOrCopyFile tmp path
+ 43 evaluate path
+ 44
+ 45 cacheDisk :: String -> (T.Text -> Maybe a) -> (a -> T.Text) -> (Text -> IO a) -> (Text -> IO a)
+ 46 cacheDisk cacheType parse render gen key = do
+ 47 root <- getXdgDirectory XdgCache "reanimate"
+ 48 createDirectoryIfMissing True root
+ 49 let path = root </> encodeInt (hash key) <.> cacheType
+ 50 hit <- doesFileExist path
+ 51 if hit
+ 52 then do
+ 53 inp <- T.readFile path
+ 54 case parse inp of
+ 55 Nothing -> genCache root path
+ 56 Just val -> pure val
+ 57 else genCache root path
+ 58 where
+ 59 genCache root path = do
+ 60 (tmpPath, tmpHandle) <- openTempFile root (encodeInt (hash key))
+ 61 new <- gen key
+ 62 T.hPutStr tmpHandle (render new)
+ 63 hClose tmpHandle
+ 64 renameOrCopyFile tmpPath path
+ 65 return new
+ 66
+ 67 cacheDiskKey :: Text -> IO Tree -> IO Tree
+ 68 cacheDiskKey key gen = cacheDiskSvg (const gen) key
+ 69
+ 70 cacheDiskSvg :: (Text -> IO Tree) -> (Text -> IO Tree)
+ 71 cacheDiskSvg = cacheDisk "svg" parse render
+ 72 where
+ 73 parse txt = case parseXML txt of
+ 74 [Elem t] -> Just (unparse t)
+ 75 _ -> Nothing
+ 76 render = T.pack . renderTree
+ 77
+ 78 cacheDiskLines :: (Text -> IO [Text]) -> (Text -> IO [Text])
+ 79 cacheDiskLines = cacheDisk "txt" parse render
+ 80 where
+ 81 parse = Just . T.lines
+ 82 render = T.unlines
+ 83
+ 84
+ 85 {-# NOINLINE cache #-}
+ 86 cache :: IORef (Map Text Tree)
+ 87 cache = unsafePerformIO (newIORef Map.empty)
+ 88
+ 89 cacheMem :: (Text -> IO Tree) -> (Text -> IO Tree)
+ 90 cacheMem gen key = do
+ 91 store <- readIORef cache
+ 92 case Map.lookup key store of
+ 93 Just svg -> return svg
+ 94 Nothing -> do
+ 95 svg <- gen key
+ 96 case svg of
+ 97 -- None usually indicates that latex or another tool was misconfigured. In this case,
+ 98 -- don't store the result.
+ 99 None -> pure svg
+ 100 _ -> atomicModifyIORef cache (\m -> (Map.insert key svg m, svg))
+ 101
+ 102 encodeInt :: Int -> String
+ 103 encodeInt i = worker (fromIntegral i) 60
+ 104 where
+ 105 worker :: Word -> Int -> String
+ 106 worker key sh
+ 107 | sh < 0 = []
+ 108 | otherwise =
+ 109 case (key `shiftR` sh) `mod` 64 of
+ 110 idx -> alphabet !! fromIntegral idx : worker key (sh-6)
+ 111 alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+$"
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.ColorComponents.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.ColorComponents.hs.html
new file mode 100644
index 0000000..3256f3c
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.ColorComponents.hs.html
@@ -0,0 +1,152 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE RecordWildCards #-}
+ 2 {- |
+ 3 Colors are three dimensional and can be projected into many color spaces
+ 4 with different properties.
+ 5
+ 6 Interpolating directly in the RGB color space is unintuitive and rarely useful.
+ 7 If you want to transition through color, you most likely want either the XYZ space
+ 8 (for physically accurate color transitions) or the LAB space (for esthetically
+ 9 pleasing colors).
+ 10 -}
+ 11 module Reanimate.ColorComponents
+ 12 ( ColorComponents(..)
+ 13 , rgbComponents
+ 14 , hsvComponents
+ 15 , labComponents
+ 16 , xyzComponents
+ 17 , lchComponents
+ 18 , interpolate
+ 19 , interpolateRGB8
+ 20 , interpolateRGBA8
+ 21 , toRGB8
+ 22 , fromRGB8
+ 23 ) where
+ 24
+ 25 import Codec.Picture
+ 26 import Codec.Picture.Types
+ 27 import Data.Colour
+ 28 import Data.Colour.CIE
+ 29 import Data.Colour.CIE.Illuminant (d65)
+ 30 import Data.Colour.RGBSpace
+ 31 import Data.Colour.RGBSpace.HSV
+ 32 import Data.Colour.SRGB
+ 33 import Data.Fixed
+ 34 import Reanimate.Ease
+ 35
+ 36 -- | Constructor and destructor for color's three components.
+ 37 data ColorComponents = ColorComponents
+ 38 { colorUnpack :: Colour Double -> (Double, Double, Double)
+ 39 -- ^ Unpack a color into its three components.
+ 40 , colorPack :: Double -> Double -> Double -> Colour Double
+ 41 -- ^ Restore a color from three coordinates.
+ 42 }
+ 43
+ 44 -- | > interpolate rgbComponents yellow blue
+ 45 --
+ 46 -- <<docs/gifs/doc_rgbComponents.gif>>
+ 47 rgbComponents :: ColorComponents
+ 48 rgbComponents = ColorComponents rgbUnpack sRGB
+ 49 where
+ 50 rgbUnpack :: Colour Double -> (Double, Double, Double)
+ 51 rgbUnpack c =
+ 52 case toSRGB c of
+ 53 RGB r g b -> (r,g,b)
+ 54
+ 55 -- | > interpolate hsvComponents yellow blue
+ 56 --
+ 57 -- <<docs/gifs/doc_hsvComponents.gif>>
+ 58 hsvComponents :: ColorComponents
+ 59 hsvComponents = ColorComponents unpack pack
+ 60 where
+ 61 unpack = hsvView.toSRGB
+ 62 pack a b c = uncurryRGB sRGB $ hsv a b c
+ 63
+ 64 -- | > interpolate labComponents yellow blue
+ 65 --
+ 66 -- <<docs/gifs/doc_labComponents.gif>>
+ 67 labComponents :: ColorComponents
+ 68 labComponents = ColorComponents unpack pack
+ 69 where
+ 70 unpack = cieLABView d65
+ 71 pack = cieLAB d65
+ 72
+ 73 -- | > interpolate xyzComponents yellow blue
+ 74 --
+ 75 -- <<docs/gifs/doc_xyzComponents.gif>>
+ 76 xyzComponents :: ColorComponents
+ 77 xyzComponents = ColorComponents cieXYZView cieXYZ
+ 78
+ 79 -- | > interpolate lchComponents yellow blue
+ 80 --
+ 81 -- <<docs/gifs/doc_lchComponents.gif>>
+ 82 lchComponents :: ColorComponents
+ 83 lchComponents = ColorComponents unpack pack
+ 84 where
+ 85 toDeg,toRad :: Double -> Double
+ 86 toRad deg = deg/180 * pi
+ 87 toDeg rad = rad/pi * 180
+ 88 unpack :: Colour Double -> (Double, Double, Double)
+ 89 unpack color =
+ 90 let (l,a,b) = cieLABView d65 color
+ 91 c = sqrt (a*a + b*b)
+ 92 h :: Double
+ 93 h = (toDeg(atan2 b a) + 360) `mod'` 360
+ 94 isZero = round (c*10000) == (0::Integer)
+ 95 in (l, c, if isZero then 0/0 else h)
+ 96 pack l c h =
+ 97 cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c)
+ 98
+ 99 -- | Smoothly interpolate between two colors using the given color components.
+ 100 interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double)
+ 101 interpolate ColorComponents{..} from to = \d ->
+ 102 colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d)
+ 103 where
+ 104 (a1,b1,c1) = colorUnpack from
+ 105 (a2,b2,c2) = colorUnpack to
+ 106
+ 107 -- | Convenience interpolation function for RGB8 values.
+ 108 interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8)
+ 109 interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to)
+ 110
+ 111 -- | Convenience interpolation function for RGBA8 values.
+ 112 interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> (Double -> PixelRGBA8)
+ 113 interpolateRGBA8 comps from to = \t ->
+ 114 case interp t of
+ 115 PixelRGB8 r g b ->
+ 116 let alpha = fromToS (fromIntegral $ pixelOpacity from) (fromIntegral $ pixelOpacity to) t
+ 117 in PixelRGBA8 r g b (round alpha)
+ 118 where
+ 119 interp = interpolateRGB8 comps (dropTransparency from) (dropTransparency to)
+ 120
+ 121 -- | Convenience function for expressing a color as an RGB8 value.
+ 122 toRGB8 :: Colour Double -> PixelRGB8
+ 123 toRGB8 c = PixelRGB8 r g b
+ 124 where
+ 125 RGB r g b = toSRGBBounded c
+ 126
+ 127 -- | Convenience function for expressing an RGB8 value as a color.
+ 128 fromRGB8 :: PixelRGB8 -> Colour Double
+ 129 fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.ColorMap.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.ColorMap.hs.html
new file mode 100644
index 0000000..bd99486
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.ColorMap.hs.html
@@ -0,0 +1,533 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE OverloadedStrings #-}
+ 2 {-|
+ 3 A colormap takes a number between 0 and 1 (inclusive) and spits out a color.
+ 4 The colors do not have an alpha component but one can be added with
+ 5 `Codec.Picture.Types.promotePixel`.
+ 6 -}
+ 7 module Reanimate.ColorMap
+ 8 ( turbo
+ 9 , viridis
+ 10 , magma
+ 11 , inferno
+ 12 , plasma
+ 13 , sinebow
+ 14 , parula
+ 15 , cividis
+ 16 , jet
+ 17 , hsv
+ 18 , hsvMatlab
+ 19 , greyscale
+ 20 ) where
+ 21
+ 22 import Data.Text (Text)
+ 23 import Data.Vector (Vector)
+ 24 import qualified Data.Text as T
+ 25 import qualified Data.Vector as V
+ 26 import Codec.Picture
+ 27 import Data.Char
+ 28 import Data.Bits
+ 29 import qualified Data.Colour.RGBSpace.HSV as HSV
+ 30 import Data.Colour.RGBSpace
+ 31
+ 32 -- | Given a number t in the range [0,1], returns the corresponding color from
+ 33 -- the “turbo” color scheme by Anton Mikhailov.
+ 34 --
+ 35 -- <<docs/gifs/doc_turbo.gif>>
+ 36 turbo :: Double -> PixelRGB8
+ 37 turbo t = PixelRGB8 red green blue
+ 38 where
+ 39 red = trunc (round (34.61 + t * (1172.33 - t * (10793.56 - t * (33300.12 - t * (38394.49 - t * 14825.05))))))
+ 40 green = trunc (round (23.31 + t * (557.33 + t * (1225.33 - t * (3574.96 - t * (1073.77 + t * 707.56))))))
+ 41 blue = trunc (round (27.2 + t * (3211.1 - t * (15327.97 - t * (27814 - t * (22569.18 - t * 6838.66))))))
+ 42 trunc :: Integer -> Pixel8
+ 43 trunc = fromIntegral . min 255 . max 0
+ 44
+ 45 -- | Given a number t in the range [0,1], returns the corresponding color from
+ 46 -- the “viridis” perceptually-uniform color scheme designed by van der Walt,
+ 47 -- Smith and Firing for matplotlib, represented as an RGB string.
+ 48 --
+ 49 -- <<docs/gifs/doc_viridis.gif>>
+ 50 viridis :: Double -> PixelRGB8
+ 51 viridis = ramp (colors
+ 52 "44015444025645045745055946075a46085c460a5d460b5e470d60470e614710634711644713\
+ 53 \6548146748166848176948186a481a6c481b6d481c6e481d6f481f7048207148217348237448\
+ 54 \2475482576482677482878482979472a7a472c7a472d7b472e7c472f7d46307e46327e46337f\
+ 55 \463480453581453781453882443983443a83443b84433d84433e85423f854240864241864142\
+ 56 \874144874045884046883f47883f48893e49893e4a893e4c8a3d4d8a3d4e8a3c4f8a3c508b3b\
+ 57 \518b3b528b3a538b3a548c39558c39568c38588c38598c375a8c375b8d365c8d365d8d355e8d\
+ 58 \355f8d34608d34618d33628d33638d32648e32658e31668e31678e31688e30698e306a8e2f6b\
+ 59 \8e2f6c8e2e6d8e2e6e8e2e6f8e2d708e2d718e2c718e2c728e2c738e2b748e2b758e2a768e2a\
+ 60 \778e2a788e29798e297a8e297b8e287c8e287d8e277e8e277f8e27808e26818e26828e26828e\
+ 61 \25838e25848e25858e24868e24878e23888e23898e238a8d228b8d228c8d228d8d218e8d218f\
+ 62 \8d21908d21918c20928c20928c20938c1f948c1f958b1f968b1f978b1f988b1f998a1f9a8a1e\
+ 63 \9b8a1e9c891e9d891f9e891f9f881fa0881fa1881fa1871fa28720a38620a48621a58521a685\
+ 64 \22a78522a88423a98324aa8325ab8225ac8226ad8127ad8128ae8029af7f2ab07f2cb17e2db2\
+ 65 \7d2eb37c2fb47c31b57b32b67a34b67935b77937b87838b9773aba763bbb753dbc743fbc7340\
+ 66 \bd7242be7144bf7046c06f48c16e4ac16d4cc26c4ec36b50c46a52c56954c56856c66758c765\
+ 67 \5ac8645cc8635ec96260ca6063cb5f65cb5e67cc5c69cd5b6ccd5a6ece5870cf5773d05675d0\
+ 68 \5477d1537ad1517cd2507fd34e81d34d84d44b86d54989d5488bd6468ed64590d74393d74195\
+ 69 \d84098d83e9bd93c9dd93ba0da39a2da37a5db36a8db34aadc32addc30b0dd2fb2dd2db5de2b\
+ 70 \b8de29bade28bddf26c0df25c2df23c5e021c8e020cae11fcde11dd0e11cd2e21bd5e21ad8e2\
+ 71 \19dae319dde318dfe318e2e418e5e419e7e419eae51aece51befe51cf1e51df4e61ef6e620f8\
+ 72 \e621fbe723fde725")
+ 73
+ 74 -- | Given a number t in the range [0,1], returns the corresponding color from
+ 75 -- the “magma” perceptually-uniform color scheme designed by van der Walt and
+ 76 -- Smith for matplotlib, represented as an RGB string.
+ 77 --
+ 78 -- <<docs/gifs/doc_magma.gif>>
+ 79 magma :: Double -> PixelRGB8
+ 80 magma = ramp (colors
+ 81 "00000401000501010601010802010902020b02020d03030f0303120404140504160605180605\
+ 82 \1a07061c08071e0907200a08220b09240c09260d0a290e0b2b100b2d110c2f120d31130d3414\
+ 83 \0e36150e38160f3b180f3d19103f1a10421c10441d11471e114920114b21114e221150241253\
+ 84 \25125527125829115a2a115c2c115f2d11612f116331116533106734106936106b38106c390f\
+ 85 \6e3b0f703d0f713f0f72400f74420f75440f764510774710784910784a10794c117a4e117b4f\
+ 86 \127b51127c52137c54137d56147d57157e59157e5a167e5c167f5d177f5f187f601880621980\
+ 87 \641a80651a80671b80681c816a1c816b1d816d1d816e1e81701f81721f817320817521817621\
+ 88 \817822817922827b23827c23827e24828025828125818326818426818627818827818928818b\
+ 89 \29818c29818e2a81902a81912b81932b80942c80962c80982d80992d809b2e7f9c2e7f9e2f7f\
+ 90 \a02f7fa1307ea3307ea5317ea6317da8327daa337dab337cad347cae347bb0357bb2357bb336\
+ 91 \7ab5367ab73779b83779ba3878bc3978bd3977bf3a77c03a76c23b75c43c75c53c74c73d73c8\
+ 92 \3e73ca3e72cc3f71cd4071cf4070d0416fd2426fd3436ed5446dd6456cd8456cd9466bdb476a\
+ 93 \dc4869de4968df4a68e04c67e24d66e34e65e44f64e55064e75263e85362e95462ea5661eb57\
+ 94 \60ec5860ed5a5fee5b5eef5d5ef05f5ef1605df2625df2645cf3655cf4675cf4695cf56b5cf6\
+ 95 \6c5cf66e5cf7705cf7725cf8745cf8765cf9785df9795df97b5dfa7d5efa7f5efa815ffb835f\
+ 96 \fb8560fb8761fc8961fc8a62fc8c63fc8e64fc9065fd9266fd9467fd9668fd9869fd9a6afd9b\
+ 97 \6bfe9d6cfe9f6dfea16efea36ffea571fea772fea973feaa74feac76feae77feb078feb27afe\
+ 98 \b47bfeb67cfeb77efeb97ffebb81febd82febf84fec185fec287fec488fec68afec88cfeca8d\
+ 99 \fecc8ffecd90fecf92fed194fed395fed597fed799fed89afdda9cfddc9efddea0fde0a1fde2\
+ 100 \a3fde3a5fde5a7fde7a9fde9aafdebacfcecaefceeb0fcf0b2fcf2b4fcf4b6fcf6b8fcf7b9fc\
+ 101 \f9bbfcfbbdfcfdbf")
+ 102
+ 103 -- | Given a number t in the range [0,1], returns the corresponding color from
+ 104 -- the “inferno” perceptually-uniform color scheme designed by van der Walt
+ 105 -- and Smith for matplotlib, represented as an RGB string.
+ 106 --
+ 107 -- <<docs/gifs/doc_inferno.gif>>
+ 108 inferno :: Double -> PixelRGB8
+ 109 inferno = ramp (colors
+ 110 "00000401000501010601010802010a02020c02020e0302100403120403140504170604190705\
+ 111 \1b08051d09061f0a07220b07240c08260d08290e092b10092d110a30120a32140b34150b3716\
+ 112 \0b39180c3c190c3e1b0c411c0c431e0c451f0c48210c4a230c4c240c4f260c51280b53290b55\
+ 113 \2b0b572d0b592f0a5b310a5c320a5e340a5f3609613809623909633b09643d09653e0966400a\
+ 114 \67420a68440a68450a69470b6a490b6a4a0c6b4c0c6b4d0d6c4f0d6c510e6c520e6d540f6d55\
+ 115 \0f6d57106e59106e5a116e5c126e5d126e5f136e61136e62146e64156e65156e67166e69166e\
+ 116 \6a176e6c186e6d186e6f196e71196e721a6e741a6e751b6e771c6d781c6d7a1d6d7c1d6d7d1e\
+ 117 \6d7f1e6c801f6c82206c84206b85216b87216b88226a8a226a8c23698d23698f246990256892\
+ 118 \25689326679526679727669827669a28659b29649d29649f2a63a02a63a22b62a32c61a52c60\
+ 119 \a62d60a82e5fa92e5eab2f5ead305dae305cb0315bb1325ab3325ab43359b63458b73557b935\
+ 120 \56ba3655bc3754bd3853bf3952c03a51c13a50c33b4fc43c4ec63d4dc73e4cc83f4bca404acb\
+ 121 \4149cc4248ce4347cf4446d04545d24644d34743d44842d54a41d74b3fd84c3ed94d3dda4e3c\
+ 122 \db503bdd513ade5238df5337e05536e15635e25734e35933e45a31e55c30e65d2fe75e2ee860\
+ 123 \2de9612bea632aeb6429eb6628ec6726ed6925ee6a24ef6c23ef6e21f06f20f1711ff1731df2\
+ 124 \741cf3761bf37819f47918f57b17f57d15f67e14f68013f78212f78410f8850ff8870ef8890c\
+ 125 \f98b0bf98c0af98e09fa9008fa9207fa9407fb9606fb9706fb9906fb9b06fb9d07fc9f07fca1\
+ 126 \08fca309fca50afca60cfca80dfcaa0ffcac11fcae12fcb014fcb216fcb418fbb61afbb81dfb\
+ 127 \ba1ffbbc21fbbe23fac026fac228fac42afac62df9c72ff9c932f9cb35f8cd37f8cf3af7d13d\
+ 128 \f7d340f6d543f6d746f5d949f5db4cf4dd4ff4df53f4e156f3e35af3e55df2e661f2e865f2ea\
+ 129 \69f1ec6df1ed71f1ef75f1f179f2f27df2f482f3f586f3f68af4f88ef5f992f6fa96f8fb9af9\
+ 130 \fc9dfafda1fcffa4")
+ 131
+ 132 -- | Given a number t in the range [0,1], returns the corresponding color from
+ 133 -- the “plasma” perceptually-uniform color scheme designed by van der Walt and
+ 134 -- Smith for matplotlib, represented as an RGB string.
+ 135 --
+ 136 -- <<docs/gifs/doc_plasma.gif>>
+ 137 plasma :: Double -> PixelRGB8
+ 138 plasma = ramp (colors
+ 139 "0d088710078813078916078a19068c1b068d1d068e20068f2206902406912605912805922a05\
+ 140 \932c05942e05952f059631059733059735049837049938049a3a049a3c049b3e049c3f049c41\
+ 141 \049d43039e44039e46039f48039f4903a04b03a14c02a14e02a25002a25102a35302a35502a4\
+ 142 \5601a45801a45901a55b01a55c01a65e01a66001a66100a76300a76400a76600a76700a86900\
+ 143 \a86a00a86c00a86e00a86f00a87100a87201a87401a87501a87701a87801a87a02a87b02a87d\
+ 144 \03a87e03a88004a88104a78305a78405a78606a68707a68808a68a09a58b0aa58d0ba58e0ca4\
+ 145 \8f0da4910ea3920fa39410a29511a19613a19814a099159f9a169f9c179e9d189d9e199da01a\
+ 146 \9ca11b9ba21d9aa31e9aa51f99a62098a72197a82296aa2395ab2494ac2694ad2793ae2892b0\
+ 147 \2991b12a90b22b8fb32c8eb42e8db52f8cb6308bb7318ab83289ba3388bb3488bc3587bd3786\
+ 148 \be3885bf3984c03a83c13b82c23c81c33d80c43e7fc5407ec6417dc7427cc8437bc9447aca45\
+ 149 \7acb4679cc4778cc4977cd4a76ce4b75cf4c74d04d73d14e72d24f71d35171d45270d5536fd5\
+ 150 \546ed6556dd7566cd8576bd9586ada5a6ada5b69db5c68dc5d67dd5e66de5f65de6164df6263\
+ 151 \e06363e16462e26561e26660e3685fe4695ee56a5de56b5de66c5ce76e5be76f5ae87059e971\
+ 152 \58e97257ea7457eb7556eb7655ec7754ed7953ed7a52ee7b51ef7c51ef7e50f07f4ff0804ef1\
+ 153 \814df1834cf2844bf3854bf3874af48849f48948f58b47f58c46f68d45f68f44f79044f79143\
+ 154 \f79342f89441f89540f9973ff9983ef99a3efa9b3dfa9c3cfa9e3bfb9f3afba139fba238fca3\
+ 155 \38fca537fca636fca835fca934fdab33fdac33fdae32fdaf31fdb130fdb22ffdb42ffdb52efe\
+ 156 \b72dfeb82cfeba2cfebb2bfebd2afebe2afec029fdc229fdc328fdc527fdc627fdc827fdca26\
+ 157 \fdcb26fccd25fcce25fcd025fcd225fbd324fbd524fbd724fad824fada24f9dc24f9dd25f8df\
+ 158 \25f8e125f7e225f7e425f6e626f6e826f5e926f5eb27f4ed27f3ee27f3f027f2f227f1f426f1\
+ 159 \f525f0f724f0f921")
+ 160
+ 161 -- | Given a number t in the range [0,1], returns the corresponding color from
+ 162 -- the “sinebow” color scheme by Jim Bumgardner and Charlie Loyd.
+ 163 --
+ 164 -- <<docs/gifs/doc_sinebow.gif>>
+ 165 sinebow :: Double -> PixelRGB8
+ 166 sinebow t = PixelRGB8 r g b
+ 167 where
+ 168 pi_1_3 = pi / 3
+ 169 pi_2_3 = pi * 2 / 3
+ 170 x = (0.5 - t) * pi
+ 171 r = round $ 255 * sin x**2
+ 172 g = round $ 255 * sin (x+pi_1_3)**2
+ 173 b = round $ 255 * sin (x+pi_2_3)**2
+ 174
+ 175 -- | Given a number t in the range [0,1], returns the corresponding color from
+ 176 -- the “cividis” color vision deficiency-optimized color scheme designed by
+ 177 -- Nuñez, Anderton, and Renslow, represented as an RGB string.
+ 178 --
+ 179 -- <<docs/gifs/doc_cividis.gif>>
+ 180 cividis :: Double -> PixelRGB8
+ 181 cividis t = PixelRGB8 red green blue
+ 182 where
+ 183 red = trunc $ round(-4.54 - t * (35.34 - t * (2381.73 - t * (6402.7 - t * (7024.72 - t * 2710.57)))))
+ 184 green = trunc $ round(32.49 + t * (170.73 + t * (52.82 - t * (131.46 - t * (176.58 - t * 67.37)))))
+ 185 blue = trunc $ round(81.24 + t * (442.36 - t * (2482.43 - t * (6167.24 - t * (6614.94 - t * 2475.67)))))
+ 186 trunc :: Integer -> Pixel8
+ 187 trunc = fromIntegral . min 255 . max 0
+ 188
+ 189 -- | Jet colormap. Used to be the default in matlab. Obsolete.
+ 190 --
+ 191 -- <<docs/gifs/doc_jet.gif>>
+ 192 jet :: Double -> PixelRGB8
+ 193 jet t = PixelRGB8 red green blue
+ 194 where
+ 195 red = trunc $ min (4*t - 1.5) (-4*t + 4.5)
+ 196 green = trunc $ min (4*t - 0.5) (-4*t + 3.5)
+ 197 blue = trunc $ min (4*t + 0.5) (-4*t + 2.5)
+ 198 trunc :: Double -> Pixel8
+ 199 trunc = round . min 255 . max 0 . (*) 255
+ 200
+ 201 -- | hsv colormap. Goes from 0 degrees to 360 degrees.
+ 202 --
+ 203 -- <<docs/gifs/doc_hsv.gif>>
+ 204 hsv :: Double -> PixelRGB8
+ 205 hsv t = PixelRGB8 (round $ r*255) (round $ g*255) (round $ b*255)
+ 206 where
+ 207 RGB r g b = HSV.hsv (t * 360) 1 1
+ 208
+ 209 -- | Matlab hsv colormap. Goes from 0 degrees to 330 degrees.
+ 210 --
+ 211 -- <<docs/gifs/doc_hsvMatlab.gif>>
+ 212 hsvMatlab :: Double -> PixelRGB8
+ 213 hsvMatlab t = PixelRGB8 (round $ r*255) (round $ g*255) (round $ b*255)
+ 214 where
+ 215 RGB r g b = HSV.hsv (t * 330) 1 1
+ 216
+ 217 -- | Greyscale colormap.
+ 218 --
+ 219 -- <<docs/gifs/doc_greyscale.gif>>
+ 220 greyscale :: Double -> PixelRGB8
+ 221 greyscale t = PixelRGB8 v v v
+ 222 where
+ 223 v = round $ t * 255
+ 224
+ 225 -- | Parula is the default colormap for matlab.
+ 226 --
+ 227 -- <<docs/gifs/doc_parula.gif>>
+ 228 parula :: Double -> PixelRGB8
+ 229 parula = ramp vec
+ 230 where
+ 231 vec = V.fromList $ pixels colorList
+ 232 pixels [] = []
+ 233 pixels (r:g:b:xs) =
+ 234 PixelRGB8 (round $ r*255) (round $ g*255) (round $ b*255) :
+ 235 pixels xs
+ 236 pixels _ = error "Reanimate.ColorMap.parula: Broken data"
+ 237 colorList :: [Double]
+ 238 colorList =
+ 239 [0.2081, 0.1663, 0.5292
+ 240 ,0.2091, 0.1721, 0.5411
+ 241 ,0.2101, 0.1779, 0.5530
+ 242 ,0.2109, 0.1837, 0.5650
+ 243 ,0.2116, 0.1895, 0.5771
+ 244 ,0.2121, 0.1954, 0.5892
+ 245 ,0.2124, 0.2013, 0.6013
+ 246 ,0.2125, 0.2072, 0.6135
+ 247 ,0.2123, 0.2132, 0.6258
+ 248 ,0.2118, 0.2192, 0.6381
+ 249 ,0.2111, 0.2253, 0.6505
+ 250 ,0.2099, 0.2315, 0.6629
+ 251 ,0.2084, 0.2377, 0.6753
+ 252 ,0.2063, 0.2440, 0.6878
+ 253 ,0.2038, 0.2503, 0.7003
+ 254 ,0.2006, 0.2568, 0.7129
+ 255 ,0.1968, 0.2632, 0.7255
+ 256 ,0.1921, 0.2698, 0.7381
+ 257 ,0.1867, 0.2764, 0.7507
+ 258 ,0.1802, 0.2832, 0.7634
+ 259 ,0.1728, 0.2902, 0.7762
+ 260 ,0.1641, 0.2975, 0.7890
+ 261 ,0.1541, 0.3052, 0.8017
+ 262 ,0.1427, 0.3132, 0.8145
+ 263 ,0.1295, 0.3217, 0.8269
+ 264 ,0.1147, 0.3306, 0.8387
+ 265 ,0.0986, 0.3397, 0.8495
+ 266 ,0.0816, 0.3486, 0.8588
+ 267 ,0.0646, 0.3572, 0.8664
+ 268 ,0.0482, 0.3651, 0.8722
+ 269 ,0.0329, 0.3724, 0.8765
+ 270 ,0.0213, 0.3792, 0.8796
+ 271 ,0.0136, 0.3853, 0.8815
+ 272 ,0.0086, 0.3911, 0.8827
+ 273 ,0.0060, 0.3965, 0.8833
+ 274 ,0.0051, 0.4017, 0.8834
+ 275 ,0.0054, 0.4066, 0.8831
+ 276 ,0.0067, 0.4113, 0.8825
+ 277 ,0.0089, 0.4159, 0.8816
+ 278 ,0.0116, 0.4203, 0.8805
+ 279 ,0.0148, 0.4246, 0.8793
+ 280 ,0.0184, 0.4288, 0.8779
+ 281 ,0.0223, 0.4329, 0.8763
+ 282 ,0.0264, 0.4370, 0.8747
+ 283 ,0.0306, 0.4410, 0.8729
+ 284 ,0.0349, 0.4449, 0.8711
+ 285 ,0.0394, 0.4488, 0.8692
+ 286 ,0.0437, 0.4526, 0.8672
+ 287 ,0.0477, 0.4564, 0.8652
+ 288 ,0.0514, 0.4602, 0.8632
+ 289 ,0.0549, 0.4640, 0.8611
+ 290 ,0.0582, 0.4677, 0.8589
+ 291 ,0.0612, 0.4714, 0.8568
+ 292 ,0.0640, 0.4751, 0.8546
+ 293 ,0.0666, 0.4788, 0.8525
+ 294 ,0.0689, 0.4825, 0.8503
+ 295 ,0.0710, 0.4862, 0.8481
+ 296 ,0.0729, 0.4899, 0.8460
+ 297 ,0.0746, 0.4937, 0.8439
+ 298 ,0.0761, 0.4974, 0.8418
+ 299 ,0.0773, 0.5012, 0.8398
+ 300 ,0.0782, 0.5051, 0.8378
+ 301 ,0.0789, 0.5089, 0.8359
+ 302 ,0.0794, 0.5129, 0.8341
+ 303 ,0.0795, 0.5169, 0.8324
+ 304 ,0.0793, 0.5210, 0.8308
+ 305 ,0.0788, 0.5251, 0.8293
+ 306 ,0.0778, 0.5295, 0.8280
+ 307 ,0.0764, 0.5339, 0.8270
+ 308 ,0.0746, 0.5384, 0.8261
+ 309 ,0.0724, 0.5431, 0.8253
+ 310 ,0.0698, 0.5479, 0.8247
+ 311 ,0.0668, 0.5527, 0.8243
+ 312 ,0.0636, 0.5577, 0.8239
+ 313 ,0.0600, 0.5627, 0.8237
+ 314 ,0.0562, 0.5677, 0.8234
+ 315 ,0.0523, 0.5727, 0.8231
+ 316 ,0.0484, 0.5777, 0.8228
+ 317 ,0.0445, 0.5826, 0.8223
+ 318 ,0.0408, 0.5874, 0.8217
+ 319 ,0.0372, 0.5922, 0.8209
+ 320 ,0.0342, 0.5968, 0.8198
+ 321 ,0.0317, 0.6012, 0.8186
+ 322 ,0.0296, 0.6055, 0.8171
+ 323 ,0.0279, 0.6097, 0.8154
+ 324 ,0.0265, 0.6137, 0.8135
+ 325 ,0.0255, 0.6176, 0.8114
+ 326 ,0.0248, 0.6214, 0.8091
+ 327 ,0.0243, 0.6250, 0.8066
+ 328 ,0.0239, 0.6285, 0.8039
+ 329 ,0.0237, 0.6319, 0.8010
+ 330 ,0.0235, 0.6352, 0.7980
+ 331 ,0.0233, 0.6384, 0.7948
+ 332 ,0.0231, 0.6415, 0.7916
+ 333 ,0.0230, 0.6445, 0.7881
+ 334 ,0.0229, 0.6474, 0.7846
+ 335 ,0.0227, 0.6503, 0.7810
+ 336 ,0.0227, 0.6531, 0.7773
+ 337 ,0.0232, 0.6558, 0.7735
+ 338 ,0.0238, 0.6585, 0.7696
+ 339 ,0.0246, 0.6611, 0.7656
+ 340 ,0.0263, 0.6637, 0.7615
+ 341 ,0.0282, 0.6663, 0.7574
+ 342 ,0.0306, 0.6688, 0.7532
+ 343 ,0.0338, 0.6712, 0.7490
+ 344 ,0.0373, 0.6737, 0.7446
+ 345 ,0.0418, 0.6761, 0.7402
+ 346 ,0.0467, 0.6784, 0.7358
+ 347 ,0.0516, 0.6808, 0.7313
+ 348 ,0.0574, 0.6831, 0.7267
+ 349 ,0.0629, 0.6854, 0.7221
+ 350 ,0.0692, 0.6877, 0.7173
+ 351 ,0.0755, 0.6899, 0.7126
+ 352 ,0.0820, 0.6921, 0.7078
+ 353 ,0.0889, 0.6943, 0.7029
+ 354 ,0.0956, 0.6965, 0.6979
+ 355 ,0.1031, 0.6986, 0.6929
+ 356 ,0.1104, 0.7007, 0.6878
+ 357 ,0.1180, 0.7028, 0.6827
+ 358 ,0.1258, 0.7049, 0.6775
+ 359 ,0.1335, 0.7069, 0.6723
+ 360 ,0.1418, 0.7089, 0.6669
+ 361 ,0.1499, 0.7109, 0.6616
+ 362 ,0.1585, 0.7129, 0.6561
+ 363 ,0.1671, 0.7148, 0.6507
+ 364 ,0.1758, 0.7168, 0.6451
+ 365 ,0.1849, 0.7186, 0.6395
+ 366 ,0.1938, 0.7205, 0.6338
+ 367 ,0.2033, 0.7223, 0.6281
+ 368 ,0.2128, 0.7241, 0.6223
+ 369 ,0.2224, 0.7259, 0.6165
+ 370 ,0.2324, 0.7275, 0.6107
+ 371 ,0.2423, 0.7292, 0.6048
+ 372 ,0.2527, 0.7308, 0.5988
+ 373 ,0.2631, 0.7324, 0.5929
+ 374 ,0.2735, 0.7339, 0.5869
+ 375 ,0.2845, 0.7354, 0.5809
+ 376 ,0.2953, 0.7368, 0.5749
+ 377 ,0.3064, 0.7381, 0.5689
+ 378 ,0.3177, 0.7394, 0.5630
+ 379 ,0.3289, 0.7406, 0.5570
+ 380 ,0.3405, 0.7417, 0.5512
+ 381 ,0.3520, 0.7428, 0.5453
+ 382 ,0.3635, 0.7438, 0.5396
+ 383 ,0.3753, 0.7446, 0.5339
+ 384 ,0.3869, 0.7454, 0.5283
+ 385 ,0.3986, 0.7461, 0.5229
+ 386 ,0.4103, 0.7467, 0.5175
+ 387 ,0.4218, 0.7473, 0.5123
+ 388 ,0.4334, 0.7477, 0.5072
+ 389 ,0.4447, 0.7482, 0.5021
+ 390 ,0.4561, 0.7485, 0.4972
+ 391 ,0.4672, 0.7487, 0.4924
+ 392 ,0.4783, 0.7489, 0.4877
+ 393 ,0.4892, 0.7491, 0.4831
+ 394 ,0.5000, 0.7491, 0.4786
+ 395 ,0.5106, 0.7492, 0.4741
+ 396 ,0.5212, 0.7492, 0.4698
+ 397 ,0.5315, 0.7491, 0.4655
+ 398 ,0.5418, 0.7490, 0.4613
+ 399 ,0.5519, 0.7489, 0.4571
+ 400 ,0.5619, 0.7487, 0.4531
+ 401 ,0.5718, 0.7485, 0.4490
+ 402 ,0.5816, 0.7482, 0.4451
+ 403 ,0.5913, 0.7479, 0.4412
+ 404 ,0.6009, 0.7476, 0.4374
+ 405 ,0.6103, 0.7473, 0.4335
+ 406 ,0.6197, 0.7469, 0.4298
+ 407 ,0.6290, 0.7465, 0.4261
+ 408 ,0.6382, 0.7460, 0.4224
+ 409 ,0.6473, 0.7456, 0.4188
+ 410 ,0.6564, 0.7451, 0.4152
+ 411 ,0.6653, 0.7446, 0.4116
+ 412 ,0.6742, 0.7441, 0.4081
+ 413 ,0.6830, 0.7435, 0.4046
+ 414 ,0.6918, 0.7430, 0.4011
+ 415 ,0.7004, 0.7424, 0.3976
+ 416 ,0.7091, 0.7418, 0.3942
+ 417 ,0.7176, 0.7412, 0.3908
+ 418 ,0.7261, 0.7405, 0.3874
+ 419 ,0.7346, 0.7399, 0.3840
+ 420 ,0.7430, 0.7392, 0.3806
+ 421 ,0.7513, 0.7385, 0.3773
+ 422 ,0.7596, 0.7378, 0.3739
+ 423 ,0.7679, 0.7372, 0.3706
+ 424 ,0.7761, 0.7364, 0.3673
+ 425 ,0.7843, 0.7357, 0.3639
+ 426 ,0.7924, 0.7350, 0.3606
+ 427 ,0.8005, 0.7343, 0.3573
+ 428 ,0.8085, 0.7336, 0.3539
+ 429 ,0.8166, 0.7329, 0.3506
+ 430 ,0.8246, 0.7322, 0.3472
+ 431 ,0.8325, 0.7315, 0.3438
+ 432 ,0.8405, 0.7308, 0.3404
+ 433 ,0.8484, 0.7301, 0.3370
+ 434 ,0.8563, 0.7294, 0.3336
+ 435 ,0.8642, 0.7288, 0.3300
+ 436 ,0.8720, 0.7282, 0.3265
+ 437 ,0.8798, 0.7276, 0.3229
+ 438 ,0.8877, 0.7271, 0.3193
+ 439 ,0.8954, 0.7266, 0.3156
+ 440 ,0.9032, 0.7262, 0.3117
+ 441 ,0.9110, 0.7259, 0.3078
+ 442 ,0.9187, 0.7256, 0.3038
+ 443 ,0.9264, 0.7256, 0.2996
+ 444 ,0.9341, 0.7256, 0.2953
+ 445 ,0.9417, 0.7259, 0.2907
+ 446 ,0.9493, 0.7264, 0.2859
+ 447 ,0.9567, 0.7273, 0.2808
+ 448 ,0.9639, 0.7285, 0.2754
+ 449 ,0.9708, 0.7303, 0.2696
+ 450 ,0.9773, 0.7326, 0.2634
+ 451 ,0.9831, 0.7355, 0.2570
+ 452 ,0.9882, 0.7390, 0.2504
+ 453 ,0.9922, 0.7431, 0.2437
+ 454 ,0.9952, 0.7476, 0.2373
+ 455 ,0.9973, 0.7524, 0.2310
+ 456 ,0.9986, 0.7573, 0.2251
+ 457 ,0.9991, 0.7624, 0.2195
+ 458 ,0.9990, 0.7675, 0.2141
+ 459 ,0.9985, 0.7726, 0.2090
+ 460 ,0.9976, 0.7778, 0.2042
+ 461 ,0.9964, 0.7829, 0.1995
+ 462 ,0.9950, 0.7880, 0.1949
+ 463 ,0.9933, 0.7931, 0.1905
+ 464 ,0.9914, 0.7981, 0.1863
+ 465 ,0.9894, 0.8032, 0.1821
+ 466 ,0.9873, 0.8083, 0.1780
+ 467 ,0.9851, 0.8133, 0.1740
+ 468 ,0.9828, 0.8184, 0.1700
+ 469 ,0.9805, 0.8235, 0.1661
+ 470 ,0.9782, 0.8286, 0.1622
+ 471 ,0.9759, 0.8337, 0.1583
+ 472 ,0.9736, 0.8389, 0.1544
+ 473 ,0.9713, 0.8441, 0.1505
+ 474 ,0.9692, 0.8494, 0.1465
+ 475 ,0.9672, 0.8548, 0.1425
+ 476 ,0.9654, 0.8603, 0.1385
+ 477 ,0.9638, 0.8659, 0.1343
+ 478 ,0.9623, 0.8716, 0.1301
+ 479 ,0.9611, 0.8774, 0.1258
+ 480 ,0.9600, 0.8834, 0.1215
+ 481 ,0.9593, 0.8895, 0.1171
+ 482 ,0.9588, 0.8958, 0.1126
+ 483 ,0.9586, 0.9022, 0.1082
+ 484 ,0.9587, 0.9088, 0.1036
+ 485 ,0.9591, 0.9155, 0.0990
+ 486 ,0.9599, 0.9225, 0.0944
+ 487 ,0.9610, 0.9296, 0.0897
+ 488 ,0.9624, 0.9368, 0.0850
+ 489 ,0.9641, 0.9443, 0.0802
+ 490 ,0.9662, 0.9518, 0.0753
+ 491 ,0.9685, 0.9595, 0.0703
+ 492 ,0.9710, 0.9673, 0.0651
+ 493 ,0.9736, 0.9752, 0.0597
+ 494 ,0.9763, 0.9831, 0.0538]
+ 495
+ 496 --------------------------------------------------------------------------------
+ 497 -- Helpers
+ 498
+ 499 colors :: Text -> Vector PixelRGB8
+ 500 colors = V.fromList . map (toColor . map (fromIntegral . digitToInt) . T.unpack) . T.chunksOf 6
+ 501 where
+ 502 toColor [r1,r2,g1,g2,b1,b2] =
+ 503 PixelRGB8 (r1 `shiftL` 4 + r2) (g1 `shiftL` 4 + g2) (b1 `shiftL` 4+b2)
+ 504 toColor _ = error "Reanimate.ColorMap.colors: Broken data"
+ 505
+ 506 ramp :: Vector PixelRGB8 -> Double -> PixelRGB8
+ 507 ramp v = \t -> v V.! max 0 (min (len-1) $ round $ t * (len'-1))
+ 508 where
+ 509 len = V.length v
+ 510 len' = fromIntegral len
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Constants.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Constants.hs.html
new file mode 100644
index 0000000..146a989
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Constants.hs.html
@@ -0,0 +1,74 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {- |
+ 2 Reanimate configures a consistent, default canvas. The values of this default
+ 3 can be observed via the constants in this module. Keep in mind, these values
+ 4 describe the /default/ canvas and will not apply to custom viewports.
+ 5 -}
+ 6 module Reanimate.Constants
+ 7 ( screenWidth
+ 8 , screenHeight
+ 9 , screenTop
+ 10 , screenBottom
+ 11 , screenLeft
+ 12 , screenRight
+ 13 , defaultDPI
+ 14 , defaultStrokeWidth
+ 15 ) where
+ 16
+ 17 import Graphics.SvgTree
+ 18
+ 19 -- | Number of units from the left-most point to the right-most point on the screen.
+ 20 screenWidth :: Fractional a => a
+ 21
+ 22 -- | Number of units from the bottom to the top of the screen.
+ 23 screenHeight :: Fractional a => a
+ 24
+ 25 -- | Position of the top of the screen.
+ 26 screenTop :: Fractional a => a
+ 27
+ 28 -- | Position of the bottom of the screen.
+ 29 screenBottom :: Fractional a => a
+ 30
+ 31 -- | Position of the left side of the screen.
+ 32 screenLeft :: Fractional a => a
+ 33
+ 34 -- | Position of the right side of the screen.
+ 35 screenRight :: Fractional a => a
+ 36
+ 37 screenWidth = 16
+ 38 screenHeight = 9
+ 39 screenTop = screenHeight/2
+ 40 screenBottom = -screenHeight/2
+ 41 screenLeft = -screenWidth/2
+ 42 screenRight = screenWidth/2
+ 43
+ 44 -- | SVG allows measurements in inches which have to be converted to local units.
+ 45 -- This value describes how many local units there are in an inch.
+ 46 defaultDPI :: Dpi
+ 47 defaultDPI = 96
+ 48
+ 49 -- | Default thickness of lines.
+ 50 defaultStrokeWidth :: Double
+ 51 defaultStrokeWidth = 0.05
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Driver.CLI.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Driver.CLI.hs.html
new file mode 100644
index 0000000..3281f5e
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Driver.CLI.hs.html
@@ -0,0 +1,251 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 module Reanimate.Driver.CLI
+ 2 ( getDriverOptions
+ 3 , Options(..)
+ 4 , Command(..)
+ 5 , Preset(..)
+ 6 , Format(..)
+ 7 , Raster(..)
+ 8 , showFormat
+ 9 , showRaster
+ 10 ) where
+ 11
+ 12 import Data.Char
+ 13 import Data.Monoid
+ 14 import Options.Applicative
+ 15 import Prelude
+ 16 import Reanimate.Render (FPS, Format (..), Height, Raster (..),
+ 17 Width)
+ 18
+ 19 newtype Options = Options
+ 20 { optsCommand :: Command
+ 21 } deriving (Show)
+ 22
+ 23 data Command
+ 24 = Raw
+ 25 { rawOutputFolder :: FilePath
+ 26 , rawFrameOffset :: Int
+ 27 , rawPrettyPrint :: Bool
+ 28 }
+ 29 | Test
+ 30 | Check
+ 31 | View
+ 32 { viewVerbose :: Bool
+ 33 , viewGHCPath :: Maybe FilePath
+ 34 , viewGHCOpts :: [String]
+ 35 , viewOrigin :: Maybe FilePath
+ 36 }
+ 37 | Render
+ 38 { renderTarget :: Maybe String
+ 39 , renderFPS :: Maybe FPS
+ 40 , renderWidth :: Maybe Width
+ 41 , renderHeight :: Maybe Height
+ 42 , renderCompile :: Bool
+ 43 , renderFormat :: Maybe Format
+ 44 , renderPreset :: Maybe Preset
+ 45 , renderRaster :: Raster
+ 46 , renderPartial :: Bool
+ 47 , renderHash :: Bool
+ 48 }
+ 49 deriving (Show)
+ 50
+ 51 data Preset = Youtube | ExampleGif | Quick | MediumQ | HighQ | LowFPS
+ 52 deriving (Show)
+ 53
+ 54 readRaster :: String -> Maybe Raster
+ 55 readRaster raster =
+ 56 case map toLower raster of
+ 57 "none" -> Just RasterNone
+ 58 "auto" -> Just RasterAuto
+ 59 "inkscape" -> Just RasterInkscape
+ 60 "rsvg" -> Just RasterRSvg
+ 61 "imagemagick" -> Just RasterMagick
+ 62 _ -> Nothing
+ 63
+ 64 showRaster :: Raster -> String
+ 65 showRaster RasterNone = "none"
+ 66 showRaster RasterAuto = "auto"
+ 67 showRaster RasterInkscape = "inkscape"
+ 68 showRaster RasterRSvg = "rsvg"
+ 69 showRaster RasterMagick = "imagemagick"
+ 70
+ 71 readFormat :: String -> Maybe Format
+ 72 readFormat fmt =
+ 73 case map toLower fmt of
+ 74 "mp4" -> Just RenderMp4
+ 75 "gif" -> Just RenderGif
+ 76 "webm" -> Just RenderWebm
+ 77 _ -> Nothing
+ 78
+ 79 showFormat :: Format -> String
+ 80 showFormat RenderMp4 = "mp4"
+ 81 showFormat RenderGif = "gif"
+ 82 showFormat RenderWebm = "webm"
+ 83
+ 84 readPreset :: String -> Maybe Preset
+ 85 readPreset preset =
+ 86 case map toLower preset of
+ 87 "youtube" -> Just Youtube
+ 88 "gif" -> Just ExampleGif
+ 89 "quick" -> Just Quick
+ 90 "medium" -> Just MediumQ
+ 91 "high" -> Just HighQ
+ 92 "lowfps" -> Just LowFPS
+ 93 _ -> Nothing
+ 94
+ 95 showPreset :: Preset -> String
+ 96 showPreset Youtube = "youtube"
+ 97 showPreset ExampleGif = "gif"
+ 98 showPreset Quick = "quick"
+ 99 showPreset MediumQ = "medium"
+ 100 showPreset HighQ = "high"
+ 101 showPreset LowFPS = "lowfps"
+ 102
+ 103 options :: Parser Options
+ 104 options = Options <$> commandP
+ 105
+ 106 commandP :: Parser Command
+ 107 commandP = subparser(
+ 108 command "test" testCommand
+ 109 <> commandGroup "Internal commands"
+ 110 <> internal )
+ 111 <|> hsubparser
+ 112 ( command "check" checkCommand
+ 113 <> command "view" viewCommand
+ 114 <> command "render" renderCommand
+ 115 <> command "raw" rawCommand
+ 116 )
+ 117 <|> infoParser viewCommand
+ 118
+ 119 rawCommand :: ParserInfo Command
+ 120 rawCommand = info parse
+ 121 (progDesc "Output raw SVGs for animation at 60 fps. Used internally by viewer.")
+ 122 where
+ 123 parse = Raw
+ 124 <$> strOption
+ 125 ( long "output" <>
+ 126 short 'o' <>
+ 127 metavar "PATH" <>
+ 128 help "Output folder" <>
+ 129 value ".")
+ 130 <*> option auto
+ 131 ( long "offset" <>
+ 132 metavar "NUMBER" <>
+ 133 help "Frame offset" <>
+ 134 value 0)
+ 135 <*> switch
+ 136 ( long "pretty-print" <>
+ 137 short 'p' <>
+ 138 help "Pretty print svg")
+ 139
+ 140 testCommand :: ParserInfo Command
+ 141 testCommand = info (parse <**> helper)
+ 142 (progDesc "Generate 10 frames spread out evenly across the animation. Used \
+ 143 \internally by the test-suite.")
+ 144 where
+ 145 parse = pure Test
+ 146
+ 147 checkCommand :: ParserInfo Command
+ 148 checkCommand = info parse
+ 149 (progDesc "Run a system's diagnostic and report any missing external dependencies.")
+ 150 where
+ 151 parse = pure Check
+ 152
+ 153 viewCommand :: ParserInfo Command
+ 154 viewCommand = info parse
+ 155 (progDesc "Play animation in browser window.")
+ 156 where
+ 157 parse = View
+ 158 <$> switch
+ 159 (long "verbose" <> short 'v')
+ 160 <*> optional (strOption (long "ghc"
+ 161 <> metavar "PATH"
+ 162 <> help "Path to GHC binary"))
+ 163 <*> many (strOption (long "ghc-opt"
+ 164 <> short 'G'
+ 165 <> help "Additional option to pass to ghc"))
+ 166 <*> optional (strOption (long "self"
+ 167 <> metavar "PATH"
+ 168 <> help "Source file used for live-reloading"))
+ 169
+ 170 renderCommand :: ParserInfo Command
+ 171 renderCommand = info parse
+ 172 (progDesc "Render animation to file.")
+ 173 where
+ 174 -- fromPreset :: (Maybe Preset -> (Command -> Command))
+ 175 -- fromPreset Nothing = id
+ 176 -- fromPreset (Just ExampleGif) = \cmd -> cmd{renderFPS=24}
+ 177 -- modParser :: Parser (Command -> Command)
+ 178 -- modParser = fmap fromPreset $
+ 179 -- optional (option (maybeReader readPreset)
+ 180 -- (long "preset" <> showDefaultWith showPreset
+ 181 -- <> metavar "TYPE"
+ 182 -- <> help "Parameter presets: youtube, gif, quick"))
+ 183 parse = Render
+ 184 <$> optional (strOption (long "target"
+ 185 <> short 'o'
+ 186 <> metavar "FILE"
+ 187 <> help "Write output to FILE"))
+ 188 <*> optional (option auto
+ 189 (long "fps" <> metavar "FPS"
+ 190 <> help "Set frames per second."))
+ 191 <*> optional (option auto
+ 192 (long "width" <> short 'w' <> metavar "PIXELS"
+ 193 <> help "Set video width."))
+ 194 <*> optional (option auto
+ 195 (long "height" <> short 'h'
+ 196 <> metavar "PIXELS" <> help "Set video height."))
+ 197 <*> switch (long "compile"
+ 198 <> help "Compile source code before rendering.")
+ 199 <*> optional (option (maybeReader readFormat)
+ 200 (long "format" <> metavar "FMT"
+ 201 <> help "Video format: mp4, gif, webm"))
+ 202 <*> optional (option (maybeReader readPreset)
+ 203 (long "preset" <> showDefaultWith showPreset
+ 204 <> metavar "TYPE"
+ 205 <> help "Parameter presets: youtube, gif, quick, medium, high"))
+ 206 <*> option (maybeReader readRaster)
+ 207 (long "raster" <> showDefaultWith showRaster
+ 208 <> metavar "RASTER"
+ 209 <> value RasterNone
+ 210 <> help "Raster engine: none, auto, inkscape, rsvg, imagemagick")
+ 211 <*> switch
+ 212 (long "partial"
+ 213 <> help "Produce partial animation even if frame generation was \
+ 214 \interrupted by ctrl-c")
+ 215 <*> flag True False
+ 216 (long "disable-hashing"
+ 217 <> help "Disable SVG dedup via hashing. This might improve performance \
+ 218 \if all your frames are unique.")
+ 219
+ 220 opts :: ParserInfo Options
+ 221 opts = info (options <**> helper )
+ 222 ( fullDesc
+ 223 <> progDesc "This program contains an animation which can either be viewed \
+ 224 \in a web-browser or rendered to disk."
+ 225 )
+ 226
+ 227 getDriverOptions :: IO Options
+ 228 getDriverOptions = customExecParser (prefs showHelpOnError) opts
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Driver.Check.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Driver.Check.hs.html
new file mode 100644
index 0000000..11d56c6
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Driver.Check.hs.html
@@ -0,0 +1,229 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE ScopedTypeVariables #-}
+ 2 module Reanimate.Driver.Check
+ 3 ( checkEnvironment
+ 4 , hasRSvg
+ 5 , hasInkscape
+ 6 , hasMagick
+ 7 , hasFFmpegRSvg
+ 8 ) where
+ 9
+ 10 import Control.Exception (SomeException, handle)
+ 11 import Control.Monad
+ 12 import Data.Maybe
+ 13 import Data.Version
+ 14 import Reanimate.Misc (runCmd_)
+ 15 import Reanimate.Driver.Magick (magickCmd)
+ 16 import System.Console.ANSI.Codes
+ 17 import System.Directory (findExecutable)
+ 18 import System.IO
+ 19 import System.IO.Temp
+ 20 import Text.ParserCombinators.ReadP
+ 21 import Text.Printf
+ 22
+ 23 --------------------------------------------------------------------------
+ 24 -- Check environment
+ 25
+ 26 checkEnvironment :: IO ()
+ 27 checkEnvironment = do
+ 28 putStrLn "reanimate checks:"
+ 29 runCheck "Has ffmpeg" hasFFmpeg
+ 30 runCheck "Has ffmpeg(rsvg)" hasFFmpegRSvg
+ 31 runCheck "Has dvisvgm" hasDvisvgm
+ 32 runCheck "Has povray" hasPovray
+ 33 runCheck "Has blender" hasBlender
+ 34 runCheck "Has rsvg-convert" hasRSvg
+ 35 runCheck "Has inkscape" hasInkscape
+ 36 runCheck "Has imagemagick" hasMagick
+ 37 runCheck "Has LaTeX" hasLaTeX
+ 38 runCheck ("Has LaTeX package '"++ "babel" ++ "'") $ hasTeXPackage "latex"
+ 39 "[english]{babel}"
+ 40 forM_ latexPackages $ \pkg ->
+ 41 runCheck ("Has LaTeX package '"++ pkg ++ "'") $ hasTeXPackage "latex" $
+ 42 "{"++pkg++"}"
+ 43 runCheck "Has XeLaTeX" hasXeLaTeX
+ 44 forM_ xelatexPackages $ \pkg ->
+ 45 runCheck ("Has XeLaTeX package '"++ pkg ++ "'") $ hasTeXPackage "xelatex" $
+ 46 "{"++pkg++"}"
+ 47 where
+ 48 latexPackages =
+ 49 ["preview"
+ 50 ,"amsmath"
+ 51 --,"amssymb"
+ 52 --,"dsfont"
+ 53 --,"setspace"
+ 54 --,"relsize"
+ 55 --,"textcomp"
+ 56 --,"mathrsfs"
+ 57 --,"calligra"
+ 58 --,"wasysym"
+ 59 --,"ragged2e"
+ 60 --,"physics"
+ 61 --,"xcolor"
+ 62 --,"textcomp"
+ 63 --,"xfrac"
+ 64 --,"microtype"
+ 65 ]
+ 66 xelatexPackages =
+ 67 ["ctex"]
+ 68 runCheck msg fn = do
+ 69 printf " %-35s" (msg ++ ":")
+ 70 val <- fn
+ 71 case val of
+ 72 Left err -> putStrLnColor Red err
+ 73 Right ok -> putStrLnColor Green ok
+ 74
+ 75 putStrLnColor :: Color -> String -> IO ()
+ 76 putStrLnColor color msg =
+ 77 putStrLn $ setSGRCode [SetColor Foreground Vivid color] ++ msg ++ setSGRCode [Reset]
+ 78
+ 79 -- latex, dvisvgm, xelatex
+ 80
+ 81 hasLaTeX :: IO (Either String String)
+ 82 hasLaTeX = hasProgram "latex"
+ 83
+ 84 hasXeLaTeX :: IO (Either String String)
+ 85 hasXeLaTeX = hasProgram "xelatex"
+ 86
+ 87 hasDvisvgm :: IO (Either String String)
+ 88 hasDvisvgm = hasProgram "dvisvgm"
+ 89
+ 90 hasPovray :: IO (Either String String)
+ 91 hasPovray = hasProgram "povray"
+ 92
+ 93 hasFFmpeg :: IO (Either String String)
+ 94 hasFFmpeg = checkMinVersion minVersion <$> ffmpegVersion
+ 95 where
+ 96 minVersion = Version [4,1,3] []
+ 97
+ 98 hasFFmpegRSvg :: IO (Either String String)
+ 99 hasFFmpegRSvg = do
+ 100 mbPath <- findExecutable "ffmpeg"
+ 101 case mbPath of
+ 102 Nothing -> return $ Left "n/a"
+ 103 Just path -> do
+ 104 ret <- runCmd_ path ["-version"]
+ 105 pure $ case ret of
+ 106 Right out | "--enable-librsvg" `elem` words out
+ 107 -> Right "yes"
+ 108 _ -> Left "no"
+ 109
+ 110 hasBlender :: IO (Either String String)
+ 111 hasBlender = checkMinVersion minVersion <$> blenderVersion
+ 112 where
+ 113 minVersion = Version [2,80] []
+ 114
+ 115 hasRSvg :: IO (Either String String)
+ 116 hasRSvg = checkMinVersion minVersion <$> rsvgVersion
+ 117 where
+ 118 minVersion = Version [2,44,0] []
+ 119
+ 120 hasInkscape :: IO (Either String String)
+ 121 hasInkscape = checkMinVersion minVersion <$> inkscapeVersion
+ 122 where
+ 123 minVersion = Version [0,92] []
+ 124
+ 125 hasMagick :: IO (Either String String)
+ 126 hasMagick = checkMinVersion minVersion <$> magickVersion
+ 127 where
+ 128 minVersion = Version [6,0,0] []
+ 129
+ 130 ffmpegVersion :: IO (Maybe Version)
+ 131 ffmpegVersion = extractVersion "ffmpeg" ["-version"] $ \line ->
+ 132 case take 3 $ words line of
+ 133 ["ffmpeg", "version", vs] -> vs
+ 134 _ -> ""
+ 135
+ 136 blenderVersion :: IO (Maybe Version)
+ 137 blenderVersion = extractVersion "blender" ["--version"] $ \line ->
+ 138 case take 2 (words line) of
+ 139 ["Blender", vs] -> vs
+ 140 _ -> ""
+ 141
+ 142 rsvgVersion :: IO (Maybe Version)
+ 143 rsvgVersion = extractVersion "rsvg-convert" ["--version"] $ \line ->
+ 144 case words line of
+ 145 ["rsvg-convert", "version", vs] -> vs
+ 146 _ -> ""
+ 147
+ 148 inkscapeVersion :: IO (Maybe Version)
+ 149 inkscapeVersion = extractVersion "inkscape" ["--version"] $ \line ->
+ 150 case take 2 $ words line of
+ 151 ["Inkscape", vs] -> vs
+ 152 _ -> ""
+ 153
+ 154 magickVersion :: IO (Maybe Version)
+ 155 magickVersion = extractVersion magickCmd ["-version"] $ \line ->
+ 156 case take 3 $ words line of
+ 157 ["Version:", "ImageMagick", vs] -> vs
+ 158 _ -> ""
+ 159
+ 160 checkMinVersion :: Version -> Maybe Version -> Either String String
+ 161 checkMinVersion _minVersion Nothing = Left "no"
+ 162 checkMinVersion minVersion (Just vs)
+ 163 | vs < minVersion = Left $ "too old: " ++ showVersion vs ++ " < " ++ showVersion minVersion
+ 164 | otherwise = Right (showVersion vs)
+ 165
+ 166 extractVersion :: FilePath -> [String] -> (String -> String) -> IO (Maybe Version)
+ 167 extractVersion execPath args outputFilter = do
+ 168 mbPath <- findExecutable execPath
+ 169 case mbPath of
+ 170 Nothing -> return Nothing
+ 171 Just path -> do
+ 172 ret <- runCmd_ path args
+ 173 case ret of
+ 174 Left{} -> return $ Just noVersion
+ 175 Right out ->
+ 176 pure $ Just $ fromMaybe noVersion $ parseVS $ outputFilter out
+ 177 where
+ 178 noVersion = Version [] []
+ 179 parseVS vs = listToMaybe $ reverse
+ 180 [ v | (v, _) <- readP_to_S parseVersion vs ]
+ 181
+ 182 hasTeXPackage :: FilePath -> String -> IO (Either String String)
+ 183 hasTeXPackage exec pkg = handle (\(_::SomeException) -> return $ Left "n/a") $
+ 184 withSystemTempDirectory "reanimate" $ \tmp_dir -> withTempFile tmp_dir "test.tex" $ \tex_file tex_handle -> do
+ 185 hPutStr tex_handle tex_document
+ 186 hPutStr tex_handle $ "\\usepackage" ++ pkg ++ "\n"
+ 187 hPutStr tex_handle "\\begin{document}\n"
+ 188 hPutStr tex_handle "blah\n"
+ 189 hPutStr tex_handle tex_epilogue
+ 190 hClose tex_handle
+ 191 ret <- runCmd_ exec ["-interaction=batchmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file]
+ 192 return $ case ret of
+ 193 Right{} -> Right "OK"
+ 194 Left{} -> Left "missing"
+ 195 where
+ 196 tex_document = "\\documentclass[preview]{standalone}\n"
+ 197 tex_epilogue =
+ 198 "\n\
+ 199 \\\end{document}"
+ 200
+ 201 hasProgram :: String -> IO (Either String String)
+ 202 hasProgram exec = do
+ 203 mbPath <- findExecutable exec
+ 204 return $ case mbPath of
+ 205 Nothing -> Left $ "'" ++ exec ++ "' not found"
+ 206 Just path -> Right path
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Driver.Compile.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Driver.Compile.hs.html
new file mode 100644
index 0000000..131765a
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Driver.Compile.hs.html
@@ -0,0 +1,58 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 module Reanimate.Driver.Compile ( compile ) where
+ 2
+ 3 import Reanimate.Driver.Server (findOwnSource)
+ 4 import System.Directory
+ 5 import System.Exit
+ 6 import System.FilePath
+ 7 import System.Process
+ 8 import System.IO
+ 9
+ 10 compile :: [String] -> IO ()
+ 11 compile opts = do
+ 12 mbSelf <- findOwnSource
+ 13 case mbSelf of
+ 14 Nothing -> do
+ 15 hPutStrLn stderr
+ 16 "Failed to find source code. Did you already compile the animations?\n\
+ 17 \Try running again without the --compile flag."
+ 18 exitFailure
+ 19 Just self -> do
+ 20 let selfDir = takeDirectory self
+ 21 selfName = takeBaseName self
+ 22 outDir = selfDir </> ".reanimate" </> selfName
+ 23 target = outDir </> selfName
+ 24 ghcOptions =
+ 25 ["-rtsopts", "--make", "-threaded", "-O2"] ++
+ 26 ["-odir", outDir, "-hidir", outDir] ++
+ 27 [self, "-o", target]
+ 28 createDirectoryIfMissing True outDir
+ 29 withCurrentDirectory selfDir $ do
+ 30 checkExitCode =<< rawSystem "stack" (["ghc", "--"] ++ ghcOptions)
+ 31 checkExitCode =<< rawSystem target opts
+ 32
+ 33 checkExitCode :: ExitCode -> IO ()
+ 34 checkExitCode ExitSuccess = return ()
+ 35 checkExitCode (ExitFailure n) = exitWith (ExitFailure n)
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Driver.Magick.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Driver.Magick.hs.html
new file mode 100644
index 0000000..110422b
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Driver.Magick.hs.html
@@ -0,0 +1,42 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 module Reanimate.Driver.Magick
+ 2 ( magickCmd
+ 3 ) where
+ 4
+ 5 import System.IO.Unsafe (unsafePerformIO)
+ 6 import System.Directory (findExecutable)
+ 7
+ 8 {-# NOINLINE magickCmd #-}
+ 9 -- |The name of the ImageMagick command. On Unix-like operating systems, the
+ 10 -- command \'convert\' does not conflict with the name of other commands. On
+ 11 -- Windows, ImageMagick version 7 is readily available, the command \'magick\'
+ 12 -- should be present, and is preferred over \'convert\'. If it is not present,
+ 13 -- \'convert\' is assumed to be the relevant command.
+ 14 magickCmd :: String
+ 15 -- The use of 'unsafeperformIO' is justified on the basis that if \'magick\' is
+ 16 -- found once, it will always be present.
+ 17 magickCmd = unsafePerformIO $ do
+ 18 mPath <- findExecutable "magick"
+ 19 pure $ maybe "convert" (const "magick") mPath
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Driver.Server.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Driver.Server.hs.html
new file mode 100644
index 0000000..634e70a
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Driver.Server.hs.html
@@ -0,0 +1,323 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE OverloadedStrings #-}
+ 2 {-# LANGUAGE ScopedTypeVariables #-}
+ 3 module Reanimate.Driver.Server
+ 4 ( serve
+ 5 , findOwnSource
+ 6 ) where
+ 7
+ 8 import Control.Concurrent
+ 9 import Control.Exception (SomeException, catch, finally)
+ 10 import Control.Monad
+ 11 import Data.IORef
+ 12 import Data.Text (Text)
+ 13 import qualified Data.Text as T
+ 14 import qualified Data.Text.Read as T
+ 15 import Data.Time
+ 16 import GHC.Environment (getFullArgs)
+ 17 import Language.Haskell.Ghcid
+ 18 import Network.WebSockets
+ 19 import Paths_reanimate
+ 20 import Reanimate.Misc (runCmdLazy, runCmd_)
+ 21 import System.Directory (createDirectoryIfMissing,
+ 22 doesFileExist, findFile, listDirectory,
+ 23 makeAbsolute,
+ 24 withCurrentDirectory)
+ 25 import System.Environment (getProgName)
+ 26 import System.Exit
+ 27 import System.FilePath
+ 28 import System.FSNotify
+ 29 import System.IO
+ 30 import System.IO.Temp
+ 31 import System.Process
+ 32 import Web.Browser (openBrowser)
+ 33
+ 34 opts :: ConnectionOptions
+ 35 opts = defaultConnectionOptions
+ 36 { connectionCompressionOptions = PermessageDeflateCompression defaultPermessageDeflate }
+ 37
+ 38 serve :: Bool -> Maybe FilePath -> [String] -> Maybe FilePath -> IO ()
+ 39 serve verbose mbGHCPath extraGHCOpts mbSelfPath = withManager $ \watch -> do
+ 40 hSetBuffering stdin NoBuffering
+ 41 self <- maybe requireOwnSource pure mbSelfPath
+ 42 when verbose $
+ 43 logMsg $ "Found own source code at: " ++ self
+ 44 hasConnectionVar <- newMVar False
+ 45
+ 46 ghci <- ghciBackend mbGHCPath self
+ 47
+ 48 -- There might already browser window open. Wait 2s to see if that window
+ 49 -- connects to us. If not, open a new window.
+ 50 _ <- forkIO $ do
+ 51 threadDelay (2*10^(6::Int))
+ 52 hasConn <- readMVar hasConnectionVar
+ 53 unless hasConn openViewer
+ 54 logMsg "Listening..."
+ 55 let options = ServerOptions
+ 56 { serverHost = "127.0.0.1"
+ 57 , serverPort = 9161
+ 58 , serverConnectionOptions = opts
+ 59 , serverRequirePong = Nothing }
+ 60 withSystemTempDirectory "reanimate-svgs" $ \tmpDir ->
+ 61 runServerWithOptions options $ \pending -> do
+ 62 logMsg "New connection received."
+ 63 hasConn <- swapMVar hasConnectionVar True
+ 64 if hasConn
+ 65 then do
+ 66 logMsg "Already connected to browser. Rejecting."
+ 67 rejectRequestWith pending defaultRejectRequest
+ 68 else do
+ 69 createDirectoryIfMissing True tmpDir
+ 70 conn <- acceptRequest pending
+ 71 slave <- newEmptyMVar
+ 72 let handler = modifyMVar_ slave $ \tid -> do
+ 73 logMsg "Reloading code..."
+ 74 killThread tid
+ 75 forkIO $ ignoreErrors $ slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self tmpDir
+ 76 killSlave = do
+ 77 tid <- takeMVar slave
+ 78 killThread tid
+ 79 stop <- watchFile watch self handler
+ 80 putMVar slave =<< forkIO (return ())
+ 81 handler
+ 82 let loop = do
+ 83 -- FIXME: We don't use msg here.
+ 84 _msg <- receiveData conn :: IO T.Text
+ 85 handler
+ 86 loop
+ 87 cleanup = do
+ 88 stop
+ 89 killSlave
+ 90 _ <- swapMVar hasConnectionVar False
+ 91 return ()
+ 92 loop `finally` cleanup
+ 93
+ 94 ignoreErrors :: IO () -> IO ()
+ 95 ignoreErrors action = action `catch` \(_::SomeException) -> return ()
+ 96
+ 97 openViewer :: IO ()
+ 98 openViewer = do
+ 99 url <- getDataFileName "viewer-elm/dist/index.html"
+ 100 logMsg "Opening browser..."
+ 101 bSucc <- openBrowser url
+ 102 if bSucc
+ 103 then logMsg "Browser opened."
+ 104 else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url
+ 105
+ 106 slaveHandler :: Bool -> Maybe FilePath -> [String] -> Connection -> GhciBackend
+ 107 -> FilePath -> FilePath -> IO ()
+ 108 slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self svgDir =
+ 109 withCurrentDirectory (takeDirectory self) $
+ 110 withSystemTempDirectory "reanimate" $ \tmpDir ->
+ 111 withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do
+ 112 outputFolder <- createTempDirectory svgDir "svgs"
+ 113 let frameFileName frameIdx =
+ 114 outputFolder </> show frameIdx <.> "svg"
+ 115
+ 116 sentFrameCount <- newMVar False
+ 117 hClose handle
+ 118 lock <- newMVar ()
+ 119 sendWebMessage conn $ WebStatus "Compiling"
+ 120 ghciThread <- forkIO $ do
+ 121 firstFrame <- newIORef True
+ 122 ghciReload ghci
+ 123 logMsg "GHCi reload done."
+ 124 ghciGenerate ghci outputFolder $ \frameIdx -> do
+ 125 first <- readIORef firstFrame
+ 126 writeIORef firstFrame False
+ 127 if first
+ 128 then
+ 129 modifyMVar_ sentFrameCount $ \sent -> do
+ 130 unless sent $
+ 131 sendWebMessage conn $ WebFrameCount frameIdx
+ 132 logMsg "Framecount sent."
+ 133 return True
+ 134 else
+ 135 withMVar lock $ \_ ->
+ 136 sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx)
+ 137 logMsg "GHCi render done."
+ 138 ret <- case mbGHCPath of
+ 139 Nothing -> do
+ 140 let args = ["ghc", "--"] ++ ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable]
+ 141 when verbose $
+ 142 logMsg $ "Running: " ++ showCommandForUser "stack" args
+ 143 runCmd_ "stack" args
+ 144 Just ghc -> do
+ 145 let args = ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable]
+ 146 when verbose $
+ 147 logMsg $ "Running: " ++ showCommandForUser ghc args
+ 148 runCmd_ ghc args
+ 149 logMsg "Compile done."
+ 150 case ret of
+ 151 Left err ->
+ 152 sendWebMessage conn $ WebError $ unlines (lines err)
+ 153 Right{} -> runCmdLazy tmpExecutable (execOpts outputFolder) $ \getFrame -> do
+ 154 frameCount <- expectFrame =<< getFrame
+ 155 modifyMVar_ sentFrameCount $ \sent -> do
+ 156 unless sent $
+ 157 sendWebMessage conn $ WebFrameCount frameCount
+ 158 return True
+ 159 replicateM_ frameCount $ do
+ 160 frameIdx <- expectFrame =<< getFrame
+ 161 withMVar lock $ \_ ->
+ 162 sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx)
+ 163 logMsg "Optimized render done."
+ 164 killThread ghciThread
+ 165 where
+ 166 execOpts output =
+ 167 [ "raw", "--output", output, "--offset", "1"
+ 168 , "+RTS", "-N", "-M2G", "-RTS"]
+ 169 expectFrame :: Either String Text -> IO Int
+ 170 expectFrame (Left "") = do
+ 171 sendWebMessage conn $ WebStatus "Done"
+ 172 exitSuccess
+ 173 expectFrame (Left err) = do
+ 174 sendWebMessage conn $ WebError err
+ 175 exitWith (ExitFailure 1)
+ 176 expectFrame (Right frame) =
+ 177 case T.decimal frame of
+ 178 Left err -> do
+ 179 hPutStrLn stderr (T.unpack frame)
+ 180 raiseError conn err
+ 181 Right (frameNumber, "") ->
+ 182 pure frameNumber
+ 183 Right {} -> do
+ 184 let err = "Unexpected output"
+ 185 hPutStrLn stderr (T.unpack frame)
+ 186 raiseError conn err
+ 187
+ 188 raiseError :: Connection -> String -> IO a
+ 189 raiseError conn err = do
+ 190 hPutStrLn stderr $ "expectFrame: " ++ err
+ 191 sendWebMessage conn $ WebError err
+ 192 exitWith (ExitFailure 1)
+ 193
+ 194 watchFile :: WatchManager -> FilePath -> IO () -> IO StopListening
+ 195 watchFile watch file action = watchTree watch (takeDirectory file) check (const action)
+ 196 where
+ 197 check event =
+ 198 takeFileName (eventPath event) == takeFileName file ||
+ 199 takeExtension (eventPath event) `elem` sourceExtensions ||
+ 200 takeExtension (eventPath event) `elem` dataExtensions
+ 201 sourceExtensions = [".hs", ".lhs"]
+ 202 dataExtensions = [".jpg", ".png", ".bmp", ".pov", ".tex", ".csv"]
+ 203
+ 204 ghcOptions :: FilePath -> [String]
+ 205 ghcOptions tmpDir =
+ 206 ["-rtsopts", "--make", "-threaded", "-O2"] ++
+ 207 ["-odir", tmpDir, "-hidir", tmpDir]
+ 208
+ 209 -- FIXME: Move to a different module
+ 210 requireOwnSource :: IO FilePath
+ 211 requireOwnSource = do
+ 212 mbSelf <- findOwnSource
+ 213 case mbSelf of
+ 214 Nothing -> do
+ 215 hPutStrLn stderr
+ 216 "Rendering in browser window is only available when interpreting.\n\
+ 217 \To render a video file, use the 'render' command or run again with --help\n\
+ 218 \to see all available options."
+ 219 exitFailure
+ 220 Just self -> pure self
+ 221
+ 222 findOwnSource :: IO (Maybe FilePath)
+ 223 findOwnSource = do
+ 224 fullArgs <- getFullArgs
+ 225 stackSource <- makeAbsolute (last fullArgs)
+ 226 exist <- doesFileExist stackSource
+ 227 if exist && isHaskellFile stackSource
+ 228 then return (Just stackSource)
+ 229 else do
+ 230 prog <- getProgName
+ 231 let hsProg
+ 232 | isHaskellFile prog = prog
+ 233 | otherwise = replaceExtension prog "hs"
+ 234 lst <- listDirectory "."
+ 235 findFile ("." : lst) hsProg
+ 236
+ 237 isHaskellFile :: FilePath -> Bool
+ 238 isHaskellFile path = takeExtension path `elem` [".hs", ".lhs"]
+ 239
+ 240 logMsg :: String -> IO ()
+ 241 logMsg msg = do
+ 242 now <- getCurrentTime
+ 243 putStrLn $ formatTime defaultTimeLocale fmt now ++ ": " ++ msg
+ 244 where
+ 245 fmt = "%F %T%2Q"
+ 246
+ 247 -------------------------------------------------------------------------------
+ 248 -- Ghci interface
+ 249
+ 250 -- stack
+ 251 -- cabal
+ 252 -- raw
+ 253 -- none?
+ 254 newtype GhciBackend = GhciBackend (MVar Ghci)
+ 255
+ 256 ghciBackend :: Maybe FilePath -> FilePath -> IO GhciBackend
+ 257 ghciBackend mbGHCPath self = do
+ 258 let ghciProc =
+ 259 case mbGHCPath of
+ 260 Just ghcPath ->
+ 261 proc ghcPath $ ["--interactive", "+RTS"] ++ words memoryLimit ++ ["-RTS"]
+ 262 Nothing ->
+ 263 proc "stack" ["exec", "ghci", "--rts-options="++memoryLimit]
+ 264 (ghci, _loads) <- startGhciProcess ghciProc $ \_stream _msg -> return ()
+ 265 void $ exec ghci $ ":load " ++ self
+ 266 ref <- newMVar ghci
+ 267 return $ GhciBackend ref
+ 268
+ 269 ghciReload :: GhciBackend -> IO ()
+ 270 ghciReload (GhciBackend ref) =
+ 271 withMVar ref $ \ghci ->
+ 272 void $ reload ghci
+ 273
+ 274 ghciGenerate :: GhciBackend -> FilePath -> (Int -> IO ()) -> IO ()
+ 275 ghciGenerate (GhciBackend ref) target cb = withMVar ref $ \ghci ->
+ 276 execStream ghci (":main raw --output=" ++ target ++ " --offset=1")
+ 277 $ \_ msg ->
+ 278 case reads msg of
+ 279 [(frameIdx,"")] -> cb frameIdx
+ 280 _ -> return ()
+ 281
+ 282 memoryLimit :: String
+ 283 memoryLimit = "-M1G"
+ 284
+ 285 -------------------------------------------------------------------------------
+ 286 -- Websocket API
+ 287
+ 288 data WebMessage
+ 289 = WebStatus String
+ 290 | WebError String
+ 291 | WebFrameCount Int
+ 292 | WebFrame Int FilePath
+ 293
+ 294 sendWebMessage :: Connection -> WebMessage -> IO ()
+ 295 sendWebMessage conn msg = sendTextData conn $
+ 296 case msg of
+ 297 WebStatus txt -> T.pack "status\n" <> T.pack txt
+ 298 WebError txt -> T.pack "error\n" <> T.pack txt
+ 299 WebFrameCount n -> T.pack $ "frame_count\n" ++ show n
+ 300 WebFrame n path -> T.pack $ "frame\n" ++ show n ++ "\n" ++ path
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Driver.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Driver.hs.html
new file mode 100644
index 0000000..9146644
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Driver.hs.html
@@ -0,0 +1,246 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE MultiWayIf #-}
+ 2 {-# LANGUAGE RecordWildCards #-}
+ 3 module Reanimate.Driver
+ 4 ( reanimate
+ 5 )
+ 6 where
+ 7
+ 8 import Control.Applicative ((<|>))
+ 9 import Control.Monad
+ 10 import Data.Maybe
+ 11 import Data.Either
+ 12 import Reanimate.Animation (Animation)
+ 13 import Reanimate.Driver.Check
+ 14 import Reanimate.Driver.CLI
+ 15 import Reanimate.Driver.Compile
+ 16 import Reanimate.Driver.Server
+ 17 import Reanimate.Parameters
+ 18 import Reanimate.Render (render, renderSnippets, renderSvgs,
+ 19 selectRaster)
+ 20 import System.Directory
+ 21 import System.Exit
+ 22 import System.FilePath
+ 23 import System.IO
+ 24 import Text.Printf
+ 25
+ 26 presetFormat :: Preset -> Format
+ 27 presetFormat Youtube = RenderMp4
+ 28 presetFormat ExampleGif = RenderGif
+ 29 presetFormat Quick = RenderMp4
+ 30 presetFormat MediumQ = RenderMp4
+ 31 presetFormat HighQ = RenderMp4
+ 32 presetFormat LowFPS = RenderMp4
+ 33
+ 34 presetFPS :: Preset -> FPS
+ 35 presetFPS Youtube = 60
+ 36 presetFPS ExampleGif = 25
+ 37 presetFPS Quick = 15
+ 38 presetFPS MediumQ = 30
+ 39 presetFPS HighQ = 30
+ 40 presetFPS LowFPS = 10
+ 41
+ 42 presetWidth :: Preset -> Width
+ 43 presetWidth Youtube = 2560
+ 44 presetWidth ExampleGif = 320
+ 45 presetWidth Quick = 320
+ 46 presetWidth MediumQ = 800
+ 47 presetWidth HighQ = 1920
+ 48 presetWidth LowFPS = presetWidth HighQ
+ 49
+ 50 presetHeight :: Preset -> Height
+ 51 presetHeight preset = presetWidth preset * 9 `div` 16
+ 52
+ 53 formatFPS :: Format -> FPS
+ 54 formatFPS RenderMp4 = 60
+ 55 formatFPS RenderGif = 25
+ 56 formatFPS RenderWebm = 60
+ 57
+ 58 formatWidth :: Format -> Width
+ 59 formatWidth RenderMp4 = 2560
+ 60 formatWidth RenderGif = 320
+ 61 formatWidth RenderWebm = 2560
+ 62
+ 63 formatHeight :: Format -> Height
+ 64 formatHeight RenderMp4 = 1440
+ 65 formatHeight RenderGif = 180
+ 66 formatHeight RenderWebm = 1440
+ 67
+ 68 formatExtension :: Format -> String
+ 69 formatExtension RenderMp4 = "mp4"
+ 70 formatExtension RenderGif = "gif"
+ 71 formatExtension RenderWebm = "webm"
+ 72
+ 73 {-|
+ 74 Main entry-point for accessing an animation. Creates a program that takes the
+ 75 following command-line arguments:
+ 76
+ 77 > Usage: PROG [COMMAND]
+ 78 > This program contains an animation which can either be viewed in a web-browser
+ 79 > or rendered to disk.
+ 80 >
+ 81 > Available options:
+ 82 > -h,--help Show this help text
+ 83 >
+ 84 > Available commands:
+ 85 > check Run a system's diagnostic and report any missing
+ 86 > external dependencies.
+ 87 > view Play animation in browser window.
+ 88 > render Render animation to file.
+ 89
+ 90 Neither the \'check\' nor the \'view\' command take any additional arguments.
+ 91 Rendering animation can be controlled with these arguments:
+ 92
+ 93 > Usage: PROG render [-o|--target FILE] [--fps FPS] [-w|--width PIXELS]
+ 94 > [-h|--height PIXELS] [--compile] [--format FMT]
+ 95 > [--preset TYPE]
+ 96 > Render animation to file.
+ 97 >
+ 98 > Available options:
+ 99 > -o,--target FILE Write output to FILE
+ 100 > --fps FPS Set frames per second.
+ 101 > -w,--width PIXELS Set video width.
+ 102 > -h,--height PIXELS Set video height.
+ 103 > --compile Compile source code before rendering.
+ 104 > --format FMT Video format: mp4, gif, webm
+ 105 > --preset TYPE Parameter presets: youtube, gif, quick
+ 106 > -h,--help Show this help text
+ 107 -}
+ 108 reanimate :: Animation -> IO ()
+ 109 reanimate animation = do
+ 110 Options {..} <- getDriverOptions
+ 111 case optsCommand of
+ 112 Raw {..} -> do
+ 113 setFPS 60
+ 114 renderSvgs rawOutputFolder rawFrameOffset rawPrettyPrint animation
+ 115 Test -> do
+ 116 setNoExternals True
+ 117 -- hSetBinaryMode stdout True
+ 118 renderSnippets animation
+ 119 Check -> checkEnvironment
+ 120 View {..} -> serve viewVerbose viewGHCPath viewGHCOpts viewOrigin
+ 121 Render {..} -> do
+ 122 let fmt =
+ 123 guessParameter renderFormat (fmap presetFormat renderPreset)
+ 124 $ case renderTarget of
+ 125 -- Format guessed from output
+ 126 Just target -> case takeExtension target of
+ 127 ".mp4" -> RenderMp4
+ 128 ".gif" -> RenderGif
+ 129 ".webm" -> RenderWebm
+ 130 _ -> RenderMp4
+ 131 -- Default to mp4 rendering.
+ 132 Nothing -> RenderMp4
+ 133
+ 134 target <- case renderTarget of
+ 135 Nothing -> do
+ 136 mbSelf <- findOwnSource
+ 137 let ext = formatExtension fmt
+ 138 self = fromMaybe "output" mbSelf
+ 139 pure $ replaceExtension self ext
+ 140 Just target -> makeAbsolute target
+ 141
+ 142 let
+ 143 fps =
+ 144 guessParameter renderFPS (fmap presetFPS renderPreset) $ formatFPS fmt
+ 145 (width, height) = fromMaybe
+ 146 ( maybe (formatWidth fmt) presetWidth renderPreset
+ 147 , maybe (formatHeight fmt) presetHeight renderPreset
+ 148 )
+ 149 (userPreferredDimensions renderWidth renderHeight)
+ 150
+ 151 raster <-
+ 152 if renderRaster == RasterNone || renderRaster == RasterAuto then do
+ 153 svgSupport <- hasFFmpegRSvg
+ 154 if isRight svgSupport
+ 155 then selectRaster renderRaster
+ 156 else do
+ 157 raster <- selectRaster RasterAuto
+ 158 when (raster == RasterNone) $ do
+ 159 hPutStrLn stderr
+ 160 "Error: your FFmpeg was built without SVG support and no raster engines \
+ 161 \are available. Please install either inkscape, imagemagick, or rsvg."
+ 162 exitWith (ExitFailure 1)
+ 163 return raster
+ 164 else selectRaster renderRaster
+ 165
+ 166 if renderCompile
+ 167 then compile $
+ 168 [ "render"
+ 169 , "--fps"
+ 170 , show fps
+ 171 , "--width"
+ 172 , show width
+ 173 , "--height"
+ 174 , show height
+ 175 , "--format"
+ 176 , showFormat fmt
+ 177 , "--raster"
+ 178 , showRaster raster
+ 179 , "--target"
+ 180 , target
+ 181 , "+RTS"
+ 182 , "-N"
+ 183 , "-RTS"
+ 184 ] ++ [ "--partial" | renderPartial ]
+ 185 else do
+ 186 setRaster raster
+ 187 setFPS fps
+ 188 setWidth width
+ 189 setHeight height
+ 190 printf
+ 191 "Animation options:\n\
+ 192 \ fps: %d\n\
+ 193 \ width: %d\n\
+ 194 \ height: %d\n\
+ 195 \ fmt: %s\n\
+ 196 \ target: %s\n\
+ 197 \ raster: %s\n"
+ 198 fps
+ 199 width
+ 200 height
+ 201 (showFormat fmt)
+ 202 target
+ 203 (show raster)
+ 204
+ 205 render animation target raster fmt width height fps renderPartial
+ 206
+ 207 guessParameter :: Maybe a -> Maybe a -> a -> a
+ 208 guessParameter a b def = fromMaybe def (a <|> b)
+ 209
+ 210
+ 211 -- If user specifies exactly one dimension explicitly, calculate the other
+ 212 userPreferredDimensions :: Maybe Width -> Maybe Height -> Maybe (Width, Height)
+ 213 userPreferredDimensions (Just width) (Just height) = Just (width, height)
+ 214 userPreferredDimensions (Just width) Nothing =
+ 215 Just (width, makeEven $ width * 9 `div` 16)
+ 216 userPreferredDimensions Nothing (Just height) =
+ 217 Just (makeEven $ height * 16 `div` 9, height)
+ 218 userPreferredDimensions Nothing Nothing = Nothing
+ 219
+ 220 -- Avoid ffmpeg failures "height not divisible by 2"
+ 221 makeEven :: Int -> Int
+ 222 makeEven x | even x = x
+ 223 | otherwise = x - 1
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Ease.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Ease.hs.html
new file mode 100644
index 0000000..febff54
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Ease.hs.html
@@ -0,0 +1,147 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Easing functions modify the rate of change in animations.
+ 3 More examples can be seen here: <https://easings.net/>.
+ 4 -}
+ 5 module Reanimate.Ease
+ 6 ( Signal
+ 7 , constantS
+ 8 , fromToS
+ 9 , reverseS
+ 10 , curveS
+ 11 , powerS
+ 12 , bellS
+ 13 , oscillateS
+ 14 , cubicBezierS
+ 15 ) where
+ 16
+ 17 -- | Signals are time-varying variables. Signals can be composed using function
+ 18 -- composition.
+ 19 type Signal = Double -> Double
+ 20
+ 21 -- | Constant signal.
+ 22 --
+ 23 -- Example:
+ 24 --
+ 25 -- @
+ 26 -- 'Reanimate.signalA' ('constantS' 0.5) 'Reanimate.Builtin.Documentation.drawProgress'
+ 27 -- @
+ 28 --
+ 29 -- <<docs/gifs/doc_constantS.gif>>
+ 30 constantS :: Double -> Signal
+ 31 constantS = const
+ 32
+ 33 -- | Signal with new starting and end values.
+ 34 --
+ 35 -- Example:
+ 36 --
+ 37 -- @
+ 38 -- 'Reanimate.signalA' ('fromToS' 0.8 0.2) 'Reanimate.Builtin.Documentation.drawProgress'
+ 39 -- @
+ 40 --
+ 41 -- <<docs/gifs/doc_fromToS.gif>>
+ 42 fromToS :: Double -> Double -> Signal
+ 43 fromToS from to t = from + (to-from)*t
+ 44
+ 45 -- | Reverse signal order.
+ 46 --
+ 47 -- Example:
+ 48 --
+ 49 -- @
+ 50 -- 'Reanimate.signalA' 'reverseS' 'Reanimate.Builtin.Documentation.drawProgress'
+ 51 -- @
+ 52 --
+ 53 -- <<docs/gifs/doc_reverseS.gif>>
+ 54 reverseS :: Signal
+ 55 reverseS t = 1-t
+ 56
+ 57 -- | S-curve signal. Takes a steepness parameter. 2 is a good default.
+ 58 --
+ 59 -- Example:
+ 60 --
+ 61 -- @
+ 62 -- 'Reanimate.signalA' ('curveS' 2) 'Reanimate.Builtin.Documentation.drawProgress'
+ 63 -- @
+ 64 --
+ 65 -- <<docs/gifs/doc_curveS.gif>>
+ 66 curveS :: Double -> Signal
+ 67 curveS steepness s =
+ 68 if s < 0.5
+ 69 then 0.5 * (2*s)**steepness
+ 70 else 1-0.5 * (2 - 2*s)**steepness
+ 71
+ 72 -- | Power curve signal. Takes a steepness parameter. 2 is a good default.
+ 73 --
+ 74 -- Example:
+ 75 --
+ 76 -- @
+ 77 -- 'Reanimate.signalA' ('powerS' 2) 'Reanimate.Builtin.Documentation.drawProgress'
+ 78 -- @
+ 79 --
+ 80 -- <<docs/gifs/doc_powerS.gif>>
+ 81 powerS :: Double -> Signal
+ 82 powerS steepness s = s**steepness
+ 83
+ 84 -- | Oscillate signal.
+ 85 --
+ 86 -- Example:
+ 87 --
+ 88 -- @
+ 89 -- 'Reanimate.signalA' 'oscillateS' 'Reanimate.Builtin.Documentation.drawProgress'
+ 90 -- @
+ 91 --
+ 92 -- <<docs/gifs/doc_oscillateS.gif>>
+ 93 oscillateS :: Signal
+ 94 oscillateS t =
+ 95 if t < 1/2
+ 96 then t*2
+ 97 else 2-t*2
+ 98
+ 99 -- | Bell-curve signal. Takes a steepness parameter. 2 is a good default.
+ 100 --
+ 101 -- Example:
+ 102 --
+ 103 -- @
+ 104 -- 'Reanimate.signalA' ('bellS' 2) 'Reanimate.Builtin.Documentation.drawProgress'
+ 105 -- @
+ 106 --
+ 107 -- <<docs/gifs/doc_bellS.gif>>
+ 108 bellS :: Double -> Signal
+ 109 bellS steepness = curveS steepness . oscillateS
+ 110
+ 111 -- | Cubic Bezier signal. Gives you a fair amount of control over how the
+ 112 -- signal will curve.
+ 113 --
+ 114 -- Example:
+ 115 --
+ 116 -- @
+ 117 -- 'Reanimate.signalA' ('cubicBezierS' (0.0, 0.8, 0.9, 1.0)) 'Reanimate.Builtin.Documentation.drawProgress'
+ 118 -- @
+ 119 --
+ 120 -- <<docs/gifs/doc_cubicBezierS.gif>>
+ 121 cubicBezierS :: (Double, Double, Double, Double) -> Signal
+ 122 cubicBezierS (x1, x2, x3, x4) s =
+ 123 let ms = 1-s
+ 124 in x1*ms^(3::Int) + 3*x2*ms^(2::Int)*s + 3*x3*ms*s^(2::Int) + x4*s^(3::Int)
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Effect.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Effect.hs.html
new file mode 100644
index 0000000..be63805
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Effect.hs.html
@@ -0,0 +1,154 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-| Effects represent modifications applied to frames of the 'Animation'.
+ 2 Effects can (and usually do) depend on time.
+ 3 One or more effects can be applied over the entire duration of animation, or modified to affect
+ 4 only a specific portion at the beginning \/ middle \/ end of the animation.
+ 5 -}
+ 6 module Reanimate.Effect
+ 7 ( -- * Primitive Effects
+ 8 Effect
+ 9 , fadeInE
+ 10 , fadeOutE
+ 11 , fadeLineInE
+ 12 , fadeLineOutE
+ 13 , fillInE
+ 14 , drawInE
+ 15 , drawOutE
+ 16 , translateE
+ 17 , scaleE
+ 18 , constE
+ 19 -- * Modifying Effects
+ 20 , overBeginning
+ 21 , overEnding
+ 22 , overInterval
+ 23 , reverseE
+ 24 , delayE
+ 25 , aroundCenterE
+ 26 -- * Applying Effects to Animations
+ 27 , applyE
+ 28 ) where
+ 29
+ 30 import Graphics.SvgTree (Tree)
+ 31 import Reanimate.Animation
+ 32 import Reanimate.Svg
+ 33
+ 34 -- | An Effect represents a modification of a SVG 'Tree' that can vary with time.
+ 35 type Effect = Duration -- ^ Duration of the effect (in seconds)
+ 36 -> Time -- ^ Time elapsed from when the effect started (in seconds)
+ 37 -> Tree -- ^ Image to be modified
+ 38 -> Tree -- ^ Image after modification
+ 39
+ 40 -- | Modify the effect so that it only applies to the initial part of the animation.
+ 41 overBeginning :: Duration -- ^ Duration of the initial segment of the animation over which the Effect should be applied
+ 42 -> Effect -- ^ The Effect to modify
+ 43 -> Effect -- ^ Effect which will only affect the initial segment of the animation
+ 44 overBeginning maxT effect _d t =
+ 45 if t < maxT
+ 46 then effect maxT t
+ 47 else id
+ 48
+ 49 -- | Modify the effect so that it only applies to the ending part of the animation.
+ 50 overEnding :: Duration -- ^ Duration of the ending segment of the animation over which the Effect should be applied
+ 51 -> Effect -- ^ The Effect to modify
+ 52 -> Effect -- ^ Effect which will only affect the ending segment of the animation
+ 53 overEnding minT effect d t =
+ 54 if t >= blankDur
+ 55 then effect minT (t-blankDur)
+ 56 else id
+ 57 where
+ 58 blankDur = d-minT
+ 59
+ 60 -- | Modify the effect so that it only applies within given interval of animation's running time.
+ 61 overInterval :: Time -- ^ time after start of animation when the effect should start
+ 62 -> Time -- ^ time after start of the animation when the effect should finish
+ 63 -> Effect -- ^ The Effect to modify
+ 64 -> Effect -- ^ Effect which will only affect the specified interval within the animation
+ 65 overInterval start end effect _d t =
+ 66 if start <= t && t <= end
+ 67 then effect dur ((t - start) / dur)
+ 68 else id
+ 69 where
+ 70 dur = end - start
+ 71
+ 72 -- | @reverseE effect@ starts where the @effect@ ends and vice versa.
+ 73 reverseE :: Effect -> Effect
+ 74 reverseE fn d t = fn d (d-t)
+ 75
+ 76 -- | Delay the effect so that it only starts after specified duration and then runs till the end of animation.
+ 77 delayE :: Duration -> Effect -> Effect
+ 78 delayE delayT fn d = overEnding (d-delayT) fn d
+ 79
+ 80 -- | Modify the animation by applying the effect. If desired, you can apply multiple effects to single animation by calling this function multiple times.
+ 81 applyE :: Effect -> Animation -> Animation
+ 82 applyE fn ani = let d = duration ani
+ 83 in mkAnimation d $ \t -> fn d (d*t) $ frameAt (d*t) ani
+ 84
+ 85 -- | Build an effect from an image-modifying function. This effect does not change as time passes.
+ 86 constE :: (Tree -> Tree) -> Effect
+ 87 constE fn _d _t = fn
+ 88
+ 89 -- | Change image opacity from 0 to 1.
+ 90 fadeInE :: Effect
+ 91 fadeInE d t = withGroupOpacity (t/d)
+ 92
+ 93 -- | Change image opacity from 1 to 0. Reverse of 'fadeInE'.
+ 94 fadeOutE :: Effect
+ 95 fadeOutE = reverseE fadeInE
+ 96
+ 97 -- | Change stroke width from 0 to given value.
+ 98 fadeLineInE :: Double -> Effect
+ 99 fadeLineInE w d t = withStrokeWidth (w*(t/d))
+ 100
+ 101 -- | Change stroke width from given value to 0. Reverse of 'fadeLineInE'.
+ 102 fadeLineOutE :: Double -> Effect
+ 103 fadeLineOutE = reverseE . fadeLineInE
+ 104
+ 105 -- | Effect of progressively drawing the image. Note that this will only affect primitive shapes (see 'pathify').
+ 106 drawInE :: Effect
+ 107 drawInE d t = withFillOpacity 0 . partialSvg (t/d) . pathify
+ 108
+ 109 -- | Reverse of 'drawInE'.
+ 110 drawOutE :: Effect
+ 111 drawOutE = reverseE drawInE
+ 112
+ 113 -- | Change fill opacity from 0 to 1.
+ 114 fillInE :: Effect
+ 115 fillInE d t = withFillOpacity f
+ 116 where
+ 117 f = t/d
+ 118
+ 119 -- | Change scale from 1 to given value.
+ 120 scaleE :: Double -> Effect
+ 121 scaleE target d t = scale (1 + (target-1) * t/d)
+ 122
+ 123 -- | Move the image from its current position to the target x y coordinates.
+ 124 translateE :: Double -> Double -> Effect
+ 125 translateE x y d t = translate (x * t/d) (y * t/d)
+ 126
+ 127 -- | Transform the effect so that the image passed to the effect's image-modifying
+ 128 -- function has coordinates (0, 0) shifted to the center of its bounding box.
+ 129 -- Also see 'aroundCenter'.
+ 130 aroundCenterE :: Effect -> Effect
+ 131 aroundCenterE e d t = aroundCenter (e d t)
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.LaTeX.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.LaTeX.hs.html
new file mode 100644
index 0000000..47961ac
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.LaTeX.hs.html
@@ -0,0 +1,205 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE OverloadedStrings #-}
+ 2 {-# LANGUAGE ScopedTypeVariables #-}
+ 3 {-|
+ 4 Copyright : Written by David Himmelstrup
+ 5 License : Unlicense
+ 6 Maintainer : lemmih@gmail.com
+ 7 Stability : experimental
+ 8 Portability : POSIX
+ 9 -}
+ 10 module Reanimate.LaTeX
+ 11 ( latex
+ 12 , latexWithHeaders
+ 13 , latexChunks
+ 14 , xelatex
+ 15 , xelatexWithHeaders
+ 16 , ctex
+ 17 , ctexWithHeaders
+ 18 , latexAlign
+ 19 )
+ 20 where
+ 21
+ 22 import qualified Data.ByteString as B
+ 23 import Data.Text ( Text )
+ 24 import qualified Data.Text as T
+ 25 import qualified Data.Text.Encoding as T
+ 26 import Graphics.SvgTree ( Tree
+ 27 , parseSvgFile
+ 28 )
+ 29 import Reanimate.Cache
+ 30 import Reanimate.Misc
+ 31 import Reanimate.Svg
+ 32 import Reanimate.Parameters
+ 33 import System.FilePath ( replaceExtension
+ 34 , takeFileName
+ 35 , (</>)
+ 36 )
+ 37 import System.IO.Unsafe ( unsafePerformIO )
+ 38
+ 39 -- | Invoke latex and import the result as an SVG object. SVG objects are
+ 40 -- cached to improve performance.
+ 41 --
+ 42 -- Example:
+ 43 --
+ 44 -- > latex "$e^{i\\pi}+1=0$"
+ 45 --
+ 46 -- <<docs/gifs/doc_latex.gif>>
+ 47 latex :: T.Text -> Tree
+ 48 latex = latexWithHeaders []
+ 49
+ 50 -- | Invoke latex with extra script headers.
+ 51 latexWithHeaders :: [T.Text] -> T.Text -> Tree
+ 52 latexWithHeaders = someTexWithHeaders "latex" "dvi" []
+ 53
+ 54 someTexWithHeaders :: String -> String -> [String] -> [T.Text] -> T.Text -> Tree
+ 55 someTexWithHeaders _exec _dvi _args _headers tex | pNoExternals = mkText tex
+ 56 someTexWithHeaders exec dvi args headers tex =
+ 57 (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG dvi exec args))
+ 58 script
+ 59 where
+ 60 script = mkTexScript exec args headers tex
+ 61
+ 62 -- | Invoke latex and separate results.
+ 63 latexChunks :: [T.Text] -> [Tree]
+ 64 latexChunks chunks | pNoExternals = map mkText chunks
+ 65 latexChunks chunks = worker (svgGlyphs $ latex $ T.concat chunks) chunks
+ 66 where
+ 67 merge lst = mkGroup [ fmt svg | (fmt, _, svg) <- lst ]
+ 68 worker [] [] = []
+ 69 worker _ [] = error "latex chunk mismatch"
+ 70 worker everything (x : xs) =
+ 71 let width = length $ svgGlyphs (latex x)
+ 72 in merge (take width everything) : worker (drop width everything) xs
+ 73
+ 74 -- | Invoke xelatex and import the result as an SVG object. SVG objects are
+ 75 -- cached to improve performance. Xelatex has support for non-western scripts.
+ 76 xelatex :: Text -> Tree
+ 77 xelatex = xelatexWithHeaders []
+ 78
+ 79 -- | Invoke xelatex with extra script headers.
+ 80 xelatexWithHeaders :: [T.Text] -> T.Text -> Tree
+ 81 xelatexWithHeaders = someTexWithHeaders "xelatex" "xdv" ["-no-pdf"]
+ 82
+ 83 -- | Invoke xelatex with "\usepackage[UTF8]{ctex}" and import the result as an
+ 84 -- SVG object. SVG objects are cached to improve performance. Xelatex has
+ 85 -- support for non-western scripts.
+ 86 --
+ 87 -- Example:
+ 88 --
+ 89 -- > ctex "中文"
+ 90 --
+ 91 -- <<docs/gifs/doc_ctex.gif>>
+ 92 ctex :: T.Text -> Tree
+ 93 ctex = ctexWithHeaders []
+ 94
+ 95 -- | Invoke xelatex with extra script headers + ctex headers.
+ 96 ctexWithHeaders :: [T.Text] -> T.Text -> Tree
+ 97 ctexWithHeaders headers = xelatexWithHeaders ("\\usepackage[UTF8]{ctex}" : headers)
+ 98
+ 99 -- | Invoke latex and import the result as an SVG object. SVG objects are
+ 100 -- cached to improve performance. This wraps the TeX code in an 'align*'
+ 101 -- context.
+ 102 --
+ 103 -- Example:
+ 104 --
+ 105 -- > latexAlign "R = \\frac{{\\Delta x}}{{kA}}"
+ 106 --
+ 107 -- <<docs/gifs/doc_latexAlign.gif>>
+ 108 latexAlign :: Text -> Tree
+ 109 latexAlign tex = latex $ T.unlines ["\\begin{align*}", tex, "\\end{align*}"]
+ 110
+ 111 postprocess :: Tree -> Tree
+ 112 postprocess = simplify
+ 113
+ 114 -- executable, arguments, header, tex
+ 115 latexToSVG :: String -> String -> [String] -> Text -> IO Tree
+ 116 latexToSVG dviExt latexExec latexArgs tex = do
+ 117 latexBin <- requireExecutable latexExec
+ 118 dvisvgm <- requireExecutable "dvisvgm"
+ 119 withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file ->
+ 120 withTempFile "svg" $ \svg_file -> do
+ 121 let dvi_file =
+ 122 tmp_dir </> replaceExtension (takeFileName tex_file) dviExt
+ 123 B.writeFile tex_file (T.encodeUtf8 tex)
+ 124 runCmd
+ 125 latexBin
+ 126 ( latexArgs
+ 127 ++ [ "-interaction=nonstopmode"
+ 128 , "-halt-on-error"
+ 129 , "-output-directory=" ++ tmp_dir
+ 130 , tex_file
+ 131 ]
+ 132 )
+ 133 runCmd
+ 134 dvisvgm
+ 135 [ dvi_file
+ 136 , "--precision=5"
+ 137 , "--exact" -- better bboxes.
+ 138 , "--no-fonts" -- use glyphs instead of fonts.
+ 139 , "--scale=0.1,-0.1"
+ 140 , "--verbosity=0"
+ 141 , "-o"
+ 142 , svg_file
+ 143 ]
+ 144 svg_data <- B.readFile svg_file
+ 145 case parseSvgFile svg_file svg_data of
+ 146 Nothing -> error "Malformed svg"
+ 147 Just svg -> return $ postprocess $ unbox $ replaceUses svg
+ 148
+ 149 mkTexScript :: String -> [String] -> [Text] -> Text -> Text
+ 150 mkTexScript latexExec latexArgs texHeaders tex =
+ 151 T.unlines
+ 152 $ [ "% " <> T.pack (unwords (latexExec : latexArgs))
+ 153 , "\\documentclass[preview]{standalone}"
+ 154 , "\\usepackage{amsmath}"
+ 155 , "\\usepackage{gensymb}"
+ 156 ]
+ 157 ++ texHeaders
+ 158 ++ [ "\\usepackage[english]{babel}"
+ 159 , "\\linespread{1}"
+ 160 , "\\begin{document}"
+ 161 , tex
+ 162 , "\\end{document}"
+ 163 ]
+ 164
+ 165 {- Packages used by manim.
+ 166
+ 167 \\\usepackage{amsmath}\n\
+ 168 \\\usepackage{amssymb}\n\
+ 169 \\\usepackage{dsfont}\n\
+ 170 \\\usepackage{setspace}\n\
+ 171 \\\usepackage{relsize}\n\
+ 172 \\\usepackage{textcomp}\n\
+ 173 \\\usepackage{mathrsfs}\n\
+ 174 \\\usepackage{calligra}\n\
+ 175 \\\usepackage{wasysym}\n\
+ 176 \\\usepackage{ragged2e}\n\
+ 177 \\\usepackage{physics}\n\
+ 178 \\\usepackage{xcolor}\n\
+ 179 \\\usepackage{textcomp}\n\
+ 180 \\\usepackage{xfrac}\n\
+ 181 \\\usepackage{microtype}\n\
+ 182 -}
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Math.Common.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Math.Common.hs.html
new file mode 100644
index 0000000..790c90b
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Math.Common.hs.html
@@ -0,0 +1,243 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE FlexibleInstances #-}
+ 2 {-# OPTIONS_GHC -Wno-orphans #-}
+ 3 {-|
+ 4 Module : Reanimate.Math.Common
+ 5 Copyright : Written by David Himmelstrup
+ 6 License : Unlicense
+ 7 Maintainer : lemmih@gmail.com
+ 8 Stability : experimental
+ 9 Portability : POSIX
+ 10
+ 11 Low-level primitives related to computational geometry.
+ 12
+ 13 -}
+ 14 module Reanimate.Math.Common
+ 15 ( -- * Ring
+ 16 Ring(..)
+ 17 , ringSize -- :: Ring a -> Int
+ 18 , ringAccess -- :: Ring a -> Int -> V2 a
+ 19 , ringClamp -- :: Ring a -> Int -> Int
+ 20 , ringUnpack -- :: Ring a -> Vector (V2 a)
+ 21 , ringPack -- :: Vector (V2 a) -> Ring a
+ 22 , ringMap -- :: (V2 a -> V2 b) -> Ring a -> Ring b
+ 23 , ringRayIntersect -- :: Ring Rational -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational)
+ 24 -- * Math
+ 25 , area -- :: Fractional a => V2 a -> V2 a -> V2 a -> a
+ 26 , area2X -- :: Fractional a => V2 a -> V2 a -> V2 a -> a
+ 27 , isLeftTurn -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool
+ 28 , isLeftTurnOrLinear -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool
+ 29 , isRightTurn -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool
+ 30 , isRightTurnOrLinear -- :: (Num a, Ord a) => V2 a -> V2 a -> V2 a -> Bool
+ 31 , direction -- :: Num a => V2 a -> V2 a -> V2 a -> a
+ 32 , isInside -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool
+ 33 , isInsideStrict -- :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool
+ 34 , barycentricCoords -- :: Fractional a => V2 a -> V2 a -> V2 a -> V2 a -> (a, a, a)
+ 35 , rayIntersect -- :: (Fractional a, Ord a) => (V2 a,V2 a) -> (V2 a,V2 a) -> Maybe (V2 a)
+ 36 , isBetween -- :: (Ord a, Fractional a) => V2 a -> (V2 a, V2 a) -> Bool
+ 37 , lineIntersect -- :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
+ 38 , distSquared -- :: (Fractional a) => V2 a -> V2 a -> a
+ 39 , approxDist -- :: (Real a, Fractional a) => V2 a -> V2 a -> a
+ 40 , distance' -- :: (Real a, Fractional a) => V2 a -> V2 a -> Double
+ 41 , triangleAngles -- :: V2 Double -> V2 Double -> V2 Double -> (Double, Double, Double)
+ 42 , Epsilon(..)
+ 43 ) where
+ 44
+ 45 import Data.Vector (Vector)
+ 46 import qualified Data.Vector as V
+ 47 import Linear.Matrix (det33)
+ 48 import Linear.Metric
+ 49 import Linear.V2
+ 50 import Linear.V3
+ 51 import Linear.Vector
+ 52 import Linear.Epsilon
+ 53
+ 54 instance Epsilon Rational where
+ 55 nearZero r = r==0
+ 56
+ 57 -- | Circular collection of pairs.
+ 58 newtype Ring a = Ring (Vector (V2 a))
+ 59
+ 60 -- | Number of elements in the ring.
+ 61 ringSize :: Ring a -> Int
+ 62 ringSize (Ring v) = length v
+ 63
+ 64 -- | Safe method for accessing elements in the ring.
+ 65 ringAccess :: Ring a -> Int -> V2 a
+ 66 ringAccess (Ring v) i = v V.! mod i (length v)
+ 67
+ 68 -- | Clamp index to within the usable range for the ring.
+ 69 ringClamp :: Ring a -> Int -> Int
+ 70 ringClamp (Ring v) i = mod i (length v)
+ 71
+ 72 -- | Convert ring to a vector.
+ 73 ringUnpack :: Ring a -> Vector (V2 a)
+ 74 ringUnpack (Ring v) = v
+ 75
+ 76 -- | Convert vector to a ring.
+ 77 ringPack :: Vector (V2 a) -> Ring a
+ 78 ringPack = Ring
+ 79
+ 80 -- | Map each element of a ring.
+ 81 ringMap :: (V2 a -> V2 b) -> Ring a -> Ring b
+ 82 ringMap fn (Ring v) = Ring (V.map fn v)
+ 83
+ 84 -- | Compute the intersection of two pairs of nodes in the ring.
+ 85 ringRayIntersect :: Ring Rational -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational)
+ 86 ringRayIntersect p (a,b) (c,d) =
+ 87 rayIntersect (ringAccess p a, ringAccess p b) (ringAccess p c, ringAccess p d)
+ 88
+ 89 -- | Compute area of triangle.
+ 90 area :: Fractional a => V2 a -> V2 a -> V2 a -> a
+ 91 area a b c = 1/2 * area2X a b c
+ 92
+ 93 -- | Compute 2x area of triangle. This avoids a division.
+ 94 area2X :: Fractional a => V2 a -> V2 a -> V2 a -> a
+ 95 area2X (V2 a1 a2) (V2 b1 b2) (V2 c1 c2) =
+ 96 det33 (V3 (V3 a1 a2 1)
+ 97 (V3 b1 b2 1)
+ 98 (V3 c1 c2 1))
+ 99
+ 100 compareEpsZero :: (Ord a, Fractional a, Epsilon a) => a -> Ordering
+ 101 compareEpsZero val
+ 102 | nearZero val = EQ
+ 103 | otherwise = compare val 0
+ 104
+ 105 {-# INLINE isLeftTurn #-}
+ 106 -- | Return @True@ iff the line from @p1@ to @p2@ makes a left-turn to @p3@.
+ 107 isLeftTurn :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool
+ 108 isLeftTurn p1 p2 p3 =
+ 109 case compareEpsZero (direction p1 p2 p3) of
+ 110 LT -> True
+ 111 EQ -> False -- colinear
+ 112 GT -> False
+ 113
+ 114 {-# INLINE isLeftTurnOrLinear #-}
+ 115 -- | Return @True@ iff the line from @p1@ to @p2@ does not make a right-turn to @p3@.
+ 116 isLeftTurnOrLinear :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool
+ 117 isLeftTurnOrLinear p1 p2 p3 =
+ 118 case compareEpsZero (direction p1 p2 p3) of
+ 119 LT -> True
+ 120 EQ -> True -- colinear
+ 121 GT -> False
+ 122
+ 123 {-# INLINE isRightTurn #-}
+ 124 -- | Return @True@ iff the line from @p1@ to @p2@ makes a right-turn to @p3@.
+ 125 isRightTurn :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool
+ 126 isRightTurn a b c = not (isLeftTurnOrLinear a b c)
+ 127
+ 128 {-# INLINE isRightTurnOrLinear #-}
+ 129 -- | Return @True@ iff the line from @p1@ to @p2@ does not make a left-turn to @p3@.
+ 130 isRightTurnOrLinear :: (Fractional a, Ord a, Epsilon a) => V2 a -> V2 a -> V2 a -> Bool
+ 131 isRightTurnOrLinear a b c = not (isLeftTurn a b c)
+ 132
+ 133 {-# INLINE direction #-}
+ 134 -- | Compute the change in direction in a line between the three points.
+ 135 direction :: Num a => V2 a -> V2 a -> V2 a -> a
+ 136 direction p1 p2 p3 = crossZ (p3-p1) (p2-p1)
+ 137
+ 138 {-# INLINE isInside #-}
+ 139 -- | Returns @True@ if the fourth argument is inside the triangle or
+ 140 -- on the border.
+ 141 isInside :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool
+ 142 isInside a b c d =
+ 143 s >= 0 && s <= 1 && t >= 0 && t <= 1 && i >= 0 && i <= 1
+ 144 where
+ 145 (s, t, i) = barycentricCoords a b c d
+ 146
+ 147 {-# INLINE isInsideStrict #-}
+ 148 -- | Returns @True@ iff the fourth argument is inside the triangle.
+ 149 isInsideStrict :: (Fractional a, Ord a) => V2 a -> V2 a -> V2 a -> V2 a -> Bool
+ 150 isInsideStrict a b c d =
+ 151 s > 0 && s < 1 && t > 0 && t < 1 && i > 0 && i < 1
+ 152 where
+ 153 (s, t, i) = barycentricCoords a b c d
+ 154
+ 155 {-# INLINE barycentricCoords #-}
+ 156 -- | Compute relative coordinates inside the triangle. Invariant: @a+b+c=1@
+ 157 barycentricCoords :: Fractional a => V2 a -> V2 a -> V2 a -> V2 a -> (a, a, a)
+ 158 barycentricCoords (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x y) =
+ 159 (lam1, lam2, lam3)
+ 160 where
+ 161 lam1 = ((y2-y3)*(x-x3) + (x3 - x2)*(y-y3)) /
+ 162 ((y2-y3)*(x1-x3) + (x3-x2)*(y1-y3))
+ 163 lam2 = ((y3-y1)*(x-x3) + (x1-x3)*(y-y3)) /
+ 164 ((y2-y3)*(x1-x3) + (x3-x2)*(y1-y3))
+ 165 lam3 = 1 - lam1 - lam2
+ 166
+ 167
+ 168 {-# INLINE rayIntersect #-}
+ 169 -- | Compute intersection of two infinite lines.
+ 170 rayIntersect :: (Fractional a, Ord a) => (V2 a,V2 a) -> (V2 a,V2 a) -> Maybe (V2 a)
+ 171 rayIntersect (V2 x1 y1,V2 x2 y2) (V2 x3 y3, V2 x4 y4)
+ 172 | yBot == 0 = Nothing
+ 173 | otherwise = Just $
+ 174 V2 (xTop/xBot) (yTop/yBot)
+ 175 where
+ 176 xTop = (x1*y2 - y1*x2)*(x3-x4) - (x1 - x2)*(x3*y4-y3*x4)
+ 177 xBot = (x1-x2)*(y3-y4)-(y1-y2)*(x3-x4)
+ 178 yTop = (x1*y2 - y1*x2)*(y3-y4) - (y1-y2)*(x3*y4-y3*x4)
+ 179 yBot = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
+ 180
+ 181 {-# INLINE isBetween #-}
+ 182 -- | Returns @True@ iff a point is on a line segment.
+ 183 isBetween :: (Ord a, Fractional a) => V2 a -> (V2 a, V2 a) -> Bool
+ 184 isBetween (V2 x y) (V2 x1 y1, V2 x2 y2) =
+ 185 ((y1 > y) /= (y2 > y) || y == y1 || y == y2) && -- y is between y1 and y2
+ 186 ((x1 > x) /= (x2 > x) || x == x1 || x == x2)
+ 187
+ 188 {-# INLINE lineIntersect #-}
+ 189 -- | Compute intersection of two line segments.
+ 190 lineIntersect :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
+ 191 lineIntersect a b =
+ 192 case rayIntersect a b of
+ 193 Just u
+ 194 | isBetween u a && isBetween u b -> Just u
+ 195 _ -> Nothing
+ 196
+ 197 -- circleIntersect :: (Ord a, Fractional a) => (V2 a, V2 a) -> (V2 a, V2 a) -> [V2 a]
+ 198
+ 199 -- | Compute the square of the distance between two points.
+ 200 distSquared :: (Num a) => V2 a -> V2 a -> a
+ 201 distSquared a b = quadrance (a ^-^ b)
+ 202
+ 203 -- | Approximate the distance between two points.
+ 204 approxDist :: (Real a, Fractional a) => V2 a -> V2 a -> a
+ 205 approxDist a b = realToFrac (sqrt (realToFrac (distSquared a b) :: Double))
+ 206
+ 207 -- | Approximate the distance between two points.
+ 208 distance' :: (Real a, Fractional a) => V2 a -> V2 a -> Double
+ 209 distance' a b = sqrt (realToFrac (distSquared a b))
+ 210
+ 211 -- sum of angles is always pi.
+ 212 -- | Approximate the angles of a triangle.
+ 213 triangleAngles :: V2 Double -> V2 Double -> V2 Double -> (Double, Double, Double)
+ 214 triangleAngles a b c =
+ 215 (findAngle (b-a) (c-a)
+ 216 ,findAngle (c-b) (a-b)
+ 217 ,findAngle (a-c) (b-c))
+ 218 where
+ 219 findAngle v1 v2 = abs (atan2 (crossZ v1 v2) (dot v1 v2))
+ 220 -- findAngle v1 v2 = acos (dot v1 v2 / (norm v1 * norm v2))
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Math.Polygon.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Math.Polygon.hs.html
new file mode 100644
index 0000000..2466385
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Math.Polygon.hs.html
@@ -0,0 +1,803 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE BangPatterns #-}
+ 2 {-# LANGUAGE ConstraintKinds #-}
+ 3 {-# OPTIONS_HADDOCK hide #-}
+ 4 module Reanimate.Math.Polygon
+ 5 ( APolygon(..)
+ 6 , Polygon
+ 7 , FPolygon
+ 8 , P
+ 9 , mkPolygon -- :: (Fractional a, Ord a) => V.Vector (V2 a) -> APolygon a
+ 10 , mkPolygonFromRing -- :: (Fractional a, Ord a) => Ring a -> APolygon a
+ 11 , castPolygon -- :: (Real a, Fractional b, Ord a) => APolygon a -> APolygon b
+ 12 , pParent -- :: Polygon -> Int -> Int -> Int
+ 13 , pSetOffset -- :: APolygon a -> Int -> APolygon a
+ 14 , pAdjustOffset -- :: APolygon a -> Int -> APolygon a
+ 15 , pSize -- :: APolygon a -> Int
+ 16 , pNull -- :: APolygon a -> Bool
+ 17 , pNext -- :: APolygon a -> Int -> Int
+ 18 , pPrev -- :: APolygon a -> Int -> Int
+ 19 , pIsSimple -- :: Polygon -> Bool
+ 20 , pIsConvex -- :: Polygon -> Bool
+ 21 , pIsCCW -- :: Polygon -> Bool
+ 22 , pScale -- :: Rational -> Polygon -> Polygon
+ 23 , pAtCentroid -- :: Polygon -> Polygon
+ 24 , pAtCenter -- :: Polygon -> Polygon
+ 25 , pTranslate -- :: V2 Rational -> Polygon -> Polygon
+ 26 , pCenter -- :: Polygon -> V2 Rational
+ 27 , pBoundingBox -- :: Polygon -> (Rational, Rational, Rational, Rational)
+ 28 , pIsInside -- :: Polygon -> V2 Rational -> Bool
+ 29 , pAccess -- :: APolygon a -> Int -> V2 a
+ 30 , pMkWinding -- :: Int -> Polygon
+ 31 , pDeoverlap -- :: Polygon -> Polygon
+ 32 , pCycles -- :: Polygon -> [Polygon]
+ 33 , pCycle -- :: (Real a, Fractional a, Ord a) => APolygon a -> Double -> APolygon a
+ 34 , pCentroid -- :: Polygon -> V2 Rational
+ 35 , pMapEdges -- :: (V2 Rational -> V2 Rational -> a) -> Polygon -> V.Vector a
+ 36 , pArea -- :: Polygon -> Rational
+ 37 , pCircumference -- :: (Real a, Fractional a) => APolygon a -> a
+ 38 , pCircumference' -- :: (Real a, Fractional a) => APolygon a -> Double
+ 39 , pAddPoints -- :: Int -> Polygon -> Polygon
+ 40 , pAddPointsRestricted -- :: [Int] -> Int -> Polygon -> Polygon
+ 41 , pAddPointsBetween -- :: (Fractional a, Ord a, Real a) => (Int, Int) -> Int -> APolygon a -> APolygon a
+ 42 , pRayIntersect -- :: Polygon -> (Int, Int) -> (Int,Int) -> Maybe (V2 Rational)
+ 43 , pOverlap -- :: Polygon -> Polygon -> Polygon
+ 44 , pCuts -- :: Polygon -> [(Polygon,Polygon)]
+ 45 , pCutEqual -- :: Polygon -> (Polygon, Polygon)
+ 46 -- * Triangulation
+ 47 , isValidTriangulation -- :: Polygon -> Triangulation -> Bool
+ 48 , triangulationsToPolygons -- :: Polygon -> Triangulation -> [Polygon]
+ 49 -- * Single-Source-Shortest-Path
+ 50 , ssspVisibility -- :: Polygon -> Polygon
+ 51 , ssspWindows -- :: Polygon -> [(V2 Rational, V2 Rational)]
+ 52 -- * Built-in shapes for testing
+ 53 , triangle -- :: Polygon
+ 54 , triangle' -- :: [P]
+ 55 , shape1 -- :: Polygon
+ 56 , shape2 -- :: Polygon
+ 57 , shape3 -- :: Polygon
+ 58 , shape4 -- :: Polygon
+ 59 , shape5 -- :: Polygon
+ 60 , shape6 -- :: Polygon
+ 61 , shape7 -- :: Polygon
+ 62 , shape8 -- :: Polygon
+ 63 , shape9 -- :: Polygon
+ 64 , shape10 -- :: Polygon
+ 65 , shape11 -- :: Polygon
+ 66 , shape12 -- :: Polygon
+ 67 , shape13 -- :: Polygon
+ 68 , shape14 -- :: Polygon
+ 69 , shape15 -- :: Polygon
+ 70 , shape16 -- :: Polygon
+ 71 , shape17 -- :: Polygon
+ 72 , shape18 -- :: Polygon
+ 73 , shape19 -- :: Polygon
+ 74 , shape20 -- :: Polygon
+ 75 , shape21 -- :: Polygon
+ 76 , shape22 -- :: Polygon
+ 77 , shape23 -- :: Polygon
+ 78 , concave -- :: Polygon
+ 79 -- * Internals
+ 80 , pRing -- :: APolygon a -> Ring a
+ 81 , pUnsafeMap -- :: (Ring a -> Ring a) -> APolygon a -> APolygon a
+ 82 , pCopy -- :: Polygon -> Polygon
+ 83 , pGenerate -- :: [(Double, Double)] -> Polygon
+ 84 , pUnGenerate -- :: Polygon -> [(Double, Double)]
+ 85 , Epsilon
+ 86 ) where
+ 87
+ 88 -- import Control.Exception
+ 89 import Data.Hashable
+ 90 import Data.List (intersect, maximumBy, sort, sortOn,
+ 91 tails)
+ 92 import Data.Maybe
+ 93 import Data.Ratio
+ 94 import Data.Serialize
+ 95 import Data.Vector (Vector)
+ 96 import qualified Data.Vector as V
+ 97 import Linear.V2
+ 98 import Linear.Vector
+ 99 import Reanimate.Math.Common
+ 100 -- import Reanimate.Math.EarClip
+ 101 import Reanimate.Math.SSSP
+ 102 import Reanimate.Math.Triangulate
+ 103
+ 104 -- import Debug.Trace
+ 105
+ 106 -- Generate random polygons, options:
+ 107 -- 1. put corners around a circle. Vary the radius.
+ 108 -- 2. close a hilbert curve
+ 109 type FPolygon = APolygon Double
+ 110 -- Optimize representation?
+ 111 -- Polygon = (Vector XNumerator, Vector XDenominator
+ 112 -- ,Vector YNumerator, Vector YDenominator)
+ 113 data APolygon a = Polygon
+ 114 { polygonPoints :: Vector (V2 a)
+ 115 , polygonOffset :: Int
+ 116 , polygonTriangulation :: Triangulation
+ 117 , polygonSSSP :: Vector SSSP
+ 118 }
+ 119 type Polygon = APolygon Rational
+ 120 type P = V2 Double
+ 121
+ 122 instance Show a => Show (APolygon a) where
+ 123 show = show . V.toList . polygonPoints
+ 124
+ 125 instance Hashable a => Hashable (APolygon a) where
+ 126 hashWithSalt s p = V.foldl' hashWithSalt s (polygonPoints p)
+ 127
+ 128 instance (PolyCtx a, Serialize a) => Serialize (APolygon a) where
+ 129 put = put . V.toList . polygonPoints
+ 130 get = mkPolygon . V.fromList <$> get
+ 131
+ 132 pRing :: APolygon a -> Ring a
+ 133 pRing = ringPack . polygonPoints
+ 134
+ 135 type PolyCtx a = (Real a, Fractional a, Epsilon a)
+ 136
+ 137 mkPolygon :: PolyCtx a => V.Vector (V2 a) -> APolygon a
+ 138 mkPolygon points = Polygon
+ 139 { polygonPoints = points
+ 140 , polygonOffset = 0
+ 141 , polygonTriangulation = trig
+ 142 , polygonSSSP = V.generate n $ \i -> sssp ring (dual i trig)
+ 143 }
+ 144 where
+ 145 n = length points
+ 146 ring = ringPack points
+ 147 trig = triangulate ring
+ 148 -- earClip ring
+ 149
+ 150 castPolygon :: (PolyCtx a, PolyCtx b) => APolygon a -> APolygon b
+ 151 castPolygon = mkPolygon . V.map (fmap realToFrac) . polygonPoints
+ 152
+ 153 mkPolygonFromRing :: PolyCtx a => Ring a -> APolygon a
+ 154 mkPolygonFromRing = mkPolygon . ringUnpack
+ 155
+ 156 pUnsafeMap :: (Ring a -> Ring a) -> APolygon a -> APolygon a
+ 157 pUnsafeMap fn p = p{ polygonPoints = ringUnpack (fn (pRing p)) }
+ 158
+ 159 -- pParent p i j = shortest-path parent from j to i
+ 160 pParent :: APolygon a -> Int -> Int -> Int
+ 161 pParent p i j =
+ 162 (sTree V.! mod (j + polygonOffset p) n - polygonOffset p) `mod` n
+ 163 where
+ 164 sTree = polygonSSSP p V.! mod (i + polygonOffset p) n
+ 165 n = pSize p
+ 166
+ 167 pCopy :: Polygon -> Polygon
+ 168 pCopy p = mkPolygon $ V.generate (pSize p) $ pAccess p
+ 169
+ 170 pSetOffset :: APolygon a -> Int -> APolygon a
+ 171 pSetOffset p offset =
+ 172 p { polygonOffset = offset `mod` pSize p }
+ 173
+ 174 pAdjustOffset :: APolygon a -> Int -> APolygon a
+ 175 pAdjustOffset p offset =
+ 176 p { polygonOffset = (polygonOffset p + offset) `mod` pSize p }
+ 177
+ 178 {-# INLINE pSize #-}
+ 179 pSize :: APolygon a -> Int
+ 180 pSize = length . polygonPoints
+ 181
+ 182 pNull :: APolygon a -> Bool
+ 183 pNull = V.null . polygonPoints
+ 184
+ 185 pNext :: APolygon a -> Int -> Int
+ 186 pNext p i = (i+1) `mod` pSize p
+ 187
+ 188 pPrev :: APolygon a -> Int -> Int
+ 189 pPrev p i = (i-1) `mod` pSize p
+ 190
+ 191 -- When is a polygon valid/simple?
+ 192 -- It is counter-clockwise.
+ 193 -- No edges intersect.
+ 194 -- O(n^2)
+ 195 -- 'checkEdge' takes 90% of the time.
+ 196 pIsSimple :: Polygon -> Bool
+ 197 pIsSimple p | pSize p < 3 = False
+ 198 pIsSimple p = pIsCCW p && noDups && checkEdge 0 2
+ 199 where
+ 200 noDups = checkForDups (sort (V.toList (polygonPoints p)))
+ 201 checkForDups (x:y:xs)
+ 202 = x /= y && checkForDups (y:xs)
+ 203 checkForDups _ = True
+ 204 len = pSize p
+ 205 -- check i,i+1 against j,j+1
+ 206 -- j > i+1
+ 207 checkEdge i j
+ 208 | j >= len = (i > len-3) || checkEdge (i+1) (i+3)
+ 209 | otherwise =
+ 210 case lineIntersect (pAccess p i, pAccess p $ i+1)
+ 211 (pAccess p j, pAccess p $ j+1) of
+ 212 Just u | u /= pAccess p i -> False
+ 213 _nothing -> checkEdge i (j+1)
+ 214
+ 215 pScale :: Rational -> Polygon -> Polygon
+ 216 pScale s = pUnsafeMap (ringMap (^* s))
+ 217
+ 218 pAtCentroid :: Polygon -> Polygon
+ 219 pAtCentroid p = pTranslate (negate c) p
+ 220 where c = pCentroid p ^/ 2
+ 221
+ 222 pAtCenter :: Polygon -> Polygon
+ 223 pAtCenter p = pTranslate (negate $ pCenter p) p
+ 224
+ 225 pTranslate :: V2 Rational -> Polygon -> Polygon
+ 226 pTranslate v = pUnsafeMap (ringMap (+v))
+ 227
+ 228 pCenter :: Polygon -> V2 Rational
+ 229 pCenter p = V2 (x+w/2) (y+h/2)
+ 230 where
+ 231 (x,y,w,h) = pBoundingBox p
+ 232
+ 233 -- Returns (min-x, min-y, width, height)
+ 234 pBoundingBox :: Polygon -> (Rational, Rational, Rational, Rational)
+ 235 pBoundingBox = \p ->
+ 236 let V2 x y = pAccess p 0 in
+ 237 case V.foldl' worker (x, y, 0, 0) (polygonPoints p) of
+ 238 (xMin, yMin, xMax, yMax) ->
+ 239 (xMin, yMin, xMax-xMin, yMax-yMin)
+ 240 where
+ 241 worker (xMin,yMin,xMax,yMax) (V2 thisX thisY) =
+ 242 (min xMin thisX, min yMin thisY
+ 243 ,max xMax thisX, max yMax thisY)
+ 244
+ 245 -- Place n points on a circle, use one parameter to slide the points back and forth.
+ 246 -- Use second parameter to move points closer to center circle.
+ 247 pGenerate :: [(Double, Double)] -> Polygon
+ 248 pGenerate points
+ 249 | len < 4 = error "pGenerate: require at least four points"
+ 250 | otherwise = mkPolygon $ V.fromList
+ 251 [ V2 (realToFrac $ cos ang * rMod)
+ 252 (realToFrac $ sin ang * rMod)
+ 253 | (i,(angMod,rMod)) <- zip [0..] points
+ 254 , let minAngle = tau / len * i - pi
+ 255 maxAngle = tau / len * (i+1) - pi
+ 256 ang = minAngle + (maxAngle-minAngle)*angMod
+ 257 ]
+ 258 where
+ 259 tau = 2*pi
+ 260 len = fromIntegral (length points)
+ 261
+ 262 pUnGenerate :: Polygon -> [(Double, Double)]
+ 263 pUnGenerate p =
+ 264 [ worker i (fmap realToFrac e)
+ 265 | (i,e) <- zip [0..] (V.toList $ polygonPoints p) ]
+ 266 where
+ 267 len = fromIntegral (pSize p)
+ 268 worker i (V2 x y) =
+ 269 let ang = atan2 y x
+ 270 minAngle = tau / len * i - pi
+ 271 maxAngle = tau / len * (i+1) - pi
+ 272 in ((ang-minAngle)/(maxAngle-minAngle), sqrt (x*x+y*y))
+ 273 tau = 2*pi
+ 274
+ 275 -- When is a triangulation valid?
+ 276 -- Intersection: No internal edges intersect.
+ 277 -- Completeness: All edge neighbours share a single internal edge.
+ 278 isValidTriangulation :: Polygon -> Triangulation -> Bool
+ 279 isValidTriangulation p t = isComplete && intersectionFree
+ 280 where
+ 281 o = polygonOffset p
+ 282 isComplete = all isProper [0 .. pSize p-1]
+ 283 isProper i =
+ 284 let j = pNext p i in
+ 285 length ((pPrev p i : (t V.! i)) `intersect` (pNext p j : t V.! j)) == 1
+ 286 intersectionFree = and
+ 287 [ case lineIntersect (pAccess p (a-o), pAccess p (b-o)) (pAccess p (c-o), pAccess p (d-o)) of
+ 288 Nothing -> True
+ 289 Just u -> u == pAccess p (a-o) || u == pAccess p (b-o) ||
+ 290 u == pAccess p (c-o) || u == pAccess p (d-o)
+ 291 | ((a,b),(c,d)) <- edgePairs ]
+ 292 edgePairs = [ (e1, e2) | (e1, rest) <- zip edges (drop 1 $ tails edges), e2 <- rest]
+ 293 edges =
+ 294 [ (n, i)
+ 295 | (n, lst) <- zip [0..] (V.toList t)
+ 296 , i <- lst
+ 297 , n < i
+ 298 ]
+ 299
+ 300 triangulationsToPolygons :: Polygon -> Triangulation -> [Polygon]
+ 301 triangulationsToPolygons p t =
+ 302 [ mkPolygon $ V.fromList
+ 303 [ pAccess p g, pAccess p i, pAccess p j ]
+ 304 | i <- [0 .. pSize p-1]
+ 305 , let js = filter (i<) $ t V.! i
+ 306 , (g, j) <- zip (i-1:js) js
+ 307 ]
+ 308
+ 309 pIsInside :: Polygon -> V2 Rational -> Bool
+ 310 pIsInside p point = or
+ 311 [ isInside (rawAccess g) (rawAccess i) (rawAccess j) point
+ 312 | i <- [0 .. pSize p-1]
+ 313 , let js = filter (i<) $ polygonTriangulation p V.! i
+ 314 , (g, j) <- zip (i-1:js) js
+ 315 ]
+ 316 where
+ 317 rawAccess x = polygonPoints p V.! x
+ 318
+ 319 -- reducePolygons :: Int -> [Polygon] -> [Polygon]
+ 320 -- reducePolygons n ps
+ 321 -- | length ps <= n = ps
+ 322 -- | otherwise =
+ 323 -- let p = findSmallest ps
+ 324 -- es = edges p
+ 325 -- e = findSmallest es
+ 326 -- in reducePolygons n (merge p e : delete p (delete e ps))
+ 327 -- where
+ 328 -- findSmallest = minimumBy (comparing area2X)
+ 329 -- shareEdge p1 p2 =
+ 330
+ 331 {-# INLINE pAccess #-}
+ 332 pAccess :: APolygon a -> Int -> V2 a
+ 333 pAccess p i = -- polygonPoints p V.! ((polygonOffset p + i) `mod` pSize p)
+ 334 polygonPoints p `V.unsafeIndex` ((polygonOffset p + i) `mod` pSize p)
+ 335
+ 336 triangle :: Polygon
+ 337 triangle = mkPolygon $ V.fromList [V2 1 1, V2 0 0, V2 2 0]
+ 338
+ 339 triangle' :: [P]
+ 340 triangle' = reverse [V2 1 1, V2 0 0, V2 2 0]
+ 341
+ 342 shape1 :: Polygon
+ 343 shape1 = mkPolygon $ V.fromList
+ 344 [ V2 0 0, V2 2 0
+ 345 , V2 2 1, V2 2 2, V2 2 3, V2 2 4, V2 2 5, V2 2 6
+ 346 , V2 1 1, V2 0 1 ]
+ 347
+ 348 shape2 :: Polygon
+ 349 shape2 = mkPolygon $ V.fromList
+ 350 [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 (-1), V2 0 (-1), V2 0 (-2)
+ 351 , V2 3 (-2), V2 3 2, V2 0 2]
+ 352
+ 353 shape3 :: Polygon
+ 354 shape3 = mkPolygon $ V.fromList
+ 355 [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 2, V2 0 2]
+ 356
+ 357 shape4 :: Polygon
+ 358 shape4 = mkPolygon $ V.fromList
+ 359 [ V2 0 0, V2 1 0, V2 1 1, V2 2 1, V2 2 (-1), V2 3 (-1),V2 3 2, V2 0 2]
+ 360
+ 361 shape5 :: Polygon
+ 362 shape5 = pCycles shape4 !! 2
+ 363
+ 364 -- square
+ 365 shape6 :: Polygon
+ 366 shape6 = mkPolygon $ V.fromList [ V2 0 0, V2 1 0, V2 1 1, V2 0 1 ]
+ 367
+ 368 shape7 :: Polygon
+ 369 shape7 = pScale 6 $ mkPolygon $ V.fromList
+ 370 [V2 ((-1567171105775771) % 144115188075855872) ((-7758063241391039) % 1152921504606846976)
+ 371 ,V2 ((-2711114907999263) % 18014398509481984) ((-3561889280168807) % 18014398509481984)
+ 372 ,V2 ((-6897139157863177) % 72057594037927936) ((-1632144794297397) % 4503599627370496)
+ 373 ,V2 (5592137945106423 % 36028797018963968) ((-71351641856107) % 281474976710656)
+ 374 ,V2 (2568147525079071 % 4503599627370496) ((-4312925637247687) % 18014398509481984)
+ 375 ,V2 (1291079014395023 % 2251799813685248) (321513444515769 % 2251799813685248)
+ 376 ,V2 (2071709221627247 % 4503599627370496) (4019115966736491 % 9007199254740992)
+ 377 ,V2 ((-1589087869859839) % 144115188075855872) (4904023654354179 % 9007199254740992)
+ 378 ,V2 ((-2328090886101149) % 36028797018963968) (2587887893460759 % 36028797018963968)
+ 379 ,V2 ((-7990199074159871) % 18014398509481984) (1301850651537745 % 4503599627370496)]
+ 380
+ 381 shape8 :: Polygon
+ 382 shape8 = pScale 10 $ pGenerate
+ 383 [(0.36,0.4),(0.7,1.8e-2),(0.7,0.2),(0.1,0.4),(0.2,0.2),(0.7,0.1),(0.4,8.0e-2)]
+ 384
+ 385 shape9 :: Polygon
+ 386 shape9 = pScale 5 $ pGenerate
+ 387 [(0.5,0.2),(0.7,0.6),(0.4,0.3),(0.1,0.7),(0.3,1.0e-2),(0.5,0.3),(0.2,0.8),(0.1,0.8),(0.7,6.0e-2),(0.1,0.6)]
+ 388
+ 389 shape10 :: Polygon
+ 390 shape10 = pGenerate
+ 391 [(0.4,0.7),(0.2,0.2),(0.3,0.9),(5.0e-2,0.1),(0.7,1.0e-2),(0.7,0.9),(0.2,0.1),(0.5,6.0e-2),(0.6,9.0e-2)]
+ 392
+ 393 shape11 :: Polygon
+ 394 shape11 = pGenerate
+ 395 [(0.1,0.8),(0.7,0.6),(0.7,0.4),(0.3,0.5),(0.8,0.9),(0.8,6.0e-2),(1.0e-2,4.0e-2),(0.8,0.1)]
+ 396
+ 397 shape12 :: Polygon
+ 398 shape12 = mkPolygon $ V.fromList
+ 399 [ V2 0 0, V2 0.5 1.5, V2 2 2, V2 (-2) 2, V2 (-0.5) 1.5 ]
+ 400
+ 401 -- F shape
+ 402 shape13 :: Polygon
+ 403 shape13 = pCycles (mkPolygon $ V.reverse (V.fromList
+ 404 [ V2 0 0, V2 0 2
+ 405 , V2 1 2, V2 1 1.7, V2 0.3 1.7, V2 0.3 1
+ 406 , V2 1 1, V2 1 0.7
+ 407 , V2 0.3 0.7, V2 0.3 0 ])) !! 7
+ 408
+ 409 -- E shape
+ 410 shape14 :: Polygon
+ 411 shape14 = pCycles (mkPolygon $ V.reverse $ V.fromList
+ 412 [ V2 0 0, V2 0 2 -- up
+ 413 , V2 1 2, V2 1 1.7, V2 0.3 1.7, V2 0.3 1 -- first prong
+ 414 , V2 1 1, V2 1 0.7, V2 0.3 0.7, V2 0.3 0.3 -- second prong
+ 415 , V2 1 0.3, V2 1 0 -- last prong
+ 416 ]) !! 9
+ 417
+ 418 --
+ 419 shape15 :: Polygon
+ 420 shape15 = mkPolygon $ V.fromList
+ 421 [ V2 0 0, V2 2 0
+ 422 , V2 2 2, V2 1 2
+ 423 , V2 1 1, V2 0 1]
+ 424
+ 425 shape16 :: Polygon
+ 426 shape16 = mkPolygon $ V.fromList
+ 427 [ V2 0 0, V2 2 0
+ 428 , V2 2 1, V2 1 1
+ 429 , V2 1 2, V2 0 2]
+ 430
+ 431 shape17 :: Polygon
+ 432 shape17 = mkPolygon $ V.fromList
+ 433 [ V2 2 0, V2 2 1
+ 434 , V2 1 1, V2 1 2
+ 435 , V2 0 2, V2 0 1, V2 0 0 ]
+ 436
+ 437 shape18 :: Polygon
+ 438 shape18 = mkPolygon $ V.fromList
+ 439 [ V2 2 0, V2 2 1, V2 2 2
+ 440 , V2 1 2, V2 1 1
+ 441 , V2 0 1, V2 0 0 ]
+ 442
+ 443 shape19 :: Polygon
+ 444 shape19 = mkPolygon $ V.fromList
+ 445 [ V2 (-3) (-3), V2 0 (-1)
+ 446 , V2 3 (-3), V2 1 0
+ 447 , V2 3 3, V2 0 1
+ 448 , V2 (-3) 3, V2 (-1) 0 ]
+ 449
+ 450 shape20 :: Polygon
+ 451 shape20 = mkPolygon $ V.fromList
+ 452 [ V2 (-3) (-3)
+ 453 , V2 0 (-1)
+ 454 , V2 3 (-3)
+ 455 , V2 5 0
+ 456 , V2 2.5 (-2)
+ 457 , V2 1 0
+ 458 , V2 3 3
+ 459 , V2 0 1
+ 460 , V2 (-3) 3
+ 461 , V2 (-1) 0 ]
+ 462
+ 463 shape21 :: Polygon
+ 464 shape21 = mkPolygon $ V.fromList
+ 465 [V2 0.0 0.0,V2 1.0 0.0,V2 1.0 1.0,V2 2.0 1.0,V2 2.0 (-1.0),V2 3.0 (-1.0)
+ 466 ,V2 3.0 2.0,V2 0.0 2.0]
+ 467
+ 468 shape22 :: Polygon
+ 469 shape22 = pScale 2 $ mkPolygon $ V.fromList
+ 470 [V2 (-0.17) (-0.08)
+ 471 ,V2 (-0.34) (-0.21)
+ 472 ,V2 0.0 0.0
+ 473 ,V2 (-0.10) 0.60
+ 474 ,V2 (-0.14) 0.19
+ 475 ,V2 (-0.05) 0.03
+ 476 ]
+ 477
+ 478 shape23 :: Polygon
+ 479 shape23 = mkPolygon $ V.fromList
+ 480 [ V2 0 0, V2 4 0
+ 481 , V2 4 3, V2 2 3
+ 482 , V2 2 2, V2 3 2
+ 483 , V2 3 1, V2 1 1
+ 484 , V2 1 2, V2 2 2
+ 485 , V2 2 3, V2 0 3 ]
+ 486
+ 487 concave :: Polygon
+ 488 concave = mkPolygon $
+ 489 V.fromList [V2 0 0, V2 2 0, V2 2 2, V2 1 1, V2 0 2]
+ 490
+ 491 pMkWinding :: Int -> Polygon
+ 492 pMkWinding n | n < 1 = error "Polygon must have at least one winding."
+ 493 pMkWinding n = mkPolygon $
+ 494 V.fromList $ p0 : p1 : walkTo p1 1 n (V2 1 0) ++ reverse (walkTo p0 1 (n+2) (V2 (-1) 0))
+ 495 where
+ 496 p0 = V2 0 0
+ 497 p1 = V2 0 1
+ 498 walkTo at a b dir
+ 499 | a == b = []
+ 500 | otherwise =
+ 501 let newAt = at + (dir ^* toRational a)
+ 502 in newAt : walkTo newAt (a+1) b (rot dir)
+ 503 rot (V2 x y) =
+ 504 V2 y (-x)
+ 505
+ 506 pDeoverlap :: Polygon -> Polygon
+ 507 pDeoverlap p = mkPolygon arr
+ 508 where
+ 509 arr = V.generate (pSize p) worker
+ 510 worker 0 = pAccess p 0
+ 511 worker n =
+ 512 if length (V.elemIndices (pAccess p n) (polygonPoints p)) /= 1
+ 513 then
+ 514 let prev = arr V.! (n-1)
+ 515 this = pAccess p n
+ 516 in lerp 0.99999 this prev
+ 517 else pAccess p n
+ 518
+ 519 pCycles :: APolygon a -> [APolygon a]
+ 520 pCycles p = map (pAdjustOffset p) [0 .. pSize p-1]
+ 521
+ 522 pCycle :: PolyCtx a => APolygon a -> Double -> APolygon a
+ 523 pCycle p 0 = p
+ 524 pCycle p t = mkPolygon $ worker 0 0
+ 525 where
+ 526 worker acc i
+ 527 | segment + acc > limit =
+ 528 V.singleton (lerp (realToFrac $ (segment + acc - limit)/segment) x y) <>
+ 529 -- V.drop (i+1) (polygonPoints p) <>
+ 530 V.fromList (map (pAccess p) [i+1..pSize p-1]) <>
+ 531 V.fromList (map (pAccess p) [0 .. i])
+ 532 -- V.take (i+1) (polygonPoints p)
+ 533 | i == pSize p-1 = V.fromList (map (pAccess p) [0 .. pSize p-1])
+ 534 | otherwise = worker (acc+segment) (i+1)
+ 535 where
+ 536 x = pAccess p i
+ 537 y = pAccess p $ i+1
+ 538 segment = distance' x y
+ 539 len = pCircumference' p
+ 540 limit = t * len
+ 541
+ 542 pCentroid :: Fractional a => APolygon a -> V2 a
+ 543 pCentroid p = V2 cx cy
+ 544 where
+ 545 a = pArea p
+ 546 cx = recip (6*a) * V.sum (pMapEdges fnX p)
+ 547 cy = recip (6*a) * V.sum (pMapEdges fnY p)
+ 548 fnX (V2 x y) (V2 x' y') = (x+x')*(x*y' - x'*y)
+ 549 fnY (V2 x y) (V2 x' y') = (y+y')*(x*y' - x'*y)
+ 550
+ 551 {-# INLINE pMapEdges #-}
+ 552 pMapEdges :: (V2 a -> V2 a -> b) -> APolygon a -> V.Vector b
+ 553 pMapEdges fn p = V.generate n $ \i ->
+ 554 if i == n-1
+ 555 then fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0)
+ 556 else fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))
+ 557 where
+ 558 n = pSize p
+ 559 arr = polygonPoints p
+ 560
+ 561 {-# SPECIALIZE pArea :: APolygon Double -> Double #-}
+ 562 {-# SPECIALIZE pArea :: APolygon Rational -> Rational #-}
+ 563 pArea :: (Fractional a) => APolygon a -> a
+ 564 pArea p =
+ 565 -- 0.5 * V.sum (pMapEdges (\(V2 x y) (V2 x' y') -> x*y' - x'*y) p)
+ 566 0.5 * worker 0 0
+ 567 where
+ 568 fn (V2 x y) (V2 x' y') = x*y' - x'*y
+ 569 arr = polygonPoints p
+ 570 worker !acc i
+ 571 | i == pSize p - 1 = acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` 0)
+ 572 | otherwise =
+ 573 worker (acc + fn (arr `V.unsafeIndex` i) (arr `V.unsafeIndex` (i+1))) (i+1)
+ 574
+ 575 pCircumference :: (Real a, Fractional a) => APolygon a -> a
+ 576 pCircumference p = sum
+ 577 [ approxDist (pAccess p i) (pAccess p $ i+1)
+ 578 | i <- [0 .. pSize p-1]]
+ 579
+ 580 pCircumference' :: (Real a, Fractional a) => APolygon a -> Double
+ 581 pCircumference' p = sum
+ 582 [ distance' (pAccess p i) (pAccess p $ i+1)
+ 583 | i <- [0 .. pSize p-1]]
+ 584
+ 585
+ 586 -- Add points by splitting the longest lines in half repeatedly.
+ 587 pAddPoints :: PolyCtx a => Int -> APolygon a -> APolygon a
+ 588 pAddPoints = pAddPointsRestricted []
+ 589
+ 590 pAddPointsRestricted :: PolyCtx a => [(V2 a, V2 a)] -> Int -> APolygon a -> APolygon a
+ 591 pAddPointsRestricted _immutableEdges n p | n <= 0 = p
+ 592 pAddPointsRestricted immutableEdges n p = pAddPointsRestricted immutableEdges (n-1) $
+ 593 mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
+ 594 where
+ 595 isImmutable idx =
+ 596 (pAccess p idx, pAccess p $ idx+1) `elem` immutableEdges ||
+ 597 (pAccess p $ idx+1, pAccess p idx) `elem` immutableEdges
+ 598 worker idx
+ 599 | idx == longestEdge && not (isImmutable idx) =
+ 600 [pAccess p idx, pMiddlePoint p idx]
+ 601 | otherwise = [pAccess p idx]
+ 602 longestEdge = maximumBy cmpLength [0 .. pSize p-1]
+ 603 cmpLength a _ | isImmutable a = LT
+ 604 cmpLength _ b | isImmutable b = GT
+ 605 cmpLength a b =
+ 606 distSquared (pAccess p a) (pAccess p $ a+1) `compare`
+ 607 distSquared (pAccess p b) (pAccess p $ b+1)
+ 608
+ 609 pMiddlePoint :: PolyCtx a => APolygon a -> Int -> V2 a
+ 610 pMiddlePoint p idx
+ 611 = lerp 0.5 (pAccess p $ idx+1) (pAccess p idx)
+ 612
+ 613 pAddPointsBetween :: PolyCtx a => (Int, Int) -> Int -> APolygon a -> APolygon a
+ 614 pAddPointsBetween _ n p | n <= 0 = p
+ 615 pAddPointsBetween (i,l) n p = pAddPointsBetween (i,l+1) (n-1) $
+ 616 mkPolygon $ V.fromList $ concatMap worker [0 .. pSize p-1]
+ 617 where
+ 618 worker idx
+ 619 | idx == longestEdge =
+ 620 [pAccess p idx, pMiddlePoint p idx]
+ 621 | otherwise = [pAccess p idx]
+ 622 longestEdge = maximumBy cmpLength [i .. i+l-1]
+ 623 cmpLength a b =
+ 624 distSquared (pAccess p a) (pAccess p $ a+1) `compare`
+ 625 distSquared (pAccess p b) (pAccess p $ b+1)
+ 626
+ 627 -- addPoints :: Int -> Polygon -> Polygon
+ 628 -- addPoints n p = mkPolygon $ V.fromList $ worker n 0 (map (pAccess p) [0..s])
+ 629 -- where
+ 630 -- worker 0 _ rest = init rest
+ 631 -- worker i acc (x:y:xs) =
+ 632 -- let xy = approxDist x y in
+ 633 -- if acc + xy > limit
+ 634 -- then x : worker (i-1) 0 (lerp ((limit-acc)/xy) y x : y:xs)
+ 635 -- else x : worker i (acc+xy) (y:xs)
+ 636 -- worker _ _ [_] = []
+ 637 -- worker _ _ _ = error "addPoints: invalid polygon"
+ 638 -- s = pSize p
+ 639 -- len = polygonLength p
+ 640 -- limit = len / fromIntegral (n+1)
+ 641
+ 642 pIsConvex :: Polygon -> Bool
+ 643 pIsConvex p = and
+ 644 [ area2X (pAccess p i) (pAccess p j) (pAccess p k) > 0
+ 645 | i <- [0..n-1]
+ 646 , j <- [i+1..n-1]
+ 647 , k <- [j+1..n-1]
+ 648 ]
+ 649 where n = pSize p
+ 650
+ 651 pIsCCW :: Polygon -> Bool
+ 652 pIsCCW p | pNull p = False
+ 653 pIsCCW p = V.sum (pMapEdges fn p) < 0
+ 654 where
+ 655 fn (V2 x1 y1) (V2 x2 y2) = (x2-x1)*(y2+y1)
+ 656
+ 657 {-# INLINE pRayIntersect #-}
+ 658 pRayIntersect :: PolyCtx a => APolygon a -> (Int, Int) -> (Int,Int) -> Maybe (V2 a)
+ 659 pRayIntersect p (a,b) (c,d) =
+ 660 rayIntersect (pAccess p a, pAccess p b) (pAccess p c, pAccess p d)
+ 661
+ 662 pCuts :: (Real a, Fractional a, Epsilon a) => APolygon a -> [(APolygon a,APolygon a)]
+ 663 pCuts p =
+ 664 [ pCutAt (pAdjustOffset p i) (j-i)
+ 665 | i <- [0 .. pSize p-1 ]
+ 666 , j <- [i+2 .. pSize p-1 ]
+ 667 , (j+1) `mod` pSize p /= i
+ 668 , pParent p i j == i ]
+ 669
+ 670 pCutEqual :: PolyCtx a => APolygon a -> (APolygon a, APolygon a)
+ 671 pCutEqual p =
+ 672 fromMaybe (p,p) $ listToMaybe $ sortOn f $ pCuts p
+ 673 where
+ 674 f (a,b) = abs (pArea a - pArea b)
+ 675
+ 676 -- FIXME: This should be more efficient
+ 677 pCutAt :: PolyCtx a => APolygon a -> Int -> (APolygon a, APolygon a)
+ 678 pCutAt p i = (mkPolygon $ V.fromList left, mkPolygon $ V.fromList right)
+ 679 where
+ 680 n = pSize p
+ 681 left = map (pAccess p) [0 .. i]
+ 682 right = map (pAccess p) (0:[i..n-1])
+ 683
+ 684 pOverlap :: PolyCtx a => APolygon a -> APolygon a -> APolygon a
+ 685 pOverlap a b = mkPolygon $ V.fromList $ clearDups $ concatMap edgeIntersect [0 .. pSize a-1]
+ 686 where
+ 687 clearDups (x:y:xs)
+ 688 | x == y = clearDups (y:xs)
+ 689 | otherwise = x : clearDups (y:xs)
+ 690 clearDups xs = xs
+ 691 edgeIntersect edge =
+ 692 sortOn (distSquared (pAccess a edge)) $ catMaybes
+ 693 [ lineIntersect (aP, aP') (bP, bP')
+ 694 | i <- [0 .. pSize b-1]
+ 695 , let aP = pAccess a edge
+ 696 aP' = pAccess a (edge+1)
+ 697 bP = pAccess b i
+ 698 bP' = pAccess b (i+1)
+ 699 ]
+ 700
+ 701 ---------------------------------------------------------
+ 702 -- SSSP visibility and SSSP windows
+ 703
+ 704 ssspVisibility :: PolyCtx a => APolygon a -> APolygon a
+ 705 ssspVisibility p = mkPolygon $
+ 706 V.fromList $ clearDups $ go [0 .. pSize p-1] -- ([root..pSize p-1] ++ [0 .. root-1])
+ 707 where
+ 708 clearDups (x:y:xs)
+ 709 | x == y = clearDups (y:xs)
+ 710 | otherwise = x : clearDups (y:xs)
+ 711 clearDups xs = xs
+ 712 obstructedBy n =
+ 713 case pParent p 0 n of
+ 714 0 -> n
+ 715 i -> obstructedBy i
+ 716 go [] = []
+ 717 go [x] = [pAccess p x]
+ 718 go (x:y:xs) =
+ 719 let xO = obstructedBy x
+ 720 yO = obstructedBy y
+ 721 in case () of
+ 722 ()
+ 723 -- Both ends are visible.
+ 724 | xO == x && yO == y -> pAccess p x : go (y:xs)
+ 725 -- X is visible, x to intersect (0,yO) (x,y)
+ 726 | xO == x ->
+ 727 pAccess p x : fromMaybe (pAccess p y) (pRayIntersect p (0,yO) (x,y)) : go (y:xs)
+ 728 -- Y is visible
+ 729 | yO == y -> fromMaybe (pAccess p x) (pRayIntersect p (0,xO) (x,y)) : pAccess p y : go (y:xs)
+ 730 -- Neither is visible and they've obstructed by the same point
+ 731 -- so the entire edge is hidden.
+ 732 | xO == yO -> go (y:xs)
+ 733 -- Neither is visible. Cast shadow from obstruction points to
+ 734 -- find if a subsection of the edge is visible.
+ 735 | otherwise ->
+ 736 let a = fromMaybe (error "a") (pRayIntersect p (0,xO) (x,y))
+ 737 b = fromMaybe (error "b") (pRayIntersect p (0,yO) (x,y))
+ 738 in if a /= b
+ 739 then a : b : go (y:xs)
+ 740 else go (y:xs)
+ 741
+ 742 ssspWindows :: Polygon -> [(V2 Rational, V2 Rational)]
+ 743 ssspWindows p = clearDups $ go (pAccess p 0) [0..pSize p-1]
+ 744 where
+ 745 clearDups (x:y:xs)
+ 746 | x == y = clearDups (y:xs)
+ 747 | otherwise = x : clearDups (y:xs)
+ 748 clearDups xs = xs
+ 749 obstructedBy n =
+ 750 case pParent p 0 n of
+ 751 0 -> n
+ 752 i -> obstructedBy i
+ 753 go _ [] = []
+ 754 go _ [_] = []
+ 755 go l (x:y:xs) =
+ 756 let xO = obstructedBy x
+ 757 yO = obstructedBy y
+ 758 in case () of
+ 759 ()
+ 760 -- Both ends are visible.
+ 761 | xO == x && yO == y -> go (pAccess p x) (y:xs)
+ 762 -- X is visible, x to intersect (0,yO) (x,y)
+ 763 | xO == x ->
+ 764 go (fromMaybe (pAccess p y) (pRayIntersect p (0,yO) (x,y))) (y:xs)
+ 765 -- Y is visible
+ 766 | yO == y ->
+ 767 let newL = fromMaybe (pAccess p x) (pRayIntersect p (0,xO) (x,y)) in
+ 768 (l, newL) :
+ 769 go newL (y:xs)
+ 770 -- Neither is visible and they've obstructed by the same point
+ 771 -- so the entire edge is hidden.
+ 772 | xO == yO -> go l (y:xs)
+ 773 -- Neither is visible. Cast shadow from obstruction points to
+ 774 -- find if a subsection of the edge is visible.
+ 775 | otherwise ->
+ 776 let a = fromMaybe (error "a") (pRayIntersect p (0,xO) (x,y))
+ 777 b = fromMaybe (error "b") (pRayIntersect p (0,yO) (x,y))
+ 778 in if a /= b
+ 779 then (l, a) : (b, pAccess p yO) : go (pAccess p yO) (y:xs)
+ 780 else go l (y:xs)
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Math.SSSP.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Math.SSSP.hs.html
new file mode 100644
index 0000000..cd16a5e
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Math.SSSP.hs.html
@@ -0,0 +1,390 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE FlexibleInstances #-}
+ 2 {-# LANGUAGE MultiParamTypeClasses #-}
+ 3 {-# LANGUAGE RecordWildCards #-}
+ 4 {-# OPTIONS_GHC -fno-warn-orphans #-}
+ 5 {-# OPTIONS_HADDOCK hide #-}
+ 6 module Reanimate.Math.SSSP
+ 7 ( -- * Single-Source-Shortest-Path
+ 8 SSSP
+ 9 , sssp -- :: (Fractional a, Ord a) => Ring a -> Dual -> SSSP
+ 10 , ssspFinger
+ 11 , dual -- :: Int -> Triangulation -> Dual
+ 12 , Dual(..)
+ 13 , DualTree(..)
+ 14 -- * Misc
+ 15 , dualToTriangulation -- :: Ring Rational -> Dual -> Triangulation
+ 16 , visibilityArray -- :: Ring Rational -> V.Vector [Int]
+ 17 , naive -- :: Ring Rational -> SSSP
+ 18 , naive2 -- :: Ring Rational -> SSSP
+ 19 , drawDual -- :: Dual -> String
+ 20 ) where
+ 21
+ 22 import Control.Monad
+ 23 import Control.Monad.ST
+ 24 import qualified Data.FingerTree as F
+ 25 import Data.Foldable
+ 26 import Data.List
+ 27 import qualified Data.Map as Map
+ 28 import Data.Maybe
+ 29 import Data.STRef
+ 30 import Data.Tree
+ 31 import qualified Data.Vector as V
+ 32 import qualified Data.Vector.Mutable as MV
+ 33 import Reanimate.Math.Common
+ 34 import Reanimate.Math.Triangulate
+ 35
+ 36 -- import Debug.Trace
+ 37
+ 38 type SSSP = V.Vector Int
+ 39
+ 40
+ 41 -- ssspParent :: Polygon -> SSSP -> Int -> Int
+ 42 -- ssspParent p sTree x =
+ 43 -- (sTree V.! ((x - polygonOffset p) `mod` n) + polygonOffset p) `mod` n
+ 44 -- where
+ 45 -- n = polygonSize p
+ 46
+ 47 visibilityArray :: Ring Rational -> V.Vector [Int]
+ 48 visibilityArray p = arr
+ 49 where
+ 50 n = ringSize p
+ 51 arr = V.fromList
+ 52 [ visibility y
+ 53 | y <- [0..n-1]
+ 54 ]
+ 55 visibility y =
+ 56 [ i
+ 57 | i <- [0..y-1]
+ 58 , y `elem` arr V.! i ] ++
+ 59 [ i
+ 60 | i <- [y+1 .. n-1]
+ 61 , let pI = ringAccess p i
+ 62 isOpen = isRightTurn pYp pY pYn
+ 63 , ringClamp p (y+1) == i || ringClamp p (y-1) == i || if isOpen
+ 64 then isLeftTurnOrLinear pY pYn pI ||
+ 65 isLeftTurnOrLinear pYp pY pI
+ 66 else not $ isRightTurn pY pYn pI ||
+ 67 isRightTurn pYp pY pI
+ 68 , let myEdges = [(e1,e2) | (e1,e2) <- edges, e1/=y, e1/=i, e2/=y,e2/=i]
+ 69 , all (isNothing . lineIntersect (pY,pI))
+ 70 [ (ringAccess p e1, ringAccess p e2) | (e1,e2) <- myEdges ]]
+ 71 where
+ 72 pY = ringAccess p y
+ 73 pYn = ringAccess p $ y+1
+ 74 pYp = ringAccess p $ y-1
+ 75 edges = zip [0..n-1] (tail [0..n-1] ++ [0])
+ 76
+ 77
+ 78
+ 79 -- Iterative Single Source Shortest Path solver. Quite slow.
+ 80 naive :: Ring Rational -> SSSP
+ 81 naive p =
+ 82 V.fromList $ Map.elems $
+ 83 Map.map snd $
+ 84 worker initial
+ 85 where
+ 86 initial = Map.singleton 0 (0,0)
+ 87 visibility = visibilityArray p
+ 88 worker :: Map.Map Int (Rational, Int) -> Map.Map Int (Rational, Int)
+ 89 worker m
+ 90 | m==newM = newM
+ 91 | otherwise = worker newM
+ 92 where
+ 93 ms' = [ Map.fromList
+ 94 [ case Map.lookup v m of
+ 95 Nothing -> (v, (distThroughI, i))
+ 96 Just (otherDist,parent)
+ 97 | otherDist > distThroughI -> (v, (distThroughI, i))
+ 98 | otherwise -> (v, (otherDist, parent))
+ 99 | v <- visibility V.! i
+ 100 , let distThroughI = dist + approxDist (ringAccess p i) (ringAccess p v) ]
+ 101 | (i,(dist,_)) <- Map.toList m
+ 102 ]
+ 103 newM = Map.unionsWith g (m:ms') :: Map.Map Int (Rational,Int)
+ 104 g a b = if fst a < fst b then a else b
+ 105
+ 106 naive2 :: Ring Rational -> SSSP
+ 107 naive2 p = runST $ do
+ 108 parents <- MV.replicate (ringSize p) (-1)
+ 109 costs <- MV.replicate (ringSize p) (-1)
+ 110 MV.write parents 0 0
+ 111 MV.write costs 0 0
+ 112 changedRef <- newSTRef False
+ 113 let loop i
+ 114 | i == ringSize p = do
+ 115 changed <- readSTRef changedRef
+ 116 when changed $ do
+ 117 writeSTRef changedRef False
+ 118 loop 0
+ 119 | otherwise = do
+ 120 myCost <- MV.read costs i
+ 121 unless (myCost < 0) $
+ 122 forM_ (visibility V.! i) $ \n -> do
+ 123 -- n is visible from i.
+ 124 theirCost <- MV.read costs n
+ 125 let throughCost = myCost + approxDist (ringAccess p i) (ringAccess p n)
+ 126 when (throughCost < theirCost || theirCost < 0) $ do
+ 127 MV.write parents n i
+ 128 MV.write costs n throughCost
+ 129 writeSTRef changedRef True
+ 130 loop (i+1)
+ 131 loop 0
+ 132 V.unsafeFreeze parents
+ 133 where
+ 134 visibility = visibilityArray p
+ 135
+ 136 -- Dual of triangulated polygon
+ 137 data Dual = Dual (Int,Int,Int) -- (a,b,c)
+ 138 DualTree -- borders ca
+ 139 DualTree -- borders bc
+ 140 deriving (Show)
+ 141
+ 142 data DualTree
+ 143 = EmptyDual
+ 144 | NodeDual Int -- axb triangle, a and b are from parent.
+ 145 DualTree -- borders xb
+ 146 DualTree -- borders ax
+ 147 deriving (Show)
+ 148
+ 149 drawDual :: Dual -> String
+ 150 drawDual d = drawTree $
+ 151 case d of
+ 152 Dual (a,b,c) l r -> Node (show (a,b,c)) [worker c a l, worker b c r]
+ 153 where
+ 154 worker _a _b EmptyDual = Node "Leaf" []
+ 155 worker a b (NodeDual x l r) =
+ 156 Node (show (b,a,x)) [worker x b l, worker a x r]
+ 157
+ 158 dualToTriangulation :: Ring Rational -> Dual -> Triangulation
+ 159 dualToTriangulation p d = edgesToTriangulation (ringSize p) $ filter goodEdge $
+ 160 case d of
+ 161 Dual (a,b,c) l r ->
+ 162 (a,b):(a,c):(b,c):worker c a l ++ worker b c r
+ 163 where
+ 164 goodEdge (a,b)
+ 165 = a /= ringClamp p (b+1) && a /= ringClamp p (b-1)
+ 166 worker _a _b EmptyDual = []
+ 167 worker a b (NodeDual x l r) =
+ 168 (a,x) : (x, b) : worker x b l ++ worker a x r
+ 169
+ 170 -- Dual path:
+ 171 -- (Int,Int,Int) + V.Vector Int + V.Vector LeftOrRight
+ 172
+ 173 -- simplifyDual :: DualTree -> DualTree
+ 174 -- -- simplifyDual (NodeDual x EmptyDual EmptyDual) = NodeLeaf x
+ 175 -- -- simplifyDual (NodeDual x l EmptyDual) = NodeDualL x l
+ 176 -- -- simplifyDual (NodeDual x EmptyDual r) = NodeDualR x r
+ 177 -- simplifyDual d = d
+ 178
+ 179 dual :: Int -> Triangulation -> Dual
+ 180 dual root t =
+ 181 case hasTriangle of
+ 182 [] -> error "weird triangulation"
+ 183 -- [] -> Dual (0,1,V.length t-1) EmptyDual (dualTree t (1, (V.length t-1)) 0)
+ 184 (x:_) -> Dual (root,rootNext,x) (dualTree t (x,root) rootNext) (dualTree t (rootNext,x) root)
+ 185 where
+ 186 rootNext = idx (root+1)
+ 187 rootPrev = idx (root-1)
+ 188 rootNNext = idx (root+2)
+ 189 idx i = i `mod` n
+ 190 hasTriangle = (rootPrev : t V.! root) `intersect` (rootNNext : t V.! rootNext)
+ 191 n = V.length t
+ 192
+ 193 -- a=6, b=0, e=1
+ 194 dualTree :: Triangulation -> (Int,Int) -> Int -> DualTree
+ 195 dualTree t (a,b) e = -- simplifyDual $
+ 196 case hasTriangle of
+ 197 [] -> EmptyDual
+ 198 [ab] ->
+ 199 NodeDual ab
+ 200 (dualTree t (ab,b) a)
+ 201 (dualTree t (a,ab) b)
+ 202 _ -> error $ "Invalid triangulation: " ++ show (a,b,e,hasTriangle)
+ 203 where
+ 204 hasTriangle = (prev a : next a : t V.! a) `intersect` (prev b : next b : t V.! b)
+ 205 \\ [e]
+ 206 n = V.length t
+ 207 next x = (x+1) `mod` n
+ 208 prev x = (x-1) `mod` n
+ 209
+ 210
+ 211 -- dualRoot :: Dual -> Int
+ 212 -- dualRoot (Dual (a,_,_) _ _) = a
+ 213
+ 214 -- O(n*ln n), could be O(n) if I could figure out how to use fingertrees...
+ 215 sssp :: (Fractional a, Ord a, Epsilon a) => Ring a -> Dual -> SSSP
+ 216 sssp p d = toSSSP $
+ 217 case d of
+ 218 Dual (a,b,c) l r ->
+ 219 (a, a) :
+ 220 (b, a) :
+ 221 (c, a) :
+ 222 worker [c] [b] a r ++
+ 223 loopLeft a c l
+ 224 where
+ 225 toSSSP =
+ 226 V.fromList . map snd . sortOn fst
+ 227 loopLeft a outer l =
+ 228 case l of
+ 229 EmptyDual -> []
+ 230 NodeDual x l' r' ->
+ 231 (x,a) :
+ 232 worker [x] [outer] a r' ++
+ 233 loopLeft a x l'
+ 234 searchFn _checkStep _cusp _x [] = Nothing
+ 235 searchFn checkStep cusp x (y:ys)
+ 236 | not (checkStep (ringAccess p cusp) (ringAccess p y) (ringAccess p x))
+ 237 = Just $ helper [] y ys
+ 238 | otherwise = Nothing
+ 239 where
+ 240 helper acc v [] = (v, [], reverse acc)
+ 241 helper acc v1 (v2:vs)
+ 242 | checkStep (ringAccess p v1) (ringAccess p v2) (ringAccess p x) =
+ 243 (v1, v2:vs, reverse acc)
+ 244 | otherwise = helper (v1:acc) v2 vs
+ 245 searchRight = searchFn isLeftTurn
+ 246 searchLeft = searchFn isRightTurn
+ 247 -- adj x = x -- ringClamp p (x-dualRoot d)
+ 248 -- optTrace msg =
+ 249 -- if False -- dualRoot d == 1 || dualRoot d == 0
+ 250 -- then trace msg
+ 251 -- else id
+ 252 worker _ _ _ EmptyDual = []
+ 253 worker f1 f2 cusp (NodeDual x l r) =
+ 254 -- (optTrace ("Funnel: " ++ show
+ 255 -- (map adj $ toList f1
+ 256 -- ,adj cusp
+ 257 -- ,map adj $ toList f2
+ 258 -- ,adj x
+ 259 -- , dualRoot d))
+ 260 -- ) $
+ 261 case searchLeft cusp x (toList f1) of
+ 262 Just (v, f1Hi, f1Lo) ->
+ 263 -- optTrace (" Visble from left: " ++ show (adj x,adj v)) $
+ 264 (x, v::Int) :
+ 265 worker f1Hi [x] v l ++
+ 266 worker (f1Lo ++ [v, x]) f2 cusp r
+ 267 Nothing ->
+ 268 case searchRight cusp x (toList f2) of
+ 269 Just (v, f2Hi, f2Lo) ->
+ 270 -- optTrace (" Visble from right: " ++ show (adj x,adj v)) $
+ 271 (x, v::Int) :
+ 272 worker f1 (f2Lo ++ [v, x]) cusp l ++
+ 273 worker [x] f2Hi v r
+ 274 Nothing ->
+ 275 -- optTrace (" Visble from cusp: " ++ show (adj x,adj cusp)) $
+ 276 (x, cusp::Int) :
+ 277 worker f1 [x] cusp l ++
+ 278 worker [x] f2 cusp r
+ 279
+ 280 data MinMax = MinMax Int Int | MinMaxEmpty deriving (Show)
+ 281 instance Semigroup MinMax where
+ 282 MinMaxEmpty <> b = b
+ 283 a <> MinMaxEmpty = a
+ 284 MinMax a _b <> MinMax _c d
+ 285 = MinMax a d
+ 286 instance Monoid MinMax where
+ 287 mempty = MinMaxEmpty
+ 288
+ 289 type Chain = F.FingerTree MinMax Int
+ 290 data Funnel = Funnel
+ 291 { funnelLeft :: Chain
+ 292 , funnelCusp :: Int
+ 293 , funnelRight :: Chain
+ 294 }
+ 295
+ 296 instance F.Measured MinMax Int where
+ 297 measure i = MinMax i i
+ 298
+ 299 splitFunnel :: (Epsilon a, Fractional a, Ord a) => Ring a -> Int -> Funnel -> (Int, Funnel, Funnel)
+ 300 splitFunnel p x Funnel{..}
+ 301 | isOnLeftChain =
+ 302 case doSearch isRightTurn funnelLeft of
+ 303 (lower, t, upper) ->
+ 304 ( t
+ 305 , Funnel upper t (F.singleton x)
+ 306 , Funnel (lower F.|> t F.|> x) funnelCusp funnelRight)
+ 307 | isOnRightChain =
+ 308 case doSearch isLeftTurn funnelRight of
+ 309 (lower, t, upper) ->
+ 310 ( t
+ 311 , Funnel funnelLeft funnelCusp (lower F.|> t F.|> x)
+ 312 , Funnel (F.singleton x) t upper)
+ 313 | otherwise =
+ 314 ( funnelCusp
+ 315 , Funnel funnelLeft funnelCusp (F.singleton x)
+ 316 , Funnel (F.singleton x) funnelCusp funnelRight)
+ 317 where
+ 318 isOnLeftChain = fromMaybe False $
+ 319 isLeftTurnOrLinear cuspElt <$> leftElt <*> pure targetElt
+ 320 isOnRightChain = fromMaybe False $
+ 321 isRightTurnOrLinear cuspElt <$> rightElt <*> pure targetElt
+ 322 doSearch fn chain =
+ 323 case F.search (searchChain fn) (chain::Chain) of
+ 324 F.Position lower t upper -> (lower, t, upper)
+ 325 F.OnLeft -> error "cannot happen"
+ 326 F.OnRight -> error "cannot happen"
+ 327 F.Nowhere -> error "cannot happen"
+ 328 searchChain _ MinMaxEmpty _ = False
+ 329 searchChain _ _ MinMaxEmpty = True
+ 330 searchChain check (MinMax _ l) (MinMax r _) =
+ 331 check (ringAccess p l) (ringAccess p r) targetElt
+ 332 cuspElt = ringAccess p funnelCusp
+ 333 targetElt = ringAccess p x
+ 334 leftElt = ringAccess p <$> chainLeft funnelLeft
+ 335 rightElt = ringAccess p <$> chainLeft funnelRight
+ 336 chainLeft chain =
+ 337 case F.viewl chain of
+ 338 F.EmptyL -> Nothing
+ 339 elt F.:< _ -> Just elt
+ 340
+ 341 -- O(n)
+ 342 ssspFinger :: (Epsilon a, Fractional a, Ord a) => Ring a -> Dual -> SSSP
+ 343 ssspFinger p d = toSSSP $
+ 344 case d of
+ 345 Dual (a,b,c) l r ->
+ 346 (a, a) :
+ 347 (b, a) :
+ 348 (c, a) :
+ 349 worker (Funnel (F.singleton c) a (F.singleton b)) r ++
+ 350 loopLeft a c l
+ 351 where
+ 352 toSSSP =
+ 353 V.fromList . map snd . sortOn fst
+ 354 loopLeft a outer l =
+ 355 case l of
+ 356 EmptyDual -> []
+ 357 NodeDual x l' r' ->
+ 358 (x,a) :
+ 359 worker (Funnel (F.singleton x) a (F.singleton outer)) r' ++
+ 360 loopLeft a x l'
+ 361 worker _ EmptyDual = []
+ 362 worker f (NodeDual x l r) =
+ 363 case splitFunnel p x f of
+ 364 (v, fL, fR) ->
+ 365 (x, v) :
+ 366 worker fL l ++
+ 367 worker fR r
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Math.Triangulate.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Math.Triangulate.hs.html
new file mode 100644
index 0000000..fe4995c
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Math.Triangulate.hs.html
@@ -0,0 +1,108 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE DataKinds #-}
+ 2 {-# LANGUAGE ScopedTypeVariables #-}
+ 3 {-# OPTIONS_HADDOCK hide #-}
+ 4 module Reanimate.Math.Triangulate
+ 5 ( Triangulation
+ 6 , edgesToTriangulation
+ 7 , edgesToTriangulationM
+ 8 , trianglesToTriangulation
+ 9 , trianglesToTriangulationM
+ 10 , triangulate
+ 11 )
+ 12 where
+ 13
+ 14 import Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate')
+ 15 import Algorithms.Geometry.PolygonTriangulation.Types
+ 16 import Control.Lens
+ 17 import Control.Monad
+ 18 import Control.Monad.ST
+ 19 import Data.Ext
+ 20 import Data.Geometry.PlanarSubdivision (PolygonFaceData)
+ 21 import Data.Geometry.Point
+ 22 import Data.Geometry.Polygon
+ 23 import qualified Data.IntSet as ISet
+ 24 import qualified Data.PlaneGraph as Geo
+ 25 import Data.Proxy
+ 26 import qualified Data.Vector as V
+ 27 import qualified Data.Vector.Mutable as MV
+ 28 import Linear.V2
+ 29 import Reanimate.Math.Common
+ 30 -- Max edges: n-2
+ 31 -- Each edge is represented twice: 2n-4
+ 32 -- Flat structure:
+ 33 -- edges :: V.Vector Int -- max length (2n-4)
+ 34 -- offsets :: V.Vector Int -- length n
+ 35 -- Combine the two vectors? < n => offsets, >= n => edges?
+ 36 type Triangulation = V.Vector [Int]
+ 37
+ 38 -- FIXME: Move to Common or a Triangulation module
+ 39 -- O(n)
+ 40 edgesToTriangulation :: Int -> [(Int, Int)] -> Triangulation
+ 41 edgesToTriangulation size edges = runST $ do
+ 42 v <- edgesToTriangulationM size edges
+ 43 V.unsafeFreeze v
+ 44
+ 45 edgesToTriangulationM :: Int -> [(Int, Int)] -> ST s (V.MVector s [Int])
+ 46 edgesToTriangulationM size edges = do
+ 47 v <- MV.replicate size []
+ 48 forM_ edges $ \(e1, e2) -> do
+ 49 MV.modify v (e1 :) e2
+ 50 MV.modify v (e2 :) e1
+ 51 forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i
+ 52 return v
+ 53
+ 54 trianglesToTriangulation :: Int -> V.Vector (Int, Int, Int) -> Triangulation
+ 55 trianglesToTriangulation size edges = runST $ do
+ 56 v <- trianglesToTriangulationM size edges
+ 57 V.unsafeFreeze v
+ 58
+ 59 trianglesToTriangulationM
+ 60 :: Int -> V.Vector (Int, Int, Int) -> ST s (V.MVector s [Int])
+ 61 trianglesToTriangulationM size trigs = do
+ 62 v <- MV.replicate size []
+ 63 forM_ (V.toList trigs) $ \(a, b, c) -> do
+ 64 MV.modify v (\x -> b : c : x) a
+ 65 MV.modify v (\x -> a : c : x) b
+ 66 MV.modify v (\x -> a : b : x) c
+ 67 forM_ [0 .. size - 1] $ \i -> MV.modify v (ISet.toList . ISet.fromList) i
+ 68 return v
+ 69
+ 70
+ 71 triangulate :: forall a. (Fractional a, Ord a) => Ring a -> Triangulation
+ 72 triangulate r = edgesToTriangulation (ringSize r) ds
+ 73 where
+ 74 ds :: [(Int,Int)]
+ 75 ds =
+ 76 [ (a^.Geo.vData, b^.Geo.vData)
+ 77 | (d, Diagonal) <- V.toList (Geo.edges pg)
+ 78 , let (a,b) = Geo.endPointData d pg ]
+ 79 pg :: Geo.PlaneGraph () Int PolygonEdgeType PolygonFaceData a
+ 80 pg = triangulate' Proxy p
+ 81 p :: SimplePolygon Int a
+ 82 p = fromPoints $
+ 83 [ Point2 x y :+ n
+ 84 | (n,V2 x y) <- zip [0..] (V.toList (ringUnpack r)) ]
+ 85 -- ringUnpack
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Misc.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Misc.hs.html
new file mode 100644
index 0000000..7a10433
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Misc.hs.html
@@ -0,0 +1,131 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 module Reanimate.Misc
+ 2 ( requireExecutable
+ 3 , runCmd
+ 4 , runCmd_
+ 5 , runCmdLazy
+ 6 , withTempDir
+ 7 , withTempFile
+ 8 , renameOrCopyFile
+ 9 ) where
+ 10
+ 11 import Control.Concurrent
+ 12 import Control.Exception (catch, evaluate, finally, throw)
+ 13 import qualified Data.Text as T
+ 14 import qualified Data.Text.IO as T
+ 15 import Foreign.C.Error
+ 16 import GHC.IO.Exception
+ 17 import System.Directory (copyFile, findExecutable, removeFile,
+ 18 renameFile)
+ 19 import System.FilePath ((<.>))
+ 20 import System.IO (hClose, hGetContents, hIsEOF, hPutStr,
+ 21 stderr)
+ 22 import System.IO.Temp (withSystemTempDirectory,
+ 23 withSystemTempFile)
+ 24 import System.Process (readProcessWithExitCode,
+ 25 runInteractiveProcess, showCommandForUser,
+ 26 terminateProcess, waitForProcess)
+ 27
+ 28
+ 29 requireExecutable :: String -> IO FilePath
+ 30 requireExecutable exec = do
+ 31 mbPath <- findExecutable exec
+ 32 case mbPath of
+ 33 Nothing -> error $ "Couldn't find executable: " ++ exec
+ 34 Just path -> return path
+ 35
+ 36 runCmd :: FilePath -> [String] -> IO ()
+ 37 runCmd exec args = do
+ 38 ret <- runCmd_ exec args
+ 39 case ret of
+ 40 Left err -> error $ showCommandForUser exec args ++ ":\n" ++ err
+ 41 Right{} -> return ()
+ 42
+ 43 runCmd_ :: FilePath -> [String] -> IO (Either String String)
+ 44 runCmd_ exec args = do
+ 45 (ret, stdout, errMsg) <- readProcessWithExitCode exec args ""
+ 46 _ <- evaluate (length stdout + length errMsg)
+ 47 case ret of
+ 48 ExitSuccess -> return (Right stdout)
+ 49 ExitFailure err | False ->
+ 50 return
+ 51 $ Left
+ 52 $ "Failed to run: "
+ 53 ++ showCommandForUser exec args
+ 54 ++ "\n"
+ 55 ++ "Error code: "
+ 56 ++ show err
+ 57 ++ "\n"
+ 58 ++ "stderr: "
+ 59 ++ errMsg
+ 60 ExitFailure{} | null errMsg -> -- LaTeX prints errors to stdout. :(
+ 61 return $ Left stdout
+ 62 ExitFailure{} -> return $ Left errMsg
+ 63
+ 64 runCmdLazy
+ 65 :: FilePath -> [String] -> (IO (Either String T.Text) -> IO a) -> IO a
+ 66 runCmdLazy exec args handler = do
+ 67 (inp, out, err, pid) <- runInteractiveProcess exec args Nothing Nothing
+ 68 hClose inp
+ 69 errOutput <- hGetContents err
+ 70 _ <- forkIO $ hPutStr stderr errOutput
+ 71 let fetch = do
+ 72 eof <- hIsEOF out
+ 73 if eof
+ 74 then do
+ 75 _ <- evaluate (length errOutput)
+ 76 ret <- waitForProcess pid
+ 77 case ret of
+ 78 ExitSuccess -> return (Left "")
+ 79 ExitFailure{} -> return (Left errOutput)
+ 80 {-ExitFailure errMsg -> do
+ 81 return $ Left $
+ 82 "Failed to run: " ++ showCommandForUser exec args ++ "\n" ++
+ 83 "Error code: " ++ show errMsg ++ "\n" ++
+ 84 "stderr: " ++ stderr-}
+ 85 else do
+ 86 line <- T.hGetLine out
+ 87 return (Right line)
+ 88 handler fetch `finally` do
+ 89 terminateProcess pid
+ 90 _ <- waitForProcess pid
+ 91 return ()
+ 92
+ 93 -- renameFile fails if we're crossing filesystem boundaries. If this happens,
+ 94 -- revert back to copyFile + removeFile.
+ 95 renameOrCopyFile :: FilePath -> FilePath -> IO ()
+ 96 renameOrCopyFile src dst = renameFile src dst `catch` exdev
+ 97 where
+ 98 exdev e = if fmap Errno (ioe_errno e) == Just eXDEV
+ 99 then copyFile src dst >> removeFile src
+ 100 else throw e
+ 101
+ 102 withTempDir :: (FilePath -> IO a) -> IO a
+ 103 withTempDir = withSystemTempDirectory "reanimate"
+ 104
+ 105 withTempFile :: String -> (FilePath -> IO a) -> IO a
+ 106 withTempFile ext action =
+ 107 withSystemTempFile ("reanimate" <.> ext) $ \path hd ->
+ 108 hClose hd >> action path
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Morph.Cache.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Morph.Cache.hs.html
new file mode 100644
index 0000000..595a66d
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Morph.Cache.hs.html
@@ -0,0 +1,66 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 module Reanimate.Morph.Cache
+ 2 ( cachePointCorrespondence -- :: Int -> PointCorrespondence -> PointCorrespondence
+ 3 ) where
+ 4
+ 5 import Control.Exception
+ 6 import qualified Data.ByteString as B
+ 7 import Data.Hashable
+ 8 import Data.Serialize
+ 9 import Reanimate.Cache (encodeInt)
+ 10 import Reanimate.Misc (renameOrCopyFile)
+ 11 import Reanimate.Morph.Common
+ 12 import System.Directory
+ 13 import System.FilePath
+ 14 import System.IO
+ 15 import System.IO.Temp
+ 16 import System.IO.Unsafe
+ 17
+ 18 -- type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon)
+ 19 cachePointCorrespondence :: Int -> PointCorrespondence -> PointCorrespondence
+ 20 cachePointCorrespondence ident fn src dst = unsafePerformIO $ do
+ 21 root <- getXdgDirectory XdgCache "reanimate"
+ 22 createDirectoryIfMissing True root
+ 23 let path = root </> template
+ 24 hit <- doesFileExist path
+ 25 if hit
+ 26 then do
+ 27 inp <- B.readFile path
+ 28 case decode inp of
+ 29 Left{} -> do
+ 30 removeFile path
+ 31 gen path
+ 32 Right out -> return out
+ 33 else gen path
+ 34 where
+ 35 gen path = do
+ 36 correspondence <- evaluate (fn src dst)
+ 37 withSystemTempFile template $ \tmp h -> do
+ 38 hClose h
+ 39 B.writeFile tmp (encode correspondence)
+ 40 renameOrCopyFile tmp path
+ 41 return correspondence
+ 42 template = encodeInt key <.> "morph"
+ 43 key = hashWithSalt ident (src,dst)
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Morph.Common.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Morph.Common.hs.html
new file mode 100644
index 0000000..8aa301d
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Morph.Common.hs.html
@@ -0,0 +1,241 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE RecordWildCards #-}
+ 2 {-# LANGUAGE TupleSections #-}
+ 3 {-# LANGUAGE UnicodeSyntax #-}
+ 4 {-|
+ 5 Copyright : Written by David Himmelstrup
+ 6 License : Unlicense
+ 7 Maintainer : lemmih@gmail.com
+ 8 Stability : experimental
+ 9 Portability : POSIX
+ 10 -}
+ 11 module Reanimate.Morph.Common
+ 12 ( PointCorrespondence
+ 13 , Trajectory
+ 14 , ObjectCorrespondence
+ 15 , Morph(..)
+ 16 , morph
+ 17 , splitObjectCorrespondence
+ 18 , dupObjectCorrespondence
+ 19 , genesisObjectCorrespondence
+ 20 , toShapes
+ 21 , normalizePolygons
+ 22 , annotatePolygons
+ 23 , unsafeSVGToPolygon
+ 24 ) where
+ 25
+ 26 import Control.Lens
+ 27 import qualified Data.Vector as V
+ 28 import Graphics.SvgTree (DrawAttributes, Texture (..),
+ 29 drawAttributes, fillColor,
+ 30 fillOpacity, groupOpacity,
+ 31 strokeColor, strokeOpacity)
+ 32 import Linear.V2
+ 33 import Reanimate.Animation
+ 34 import Reanimate.ColorComponents
+ 35 import Reanimate.Ease
+ 36 import Reanimate.Math.Polygon (APolygon, Epsilon, Polygon,
+ 37 mkPolygon, pAddPoints, pCentroid,
+ 38 pCutEqual, pSize, polygonPoints)
+ 39 import Reanimate.PolyShape
+ 40 import Reanimate.Svg
+ 41
+ 42 -- import Debug.Trace
+ 43
+ 44 -- Correspondence
+ 45 -- Trajectory
+ 46 -- Color interpolation
+ 47 -- Polygon holes
+ 48 -- Polygon splitting
+ 49
+ 50 -- Graphical polygon? FIXME: Come up with a better name.
+ 51 type GPolygon = (DrawAttributes, Polygon)
+ 52
+ 53 -- | Method determining how points in the source polygon align with
+ 54 -- points in the target polygon.
+ 55 type PointCorrespondence = Polygon → Polygon → (Polygon, Polygon)
+ 56
+ 57 -- | Method for interpolating between two aligned polygons.
+ 58 type Trajectory = (Polygon, Polygon) → (Double → Polygon)
+ 59
+ 60 -- | Method for pairing sets of polygons.
+ 61 type ObjectCorrespondence = [GPolygon] → [GPolygon] → [(GPolygon, GPolygon)]
+ 62
+ 63 -- | Morphing strategy
+ 64 data Morph = Morph
+ 65 { morphTolerance :: Double
+ 66 -- ^ Morphing curves is not always possible and
+ 67 -- sometimes shapes are reduced to polygons or meta-curves.
+ 68 -- This parameter determined the accuracy of this transformation.
+ 69 , morphColorComponents :: ColorComponents
+ 70 -- ^ Color components used for color interpolation. LAB is usually
+ 71 -- the best option here.
+ 72 , morphPointCorrespondence :: PointCorrespondence
+ 73 -- ^ Desired point-correspondence algorithm.
+ 74 , morphTrajectory :: Trajectory
+ 75 -- ^ Desired interpolation algorithm.
+ 76 , morphObjectCorrespondence :: ObjectCorrespondence
+ 77 -- ^ Desired object-correspondence algorithm.
+ 78 }
+ 79
+ 80 {-# INLINE morph #-}
+ 81 -- | Apply morphing strategy to interpolate between two SVG images.
+ 82 morph :: Morph -> SVG -> SVG -> Double -> SVG
+ 83 morph Morph{..} src dst = \t ->
+ 84 case t of
+ 85 0 -> lowerTransformations src
+ 86 1 -> lowerTransformations dst
+ 87 _ -> mkGroup
+ 88 [ render (genPoints t)
+ 89 & drawAttributes .~ genAttrs t
+ 90 | (genAttrs, genPoints) <- gens
+ 91 ]
+ 92 where
+ 93 render p = mkLinePathClosed
+ 94 [ (x,y) | V2 x y <- map (fmap realToFrac) $ V.toList $ polygonPoints p ]
+ 95 srcShapes = toShapes morphTolerance src
+ 96 dstShapes = toShapes morphTolerance dst
+ 97 pairs = morphObjectCorrespondence srcShapes dstShapes
+ 98 gens =
+ 99 [ (interpolateAttrs morphColorComponents srcAttr dstAttr, morphTrajectory arranged)
+ 100 | ((srcAttr, srcPoly'), (dstAttr, dstPoly')) <- pairs
+ 101 , let arranged = morphPointCorrespondence srcPoly' dstPoly'
+ 102 ]
+ 103
+ 104 -- | Add points to each polygon such that they end up with same size.
+ 105 normalizePolygons :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
+ 106 normalizePolygons src dst =
+ 107 (pAddPoints (max 0 $ dstN-srcN) src
+ 108 ,pAddPoints (max 0 $ srcN-dstN) dst)
+ 109 where
+ 110 srcN = pSize src
+ 111 dstN = pSize dst
+ 112
+ 113 interpolateAttrs :: ColorComponents -> DrawAttributes -> DrawAttributes -> Double -> DrawAttributes
+ 114 interpolateAttrs colorComps src dst t =
+ 115 src & fillColor .~ (interpColor <$> src^.fillColor <*> dst^.fillColor)
+ 116 & strokeColor .~ (interpColor <$> src^.strokeColor <*> dst^.strokeColor)
+ 117 & fillOpacity .~ (interpOpacity <$> src^.fillOpacity <*> dst^.fillOpacity)
+ 118 & groupOpacity .~ (interpOpacity <$> src^.groupOpacity <*> dst^.groupOpacity)
+ 119 & strokeOpacity .~ (interpOpacity <$> src^.strokeOpacity <*> dst^.strokeOpacity)
+ 120 where
+ 121 interpColor (ColorRef a) (ColorRef b) =
+ 122 ColorRef $ interpolateRGBA8 colorComps a b t
+ 123 -- interpolateColor (ColorRef a) FillNone = ColorRef a
+ 124 interpColor a _ = a
+ 125 interpOpacity a b = realToFrac (fromToS (realToFrac a) (realToFrac b) t)
+ 126
+ 127 -- | Object-correspondence algorithm that spawn objects as necessary.
+ 128 genesisObjectCorrespondence :: ObjectCorrespondence
+ 129 genesisObjectCorrespondence left right =
+ 130 case (left, right) of
+ 131 ([] , []) -> []
+ 132 ([], (y1,y2):ys) ->
+ 133 ((y1,y2), (y1, emptyFrom y2 y2)) : genesisObjectCorrespondence [] ys
+ 134 ((x1,x2):xs, []) ->
+ 135 ((x1,x2), (x1, emptyFrom x2 x2)) : genesisObjectCorrespondence xs []
+ 136 (x:xs, y:ys) ->
+ 137 (x,y) : genesisObjectCorrespondence xs ys
+ 138 where
+ 139 emptyFrom a b = mkPolygon $ V.map (const $ pCentroid a) (polygonPoints b)
+ 140
+ 141 -- | Object-correspondence algorithm that duplicate objects as necessary.
+ 142 dupObjectCorrespondence :: ObjectCorrespondence
+ 143 dupObjectCorrespondence left right =
+ 144 case (left, right) of
+ 145 (_, []) -> []
+ 146 ([], _) -> []
+ 147 ([x], [y]) ->
+ 148 [(x,y)]
+ 149 ([(x1,x2)], yShapes) ->
+ 150 let x2s = replicate (length yShapes) x2
+ 151 in dupObjectCorrespondence (map (x1,) x2s) yShapes
+ 152 (xShapes, [(y1,y2)]) ->
+ 153 let y2s = replicate (length xShapes) y2
+ 154 in dupObjectCorrespondence xShapes (map (y1,) y2s)
+ 155 (x:xs, y:ys) ->
+ 156 (x, y) : dupObjectCorrespondence xs ys
+ 157
+ 158 -- | Object-correspondence algorithm that splits objects in smaller pieces
+ 159 -- as necessary.
+ 160 splitObjectCorrespondence :: ObjectCorrespondence
+ 161 -- splitObjectCorrespondence = dupObjectCorrespondence
+ 162 splitObjectCorrespondence left right =
+ 163 case (left, right) of
+ 164 (_, []) -> []
+ 165 ([], _) -> []
+ 166 ([x], [y]) ->
+ 167 [(x,y)]
+ 168 ([(x1,x2)], yShapes) ->
+ 169 let x2s = splitPolygon (length yShapes) x2
+ 170 in splitObjectCorrespondence (map (x1,) x2s) yShapes
+ 171 (xShapes, [(y1,y2)]) ->
+ 172 let y2s = splitPolygon (length xShapes) y2
+ 173 in splitObjectCorrespondence xShapes (map (y1,) y2s)
+ 174 (x:xs, y:ys) ->
+ 175 (x,y) : splitObjectCorrespondence xs ys
+ 176
+ 177 splitPolygon :: Int -> Polygon -> [Polygon]
+ 178 splitPolygon 1 p = [p]
+ 179 splitPolygon n p =
+ 180 let (a,b) = pCutEqual p
+ 181 in splitPolygon (n`div`2) a ++ splitPolygon ((n+1)`div`2) b
+ 182
+ 183 -- joinPairs :: Correspondence -> [(DrawAttributes, PolyShape)] -> [(DrawAttributes, PolyShape)]
+ 184 -- -> [(DrawAttributes, DrawAttributes, [(RPoint, RPoint)])]
+ 185 -- joinPairs _ _ [] = []
+ 186 -- joinPairs _ [] _ = []
+ 187 -- joinPairs corr [(x1,x2)] [(y1,y2)] =
+ 188 -- [(x1,y1, corr x2 y2)]
+ 189 -- joinPairs corr [(x1,x2)] yShapes =
+ 190 -- let x2s = splitPolyShape 0.001 (length yShapes) x2
+ 191 -- in joinPairs corr (map (x1,) x2s) yShapes
+ 192 -- joinPairs corr xShapes [(y1,y2)] =
+ 193 -- let y2s = reverse $ splitPolyShape 0.001 (length xShapes) y2
+ 194 -- in joinPairs corr xShapes (map (y1,) y2s)
+ 195 -- joinPairs corr ((x1,x2):xs) ((y1,y2):ys) =
+ 196 -- (x1,y1, corr x2 y2) : joinPairs corr xs ys
+ 197 -- joinPairs _ _ _ = []
+ 198
+ 199 -- FIXME: sort by size, smallest to largest
+ 200 -- | Extract shapes and their graphical attributes from an SVG node.
+ 201 toShapes :: Double -> SVG -> [(DrawAttributes, Polygon)]
+ 202 toShapes tol src =
+ 203 [ (attrs, plToPolygon tol shape)
+ 204 | (_, attrs, glyph) <- svgGlyphs $ lowerTransformations $ pathify src
+ 205 , shape <- map mergePolyShapeHoles $ plGroupShapes $ svgToPolyShapes glyph
+ 206 ]
+ 207
+ 208 -- | Extract the first polygon in an SVG node. Will fail if there
+ 209 -- are no acceptable shapes.
+ 210 unsafeSVGToPolygon :: Double -> SVG -> Polygon
+ 211 unsafeSVGToPolygon tol src = snd $ head $ toShapes tol src
+ 212
+ 213 -- | Map over each polygon in an SVG node.
+ 214 annotatePolygons :: (Polygon -> SVG) -> SVG -> SVG
+ 215 annotatePolygons fn svg = mkGroup
+ 216 [ fn poly & drawAttributes .~ attr
+ 217 | (attr, poly) <- toShapes 0.001 svg
+ 218 ]
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Morph.Linear.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Morph.Linear.hs.html
new file mode 100644
index 0000000..5998766
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Morph.Linear.hs.html
@@ -0,0 +1,118 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Copyright : Written by David Himmelstrup
+ 3 License : Unlicense
+ 4 Maintainer : lemmih@gmail.com
+ 5 Stability : experimental
+ 6 Portability : POSIX
+ 7 -}
+ 8 module Reanimate.Morph.Linear
+ 9 ( linear, rawLinear
+ 10 , closestLinearCorrespondence
+ 11 , closestLinearCorrespondenceA
+ 12 , linearTrajectory
+ 13 ) where
+ 14
+ 15 import Data.Hashable
+ 16 import qualified Data.Vector as V
+ 17 import Linear.Vector
+ 18 import Reanimate.ColorComponents
+ 19 import Reanimate.Math.Common
+ 20 import Reanimate.Math.Polygon
+ 21 import Reanimate.Morph.Cache
+ 22 import Reanimate.Morph.Common
+ 23
+ 24 -- | Linear interpolation strategy.
+ 25 --
+ 26 -- Example:
+ 27 --
+ 28 -- @
+ 29 -- 'Reanimate.playThenReverseA' $ 'Reanimate.pauseAround' 0.5 0.5 $ 'Reanimate.mkAnimation' 3 $ \\t ->
+ 30 -- 'Reanimate.withStrokeLineJoin' 'Graphics.SvgTree.JoinRound' $
+ 31 -- let src = 'Reanimate.scale' 8 $ 'Reanimate.center' $ 'Reanimate.LaTeX.latex' \"X\"
+ 32 -- dst = 'Reanimate.scale' 8 $ 'Reanimate.center' $ 'Reanimate.LaTeX.latex' \"H\"
+ 33 -- in 'morph' 'linear' src dst t
+ 34 -- @
+ 35 --
+ 36 -- <<docs/gifs/doc_linear.gif>>
+ 37 linear :: Morph
+ 38 linear = rawLinear
+ 39 { morphPointCorrespondence =
+ 40 cachePointCorrespondence (hash ("closest"::String))
+ 41 closestLinearCorrespondence }
+ 42
+ 43 -- | Linear interpolation strategy without realigning corners.
+ 44 -- May give better results if the polygons are already aligned.
+ 45 -- Usually gives worse results.
+ 46 --
+ 47 -- Example:
+ 48 --
+ 49 -- @
+ 50 -- 'Reanimate.playThenReverseA' $ 'Reanimate.pauseAround' 0.5 0.5 $ 'Reanimate.mkAnimation' 3 $ \\t ->
+ 51 -- 'Reanimate.withStrokeLineJoin' 'Graphics.SvgTree.JoinRound' $
+ 52 -- let src = 'Reanimate.scale' 8 $ 'Reanimate.center' $ 'Reanimate.LaTeX.latex' \"X\"
+ 53 -- dst = 'Reanimate.scale' 8 $ 'Reanimate.center' $ 'Reanimate.LaTeX.latex' \"H\"
+ 54 -- in 'morph' 'rawLinear' src dst t
+ 55 -- @
+ 56 --
+ 57 -- <<docs/gifs/doc_rawLinear.gif>>
+ 58 rawLinear :: Morph
+ 59 rawLinear = Morph
+ 60 { morphTolerance = 0.001
+ 61 , morphColorComponents = labComponents
+ 62 , morphPointCorrespondence = normalizePolygons
+ 63 , morphTrajectory = linearTrajectory
+ 64 , morphObjectCorrespondence = splitObjectCorrespondence }
+ 65
+ 66 -- | Cycle polygons until the sum of the point trajectory path lengths
+ 67 -- is smallest.
+ 68 closestLinearCorrespondence :: PointCorrespondence
+ 69 closestLinearCorrespondence = closestLinearCorrespondenceA
+ 70
+ 71 -- | Cycle polygons until the sum of the point trajectory path lengths
+ 72 -- is smallest.
+ 73 closestLinearCorrespondenceA :: (Real a, Fractional a, Epsilon a) => APolygon a -> APolygon a -> (APolygon a, APolygon a)
+ 74 closestLinearCorrespondenceA src' dst' =
+ 75 (src, worker dst (score dst) options)
+ 76 where
+ 77 (src, dst) = normalizePolygons src' dst'
+ 78 worker bestP _bestPScore [] = bestP
+ 79 worker bestP bestPScore (x:xs) =
+ 80 let newScore = score x in
+ 81 if newScore < bestPScore
+ 82 then worker x newScore xs
+ 83 else worker bestP bestPScore xs
+ 84 options = pCycles dst
+ 85 score p = sum
+ 86 [ -- approxDist (pAccess src n) (pAccess p n)
+ 87 distSquared (pAccess src n) (pAccess p n)
+ 88 | n <- [0 .. pSize src-1] ]
+ 89
+ 90 -- | Strategy for moving points in a linear (straight-line) trajectory.
+ 91 linearTrajectory :: Trajectory
+ 92 linearTrajectory (src,dst)
+ 93 | pSize src == pSize dst = \t -> mkPolygon $
+ 94 V.zipWith (lerp $ realToFrac t) (polygonPoints dst) (polygonPoints src)
+ 95 | otherwise = error $ "Invalid lengths: " ++ show (pSize src, pSize dst)
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Parameters.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Parameters.hs.html
new file mode 100644
index 0000000..7bf78d5
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Parameters.hs.html
@@ -0,0 +1,145 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {- |
+ 2 Parameters define the global context of an animation. They are set once
+ 3 before an animation is rendered and may not change during rendering.
+ 4 -}
+ 5 module Reanimate.Parameters
+ 6 ( Raster(..)
+ 7 , Width
+ 8 , Height
+ 9 , FPS
+ 10 , pRaster
+ 11 , pFPS
+ 12 , pWidth
+ 13 , pHeight
+ 14 , pNoExternals
+ 15 , pRootDirectory
+ 16 , setRaster
+ 17 , setFPS
+ 18 , setWidth
+ 19 , setHeight
+ 20 , setNoExternals
+ 21 , setRootDirectory
+ 22 ) where
+ 23
+ 24 import System.IO.Unsafe
+ 25 import Data.IORef
+ 26
+ 27 -- | Width of animation in pixels.
+ 28 type Width = Int
+ 29 -- | Height of animation in pixels.
+ 30 type Height = Int
+ 31 -- | Framerate of animation in frames per second.
+ 32 type FPS = Int
+ 33
+ 34 -- | Raster engines turn SVG images into pixels.
+ 35 data Raster
+ 36 = RasterNone -- ^ Do not use any external raster engine. Rely on the browser or ffmpeg.
+ 37 | RasterAuto -- ^ Scan for installed raster engines and pick the fastest one.
+ 38 | RasterInkscape -- ^ Use Inkscape to raster SVG images.
+ 39 | RasterRSvg -- ^ Use rsvg-convert to raster SVG images.
+ 40 | RasterMagick -- ^ Use imagemagick to raster SVG images.
+ 41 deriving (Show, Eq)
+ 42
+ 43 {-# NOINLINE pRasterRef #-}
+ 44 pRasterRef :: IORef Raster
+ 45 pRasterRef = unsafePerformIO (newIORef RasterNone)
+ 46
+ 47 {-# NOINLINE pRaster #-}
+ 48 -- | Selected raster engine.
+ 49 pRaster :: Raster
+ 50 pRaster = unsafePerformIO (readIORef pRasterRef)
+ 51
+ 52 -- | Set raster engine.
+ 53 setRaster :: Raster -> IO ()
+ 54 setRaster = writeIORef pRasterRef
+ 55
+ 56 {-# NOINLINE pFPSRef #-}
+ 57 pFPSRef :: IORef FPS
+ 58 pFPSRef = unsafePerformIO (newIORef 0)
+ 59
+ 60 {-# NOINLINE pFPS #-}
+ 61 -- | Selected framerate.
+ 62 pFPS :: FPS
+ 63 pFPS = unsafePerformIO (readIORef pFPSRef)
+ 64
+ 65 -- | Set desired framerate.
+ 66 setFPS :: FPS -> IO ()
+ 67 setFPS = writeIORef pFPSRef
+ 68
+ 69 {-# NOINLINE pWidthRef #-}
+ 70 pWidthRef :: IORef FPS
+ 71 pWidthRef = unsafePerformIO (newIORef 0)
+ 72
+ 73 {-# NOINLINE pWidth #-}
+ 74 -- | Width of animation in pixel.
+ 75 pWidth :: Width
+ 76 pWidth = unsafePerformIO (readIORef pWidthRef)
+ 77
+ 78 -- | Set desired width of animation in pixel.
+ 79 setWidth :: Width -> IO ()
+ 80 setWidth = writeIORef pWidthRef
+ 81
+ 82 {-# NOINLINE pHeightRef #-}
+ 83 pHeightRef :: IORef FPS
+ 84 pHeightRef = unsafePerformIO (newIORef 0)
+ 85
+ 86 {-# NOINLINE pHeight #-}
+ 87 -- | Height of animation in pixel.
+ 88 pHeight :: Height
+ 89 pHeight = unsafePerformIO (readIORef pHeightRef)
+ 90
+ 91 -- | Set desired height of animation in pixel.
+ 92 setHeight :: Height -> IO ()
+ 93 setHeight = writeIORef pHeightRef
+ 94
+ 95 {-# NOINLINE pNoExternalsRef #-}
+ 96 pNoExternalsRef :: IORef Bool
+ 97 pNoExternalsRef = unsafePerformIO (newIORef False)
+ 98
+ 99 {-# NOINLINE pNoExternals #-}
+ 100 -- | This parameter determined whether or not external tools are allowed.
+ 101 -- If this flag is True then tools such as 'Reanimate.LaTeX.latex' and
+ 102 -- 'Reanimate.Blender.blender' will not be invoked.
+ 103 pNoExternals :: Bool
+ 104 pNoExternals = unsafePerformIO (readIORef pNoExternalsRef)
+ 105
+ 106 -- | Set whether external tools are allowed.
+ 107 setNoExternals :: Bool -> IO ()
+ 108 setNoExternals = writeIORef pNoExternalsRef
+ 109
+ 110 {-# NOINLINE pRootDirectoryRef #-}
+ 111 pRootDirectoryRef :: IORef FilePath
+ 112 pRootDirectoryRef = unsafePerformIO (newIORef (error "root directory not set"))
+ 113
+ 114 {-# NOINLINE pRootDirectory #-}
+ 115 -- | Root directory of animation. Images and other data has to be placed
+ 116 -- here if they are referenced in an SVG image.
+ 117 pRootDirectory :: FilePath
+ 118 pRootDirectory = unsafePerformIO (readIORef pRootDirectoryRef)
+ 119
+ 120 -- | Set the root animation directory.
+ 121 setRootDirectory :: FilePath -> IO ()
+ 122 setRootDirectory = writeIORef pRootDirectoryRef
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.PolyShape.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.PolyShape.hs.html
new file mode 100644
index 0000000..f9892fc
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.PolyShape.hs.html
@@ -0,0 +1,472 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Module : Reanimate.PolyShape
+ 3 Copyright : Written by David Himmelstrup
+ 4 License : Unlicense
+ 5 Maintainer : lemmih@gmail.com
+ 6 Stability : experimental
+ 7 Portability : POSIX
+ 8
+ 9 A PolyShape is a closed set of curves.
+ 10
+ 11 -}
+ 12 module Reanimate.PolyShape
+ 13 ( PolyShape(..)
+ 14 , PolyShapeWithHoles
+ 15 , svgToPolyShapes -- :: Tree -> [PolyShape]
+ 16 , svgToPolygons -- :: Double -> Svg -> [Polygon]
+ 17
+ 18 , renderPolyShape -- :: PolyShape -> Tree
+ 19 , renderPolyShapes -- :: [PolyShape] -> Tree
+ 20 , renderPolyShapePoints -- :: PolyShape -> Tree
+ 21
+ 22 , plPathCommands -- :: PolyShape -> [PathCommand]
+ 23 , plLineCommands -- :: PolyShape -> [LineCommand]
+ 24
+ 25 , plLength -- :: PolyShape -> Double
+ 26 , plArea
+ 27 , plCurves -- :: PolyShape -> [CubicBezier Double]
+ 28 , isInsideOf -- :: PolyShape -> PolyShape -> Bool
+ 29
+ 30 , plFromPolygon -- :: [RPoint] -> PolyShape
+ 31 , plToPolygon -- :: Double -> PolyShape -> Polygon
+ 32 , plDecompose -- :: [PolyShape] -> [[RPoint]]
+ 33 , unionPolyShapes -- :: [PolyShape] -> [PolyShape]
+ 34 , unionPolyShapes' -- :: Double -> [PolyShape] -> [PolyShape]
+ 35 , plDecompose' -- :: Double -> [PolyShape] -> [[RPoint]]
+ 36 , decomposePolygon -- :: [Point Double] -> [[RPoint]]
+ 37 , plGroupShapes -- :: [PolyShape] -> [PolyShapeWithHoles]
+ 38 , mergePolyShapeHoles -- :: PolyShapeWithHoles -> PolyShape
+ 39 , plPartial
+ 40 , plGroupTouching
+ 41 ) where
+ 42
+ 43 import Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate')
+ 44 import Control.Lens ((&), (.~), (^.))
+ 45 import Data.Ext
+ 46 import Data.Geometry.PlanarSubdivision (PolygonFaceData (..))
+ 47 import qualified Data.Geometry.Point as Geo
+ 48 import qualified Data.Geometry.Polygon as Geo
+ 49 import Data.List (nub, partition, sortOn)
+ 50 import qualified Data.PlaneGraph as Geo
+ 51 import Data.Proxy
+ 52 import qualified Data.Vector as V
+ 53 import Geom2D.CubicBezier.Linear (ClosedPath (..),
+ 54 CubicBezier (..),
+ 55 FillRule (..), PathJoin (..),
+ 56 QuadBezier (..), arcLength,
+ 57 arcLengthParam,
+ 58 bezierIntersection,
+ 59 bezierSubsegment,
+ 60 closedPathCurves, closest,
+ 61 colinear, curvesToClosed,
+ 62 evalBezier, quadToCubic,
+ 63 reorient, splitBezier, union,
+ 64 vectorDistance)
+ 65 import Graphics.SvgTree (PathCommand (..), RPoint,
+ 66 Tree, defaultSvg,
+ 67 pathDefinition, pathTree)
+ 68 import Linear.V2
+ 69 import Reanimate.Animation
+ 70 import Reanimate.Constants
+ 71 import Reanimate.Math.Polygon (Polygon, mkPolygon, pArea,
+ 72 pIsCCW)
+ 73 import Reanimate.Svg
+ 74
+ 75 -- | Shape drawn by continuous line. May have overlap, may be convex.
+ 76 newtype PolyShape = PolyShape { unPolyShape :: ClosedPath Double }
+ 77 deriving (Show)
+ 78
+ 79 -- | Polyshape with smaller, fully-enclosed holes.
+ 80 data PolyShapeWithHoles = PolyShapeWithHoles
+ 81 { polyShapeParent :: PolyShape
+ 82 , polyShapeHoles :: [PolyShape]
+ 83 }
+ 84
+ 85
+ 86 -- | Render a set of polyshapes as a single SVG path.
+ 87 renderPolyShapes :: [PolyShape] -> Tree
+ 88 renderPolyShapes pls =
+ 89 pathTree $ defaultSvg & pathDefinition .~ concatMap plPathCommands pls
+ 90
+ 91 -- | Render a polyshape as a single SVG path.
+ 92 renderPolyShape :: PolyShape -> Tree
+ 93 renderPolyShape pl =
+ 94 pathTree $ defaultSvg & pathDefinition .~ plPathCommands pl
+ 95
+ 96 -- | Render control-points of a polyshape as circles.
+ 97 renderPolyShapePoints :: PolyShape -> Tree
+ 98 renderPolyShapePoints = mkGroup . map renderPoint . plCurves
+ 99 where
+ 100 renderPoint (CubicBezier (V2 x y) _ _ _) =
+ 101 translate x y $ mkCircle 0.02
+ 102
+ 103 -- | Length of polyshape circumference.
+ 104 plLength :: PolyShape -> Double
+ 105 plLength = sum . map cubicLength . plCurves
+ 106 where
+ 107 cubicLength c = arcLength c 1 polyShapeTolerance
+ 108
+ 109 -- | Area of polyshape.
+ 110 plArea :: PolyShape -> Double
+ 111 plArea pl = realToFrac $ pArea $ plToPolygon polyShapeTolerance pl
+ 112
+ 113 -- 1/10th of a pixel if rendered at 2560x1440
+ 114 polyShapeTolerance :: Double
+ 115 polyShapeTolerance = screenWidth/25600
+ 116
+ 117 -- | Construct a polyshape from the vertices in a polygon.
+ 118 plFromPolygon :: [RPoint] -> PolyShape
+ 119 plFromPolygon = PolyShape . ClosedPath . map worker
+ 120 where
+ 121 worker val = (val, JoinLine)
+ 122
+ 123 -- | Approximate a polyshape as a polygon within the given tolerance.
+ 124 plToPolygon :: Double -> PolyShape -> Polygon
+ 125 plToPolygon tol pl =
+ 126 let p = V.init . V.fromList . map (fmap realToFrac) .
+ 127 plPolygonify tol $ pl
+ 128 in if pIsCCW (mkPolygon p) then mkPolygon p else mkPolygon (V.reverse p)
+ 129
+ 130 -- | Partially draw polyshape.
+ 131 plPartial :: Double -> PolyShape -> PolyShape
+ 132 plPartial delta pl | delta >= 1 = pl
+ 133 plPartial delta pl = PolyShape $ curvesToClosed (lineOut ++ [joinB] ++ lineIn)
+ 134 where
+ 135 lineOutEnd = cubicC3 (last lineOut)
+ 136 lineInBegin = cubicC0 (head lineIn)
+ 137 joinB = CubicBezier lineOutEnd lineOutEnd lineOutEnd lineInBegin
+ 138 lineOut = takeLen (len*delta/2) $ plCurves pl
+ 139 lineIn =
+ 140 reverse $ map reorient $
+ 141 takeLen (len*delta/2) $ reverse $ map reorient $ plCurves pl
+ 142 len = plLength pl
+ 143 takeLen _ [] = []
+ 144 takeLen l (c:cs) =
+ 145 let cLen = arcLength c 1 polyShapeTolerance in
+ 146 if l < cLen
+ 147 then [bezierSubsegment c 0 (arcLengthParam c l polyShapeTolerance)]
+ 148 else c : takeLen (l-cLen) cs
+ 149
+ 150 -- plPartial' :: Double -> ([RPoint], PolyShape) -> PolyShape
+ 151 -- plPartial' delta (seen', PolyShape (ClosedPath lst)) =
+ 152 -- case lst of
+ 153 -- [] -> PolyShape (ClosedPath [])
+ 154 -- (startP, startJoin) : rest -> PolyShape $ ClosedPath $
+ 155 -- (startP, startJoin) : worker startP rest
+ 156 -- where
+ 157 -- seen = filter (`elem` plPoints) seen'
+ 158 -- closestSeen pt = minimumBy (comparing (vectorDistance pt)) seen
+ 159 -- worker _ [] = []
+ 160 -- worker _ ((newP, newJoin) : rest)
+ 161 -- | newP `elem` seen = (newP, newJoin) : worker newP rest
+ 162 -- | otherwise =
+ 163 -- let newAt = interpolateVector (closestSeen newP) newP delta
+ 164 -- in (newAt, newJoin) : worker newAt rest
+ 165 -- plPoints =
+ 166 -- [ p | (p,_) <- lst ]
+ 167
+ 168 -- | Find intersection points.
+ 169 plGroupTouching :: [PolyShape] -> [[([RPoint],PolyShape)]]
+ 170 plGroupTouching [] = []
+ 171 plGroupTouching pls = worker [polyShapeOrigin (head pls)] pls
+ 172 where
+ 173 worker _ [] = []
+ 174 worker seen shapes =
+ 175 let (touching, notTouching) = partition (isTouching seen) shapes
+ 176 in if null touching
+ 177 then plGroupTouching notTouching
+ 178 else map ((,) seen . changeOrigin seen) touching :
+ 179 worker (seen ++ concatMap plPoints touching) notTouching
+ 180 isTouching pts = any (`elem` pts) . plPoints
+ 181 changeOrigin seen (PolyShape (ClosedPath segments)) = PolyShape $ ClosedPath $ helper [] segments
+ 182 where
+ 183 helper acc [] = reverse acc
+ 184 helper acc lst@((startP,startJ):rest)
+ 185 | startP `elem` seen = lst ++ reverse acc
+ 186 | otherwise = helper ((startP, startJ):acc) rest
+ 187 plPoints :: PolyShape -> [RPoint]
+ 188 plPoints (PolyShape (ClosedPath lst)) =
+ 189 [ p | (p,_) <- lst ]
+ 190
+ 191 -- | Deconstruct a polyshape into non-intersecting, convex polygons.
+ 192 plDecompose :: [PolyShape] -> [[RPoint]]
+ 193 plDecompose = plDecompose' 0.001
+ 194
+ 195 -- | Deconstruct a polyshape into non-intersecting, convex polygons.
+ 196 plDecompose' :: Double -> [PolyShape] -> [[RPoint]]
+ 197 plDecompose' tol =
+ 198 concatMap (decomposePolygon . plPolygonify tol . mergePolyShapeHoles) .
+ 199 plGroupShapes .
+ 200 unionPolyShapes
+ 201
+ 202 -- | Split polygon into smaller, convex polygons.
+ 203 decomposePolygon :: [RPoint] -> [[RPoint]]
+ 204 decomposePolygon poly =
+ 205 [ [ V2 x y
+ 206 | v <- V.toList (Geo.boundaryVertices f pg)
+ 207 , let Geo.Point2 x y = pg^.Geo.vertexDataOf v . Geo.location ]
+ 208 | (f, Inside) <- V.toList (Geo.internalFaces pg) ]
+ 209
+ 210 where
+ 211 pg = triangulate' Proxy p
+ 212 p = Geo.fromPoints $
+ 213 [ Geo.Point2 x y :+ ()
+ 214 | V2 x y <- poly ]
+ 215
+ 216 plPolygonify :: Double -> PolyShape -> [RPoint]
+ 217 plPolygonify tol shape =
+ 218 startPoint (head curves) : concatMap worker curves
+ 219 where
+ 220 curves = plCurves shape
+ 221 worker c | endPoint c == startPoint c =
+ 222 [] -- error $ "Bad bezier: " ++ show c
+ 223 worker c =
+ 224 if colinear c tol -- && arcLength c 1 tol < 1
+ 225 then [endPoint c]
+ 226 else
+ 227 let (lhs,rhs) = splitBezier c 0.5
+ 228 in worker lhs ++ worker rhs
+ 229 endPoint (CubicBezier _ _ _ d) = d
+ 230 startPoint (CubicBezier a _ _ _) = a
+ 231
+ 232 -- | Convert a polyshape to a list of SVG path commands.
+ 233 plPathCommands :: PolyShape -> [PathCommand]
+ 234 plPathCommands = lineToPath . plLineCommands
+ 235
+ 236 -- | Convert a polyshape to a list of line commands.
+ 237 plLineCommands :: PolyShape -> [LineCommand]
+ 238 plLineCommands pl =
+ 239 case curves of
+ 240 [] -> []
+ 241 (CubicBezier start _ _ _:_) ->
+ 242 LineMove start :
+ 243 zipWith worker (drop 1 dstList ++ [start]) joinList ++
+ 244 [LineEnd start]
+ 245 where
+ 246 ClosedPath closedPath = unPolyShape pl
+ 247 (dstList, joinList) = unzip closedPath
+ 248 curves = plCurves pl
+ 249 worker dst JoinLine =
+ 250 LineBezier [dst]
+ 251 worker dst (JoinCurve a b) =
+ 252 LineBezier [a,b,dst]
+ 253
+ 254 -- | Extract all shapes from SVG nodes. Drawing attributes such
+ 255 -- as stroke and fill color are discarded.
+ 256 svgToPolyShapes :: Tree -> [PolyShape]
+ 257 svgToPolyShapes = cmdsToPolyShapes . toLineCommands . extractPath
+ 258
+ 259 -- | Extract all polygons from SVG nodes. Curves are approximated to
+ 260 -- within the given tolerance.
+ 261 svgToPolygons :: Double -> SVG -> [Polygon]
+ 262 svgToPolygons tol = map (toPolygon . plPolygonify tol) . svgToPolyShapes
+ 263 where
+ 264 toPolygon :: [RPoint] -> Polygon
+ 265 toPolygon = mkPolygon .
+ 266 V.fromList . nub . map (fmap realToFrac)
+ 267
+ 268 cmdsToPolyShapes :: [LineCommand] -> [PolyShape]
+ 269 cmdsToPolyShapes [] = []
+ 270 cmdsToPolyShapes cmds =
+ 271 case cmds of
+ 272 (LineMove dst:cont) -> map PolyShape $ worker dst [] cont
+ 273 _ -> bad
+ 274 where
+ 275 bad = error $ "Reanimate.PolyShape: Invalid commands: " ++ show cmds
+ 276 finalize [] rest = rest
+ 277 finalize acc rest = ClosedPath (reverse acc) : rest
+ 278 worker _from acc [] = finalize acc []
+ 279 worker _from acc (LineMove newStart : xs) =
+ 280 finalize acc $
+ 281 worker newStart [] xs
+ 282 worker from acc (LineEnd orig:LineMove dst:xs) | from /= orig =
+ 283 finalize ((from, JoinLine):acc) $
+ 284 worker dst [] xs
+ 285 worker _from acc (LineEnd{}:LineMove dst:xs) =
+ 286 finalize acc $
+ 287 worker dst [] xs
+ 288 worker from acc [LineEnd orig] | from /= orig =
+ 289 finalize ((from, JoinLine):acc) []
+ 290 worker _from acc [LineEnd{}] =
+ 291 finalize acc []
+ 292 worker from acc (LineBezier [x]:xs) =
+ 293 worker x ((from, JoinLine) : acc) xs
+ 294 worker from acc (LineBezier [a,b]:xs) =
+ 295 let quad = QuadBezier from a b
+ 296 CubicBezier _ a' b' c' = quadToCubic quad
+ 297 in worker from acc (LineBezier [a',b',c']:xs)
+ 298 worker from acc (LineBezier [a,b,c]:xs) =
+ 299 worker c ((from, JoinCurve a b) : acc) xs
+ 300 worker _ _ _ = bad
+ 301
+ 302 -- | Merge overlapping shapes.
+ 303 unionPolyShapes :: [PolyShape] -> [PolyShape]
+ 304 unionPolyShapes shapes =
+ 305 map PolyShape $
+ 306 union (map unPolyShape shapes) FillNonZero (polyShapeTolerance/10000)
+ 307
+ 308 -- | Merge overlapping shapes to within given tolerance.
+ 309 unionPolyShapes' :: Double -> [PolyShape] -> [PolyShape]
+ 310 unionPolyShapes' tol shapes =
+ 311 map PolyShape $
+ 312 union (map unPolyShape shapes) FillNonZero tol
+ 313
+ 314 -- | True iff lhs is inside of rhs.
+ 315 -- lhs and rhs may not overlap.
+ 316 -- Implementation: Trace a vertical line through the origin of A and check
+ 317 -- of this line intersects and odd number of times on both sides of A.
+ 318 isInsideOf :: PolyShape -> PolyShape -> Bool
+ 319 lhs `isInsideOf` rhs =
+ 320 odd (length upHits) && odd (length downHits)
+ 321 where
+ 322 (upHits, downHits) = polyIntersections origin rhs
+ 323 origin = polyShapeOrigin lhs
+ 324
+ 325 polyIntersections :: RPoint -> PolyShape -> ([RPoint],[RPoint])
+ 326 polyIntersections origin rhs =
+ 327 (nub $ concatMap (intersections rayUp) curves
+ 328 ,nub $ concatMap (intersections rayDown) curves)
+ 329 where
+ 330 curves = plCurves rhs
+ 331
+ 332 intersections line bs =
+ 333 map (evalBezier bs . fst) (bezierIntersection bs line polyShapeTolerance)
+ 334 limit = 1000
+ 335 rayUp = CubicBezier origin origin origin (V2 limit limit)
+ 336 rayDown = CubicBezier origin origin origin (V2 (-limit) (-limit))
+ 337
+ 338 polyShapeOrigin :: PolyShape -> V2 Double
+ 339 polyShapeOrigin (PolyShape closedPath) =
+ 340 case closedPath of
+ 341 ClosedPath [] -> V2 0 0
+ 342 ClosedPath ((start,_):_) -> start
+ 343
+ 344 -- | Find holes and group them with their parent.
+ 345 plGroupShapes :: [PolyShape] -> [PolyShapeWithHoles]
+ 346 plGroupShapes = worker
+ 347 where
+ 348 worker (s:rest)
+ 349 | null (parents s rest) =
+ 350 let isOnlyChild x = parents x (s:rest) == [s]
+ 351 (holes, nonHoles) = partition isOnlyChild rest
+ 352 prime = PolyShapeWithHoles
+ 353 { polyShapeParent = s
+ 354 , polyShapeHoles = holes }
+ 355 in prime : worker nonHoles
+ 356 | otherwise = worker (rest ++ [s])
+ 357 worker [] = []
+ 358
+ 359 parents :: PolyShape -> [PolyShape] -> [PolyShape]
+ 360 parents self = filter (self `isInsideOf`) . filter (/=self)
+ 361
+ 362 instance Eq PolyShape where
+ 363 a == b = plCurves a == plCurves b
+ 364
+ 365 -- | Cut out holes.
+ 366 mergePolyShapeHoles :: PolyShapeWithHoles -> PolyShape
+ 367 mergePolyShapeHoles (PolyShapeWithHoles parent []) = parent
+ 368 mergePolyShapeHoles (PolyShapeWithHoles parent (child:children)) =
+ 369 mergePolyShapeHoles $
+ 370 PolyShapeWithHoles (mergePolyShapeHole parent child) children
+ 371
+ 372 -- Merge
+ 373 mergePolyShapeHole :: PolyShape -> PolyShape -> PolyShape
+ 374 mergePolyShapeHole parent child =
+ 375 snd $ head $
+ 376 sortOn fst
+ 377 [ cutSingleHole newParent child
+ 378 | newParent <- polyShapePermutations parent ]
+ 379
+ 380 {-
+ 381 parent:
+ 382 (a,b)
+ 383 (b,c)
+ 384 (c,a)
+ 385
+ 386 child:
+ 387 (x,y)
+ 388 (y,z)
+ 389 (z,x)
+ 390
+ 391 P = split (a,b)
+ 392 new:
+ 393 (P,b) p2b
+ 394 (b,c) pTail
+ 395 (c,a) pTail
+ 396 (a,P) a2p
+ 397
+ 398 (P,x) p2x
+ 399
+ 400 (x,y) childCurves
+ 401 (y,z) childCurves
+ 402 (z,x) childCurves
+ 403
+ 404 (x,P) x2p
+ 405
+ 406 -}
+ 407 cutSingleHole :: PolyShape -> PolyShape -> (Double, PolyShape)
+ 408 cutSingleHole parent child =
+ 409 (score, PolyShape $ curvesToClosed $
+ 410 p2b:pTail ++ [a2p] ++
+ 411 [p2x] ++ childCurves ++
+ 412 [x2p]
+ 413 )
+ 414 where
+ 415 -- vect = (childOrigin - p) * 0 -- 0.0001
+ 416 vectL = 0 -- rotate90L $* vect
+ 417 vectR = 0 -- rotate90R $* vect
+ 418 score = vectorDistance childOrigin p
+ 419 childOrigin = polyShapeOrigin child
+ 420 childOrigin' = childOrigin - vectL
+ 421 (pHead:pTail) = plCurves parent
+ 422 childCurves = plCurves child
+ 423
+ 424 pParam = closest pHead childOrigin polyShapeTolerance
+ 425
+ 426 (a2p, p2b') = splitBezier pHead pParam
+ 427 p2b = case p2b' of
+ 428 CubicBezier a b c d -> CubicBezier (a - vectL) b c d
+ 429
+ 430 p = evalBezier pHead pParam
+ 431 -- straight line to child origin
+ 432 p2x = lineBetween (p - vectR) childOrigin
+ 433 -- straight line from child origin
+ 434 x2p = lineBetween childOrigin' p
+ 435
+ 436 lineBetween a = CubicBezier a a a
+ 437
+ 438 -- | Destruct a polyshape into constituent curves.
+ 439 plCurves :: PolyShape -> [CubicBezier Double]
+ 440 plCurves = closedPathCurves . unPolyShape
+ 441
+ 442 polyShapePermutations :: PolyShape -> [PolyShape]
+ 443 polyShapePermutations =
+ 444 map (PolyShape . curvesToClosed) . cycleList . plCurves
+ 445 where
+ 446 cycleList lst =
+ 447 let n = length lst in
+ 448 [ take n $ drop i $ cycle lst
+ 449 | i <- [0.. n-1] ]
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Raster.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Raster.hs.html
new file mode 100644
index 0000000..3b64dd6
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Raster.hs.html
@@ -0,0 +1,339 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Module : Reanimate.Raster
+ 3 Copyright : Written by David Himmelstrup
+ 4 License : Unlicense
+ 5 Maintainer : lemmih@gmail.com
+ 6 Stability : experimental
+ 7 Portability : POSIX
+ 8
+ 9 Tools for generating, manipulating, and embedding raster images.
+ 10
+ 11 -}
+ 12 module Reanimate.Raster
+ 13 ( mkImage -- :: Double -> Double -> FilePath -> SVG
+ 14 , cacheImage -- :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath
+ 15 , prerenderSvg -- :: Hashable a => a -> SVG -> SVG
+ 16 , prerenderSvgFile -- :: Hashable a => a -> Width -> Height -> SVG -> FilePath
+ 17 , embedImage -- :: PngSavable a => Image a -> SVG
+ 18 , embedDynamicImage -- :: DynamicImage -> SVG
+ 19 , embedPng -- :: Double -> Double -> LBS.ByteString -> SVG
+ 20 , raster -- :: SVG -> DynamicImage
+ 21 , rasterSized -- :: Width -> Height -> SVG -> DynamicImage
+ 22 , vectorize -- :: FilePath -> SVG
+ 23 , vectorize_ -- :: [String] -> FilePath -> SVG
+ 24 , svgAsPngFile -- :: SVG -> FilePath
+ 25 , svgAsPngFile' -- :: Width -> Height -> SVG -> FilePath
+ 26 )
+ 27 where
+ 28
+ 29 import Codec.Picture
+ 30 import Control.Lens ( (&)
+ 31 , (.~)
+ 32 )
+ 33 import Control.Monad
+ 34 import qualified Data.ByteString as B
+ 35 import qualified Data.ByteString.Base64.Lazy as Base64
+ 36 import qualified Data.ByteString.Lazy.Char8 as LBS
+ 37 import Data.Hashable
+ 38 import qualified Data.Text as T
+ 39 import Graphics.SvgTree ( Number(..)
+ 40 , defaultSvg
+ 41 , parseSvgFile
+ 42 )
+ 43 import qualified Graphics.SvgTree as Svg
+ 44 import Reanimate.Animation
+ 45 import Reanimate.Cache
+ 46 import Reanimate.Driver.Magick
+ 47 import Reanimate.Misc
+ 48 import Reanimate.Render
+ 49 import Reanimate.Parameters
+ 50 import Reanimate.Constants
+ 51 import Reanimate.Svg.Constructors
+ 52 import Reanimate.Svg.Unuse
+ 53 import System.Directory
+ 54 import System.FilePath
+ 55 import System.IO
+ 56 import System.IO.Temp
+ 57 import System.IO.Unsafe
+ 58
+ 59 -- | Load an external image. Width and height must be specified,
+ 60 -- ignoring the image's aspect ratio. The center of the image is
+ 61 -- placed at position (0,0).
+ 62 --
+ 63 -- For security reasons, must SVG renderer do not allow arbitrary
+ 64 -- image links. For some renderers, we can get around this by placing
+ 65 -- the images in the same root directory as the parent SVG file. Other
+ 66 -- renderers (like Chrome and ffmpeg) requires that the image is inlined
+ 67 -- as base64 data. External SVG files are an exception, though, as must
+ 68 -- always be inlined directly. `mkImage` attempts to hide all the complexity
+ 69 -- but edge-cases may exist.
+ 70 --
+ 71 -- Example:
+ 72 --
+ 73 -- @
+ 74 -- 'mkImage' 'screenWidth' 'screenHeight' \"..\/data\/haskell.svg\"
+ 75 -- @
+ 76 --
+ 77 -- <<docs/gifs/doc_mkImage.gif>>
+ 78 mkImage
+ 79 :: Double -- ^ Desired image width.
+ 80 -> Double -- ^ Desired image height.
+ 81 -> FilePath -- ^ Path to external image file.
+ 82 -> SVG
+ 83 mkImage width height path | takeExtension path == ".svg" = unsafePerformIO $ do
+ 84 svg_data <- B.readFile path
+ 85 case parseSvgFile path svg_data of
+ 86 Nothing -> error "Malformed svg"
+ 87 Just svg ->
+ 88 return
+ 89 $ scaleXY (width / screenWidth) (height / screenHeight)
+ 90 $ embedDocument svg
+ 91 mkImage width height path | pRaster == RasterNone = unsafePerformIO $ do
+ 92 inp <- LBS.readFile path
+ 93 let imgData = LBS.unpack $ Base64.encode inp
+ 94 return
+ 95 $ flipYAxis
+ 96 $ Svg.imageTree
+ 97 $ defaultSvg
+ 98 & Svg.imageWidth
+ 99 .~ Svg.Num width
+ 100 & Svg.imageHeight
+ 101 .~ Svg.Num height
+ 102 & Svg.imageHref
+ 103 .~ ("data:" ++ mimeType ++ ";base64," ++ imgData)
+ 104 & Svg.imageCornerUpperLeft
+ 105 .~ (Svg.Num (-width / 2), Svg.Num (-height / 2))
+ 106 & Svg.imageAspectRatio
+ 107 .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing
+ 108 where
+ 109 -- FIXME: Is there a better way to do this?
+ 110 mimeType = case takeExtension path of
+ 111 ".jpg" -> "image/jpeg"
+ 112 ext -> "image/" ++ drop 1 ext
+ 113 mkImage width height path = unsafePerformIO $ do
+ 114 exists <- doesFileExist target
+ 115 unless exists $ copyFile path target
+ 116 return
+ 117 $ flipYAxis
+ 118 $ Svg.imageTree
+ 119 $ defaultSvg
+ 120 & Svg.imageWidth
+ 121 .~ Svg.Num width
+ 122 & Svg.imageHeight
+ 123 .~ Svg.Num height
+ 124 & Svg.imageHref
+ 125 .~ ("file://" ++ target)
+ 126 & Svg.imageCornerUpperLeft
+ 127 .~ (Svg.Num (-width / 2), Svg.Num (-height / 2))
+ 128 & Svg.imageAspectRatio
+ 129 .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing
+ 130 where
+ 131 target = pRootDirectory </> encodeInt hashPath <.> takeExtension path
+ 132 hashPath = hash path
+ 133
+ 134 -- | Write in-memory image to cache file if (and only if) such cache file doesn't
+ 135 -- already exist.
+ 136 cacheImage :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath
+ 137 cacheImage key gen = unsafePerformIO $ cacheFile template $ \path ->
+ 138 writePng path gen
+ 139 where template = encodeInt (hash key) <.> "png"
+ 140
+ 141 -- Warning: Caching svg elements with links to external objects does
+ 142 -- not work. 2020-06-01
+ 143 -- | Same as 'prerenderSvg' but returns the location of the rendered image
+ 144 -- as a FilePath.
+ 145 prerenderSvgFile :: Hashable a => a -> Width -> Height -> SVG -> FilePath
+ 146 prerenderSvgFile key width height svg =
+ 147 unsafePerformIO $ cacheFile template $ \path -> do
+ 148 let svgPath = replaceExtension path "svg"
+ 149 writeFile svgPath rendered
+ 150 engine <- requireRaster pRaster
+ 151 applyRaster engine svgPath
+ 152 where
+ 153 template = encodeInt (hash (key, width, height)) <.> "png"
+ 154 rendered = renderSvg (Just $ Px $ fromIntegral width)
+ 155 (Just $ Px $ fromIntegral height)
+ 156 svg
+ 157
+ 158 -- | Render SVG node to a PNG file and return a new node containing
+ 159 -- that image. For static SVG nodes, this can hugely improve performance.
+ 160 -- The first argument is the key that determines SVG uniqueness. It
+ 161 -- is entirely your responsibility to ensure that all keys are unique.
+ 162 -- If they are not, you will be served stale results from the cache.
+ 163 prerenderSvg :: Hashable a => a -> SVG -> SVG
+ 164 prerenderSvg key =
+ 165 mkImage screenWidth screenHeight . prerenderSvgFile key pWidth pHeight
+ 166
+ 167
+ 168 {-# INLINE embedImage #-}
+ 169 -- | Embed an in-memory PNG image. Note, the pixel size of the image
+ 170 -- is used as the dimensions. As such, embedding a 100x100 PNG will
+ 171 -- result in an image 100 units wide and 100 units high. Consider
+ 172 -- using with 'scaleToSize'.
+ 173 embedImage :: PngSavable a => Image a -> SVG
+ 174 embedImage img = embedPng width height (encodePng img)
+ 175 where
+ 176 width = fromIntegral $ imageWidth img
+ 177 height = fromIntegral $ imageHeight img
+ 178
+ 179 -- | Embed in-memory PNG bytestring without parsing it.
+ 180 embedPng
+ 181 :: Double -- ^ Width
+ 182 -> Double -- ^ Height
+ 183 -> LBS.ByteString -- ^ Raw PNG data
+ 184 -> SVG
+ 185 -- embedPng w h png = unsafePerformIO $ do
+ 186 -- LBS.writeFile path png
+ 187 -- return $ ImageTree $ defaultSvg
+ 188 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2))
+ 189 -- & Svg.imageWidth .~ Svg.Num w
+ 190 -- & Svg.imageHeight .~ Svg.Num h
+ 191 -- & Svg.imageHref .~ ("file://"++path)
+ 192 -- where
+ 193 -- path = "/tmp" </> show (hash png) <.> "png"
+ 194 embedPng w h png =
+ 195 flipYAxis
+ 196 $ Svg.imageTree
+ 197 $ defaultSvg
+ 198 & Svg.imageCornerUpperLeft
+ 199 .~ (Svg.Num (-w / 2), Svg.Num (-h / 2))
+ 200 & Svg.imageWidth
+ 201 .~ Svg.Num w
+ 202 & Svg.imageHeight
+ 203 .~ Svg.Num h
+ 204 & Svg.imageHref
+ 205 .~ ("data:image/png;base64," ++ imgData)
+ 206 where imgData = LBS.unpack $ Base64.encode png
+ 207
+ 208
+ 209 {-# INLINE embedDynamicImage #-}
+ 210 -- | Embed an in-memory image. Note, the pixel size of the image
+ 211 -- is used as the dimensions. As such, embedding a 100x100 image will
+ 212 -- result in an image 100 units wide and 100 units high. Consider
+ 213 -- using with 'scaleToSize'.
+ 214 embedDynamicImage :: DynamicImage -> SVG
+ 215 embedDynamicImage img = embedPng width height imgData
+ 216 where
+ 217 width = fromIntegral $ dynamicMap imageWidth img
+ 218 height = fromIntegral $ dynamicMap imageHeight img
+ 219 imgData = case encodeDynamicPng img of
+ 220 Left err -> error err
+ 221 Right dat -> dat
+ 222
+ 223 -- embedImageFile :: FilePath -> Tree
+ 224 -- embedImageFile path = unsafePerformIO $ do
+ 225 -- png <- B.readFile path
+ 226 -- case decodePng png of
+ 227 -- Left{} -> error "bad image"
+ 228 -- Right img -> return $
+ 229 -- let width = fromIntegral $ dynamicMap imageWidth img
+ 230 -- height = fromIntegral $ dynamicMap imageHeight img in
+ 231 -- ImageTree $ defaultSvg
+ 232 -- & Svg.imageCornerUpperLeft .~ (Svg.Num (-width/2), Svg.Num (-height/2))
+ 233 -- & Svg.imageWidth .~ Svg.Num width
+ 234 -- & Svg.imageHeight .~ Svg.Num height
+ 235 -- & Svg.imageHref .~ ("file://" ++ path)
+ 236
+ 237
+ 238 -- | Convert an SVG object to a pixel-based image. The default resolution
+ 239 -- is 2560x1440. See also 'rasterSized'. Multiple raster engines are supported
+ 240 -- and are selected using the '--raster' flag in the driver.
+ 241 raster :: SVG -> DynamicImage
+ 242 raster = rasterSized 2560 1440
+ 243
+ 244 -- | Convert an SVG object to a pixel-based image.
+ 245 rasterSized
+ 246 :: Width -- ^ X resolution in pixels
+ 247 -> Height -- ^ Y resolution in pixels
+ 248 -> SVG -- ^ SVG object
+ 249 -> DynamicImage
+ 250 rasterSized w h svg = unsafePerformIO $ do
+ 251 png <- B.readFile (svgAsPngFile' w h svg)
+ 252 case decodePng png of
+ 253 Left{} -> error "bad image"
+ 254 Right img -> return img
+ 255
+ 256 -- | Use \'potrace\' to trace edges in a raster image and convert them to SVG polygons.
+ 257 vectorize :: FilePath -> SVG
+ 258 vectorize = vectorize_ []
+ 259
+ 260 -- | Same as 'vectorize' but takes a list of arguments for \'potrace\'.
+ 261 vectorize_ :: [String] -> FilePath -> SVG
+ 262 vectorize_ _ path | pNoExternals = mkText $ T.pack path
+ 263 vectorize_ args path = unsafePerformIO $ do
+ 264 root <- getXdgDirectory XdgCache "reanimate"
+ 265 createDirectoryIfMissing True root
+ 266 let svgPath = root </> encodeInt key <.> "svg"
+ 267 hit <- doesFileExist svgPath
+ 268 unless hit $ withSystemTempFile "file.svg" $ \tmpSvgPath svgH ->
+ 269 withSystemTempFile "file.bmp" $ \tmpBmpPath bmpH -> do
+ 270 hClose svgH
+ 271 hClose bmpH
+ 272 potrace <- requireExecutable "potrace"
+ 273 magick <- requireExecutable magickCmd
+ 274 runCmd magick [path, "-flatten", tmpBmpPath]
+ 275 runCmd potrace (args ++ ["--svg", "--output", tmpSvgPath, tmpBmpPath])
+ 276 renameOrCopyFile tmpSvgPath svgPath
+ 277 svg_data <- B.readFile svgPath
+ 278 case parseSvgFile svgPath svg_data of
+ 279 Nothing -> do
+ 280 removeFile svgPath
+ 281 error "Malformed svg"
+ 282 Just svg -> return $ unbox $ replaceUses svg
+ 283 where key = hash (path, args)
+ 284
+ 285 -- imageAsFile :: DynamicImage -> FilePath
+ 286 -- imageAsFile img
+ 287
+ 288 -- | Convert an SVG object to a pixel-based image and save it to disk, returning
+ 289 -- the filepath. The default resolution is 2560x1440. See also 'svgAsPngFile''.
+ 290 -- Multiple raster engines are supported and are selected using the '--raster'
+ 291 -- flag in the driver.
+ 292 svgAsPngFile :: SVG -> FilePath
+ 293 svgAsPngFile = svgAsPngFile' width height
+ 294 where
+ 295 width = 2560
+ 296 height = width * 9 `div` 16
+ 297
+ 298 -- | Convert an SVG object to a pixel-based image and save it to disk, returning
+ 299 -- the filepath.
+ 300 svgAsPngFile'
+ 301 :: Width -- ^ Width
+ 302 -> Height -- ^ Height
+ 303 -> SVG -- ^ SVG object
+ 304 -> FilePath
+ 305 svgAsPngFile' _ _ _ | pNoExternals = "/svgAsPngFile/has/been/disabled"
+ 306 svgAsPngFile' width height svg =
+ 307 unsafePerformIO $ cacheFile template $ \pngPath -> do
+ 308 let svgPath = replaceExtension pngPath "svg"
+ 309 writeFile svgPath rendered
+ 310 engine <- requireRaster pRaster
+ 311 applyRaster engine svgPath
+ 312 where
+ 313 template = encodeInt (hash rendered) <.> "png"
+ 314 rendered = renderSvg (Just $ Px $ fromIntegral width)
+ 315 (Just $ Px $ fromIntegral height)
+ 316 svg
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Render.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Render.hs.html
new file mode 100644
index 0000000..73ea755
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Render.hs.html
@@ -0,0 +1,445 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE MultiWayIf #-}
+ 2 {-|
+ 3 Copyright : Written by David Himmelstrup
+ 4 License : Unlicense
+ 5 Maintainer : lemmih@gmail.com
+ 6 Stability : experimental
+ 7 Portability : POSIX
+ 8
+ 9 Internal tools for rastering SVGs and rendering videos. You are unlikely
+ 10 to ever directly use the functions in this module.
+ 11
+ 12 -}
+ 13 module Reanimate.Render
+ 14 ( render
+ 15 , renderSvgs
+ 16 , renderSnippets -- :: Animation -> IO ()
+ 17 , renderLimitedFrames
+ 18 , Format(..)
+ 19 , Raster(..)
+ 20 , Width, Height, FPS
+ 21 , requireRaster -- :: Raster -> IO Raster
+ 22 , selectRaster -- :: Raster -> IO Raster
+ 23 , applyRaster -- :: Raster -> FilePath -> IO ()
+ 24 ) where
+ 25
+ 26 import Control.Concurrent
+ 27 import Control.Exception
+ 28 import Control.Monad (forM_, forever, unless, void, when)
+ 29 import Data.Either
+ 30 import Data.Function
+ 31 import qualified Data.Text as T
+ 32 import qualified Data.Text.IO as T
+ 33 import Data.Time
+ 34 import Graphics.SvgTree (Number (..))
+ 35 import Numeric
+ 36 import Reanimate.Animation
+ 37 import Reanimate.Driver.Check
+ 38 import Reanimate.Driver.Magick
+ 39 import Reanimate.Misc
+ 40 import Reanimate.Parameters
+ 41 import System.Console.ANSI.Codes
+ 42 import System.Exit
+ 43 import System.FileLock (withTryFileLock, SharedExclusive(..), unlockFile)
+ 44 import System.Directory
+ 45 import System.FilePath (replaceExtension, (<.>), (</>))
+ 46 import System.IO
+ 47 import Text.Printf (printf)
+ 48
+ 49 idempotentFile :: FilePath -> IO () -> IO ()
+ 50 idempotentFile path action = do
+ 51 _ <- withTryFileLock lockFile Exclusive $ \lock -> do
+ 52 haveFile <- doesFileExist path
+ 53 unless haveFile action
+ 54 unlockFile lock
+ 55 _ <- try (removeFile lockFile) :: IO (Either SomeException ())
+ 56 return ()
+ 57 return ()
+ 58 where
+ 59 lockFile = path <.> "lock"
+ 60
+ 61 -- | Generate SVGs at 60fps and put them in a folder.
+ 62 renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO ()
+ 63 renderSvgs folder offset _prettyPrint ani = do
+ 64 print frameCount
+ 65 lock <- newMVar ()
+ 66 handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do
+ 67 let nth = (nth'+offset) `mod` frameCount
+ 68 now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
+ 69 frame = frameAt (if frameCount <= 1 then 0 else now) ani
+ 70 path = folder </> show nth <.> "svg"
+ 71 ~svg = renderSvg Nothing Nothing frame
+ 72
+ 73 idempotentFile path $
+ 74 writeFile path svg
+ 75 withMVar lock $ \_ -> do
+ 76 print nth
+ 77 hFlush stdout
+ 78 where
+ 79 rate = 60
+ 80 frameCount = round (duration ani * fromIntegral rate) :: Int
+ 81 errHandler (ErrorCall msg) = do
+ 82 hPutStrLn stderr msg
+ 83 exitWith (ExitFailure 1)
+ 84
+ 85 -- | Render as many frames as possible in 2 seconds. Limited to 20 frames.
+ 86 renderLimitedFrames :: FilePath -> Int -> Bool -> Int -> Animation -> IO ()
+ 87 renderLimitedFrames folder offset _prettyPrint rate ani = do
+ 88 now <- getCurrentTime
+ 89 worker (addUTCTime timeLimit now) frameLimit (frameOrder rate frameCount)
+ 90 where
+ 91 timeLimit = 2
+ 92 frameLimit = 20 :: Int
+ 93 worker _ 0 _ = return ()
+ 94 worker _ _ [] = putStrLn "Done"
+ 95 worker localTimeLimit l (x:xs) = do
+ 96 curTime <- getCurrentTime
+ 97 if curTime > localTimeLimit
+ 98 then return ()
+ 99 else do
+ 100 let nth = (x+offset) `mod` frameCount
+ 101 now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
+ 102 frame = frameAt (if frameCount <= 1 then 0 else now) ani
+ 103 svg = renderSvg Nothing Nothing frame
+ 104 path = folder </> show nth <.> "svg"
+ 105 tmpPath = path <.> "tmp"
+ 106 haveFile <- doesFileExist path
+ 107 if haveFile
+ 108 then worker localTimeLimit l xs
+ 109 else do
+ 110 writeFile tmpPath svg
+ 111 renameOrCopyFile tmpPath path
+ 112 print nth
+ 113 worker localTimeLimit (l-1) xs
+ 114 frameCount = round (duration ani * fromIntegral rate) :: Int
+ 115
+ 116 -- XXX: Merge with 'renderSvgs'
+ 117 -- | Render 10 frames and print them to stdout. Used for testing.
+ 118 --
+ 119 -- XXX: Not related to the snippets in the playground.
+ 120 renderSnippets :: Animation -> IO ()
+ 121 renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do
+ 122 let now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
+ 123 frame = frameAt now ani
+ 124 svg = renderSvg Nothing Nothing frame
+ 125 putStr (show nth)
+ 126 T.putStrLn $ T.concat . T.lines . T.pack $ svg
+ 127 where frameCount = 10 :: Integer
+ 128
+ 129 frameOrder :: Int -> Int -> [Int]
+ 130 frameOrder fps nFrames = worker [] fps
+ 131 where
+ 132 worker _seen 0 = []
+ 133 worker seen nthFrame = filterFrameList seen nthFrame nFrames
+ 134 ++ worker (nthFrame : seen) (nthFrame `div` 2)
+ 135
+ 136 filterFrameList :: [Int] -> Int -> Int -> [Int]
+ 137 filterFrameList seen nthFrame nFrames = filter (not . isSeen)
+ 138 [0, nthFrame .. nFrames - 1]
+ 139 where isSeen x = any (\y -> x `mod` y == 0) seen
+ 140
+ 141 -- | Video formats supported by reanimate.
+ 142 data Format = RenderMp4 | RenderGif | RenderWebm
+ 143 deriving (Show)
+ 144
+ 145 mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
+ 146 mp4Arguments fps progress template target =
+ 147 [ "-r"
+ 148 , show fps
+ 149 , "-i"
+ 150 , template
+ 151 , "-y"
+ 152 , "-c:v"
+ 153 , "libx264"
+ 154 , "-vf"
+ 155 , "fps=" ++ show fps
+ 156 , "-preset"
+ 157 , "slow"
+ 158 , "-crf"
+ 159 , "18"
+ 160 , "-movflags"
+ 161 , "+faststart"
+ 162 , "-progress"
+ 163 , progress
+ 164 , "-pix_fmt"
+ 165 , "yuv420p"
+ 166 , target
+ 167 ]
+ 168
+ 169 -- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
+ 170 -- gifArguments fps progress template target =
+ 171
+ 172 -- | Render animation to a video file with given parameters.
+ 173 render
+ 174 :: Animation
+ 175 -> FilePath
+ 176 -> Raster
+ 177 -> Format
+ 178 -> Width
+ 179 -> Height
+ 180 -> FPS
+ 181 -> Bool
+ 182 -> IO ()
+ 183 render ani target raster format width height fps partial = do
+ 184 printf "Starting render of animation: %.1f\n" (duration ani)
+ 185 ffmpeg <- requireExecutable "ffmpeg"
+ 186 generateFrames raster ani width height fps partial $ \template ->
+ 187 withTempFile "txt" $ \progress -> do
+ 188 writeFile progress ""
+ 189 progressH <- openFile progress ReadMode
+ 190 hSetBuffering progressH NoBuffering
+ 191 allFinished <- newEmptyMVar
+ 192 void $ forkIO $ do
+ 193 progressPrinter "rendered" (animationFrameCount ani fps)
+ 194 $ \done -> fix $ \loop -> do
+ 195 eof <- hIsEOF progressH
+ 196 if eof
+ 197 then threadDelay 1000000 >> loop
+ 198 else do
+ 199 l <- try (hGetLine progressH)
+ 200 case l of
+ 201 Left SomeException{} -> return ()
+ 202 Right str ->
+ 203 case take 6 str of
+ 204 "frame=" -> do
+ 205 void $ swapMVar done (read (drop 6 str))
+ 206 loop
+ 207 _ | str == "progress=end" -> return ()
+ 208 _ -> loop
+ 209 putMVar allFinished ()
+ 210 case format of
+ 211 RenderMp4 -> runCmd ffmpeg (mp4Arguments fps progress template target)
+ 212 RenderGif -> withTempFile "png" $ \palette -> do
+ 213 runCmd
+ 214 ffmpeg
+ 215 [ "-i"
+ 216 , template
+ 217 , "-y"
+ 218 , "-vf"
+ 219 , "fps="
+ 220 ++ show fps
+ 221 ++ ",scale="
+ 222 ++ show width
+ 223 ++ ":"
+ 224 ++ show height
+ 225 ++ ":flags=lanczos,palettegen"
+ 226 , "-t"
+ 227 , showFFloat Nothing (duration ani) ""
+ 228 , palette
+ 229 ]
+ 230 runCmd
+ 231 ffmpeg
+ 232 [ "-framerate"
+ 233 , show fps
+ 234 , "-i"
+ 235 , template
+ 236 , "-y"
+ 237 , "-i"
+ 238 , palette
+ 239 , "-progress"
+ 240 , progress
+ 241 , "-filter_complex"
+ 242 , "fps="
+ 243 ++ show fps
+ 244 ++ ",scale="
+ 245 ++ show width
+ 246 ++ ":"
+ 247 ++ show height
+ 248 ++ ":flags=lanczos[x];[x][1:v]paletteuse"
+ 249 , "-t"
+ 250 , showFFloat Nothing (duration ani) ""
+ 251 , target
+ 252 ]
+ 253 RenderWebm -> runCmd
+ 254 ffmpeg
+ 255 [ "-r"
+ 256 , show fps
+ 257 , "-i"
+ 258 , template
+ 259 , "-y"
+ 260 , "-progress"
+ 261 , progress
+ 262 , "-c:v"
+ 263 , "libvpx-vp9"
+ 264 , "-vf"
+ 265 , "fps=" ++ show fps
+ 266 , target
+ 267 ]
+ 268 takeMVar allFinished
+ 269
+ 270 ---------------------------------------------------------------------------------
+ 271 -- Helpers
+ 272
+ 273 progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO ()
+ 274 progressPrinter typeName maxCount action = do
+ 275 printf "\rFrames %s: 0/%d" typeName maxCount
+ 276 putStr $ clearFromCursorToLineEndCode ++ "\r"
+ 277 done <- newMVar (0 :: Int)
+ 278 start <- getCurrentTime
+ 279 let bgThread = forever $ do
+ 280 nDone <- readMVar done
+ 281 now <- getCurrentTime
+ 282 let spent = diffUTCTime now start
+ 283 remaining =
+ 284 (spent / (fromIntegral nDone / fromIntegral maxCount)) - spent
+ 285 printf "\rFrames %s: %d/%d" typeName nDone maxCount
+ 286 putStr $ ", time spent: " ++ ppDiff spent
+ 287 unless (nDone == 0) $ do
+ 288 putStr $ ", time remaining: " ++ ppDiff remaining
+ 289 putStr $ ", total time: " ++ ppDiff (remaining + spent)
+ 290 putStr $ clearFromCursorToLineEndCode ++ "\r"
+ 291 hFlush stdout
+ 292 threadDelay 1000000
+ 293 withBackgroundThread bgThread $ action done
+ 294 now <- getCurrentTime
+ 295 let spent = diffUTCTime now start
+ 296 printf "\rFrames %s: %d/%d" typeName maxCount maxCount
+ 297 putStr $ ", time spent: " ++ ppDiff spent
+ 298 putStr $ clearFromCursorToLineEndCode ++ "\n"
+ 299
+ 300 animationFrameCount :: Animation -> FPS -> Int
+ 301 animationFrameCount ani rate = round (duration ani * fromIntegral rate) :: Int
+ 302
+ 303 generateFrames
+ 304 :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a
+ 305 generateFrames raster ani width_ height_ rate partial action = withTempDir $ \tmp -> do
+ 306 let frameName nth = tmp </> printf nameTemplate nth
+ 307 setRootDirectory tmp
+ 308 progressPrinter "generated" frameCount
+ 309 $ \done -> handle h $ concurrentForM_ frames $ \n -> do
+ 310 writeFile (frameName n) $ renderSvg width height $ nthFrame n
+ 311 modifyMVar_ done $ \nDone -> return (nDone + 1)
+ 312
+ 313 when (isValidRaster raster)
+ 314 $ progressPrinter "rastered" frameCount
+ 315 $ \done -> handle h $ concurrentForM_ frames $ \n -> do
+ 316 applyRaster raster (frameName n)
+ 317 modifyMVar_ done $ \nDone -> return (nDone + 1)
+ 318
+ 319 action (tmp </> rasterTemplate raster)
+ 320 where
+ 321 isValidRaster RasterNone = False
+ 322 isValidRaster RasterAuto = False
+ 323 isValidRaster _ = True
+ 324
+ 325 width = Just $ Px $ fromIntegral width_
+ 326 height = Just $ Px $ fromIntegral height_
+ 327 h UserInterrupt | partial = do
+ 328 hPutStrLn
+ 329 stderr
+ 330 "\nCtrl-C detected. Trying to generate video with available frames. \
+ 331 \Hit ctrl-c again to abort."
+ 332 return ()
+ 333 h other = throwIO other
+ 334 -- frames = [0..frameCount-1]
+ 335 frames = frameOrder rate frameCount
+ 336 nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani
+ 337 frameCount = animationFrameCount ani rate
+ 338 nameTemplate :: String
+ 339 nameTemplate = "render-%05d.svg"
+ 340
+ 341 withBackgroundThread :: IO () -> IO a -> IO a
+ 342 withBackgroundThread t = bracket (forkIO t) killThread . const
+ 343
+ 344 ppDiff :: NominalDiffTime -> String
+ 345 ppDiff diff | hours == 0 && mins == 0 = show secs ++ "s"
+ 346 | hours == 0 = printf "%.2d:%.2d" mins secs
+ 347 | otherwise = printf "%.2d:%.2d:%.2d" hours mins secs
+ 348 where
+ 349 (osecs, secs) = round diff `divMod` (60 :: Int)
+ 350 (hours, mins) = osecs `divMod` 60
+ 351
+ 352 rasterTemplate :: Raster -> String
+ 353 rasterTemplate RasterNone = "render-%05d.svg"
+ 354 rasterTemplate RasterAuto = "render-%05d.svg"
+ 355 rasterTemplate _ = "render-%05d.png"
+ 356
+ 357 -- | Resolve RasterNone and RasterAuto. If no valid raster can
+ 358 -- be found, exit with an error message.
+ 359 requireRaster :: Raster -> IO Raster
+ 360 requireRaster raster = do
+ 361 raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster)
+ 362 case raster' of
+ 363 RasterNone -> do
+ 364 hPutStrLn
+ 365 stderr
+ 366 "Raster required but none could be found. \
+ 367 \Please install either inkscape, imagemagick, or rsvg-convert."
+ 368 exitWith (ExitFailure 1)
+ 369 _ -> pure raster'
+ 370
+ 371 -- | Resolve RasterNone and RasterAuto. If no valid raster can
+ 372 -- be found, return RasterNone.
+ 373 selectRaster :: Raster -> IO Raster
+ 374 selectRaster RasterAuto = do
+ 375 rsvg <- hasRSvg
+ 376 ink <- hasInkscape
+ 377 magick <- hasMagick
+ 378 if
+ 379 | isRight rsvg -> pure RasterRSvg
+ 380 | isRight ink -> pure RasterInkscape
+ 381 | isRight magick -> pure RasterMagick
+ 382 | otherwise -> pure RasterNone
+ 383 selectRaster r = pure r
+ 384
+ 385 -- | Convert SVG file to a PNG file with selected raster engine. If
+ 386 -- raster engine is RasterAuto or RasterNone, do nothing.
+ 387 applyRaster :: Raster -> FilePath -> IO ()
+ 388 applyRaster RasterNone _ = return ()
+ 389 applyRaster RasterAuto _ = return ()
+ 390 applyRaster RasterInkscape path = runCmd
+ 391 "inkscape"
+ 392 [ "--without-gui"
+ 393 , "--file=" ++ path
+ 394 , "--export-png=" ++ replaceExtension path "png"
+ 395 ]
+ 396 applyRaster RasterRSvg path = runCmd
+ 397 "rsvg-convert"
+ 398 [path, "--unlimited", "--output", replaceExtension path "png"]
+ 399 applyRaster RasterMagick path =
+ 400 runCmd magickCmd [path, replaceExtension path "png"]
+ 401
+ 402 concurrentForM_ :: [a] -> (a -> IO ()) -> IO ()
+ 403 concurrentForM_ lst action = do
+ 404 n <- getNumCapabilities
+ 405 sem <- newQSemN n
+ 406 eVar <- newEmptyMVar
+ 407 forM_ lst $ \elt -> do
+ 408 waitQSemN sem 1
+ 409 emp <- isEmptyMVar eVar
+ 410 if emp
+ 411 then
+ 412 void
+ 413 $ forkIO
+ 414 ( catch (action elt) (void . tryPutMVar eVar)
+ 415 `finally` signalQSemN sem 1
+ 416 )
+ 417 else signalQSemN sem 1
+ 418 waitQSemN sem n
+ 419 mbE <- tryTakeMVar eVar
+ 420 case mbE of
+ 421 Nothing -> return ()
+ 422 Just e -> throwIO (e :: SomeException)
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Scene.Core.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Scene.Core.hs.html
new file mode 100644
index 0000000..aa5adac
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Scene.Core.hs.html
@@ -0,0 +1,186 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE RankNTypes #-}
+ 2
+ 3 module Reanimate.Scene.Core where
+ 4
+ 5 import Control.Monad.Fix (MonadFix (..))
+ 6 import Control.Monad.ST
+ 7 import Data.List
+ 8 import Reanimate.Animation
+ 9 import Reanimate.Svg.Constructors
+ 10
+ 11 -- | The ZIndex property specifies the stack order of sprites and animations. Elements
+ 12 -- with a higher ZIndex will be drawn on top of elements with a lower index.
+ 13 type ZIndex = Int
+ 14
+ 15 -- (seq duration, par duration)
+ 16 -- [(Time, Animation, ZIndex)]
+ 17 -- Map Time [(Animation, ZIndex)]
+ 18 type Gen s = ST s (Duration -> Time -> (SVG, ZIndex))
+ 19
+ 20 -- | A 'Scene' represents a sequence of animations and variables
+ 21 -- that change over time.
+ 22 newtype Scene s a = M {unM :: Time -> ST s (a, Duration, Duration, [Gen s])}
+ 23
+ 24 instance Functor (Scene s) where
+ 25 fmap f action = M $ \t -> do
+ 26 (a, d1, d2, gens) <- unM action t
+ 27 return (f a, d1, d2, gens)
+ 28
+ 29 instance Applicative (Scene s) where
+ 30 pure a = M $ \_ -> return (a, 0, 0, [])
+ 31 f <*> g = M $ \t -> do
+ 32 (f', s1, p1, gen1) <- unM f t
+ 33 (g', s2, p2, gen2) <- unM g (t + s1)
+ 34 return (f' g', s1 + s2, max p1 (s1 + p2), gen1 ++ gen2)
+ 35
+ 36 instance Monad (Scene s) where
+ 37 return = pure
+ 38 f >>= g = M $ \t -> do
+ 39 (a, s1, p1, gen1) <- unM f t
+ 40 (b, s2, p2, gen2) <- unM (g a) (t + s1)
+ 41 return (b, s1 + s2, max p1 (s1 + p2), gen1 ++ gen2)
+ 42
+ 43 instance MonadFix (Scene s) where
+ 44 mfix fn = M $ \t -> mfix (\v -> let (a, _s, _p, _gens) = v in unM (fn a) t)
+ 45
+ 46 liftST :: ST s a -> Scene s a
+ 47 liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, [])
+ 48
+ 49 -- | Evaluate the value of a scene.
+ 50 evalScene :: (forall s. Scene s a) -> a
+ 51 evalScene action = runST $ do
+ 52 (val, _, _, _) <- unM action 0
+ 53 return val
+ 54
+ 55 -- | Render a 'Scene' to an 'Animation'.
+ 56 scene :: (forall s. Scene s a) -> Animation
+ 57 scene = sceneAnimation
+ 58
+ 59 -- | Render a 'Scene' to an 'Animation'.
+ 60 sceneAnimation :: (forall s. Scene s a) -> Animation
+ 61 sceneAnimation action =
+ 62 runST
+ 63 ( do
+ 64 (_, s, p, gens) <- unM action 0
+ 65 let dur = max s p
+ 66 genFns <- sequence gens
+ 67 return $
+ 68 mkAnimation
+ 69 dur
+ 70 ( \t ->
+ 71 mkGroup $
+ 72 map fst $
+ 73 sortOn
+ 74 snd
+ 75 [spriteRender dur (t * dur) | spriteRender <- genFns]
+ 76 )
+ 77 )
+ 78
+ 79 -- | Execute actions in a scene without advancing the clock. Note that scenes do not end before
+ 80 -- all forked actions have completed.
+ 81 --
+ 82 -- Example:
+ 83 --
+ 84 -- @
+ 85 -- do 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'
+ 86 -- 'play' 'Reanimate.Builtin.Documentation.drawCircle'
+ 87 -- @
+ 88 --
+ 89 -- <<docs/gifs/doc_fork.gif>>
+ 90 fork :: Scene s a -> Scene s a
+ 91 fork (M action) = M $ \t -> do
+ 92 (a, s, p, gens) <- action t
+ 93 return (a, 0, max s p, gens)
+ 94
+ 95 -- | Query the current clock timestamp.
+ 96 --
+ 97 -- Example:
+ 98 --
+ 99 -- @
+ 100 -- do now \<- 'play' 'Reanimate.Builtin.Documentation.drawCircle' *\> 'queryNow'
+ 101 -- 'play' $ 'staticFrame' 1 $ 'scale' 2 $ 'withStrokeWidth' 0.05 $
+ 102 -- 'mkText' $ "Now=" <> T.pack (show now)
+ 103 -- @
+ 104 --
+ 105 -- <<docs/gifs/doc_queryNow.gif>>
+ 106 queryNow :: Scene s Time
+ 107 queryNow = M $ \t -> return (t, 0, 0, [])
+ 108
+ 109 -- | Advance the clock by a given number of seconds.
+ 110 --
+ 111 -- Example:
+ 112 --
+ 113 -- @
+ 114 -- do 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'
+ 115 -- 'wait' 1
+ 116 -- 'play' 'Reanimate.Builtin.Documentation.drawCircle'
+ 117 -- @
+ 118 --
+ 119 -- <<docs/gifs/doc_wait.gif>>
+ 120 wait :: Duration -> Scene s ()
+ 121 wait d = M $ \_ -> return ((), d, 0, [])
+ 122
+ 123 -- | Wait until the clock is equal to the given timestamp.
+ 124 waitUntil :: Time -> Scene s ()
+ 125 waitUntil tNew = do
+ 126 now <- queryNow
+ 127 wait (max 0 (tNew - now))
+ 128
+ 129 -- | Wait until all forked and sequential animations have finished.
+ 130 --
+ 131 -- Example:
+ 132 --
+ 133 -- @
+ 134 -- do 'waitOn' $ 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'
+ 135 -- 'play' 'Reanimate.Builtin.Documentation.drawCircle'
+ 136 -- @
+ 137 --
+ 138 -- <<docs/gifs/doc_waitOn.gif>>
+ 139 waitOn :: Scene s a -> Scene s a
+ 140 waitOn (M action) = M $ \t -> do
+ 141 (a, s, p, gens) <- action t
+ 142 return (a, max s p, 0, gens)
+ 143
+ 144 -- | Change the ZIndex of a scene.
+ 145 adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
+ 146 adjustZ fn (M action) = M $ \t -> do
+ 147 (a, s, p, gens) <- action t
+ 148 return (a, s, p, map genFn gens)
+ 149 where
+ 150 genFn gen = do
+ 151 frameGen <- gen
+ 152 return $ \d t -> let (svg, z) = frameGen d t in (svg, fn z)
+ 153
+ 154 -- | Query the duration of a scene.
+ 155 withSceneDuration :: Scene s () -> Scene s Duration
+ 156 withSceneDuration s = do
+ 157 t1 <- queryNow
+ 158 s
+ 159 t2 <- queryNow
+ 160 return (t2 - t1)
+ 161
+ 162 addGen :: Gen s -> Scene s ()
+ 163 addGen gen = M $ \_ -> return ((), 0, 0, [gen])
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Scene.Sprite.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Scene.Sprite.hs.html
new file mode 100644
index 0000000..a064050
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Scene.Sprite.hs.html
@@ -0,0 +1,439 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE ApplicativeDo #-}
+ 2 {-# LANGUAGE PatternSynonyms #-}
+ 3 {-# LANGUAGE RankNTypes #-}
+ 4
+ 5 module Reanimate.Scene.Sprite where
+ 6
+ 7 import Control.Monad (void)
+ 8 import Control.Monad.ST (ST)
+ 9 import Data.Bifunctor (Bifunctor (first))
+ 10 import Data.STRef (STRef, modifySTRef, newSTRef, readSTRef)
+ 11 import Graphics.SvgTree
+ 12 ( pattern None,
+ 13 )
+ 14 import Reanimate.Animation
+ 15 ( Animation,
+ 16 Duration,
+ 17 SVG,
+ 18 Sync (SyncStretch),
+ 19 Time,
+ 20 dropA,
+ 21 duration,
+ 22 getAnimationFrame,
+ 23 )
+ 24 import Reanimate.Effect (Effect, delayE)
+ 25 import Reanimate.Scene.Core
+ 26 ( Scene (M),
+ 27 ZIndex,
+ 28 addGen,
+ 29 fork,
+ 30 liftST,
+ 31 queryNow,
+ 32 sceneAnimation,
+ 33 wait,
+ 34 )
+ 35 import Reanimate.Scene.Var (unpackVar, Var (..), newVar, readVar)
+ 36 import Reanimate.Transition (Transition, overlapT)
+ 37
+ 38 -- | Create and render a variable. The rendering will be born at the current timestamp
+ 39 -- and will persist until the end of the scene.
+ 40 --
+ 41 -- Example:
+ 42 --
+ 43 -- @
+ 44 -- do var \<- 'simpleVar' 'mkCircle' 0
+ 45 -- 'tweenVar' var 2 $ \\val -> 'fromToS' val ('Reanimate.Constants.screenHeight'/2)
+ 46 -- @
+ 47 --
+ 48 -- <<docs/gifs/doc_simpleVar.gif>>
+ 49 simpleVar :: (a -> SVG) -> a -> Scene s (Var s a)
+ 50 simpleVar render def = do
+ 51 v <- newVar def
+ 52 _ <- newSprite $ render <$> unVar v
+ 53 return v
+ 54
+ 55 -- | Helper function for filtering variables.
+ 56 findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)
+ 57 findVar _cond [] = error "Variable not found."
+ 58 findVar cond (v : vs) = do
+ 59 val <- readVar v
+ 60 if cond val then return v else findVar cond vs
+ 61
+ 62 -- | Play an animation once and then remove it. This advances the clock by the duration of the
+ 63 -- animation.
+ 64 --
+ 65 -- Example:
+ 66 --
+ 67 -- @
+ 68 -- do 'play' 'Reanimate.Builtin.Documentation.drawBox'
+ 69 -- 'play' 'Reanimate.Builtin.Documentation.drawCircle'
+ 70 -- @
+ 71 --
+ 72 -- <<docs/gifs/doc_play.gif>>
+ 73 play :: Animation -> Scene s ()
+ 74 play ani = newSpriteA ani >>= destroySprite
+ 75
+ 76 -- | Sprites are animations with a given time of birth as well as a time of death.
+ 77 -- They can be controlled using variables, tweening, and effects.
+ 78 data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex))))
+ 79
+ 80 -- | Sprite frame generator. Generates frames over time in a stateful environment.
+ 81 newtype Frame s a = Frame {unFrame :: ST s (Time -> Duration -> Time -> a)}
+ 82
+ 83 instance Functor (Frame s) where
+ 84 fmap fn (Frame gen) = Frame $ do
+ 85 m <- gen
+ 86 return (\real_t d t -> fn $ m real_t d t)
+ 87
+ 88 instance Applicative (Frame s) where
+ 89 pure v = Frame $ return (\_ _ _ -> v)
+ 90 Frame f <*> Frame g = Frame $ do
+ 91 m1 <- f
+ 92 m2 <- g
+ 93 return $ \real_t d t -> m1 real_t d t (m2 real_t d t)
+ 94
+ 95 -- | Dereference a variable as a Sprite frame.
+ 96 --
+ 97 -- Example:
+ 98 --
+ 99 -- @
+ 100 -- do v \<- 'newVar' 0
+ 101 -- 'newSprite' $ 'mkCircle' \<$\> 'unVar' v
+ 102 -- 'tweenVar' v 1 $ \\val -> 'fromToS' val 3
+ 103 -- 'tweenVar' v 1 $ \\val -> 'fromToS' val 0
+ 104 -- @
+ 105 --
+ 106 -- <<docs/gifs/doc_unVar.gif>>
+ 107 unVar :: Var s a -> Frame s a
+ 108 unVar var = Frame $ do
+ 109 fn <- unpackVar var
+ 110 return $ \real_t _d _t -> fn real_t
+ 111
+ 112 -- | Dereference seconds since sprite birth.
+ 113 spriteT :: Frame s Time
+ 114 spriteT = Frame $ return (\_real_t _d t -> t)
+ 115
+ 116 -- | Dereference duration of the current sprite.
+ 117 spriteDuration :: Frame s Duration
+ 118 spriteDuration = Frame $ return (\_real_t d _t -> d)
+ 119
+ 120 -- | Create new sprite defined by a frame generator. Unless otherwise specified using
+ 121 -- 'destroySprite', the sprite will die at the end of the scene.
+ 122 --
+ 123 -- Example:
+ 124 --
+ 125 -- @
+ 126 -- do 'newSprite' $ 'mkCircle' \<$\> 'spriteT' -- Circle sprite where radius=time.
+ 127 -- 'wait' 2
+ 128 -- @
+ 129 --
+ 130 -- <<docs/gifs/doc_newSprite.gif>>
+ 131 newSprite :: Frame s SVG -> Scene s (Sprite s)
+ 132 newSprite render = do
+ 133 now <- queryNow
+ 134 ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0))
+ 135 addGen $ do
+ 136 fn <- unFrame render
+ 137 (spriteDur, spriteEffectGen) <- readSTRef ref
+ 138 spriteEffect <- spriteEffectGen
+ 139 return $ \d absT ->
+ 140 let relD = (if spriteDur < 0 then d else spriteDur) - now
+ 141 relT = absT - now
+ 142 -- Sprite is live [now;duration[
+ 143 -- If we're at the end of a scene, sprites
+ 144 -- are live: [now;duration]
+ 145 -- This behavior is difficult to get right. See the 'bug_*' examples for
+ 146 -- automated tests.
+ 147 inTimeSlice = relT >= 0 && relT < relD
+ 148 isLastFrame = d == absT && relT == relD
+ 149 in if inTimeSlice || isLastFrame
+ 150 then spriteEffect relD relT (fn absT relD relT)
+ 151 else (None, 0)
+ 152 return $ Sprite now ref
+ 153
+ 154 -- | Create new sprite defined by a frame generator. The sprite will die at
+ 155 -- the end of the scene.
+ 156 newSprite_ :: Frame s SVG -> Scene s ()
+ 157 newSprite_ = void . newSprite
+ 158
+ 159 -- | Create a new sprite from an animation. This advances the clock by the
+ 160 -- duration of the animation. Unless otherwise specified using
+ 161 -- 'destroySprite', the sprite will die at the end of the scene.
+ 162 --
+ 163 -- Note: If the scene doesn't end immediately after the duration of the
+ 164 -- animation, the animation will be stretched to match the lifetime of the
+ 165 -- sprite. See 'newSpriteA'' and 'play'.
+ 166 --
+ 167 -- Example:
+ 168 --
+ 169 -- @
+ 170 -- do 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
+ 171 -- 'play' 'Reanimate.Builtin.Documentation.drawBox'
+ 172 -- 'play' $ 'reverseA' 'Reanimate.Builtin.Documentation.drawBox'
+ 173 -- @
+ 174 --
+ 175 -- <<docs/gifs/doc_newSpriteA.gif>>
+ 176 newSpriteA :: Animation -> Scene s (Sprite s)
+ 177 newSpriteA = newSpriteA' SyncStretch
+ 178
+ 179 -- | Create a new sprite from an animation and specify the synchronization policy. This advances
+ 180 -- the clock by the duration of the animation.
+ 181 --
+ 182 -- Example:
+ 183 --
+ 184 -- @
+ 185 -- do 'fork' $ 'newSpriteA'' 'SyncFreeze' 'Reanimate.Builtin.Documentation.drawCircle'
+ 186 -- 'play' 'Reanimate.Builtin.Documentation.drawBox'
+ 187 -- 'play' $ 'reverseA' 'Reanimate.Builtin.Documentation.drawBox'
+ 188 -- @
+ 189 --
+ 190 -- <<docs/gifs/doc_newSpriteA'.gif>>
+ 191 newSpriteA' :: Sync -> Animation -> Scene s (Sprite s)
+ 192 newSpriteA' sync animation =
+ 193 newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration)
+ 194 <* wait (duration animation)
+ 195
+ 196 -- | Create a sprite from a static SVG image.
+ 197 --
+ 198 -- Example:
+ 199 --
+ 200 -- @
+ 201 -- do 'newSpriteSVG' $ 'mkBackground' "lightblue"
+ 202 -- 'play' 'Reanimate.Builtin.Documentation.drawCircle'
+ 203 -- @
+ 204 --
+ 205 -- <<docs/gifs/doc_newSpriteSVG.gif>>
+ 206 newSpriteSVG :: SVG -> Scene s (Sprite s)
+ 207 newSpriteSVG = newSprite . pure
+ 208
+ 209 -- | Create a permanent sprite from a static SVG image. Same as `newSpriteSVG`
+ 210 -- but the sprite isn't returned and thus cannot be destroyed.
+ 211 newSpriteSVG_ :: SVG -> Scene s ()
+ 212 newSpriteSVG_ = void . newSpriteSVG
+ 213
+ 214 -- | Change the rendering of a sprite using data from a variable. If data from several variables
+ 215 -- is needed, use a frame generator instead.
+ 216 --
+ 217 -- Example:
+ 218 --
+ 219 -- @
+ 220 -- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawBox'
+ 221 -- v \<- 'newVar' 0
+ 222 -- 'applyVar' v s 'rotate'
+ 223 -- 'tweenVar' v 2 $ \\val -> 'fromToS' val 90
+ 224 -- @
+ 225 --
+ 226 -- <<docs/gifs/doc_applyVar.gif>>
+ 227 applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s ()
+ 228 applyVar var sprite fn = spriteModify sprite $ do
+ 229 varFn <- unVar var
+ 230 return $ first $ fn varFn
+ 231
+ 232 -- | Destroy a sprite, preventing it from being rendered in the future of the scene.
+ 233 -- If 'destroySprite' is invoked multiple times, the earliest time-of-death is used.
+ 234 --
+ 235 -- Example:
+ 236 --
+ 237 -- @
+ 238 -- do s <- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'mkCircle' 1
+ 239 -- 'fork' $ 'wait' 1 \>\> 'destroySprite' s
+ 240 -- 'play' 'Reanimate.Builtin.Documentation.drawBox'
+ 241 -- @
+ 242 --
+ 243 -- <<docs/gifs/doc_destroySprite.gif>>
+ 244 destroySprite :: Sprite s -> Scene s ()
+ 245 destroySprite (Sprite _ ref) = do
+ 246 now <- queryNow
+ 247 liftST $
+ 248 modifySTRef ref $ \(ttl, render) ->
+ 249 (if ttl < 0 then now else min ttl now, render)
+ 250
+ 251 -- | Low-level frame modifier.
+ 252 spriteModify :: Sprite s -> Frame s ((SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s ()
+ 253 spriteModify (Sprite born ref) modFn = liftST $
+ 254 modifySTRef ref $ \(ttl, renderGen) ->
+ 255 ( ttl,
+ 256 do
+ 257 render <- renderGen
+ 258 modRender <- unFrame modFn
+ 259 return $ \relD relT ->
+ 260 let absT = relT + born in modRender absT relD relT . render relD relT
+ 261 )
+ 262
+ 263 -- | Map the SVG output of a sprite.
+ 264 --
+ 265 -- Example:
+ 266 --
+ 267 -- @
+ 268 -- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
+ 269 -- 'wait' 1
+ 270 -- 'spriteMap' s 'flipYAxis'
+ 271 -- @
+ 272 --
+ 273 -- <<docs/gifs/doc_spriteMap.gif>>
+ 274 spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s ()
+ 275 spriteMap sprite@(Sprite born _) fn = do
+ 276 now <- queryNow
+ 277 let tDelta = now - born
+ 278 spriteModify sprite $ do
+ 279 t <- spriteT
+ 280 return $ \(svg, zindex) -> (if (t - tDelta) < 0 then svg else fn svg, zindex)
+ 281
+ 282 -- | Modify the output of a sprite between @now@ and @now+duration@.
+ 283 --
+ 284 -- Example:
+ 285 --
+ 286 -- @
+ 287 -- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
+ 288 -- 'spriteTween' s 1 $ \\val -> 'translate' ('Reanimate.Constants.screenWidth'*0.3*val) 0
+ 289 -- @
+ 290 --
+ 291 -- <<docs/gifs/doc_spriteTween.gif>>
+ 292 spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()
+ 293 spriteTween sprite@(Sprite born _) dur fn = do
+ 294 now <- queryNow
+ 295 let tDelta = now - born
+ 296 spriteModify sprite $ do
+ 297 t <- spriteT
+ 298 return $ first $ \svg -> fn (clamp 0 1 $ (t - tDelta) / dur) svg
+ 299 wait dur
+ 300 where
+ 301 clamp a b v
+ 302 | v < a = a
+ 303 | v > b = b
+ 304 | otherwise = v
+ 305
+ 306 -- | Create a new variable and apply it to a sprite.
+ 307 --
+ 308 -- Example:
+ 309 --
+ 310 -- @
+ 311 -- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawBox'
+ 312 -- v \<- 'spriteVar' s 0 'rotate'
+ 313 -- 'tweenVar' v 2 $ \\val -> 'fromToS' val 90
+ 314 -- @
+ 315 --
+ 316 -- <<docs/gifs/doc_spriteVar.gif>>
+ 317 spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)
+ 318 spriteVar sprite def fn = do
+ 319 v <- newVar def
+ 320 applyVar v sprite fn
+ 321 return v
+ 322
+ 323 -- | Apply an effect to a sprite.
+ 324 --
+ 325 -- Example:
+ 326 --
+ 327 -- @
+ 328 -- do s <- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
+ 329 -- 'spriteE' s $ 'overBeginning' 1 'fadeInE'
+ 330 -- 'spriteE' s $ 'overEnding' 0.5 'fadeOutE'
+ 331 -- @
+ 332 --
+ 333 -- <<docs/gifs/doc_spriteE.gif>>
+ 334 spriteE :: Sprite s -> Effect -> Scene s ()
+ 335 spriteE (Sprite born ref) effect = do
+ 336 now <- queryNow
+ 337 liftST $
+ 338 modifySTRef ref $ \(ttl, renderGen) ->
+ 339 ( ttl,
+ 340 do
+ 341 render <- renderGen
+ 342 return $ \d t svg ->
+ 343 let (svg', z) = render d t svg
+ 344 in (delayE (max 0 $ now - born) effect d t svg', z)
+ 345 )
+ 346
+ 347 -- | Set new ZIndex of a sprite.
+ 348 --
+ 349 -- Example:
+ 350 --
+ 351 -- @
+ 352 -- do s1 \<- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'withFillColor' "blue" $ 'mkCircle' 3
+ 353 -- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'withFillColor' "red" $ 'mkRect' 8 3
+ 354 -- 'wait' 1
+ 355 -- 'spriteZ' s1 1
+ 356 -- 'wait' 1
+ 357 -- @
+ 358 --
+ 359 -- <<docs/gifs/doc_spriteZ.gif>>
+ 360 spriteZ :: Sprite s -> ZIndex -> Scene s ()
+ 361 spriteZ (Sprite born ref) zindex = do
+ 362 now <- queryNow
+ 363 liftST $
+ 364 modifySTRef ref $ \(ttl, renderGen) ->
+ 365 ( ttl,
+ 366 do
+ 367 render <- renderGen
+ 368 return $ \d t svg ->
+ 369 let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex)
+ 370 )
+ 371
+ 372 -- | Destroy all local sprites at the end of a scene.
+ 373 --
+ 374 -- Example:
+ 375 --
+ 376 -- @
+ 377 -- do -- the rect lives through the entire 3s animation
+ 378 -- 'newSpriteSVG_' $ 'translate' (-3) 0 $ 'mkRect' 4 4
+ 379 -- 'wait' 1
+ 380 -- 'spriteScope' $ do
+ 381 -- -- the circle only lives for 1 second.
+ 382 -- local \<- 'newSpriteSVG' $ 'translate' 3 0 $ 'mkCircle' 2
+ 383 -- 'spriteE' local $ 'overBeginning' 0.3 'fadeInE'
+ 384 -- 'spriteE' local $ 'overEnding' 0.3 'fadeOutE'
+ 385 -- 'wait' 1
+ 386 -- 'wait' 1
+ 387 -- @
+ 388 --
+ 389 -- <<docs/gifs/doc_spriteScope.gif>>
+ 390 spriteScope :: Scene s a -> Scene s a
+ 391 spriteScope (M action) = M $ \t -> do
+ 392 (a, s, p, gens) <- action t
+ 393 return (a, s, p, map (genFn (t + max s p)) gens)
+ 394 where
+ 395 genFn maxT gen = do
+ 396 frameGen <- gen
+ 397 return $ \_ t ->
+ 398 if t < maxT
+ 399 then frameGen maxT t
+ 400 else (None, 0)
+ 401
+ 402 asAnimation :: (forall s'. Scene s' a) -> Scene s Animation
+ 403 asAnimation s = do
+ 404 now <- queryNow
+ 405 return $ dropA now (sceneAnimation (wait now >> s))
+ 406
+ 407 -- | Apply a transformation with a given overlap. This makes sure
+ 408 -- to keep timestamps intact such that events can still be timed
+ 409 -- by transcripts.
+ 410 transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s ()
+ 411 transitionO t o a b = do
+ 412 aA <- asAnimation a
+ 413 bA <- fork $ do
+ 414 wait (duration aA - o)
+ 415 asAnimation b
+ 416 play $ overlapT o t aA bA
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Scene.Var.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Scene.Var.hs.html
new file mode 100644
index 0000000..926a43f
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Scene.Var.hs.html
@@ -0,0 +1,193 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE LambdaCase #-}
+ 2 {-# LANGUAGE RecordWildCards #-}
+ 3
+ 4 module Reanimate.Scene.Var where
+ 5
+ 6 import Control.Monad.ST (ST)
+ 7 import qualified Data.Map as M
+ 8 import Data.Maybe (fromMaybe)
+ 9 import Data.STRef
+ 10 import Reanimate.Animation (Duration, Time)
+ 11 import Reanimate.Scene.Core (Scene, liftST, queryNow, wait)
+ 12
+ 13 -- | Time dependent variable.
+ 14 newtype Var s a = Var (STRef s (VarData a))
+ 15
+ 16 -- Note: We must ensure that upon transforming an VarData,
+ 17 -- 1. evarDefault old == evarDefault new
+ 18 -- 2. isNothing (evarLastTime old) || isJust (evarLastTime new) i.e. once evarLastValue has a Just value,
+ 19 -- it shouldn't be Nothing again.
+ 20 -- 3. isNothing (evarLastTime var) => M.null (evarTimeline var)
+ 21 data VarData a = VarData
+ 22 { evarDefault :: a,
+ 23 evarTimeline :: Timeline a,
+ 24 evarLastTime :: Maybe Time,
+ 25 evarLastValue :: a
+ 26 }
+ 27
+ 28 data Modifier a = StaticValue a | TweenValue Duration (a -> Time -> a)
+ 29
+ 30 type Timeline a = M.Map Time (Modifier a)
+ 31
+ 32 -- | Create a new variable with a default value.
+ 33 -- Variables always have a defined value even if they are read at a timestamp that is
+ 34 -- earlier than when the variable was created. For example:
+ 35 --
+ 36 -- @
+ 37 -- do v \<- 'fork' ('wait' 10 \>\> 'newVar' 0) -- Create a variable at timestamp '10'.
+ 38 -- 'readVar' v -- Read the variable at timestamp '0'.
+ 39 -- -- The value of the variable will be '0'.
+ 40 -- @
+ 41 newVar :: a -> Scene s (Var s a)
+ 42 newVar def = Var <$> liftST (newSTRef $ VarData def M.empty Nothing def)
+ 43
+ 44 -- | Read the value of a variable at the current timestamp.
+ 45 readVar :: Var s a -> Scene s a
+ 46 readVar (Var ref) = readVarData <$> liftST (readSTRef ref) <*> queryNow
+ 47
+ 48 unpackVar :: Var s a -> ST s (Time -> a)
+ 49 unpackVar (Var ref) = readVarData <$> readSTRef ref
+ 50
+ 51 -- | Write the value of a variable at the current timestamp.
+ 52 --
+ 53 -- Example:
+ 54 --
+ 55 -- @
+ 56 -- do v \<- 'newVar' 0
+ 57 -- 'newSprite' $ 'mkCircle' \<$\> 'unVar' v
+ 58 -- 'writeVar' v 1; 'wait' 1
+ 59 -- 'writeVar' v 2; 'wait' 1
+ 60 -- 'writeVar' v 3; 'wait' 1
+ 61 -- @
+ 62 --
+ 63 -- <<docs/gifs/doc_writeVar.gif>>
+ 64 writeVar :: Var s a -> a -> Scene s ()
+ 65 writeVar (Var ref) val = do
+ 66 now <- queryNow
+ 67 liftST $ modifySTRef ref $ writeVarData now val
+ 68
+ 69 -- | Modify the value of a variable at the current timestamp and all future timestamps.
+ 70 modifyVar :: Var s a -> (a -> a) -> Scene s ()
+ 71 modifyVar (Var ref) fn = do
+ 72 now <- queryNow
+ 73 liftST $ modifySTRef ref $ modifyVarData now fn
+ 74
+ 75 -- | Modify a variable between @now@ and @now+duration@.
+ 76 tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()
+ 77 tweenVar _ dur _ | dur < 0 = error "Reanimate.tweenVar: durations must be non-negative"
+ 78 tweenVar (Var ref) dur fn = do
+ 79 now <- queryNow
+ 80 liftST $ modifySTRef ref $ tweenVarData now dur fn
+ 81 wait dur
+ 82
+ 83 readVarData :: VarData a -> Time -> a
+ 84 readVarData (VarData def _ Nothing _) _ = def
+ 85 readVarData (VarData def timeline (Just lastTime) lastValue) now
+ 86 | now < lastTime = lookupTimeline timeline def now
+ 87 | otherwise = lastValue
+ 88
+ 89 lookupTimeline :: Timeline a -> a -> Time -> a
+ 90 lookupTimeline timeline def now = case M.lookupLE now timeline of
+ 91 Just (_, StaticValue sVal) -> sVal
+ 92 Just (t, TweenValue dur f)
+ 93 | t + dur > now -> f def now
+ 94 _ -> def
+ 95
+ 96 writeVarData :: Time -> a -> VarData a -> VarData a
+ 97 writeVarData now x var =
+ 98 let before = keepBefore now var
+ 99 after = VarData (evarDefault var) M.empty (Just now) x
+ 100 in after `elseVar` before
+ 101
+ 102 modifyVarData :: Time -> (a -> a) -> VarData a -> VarData a
+ 103 modifyVarData now fn var =
+ 104 let before = keepBefore now var
+ 105 after = keepFrom now var
+ 106 timeline = flip M.map (evarTimeline after) $ \case
+ 107 StaticValue s -> StaticValue $ fn s
+ 108 TweenValue dur f -> TweenValue dur $ \a t -> fn (f a t)
+ 109 in after {evarTimeline = timeline, evarLastValue = fn $ evarLastValue after} `elseVar` before
+ 110
+ 111 -- Note: The function passed here takes time on the scale 0 to 1
+ 112 -- while the function in `TweenValue` takes time on an absolute scale.
+ 113 tweenVarData :: Time -> Duration -> (a -> Time -> a) -> VarData a -> VarData a
+ 114 tweenVarData st dur fn var@VarData {..} =
+ 115 let nd = st + dur
+ 116 before = keepBefore st var
+ 117 during = keepInRange (Just st) (Just nd) var
+ 118 tweenFn a t =
+ 119 let idx = (t - st) / dur
+ 120 idx' = if isNaN idx then 1 else idx
+ 121 in fn (readVarData (during {evarDefault = a}) t) idx'
+ 122 valueTweenEnd = tweenFn evarDefault nd -- we'll never use the def here, replace with error?
+ 123 after = VarData evarDefault (M.singleton st $ TweenValue dur tweenFn) (Just nd) valueTweenEnd
+ 124 in after `elseVar` before
+ 125
+ 126 -- Returns the union of two vars such that we use the second var if first var doesn't have a value.
+ 127 -- Assumes both vars have same default value.
+ 128 elseVar :: VarData a -> VarData a -> VarData a
+ 129 elseVar var1 var2
+ 130 | Just t <- evarLastTime var1 =
+ 131 let afterTimeline = evarTimeline var1
+ 132 joinAt = fromMaybe t . fmap fst $ M.lookupMin afterTimeline
+ 133 beforeTimeline = case keepBefore joinAt var2 of
+ 134 x
+ 135 | Just lastTime <- evarLastTime x, lastTime < joinAt -> M.insert lastTime (StaticValue $ evarLastValue x) $ evarTimeline x
+ 136 | otherwise -> evarTimeline x
+ 137 in var1 {evarTimeline = M.union afterTimeline beforeTimeline}
+ 138 | otherwise = var2
+ 139
+ 140 -- Restrict a var to a given time interval.
+ 141 keepInRange :: Maybe Time -> Maybe Time -> VarData a -> VarData a
+ 142 keepInRange st nd = fromMaybe id (keepFrom <$> st) . fromMaybe id (keepBefore <$> nd)
+ 143
+ 144 -- Restrict a var to start at given timestamp.
+ 145 keepFrom :: Time -> VarData a -> VarData a
+ 146 keepFrom st VarData {..} =
+ 147 let timeline' = M.dropWhileAntitone (< st) evarTimeline
+ 148 -- if there is no modifier in timeline starting at st,
+ 149 -- we must get the modifier that starts before and truncate it to start at st.
+ 150 timeline'' = case M.lookupLE st evarTimeline of
+ 151 Just (t, val@(StaticValue _))
+ 152 | t < st -> M.insert st val timeline'
+ 153 Just (t, TweenValue dur fn)
+ 154 | t < st, t + dur > st -> M.insert st (TweenValue (t + dur - st) fn) timeline'
+ 155 _ -> timeline'
+ 156 in VarData evarDefault timeline'' (max evarLastTime $ Just st) evarLastValue
+ 157
+ 158 -- Restrict a var to end(clamp) at given timestamp.
+ 159 keepBefore :: Time -> VarData a -> VarData a
+ 160 keepBefore nd var@VarData {..} =
+ 161 let timeline' = M.takeWhileAntitone (< nd) evarTimeline
+ 162 lastModifier = M.lookupMax timeline'
+ 163 timeline'' = case lastModifier of
+ 164 Just (t, TweenValue dur fn)
+ 165 | t + dur > nd -> M.insert t (TweenValue (nd - t) fn) timeline'
+ 166 _ -> timeline'
+ 167 lastTime = case lastModifier of
+ 168 Just (t, TweenValue dur _) -> Just $ min nd (t + dur)
+ 169 _ -> min nd <$> evarLastTime
+ 170 in VarData evarDefault timeline'' lastTime (fromMaybe evarDefault $ fmap (readVarData var) lastTime)
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Svg.BoundingBox.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Svg.BoundingBox.hs.html
new file mode 100644
index 0000000..314bcde
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Svg.BoundingBox.hs.html
@@ -0,0 +1,153 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Bounding-boxes can be immensely useful for aligning objects
+ 3 but they are not part of the SVG specification and cannot be
+ 4 computed for all SVG nodes. In particular, you'll get bad results
+ 5 when asking for the bounding boxes of Text nodes (because fonts
+ 6 are difficult), clipped nodes, and filtered nodes.
+ 7 -}
+ 8 module Reanimate.Svg.BoundingBox
+ 9 ( boundingBox
+ 10 , svgHeight
+ 11 , svgWidth
+ 12 ) where
+ 13
+ 14 import Control.Arrow ((***))
+ 15 import Control.Lens ((^.))
+ 16 import Data.List
+ 17 import Data.Maybe (mapMaybe)
+ 18 import qualified Data.Vector.Unboxed as V
+ 19 import qualified Geom2D.CubicBezier.Linear as Bezier
+ 20 import Graphics.SvgTree
+ 21 import Linear.V2 hiding (angle)
+ 22 import Linear.Vector
+ 23 import Reanimate.Constants
+ 24 import Reanimate.Svg.LineCommand
+ 25 import qualified Reanimate.Transform as Transform
+ 26
+ 27 -- | Return bounding box of SVG tree.
+ 28 -- The four numbers returned are (minimal X-coordinate, minimal Y-coordinate, width, height)
+ 29 --
+ 30 -- Note: Bounding boxes are computed on a best-effort basis and will not work
+ 31 -- in all cases. The only supported SVG nodes are: path, circle, polyline,
+ 32 -- ellipse, line, rectangle, image. All other nodes return (0,0,0,0).
+ 33 boundingBox :: Tree -> (Double, Double, Double, Double)
+ 34 boundingBox t =
+ 35 case svgBoundingPoints t of
+ 36 [] -> (0,0,0,0)
+ 37 (V2 x y:rest) ->
+ 38 let (minx, miny, maxx, maxy) = foldl' worker (x, y, x, y) rest
+ 39 in (minx, miny, maxx-minx, maxy-miny)
+ 40 where
+ 41 worker (minx, miny, maxx, maxy) (V2 x y) =
+ 42 (min minx x, min miny y, max maxx x, max maxy y)
+ 43
+ 44 -- | Height of SVG node in local units (not pixels). Computed on best-effort basis
+ 45 -- and will not give accurate results for all SVG nodes.
+ 46 svgHeight :: Tree -> Double
+ 47 svgHeight t = h
+ 48 where
+ 49 (_x, _y, _w, h) = boundingBox t
+ 50
+ 51 -- | Width of SVG node in local units (not pixels). Computed on best-effort basis
+ 52 -- and will not give accurate results for all SVG nodes.
+ 53 svgWidth :: Tree -> Double
+ 54 svgWidth t = w
+ 55 where
+ 56 (_x, _y, w, _h) = boundingBox t
+ 57
+ 58 -- | Sampling of points in a line path.
+ 59 linePoints :: [LineCommand] -> [RPoint]
+ 60 linePoints = worker zero
+ 61 where
+ 62 worker _from [] = []
+ 63 worker from (x:xs) =
+ 64 case x of
+ 65 LineMove to -> worker to xs
+ 66 -- LineDraw to -> from:to:worker to xs
+ 67 LineBezier [p] ->
+ 68 p : worker p xs
+ 69 LineBezier ctrl -> -- approximation
+ 70 let bezier = Bezier.AnyBezier (V.fromList (from:ctrl))
+ 71 in [ Bezier.evalBezier bezier (recip chunks*i) | i <- [0..chunks]] ++
+ 72 worker (last ctrl) xs
+ 73 LineEnd p -> p : worker p xs
+ 74 chunks = 10
+ 75
+ 76 svgBoundingPoints :: Tree -> [RPoint]
+ 77 svgBoundingPoints t = map (Transform.transformPoint m) $
+ 78 case t of
+ 79 None -> []
+ 80 UseTree{} -> []
+ 81 GroupTree g -> concatMap svgBoundingPoints (g^.groupChildren)
+ 82 SymbolTree g -> concatMap svgBoundingPoints (g^.groupChildren)
+ 83 FilterTree{} -> []
+ 84 DefinitionTree{} -> []
+ 85 PathTree p -> linePoints $ toLineCommands (p^.pathDefinition)
+ 86 CircleTree c -> circleBoundingPoints c
+ 87 PolyLineTree pl -> pl ^. polyLinePoints
+ 88 EllipseTree e -> ellipseBoundingPoints e
+ 89 LineTree line -> map pointToRPoint [line^.linePoint1, line^.linePoint2]
+ 90 RectangleTree rect ->
+ 91 case pointToRPoint (rect^.rectUpperLeftCorner) of
+ 92 V2 x y -> V2 x y :
+ 93 case mapTuple (fmap $ toUserUnit defaultDPI) (rect^.rectWidth, rect^.rectHeight) of
+ 94 (Just (Num w), Just (Num h)) -> [V2 (x+w) (y+h)]
+ 95 _ -> []
+ 96 TextTree{} -> []
+ 97 ImageTree img ->
+ 98 case (img^.imageCornerUpperLeft, img^.imageWidth, img^.imageHeight) of
+ 99 ((Num x, Num y), Num w, Num h) ->
+ 100 [V2 x y, V2 (x+w) (y+h)]
+ 101 _ -> []
+ 102 MeshGradientTree{} -> []
+ 103 _ -> []
+ 104 where
+ 105 m = Transform.mkMatrix (t^.transform)
+ 106 mapTuple f = f *** f
+ 107 pointToRPoint p =
+ 108 case mapTuple (toUserUnit defaultDPI) p of
+ 109 (Num x, Num y) -> V2 x y
+ 110 _ -> error "Reanimate.Svg.svgBoundingPoints: Unrecognized number format."
+ 111
+ 112 circleBoundingPoints circ =
+ 113 let (xnum, ynum) = circ ^. circleCenter
+ 114 rnum = circ ^. circleRadius
+ 115 in case mapMaybe unpackNumber [xnum, ynum, rnum] of
+ 116 [x, y, r] -> [ V2 (x + r * cos angle) (y + r * sin angle) | angle <- [0, pi/10 .. 2 * pi]]
+ 117 _ -> []
+ 118
+ 119 ellipseBoundingPoints e =
+ 120 let (xnum,ynum) = e ^. ellipseCenter
+ 121 xrnum = e ^. ellipseXRadius
+ 122 yrnum = e ^. ellipseYRadius
+ 123 in case mapMaybe unpackNumber [xnum, ynum, xrnum, yrnum] of
+ 124 [x,y,xr,yr] -> [V2 (x + xr * cos angle) (y + yr * sin angle) | angle <- [0, pi/10 .. 2 * pi]]
+ 125 _ -> []
+ 126
+ 127 unpackNumber n =
+ 128 case toUserUnit defaultDPI n of
+ 129 Num d -> Just d
+ 130 _ -> Nothing
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Svg.Constructors.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Svg.Constructors.hs.html
new file mode 100644
index 0000000..d612b53
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Svg.Constructors.hs.html
@@ -0,0 +1,449 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-| Functions for creating basic SVG elements and applying transformations to them. -}
+ 2 module Reanimate.Svg.Constructors
+ 3 ( -- * Primitive shapes
+ 4 mkCircle
+ 5 , mkEllipse
+ 6 , mkRect
+ 7 , mkLine
+ 8 , mkPath
+ 9 , mkPathString
+ 10 , mkPathText
+ 11 , mkLinePath
+ 12 , mkLinePathClosed
+ 13 , mkClipPath
+ 14 , mkText
+ 15 -- * Grouping shapes and definitions
+ 16 , mkGroup
+ 17 , mkDefinitions
+ 18 , mkUse
+ 19 -- * Attributes
+ 20 , withId
+ 21 , withStrokeColor
+ 22 , withStrokeColorPixel
+ 23 , withStrokeDashArray
+ 24 , withStrokeLineJoin
+ 25 , withFillColor
+ 26 , withFillColorPixel
+ 27 , withFillOpacity
+ 28 , withGroupOpacity
+ 29 , withStrokeWidth
+ 30 , withClipPathRef
+ 31 -- * Transformations
+ 32 , center
+ 33 , centerX
+ 34 , centerY
+ 35 , centerUsing
+ 36 , translate
+ 37 , rotate
+ 38 , rotateAroundCenter
+ 39 , rotateAround
+ 40 , scale
+ 41 , scaleToSize
+ 42 , scaleToWidth
+ 43 , scaleToHeight
+ 44 , scaleXY
+ 45 , flipXAxis
+ 46 , flipYAxis
+ 47 , aroundCenter
+ 48 , aroundCenterX
+ 49 , aroundCenterY
+ 50 , withTransformations
+ 51 , withViewBox
+ 52 -- * Other
+ 53 , mkColor
+ 54 , mkBackground
+ 55 , mkBackgroundPixel
+ 56 , gridLayout
+ 57
+ 58 ) where
+ 59
+ 60 import Codec.Picture (PixelRGBA8 (..))
+ 61 import Control.Lens ((&), (.~), (?~))
+ 62 import Data.Attoparsec.Text (parseOnly)
+ 63 import qualified Data.Map as Map
+ 64 import qualified Data.Text as T
+ 65 import Graphics.SvgTree
+ 66 import Graphics.SvgTree.NamedColors
+ 67 import Graphics.SvgTree.PathParser
+ 68 import Linear.V2 hiding (angle)
+ 69 import Reanimate.Constants
+ 70 import Reanimate.Svg.BoundingBox
+ 71
+ 72 -- | Apply list of transformations to given image.
+ 73 withTransformations :: [Transformation] -> Tree -> Tree
+ 74 withTransformations transformations t =
+ 75 mkGroup [t] & transform ?~ transformations
+ 76
+ 77 -- | @translate x y image@ moves the @image@ by @x@ along X-axis and by @y@ along Y-axis.
+ 78 translate :: Double -> Double -> Tree -> Tree
+ 79 translate x y = withTransformations [Translate x y]
+ 80
+ 81 -- | @rotate angle image@ rotates the @image@ around origin @(0,0)@ counterclockwise by @angle@
+ 82 -- given in degrees.
+ 83 rotate :: Double -> Tree -> Tree
+ 84 rotate a = withTransformations [Rotate a Nothing]
+ 85
+ 86 -- | @rotate angle point image@ rotates the @image@ around given @point@ counterclockwise by
+ 87 -- @angle@ given in degrees.
+ 88 rotateAround :: Double -> RPoint -> Tree -> Tree
+ 89 rotateAround a (V2 x y) = withTransformations [Rotate a (Just (x,y))]
+ 90
+ 91 -- | @rotate angle image@ rotates the @image@ around the center of its bounding box counterclockwise
+ 92 -- by @angle@ given in degrees.
+ 93 rotateAroundCenter :: Double -> Tree -> Tree
+ 94 rotateAroundCenter a t =
+ 95 rotateAround a (V2 (x+w/2) (y+h/2)) t
+ 96 where
+ 97 (x,y,w,h) = boundingBox t
+ 98
+ 99 -- | @aroundCenter f image@ first moves the image so the center of its bounding box is at the origin
+ 100 -- @(0, 0)@, applies transformation @f@ to it and then moves the transformed image back to its
+ 101 -- original position.
+ 102 aroundCenter :: (Tree -> Tree) -> Tree -> Tree
+ 103 aroundCenter fn t =
+ 104 translate (-offsetX) (-offsetY) $ fn $ translate offsetX offsetY t
+ 105 where
+ 106 offsetX = -x-w/2
+ 107 offsetY = -y-h/2
+ 108 (x,y,w,h) = boundingBox t
+ 109
+ 110 -- | Same as 'aroundCenter' but only for the Y-axis.
+ 111 aroundCenterY :: (Tree -> Tree) -> Tree -> Tree
+ 112 aroundCenterY fn t =
+ 113 translate 0 (-offsetY) $ fn $ translate 0 offsetY t
+ 114 where
+ 115 offsetY = -y-h/2
+ 116 (_x,y,_w,h) = boundingBox t
+ 117
+ 118 -- | Same as 'aroundCenter' but only for the X-axis.
+ 119 aroundCenterX :: (Tree -> Tree) -> Tree -> Tree
+ 120 aroundCenterX fn t =
+ 121 translate (-offsetX) 0 $ fn $ translate offsetX 0 t
+ 122 where
+ 123 offsetX = -x-w/2
+ 124 (x,_y,w,_h) = boundingBox t
+ 125
+ 126 -- | Scale the image uniformly by given factor along both X and Y axes.
+ 127 -- For example @scale 2 image@ makes the image twice as large, while @scale 0.5 image@ makes it
+ 128 -- half the original size. Negative values are also allowed, and lead to flipping the image along
+ 129 -- both X and Y axes.
+ 130 scale :: Double -> Tree -> Tree
+ 131 scale a = withTransformations [Scale a Nothing]
+ 132
+ 133 -- | @scaleToSize width height@ resizes the image so that its bounding box has corresponding @width@
+ 134 -- and @height@.
+ 135 scaleToSize :: Double -> Double -> Tree -> Tree
+ 136 scaleToSize w h t =
+ 137 scaleXY (w/w') (h/h') t
+ 138 where
+ 139 (_x, _y, w', h') = boundingBox t
+ 140
+ 141 -- | @scaleToWidth width@ scales the image so that the width of its bounding box ends up having
+ 142 -- given @width@.
+ 143 scaleToWidth :: Double -> Tree -> Tree
+ 144 scaleToWidth w t =
+ 145 scale (w/w') t
+ 146 where
+ 147 (_x, _y, w', _h') = boundingBox t
+ 148
+ 149 -- | @scaleToHeight height@ scales the image so that the height of its bounding box ends up having
+ 150 -- given @height@.
+ 151 scaleToHeight :: Double -> Tree -> Tree
+ 152 scaleToHeight h t =
+ 153 scale (h/h') t
+ 154 where
+ 155 (_x, _y, _w', h') = boundingBox t
+ 156
+ 157 -- | Similar to 'scale', except scale factors for X and Y axes are specified separately.
+ 158 scaleXY :: Double -> Double -> Tree -> Tree
+ 159 scaleXY x y = withTransformations [Scale x (Just y)]
+ 160
+ 161
+ 162 -- | Flip the image along vertical axis so that what was on the right will end up on left and vice
+ 163 -- versa.
+ 164 flipXAxis :: Tree -> Tree
+ 165 flipXAxis = scaleXY (-1) 1
+ 166
+ 167 -- | Flip the image along horizontal so that what was on the top will end up in the bottom and vice
+ 168 -- versa.
+ 169 flipYAxis :: Tree -> Tree
+ 170 flipYAxis = scaleXY 1 (-1)
+ 171
+ 172 -- | Translate given image so that the center of its bouding box coincides with coordinates
+ 173 -- @(0, 0)@.
+ 174 center :: Tree -> Tree
+ 175 center t = centerUsing t t
+ 176
+ 177 -- | Translate given image so that the X-coordinate of the center of its bouding box is 0.
+ 178 centerX :: Tree -> Tree
+ 179 centerX t = translate (-x-w/2) 0 t
+ 180 where
+ 181 (x, _y, w, _h) = boundingBox t
+ 182
+ 183 -- | Translate given image so that the Y-coordinate of the center of its bouding box is 0.
+ 184 centerY :: Tree -> Tree
+ 185 centerY t = translate 0 (-y-h/2) t
+ 186 where
+ 187 (_x, y, _w, h) = boundingBox t
+ 188
+ 189 -- | Center the second argument using the bounding-box of the first.
+ 190 centerUsing :: Tree -> Tree -> Tree
+ 191 centerUsing a = translate (-x-w/2) (-y-h/2)
+ 192 where
+ 193 (x, y, w, h) = boundingBox a
+ 194
+ 195 -- | Create 'Texture' based on SVG color name.
+ 196 -- See <https://en.wikipedia.org/wiki/Web_colors#X11_color_names> for the list of available names.
+ 197 -- If the provided name doesn't correspond to valid SVG color name, white-ish color is used.
+ 198 mkColor :: String -> Texture
+ 199 mkColor name =
+ 200 case Map.lookup (T.pack name) svgNamedColors of
+ 201 Nothing -> ColorRef (PixelRGBA8 240 248 255 255)
+ 202 Just c -> ColorRef c
+ 203
+ 204 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke>
+ 205 withStrokeColor :: String -> Tree -> Tree
+ 206 withStrokeColor color = strokeColor .~ pure (mkColor color)
+ 207
+ 208 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke>
+ 209 withStrokeColorPixel :: PixelRGBA8 -> Tree -> Tree
+ 210 withStrokeColorPixel color = strokeColor .~ pure (ColorRef color)
+ 211
+ 212 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke-dasharray>
+ 213 withStrokeDashArray :: [Double] -> Tree -> Tree
+ 214 withStrokeDashArray arr = strokeDashArray .~ pure (map Num arr)
+ 215
+ 216 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke-linejoin>
+ 217 withStrokeLineJoin :: LineJoin -> Tree -> Tree
+ 218 withStrokeLineJoin ljoin = strokeLineJoin .~ pure ljoin
+ 219
+ 220 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/fill>
+ 221 withFillColor :: String -> Tree -> Tree
+ 222 withFillColor color = fillColor .~ pure (mkColor color)
+ 223
+ 224 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/fill>
+ 225 withFillColorPixel :: PixelRGBA8 -> Tree -> Tree
+ 226 withFillColorPixel color = fillColor .~ pure (ColorRef color)
+ 227
+ 228 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/fill-opacity>
+ 229 withFillOpacity :: Double -> Tree -> Tree
+ 230 withFillOpacity opacity = fillOpacity ?~ realToFrac opacity
+ 231
+ 232 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/opacity>
+ 233 withGroupOpacity :: Double -> Tree -> Tree
+ 234 withGroupOpacity opacity = groupOpacity ?~ realToFrac opacity
+ 235
+ 236 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/stroke-width>
+ 237 withStrokeWidth :: Double -> Tree -> Tree
+ 238 withStrokeWidth width = strokeWidth .~ pure (Num width)
+ 239
+ 240 -- | See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/clip-path>
+ 241 withClipPathRef :: ElementRef -- ^ Reference to clip path defined previously (e.g. by 'mkClipPath')
+ 242 -> Tree -- ^ Image that will be clipped by the referenced clip path
+ 243 -> Tree
+ 244 withClipPathRef ref sub = mkGroup [sub] & clipPathRef .~ pure ref
+ 245
+ 246 -- | Assigns ID attribute to given image.
+ 247 withId :: String -> Tree -> Tree
+ 248 withId idTag = attrId ?~ idTag
+ 249
+ 250 -- | @mkRect width height@ creates a rectangle with given @with@ and @height@, centered at @(0, 0)@.
+ 251 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/rect>
+ 252 mkRect :: Double -> Double -> Tree
+ 253 mkRect width height = translate (-width/2) (-height/2) $ rectangleTree $ defaultSvg
+ 254 & rectUpperLeftCorner .~ (Num 0, Num 0)
+ 255 & rectWidth ?~ Num width
+ 256 & rectHeight ?~ Num height
+ 257
+ 258 -- | Create a circle with given radius, centered at @(0, 0)@.
+ 259 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/circle>
+ 260 mkCircle :: Double -> Tree
+ 261 mkCircle radius = circleTree $ defaultSvg
+ 262 & circleCenter .~ (Num 0, Num 0)
+ 263 & circleRadius .~ Num radius
+ 264
+ 265 -- | Create an ellipse given X-axis radius, and Y-axis radius, with center at @(0, 0)@.
+ 266 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/ellipse>
+ 267 mkEllipse :: Double -> Double -> Tree
+ 268 mkEllipse rx ry = ellipseTree $ defaultSvg
+ 269 & ellipseCenter .~ (Num 0, Num 0)
+ 270 & ellipseXRadius .~ Num rx
+ 271 & ellipseYRadius .~ Num ry
+ 272
+ 273 -- | Create a line segment between two points given by their @(x, y)@ coordinates.
+ 274 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/line>
+ 275 mkLine :: (Double,Double) -> (Double, Double) -> Tree
+ 276 mkLine (x1,y1) (x2,y2) = lineTree $ defaultSvg
+ 277 & linePoint1 .~ (Num x1, Num y1)
+ 278 & linePoint2 .~ (Num x2, Num y2)
+ 279
+ 280 -- | Merges multiple images into one.
+ 281 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/g>
+ 282 mkGroup :: [Tree] -> Tree
+ 283 mkGroup forest = groupTree $ defaultSvg
+ 284 & groupChildren .~ forest
+ 285
+ 286 -- | Create definition of graphical objects that can be used at later time.
+ 287 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/defs>
+ 288 mkDefinitions :: [Tree] -> Tree
+ 289 mkDefinitions forest = definitionTree $ defaultSvg
+ 290 & groupChildren .~ forest
+ 291
+ 292 -- | Create an element by referring to existing element defined previously.
+ 293 -- For example you can create a graphical element, assign ID to it using 'withId', wrap it in
+ 294 -- 'mkDefinitions' and then use it via @use "myId"@.
+ 295 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/use>
+ 296 mkUse :: String -> Tree
+ 297 mkUse name = useTree (defaultSvg & useName .~ name)
+ 298
+ 299 -- | A clip path restricts the region to which paint can be applied.
+ 300 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Element/clipPath>
+ 301 mkClipPath :: String -- ^ ID of the clip path, which can then be referred to by other elements
+ 302 -- using 'withClipPathRef'.
+ 303 -> [Tree] -- ^ List of shapes that will determine the final shape of the clipping region
+ 304 -> Tree
+ 305 mkClipPath idTag forest = withId idTag $ clipPathTree $ defaultSvg
+ 306 & clipPathContent .~ forest
+ 307
+ 308 -- | Create a path from the list of path commands.
+ 309 -- See <https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d#Path_commands>
+ 310 mkPath :: [PathCommand] -> Tree
+ 311 mkPath cmds = pathTree $ defaultSvg & pathDefinition .~ cmds
+ 312
+ 313 -- | Similar to 'mkPathText', but taking SVG path command as a String.
+ 314 mkPathString :: String -> Tree
+ 315 mkPathString = mkPathText . T.pack
+ 316
+ 317 -- | Create path from textual representation of SVG path command.
+ 318 -- If the text doesn't represent valid path command, this function fails with 'Prelude.error'.
+ 319 -- Use 'mkPath' for type safe way of creating paths.
+ 320 mkPathText :: T.Text -> Tree
+ 321 mkPathText str =
+ 322 case parseOnly pathParser str of
+ 323 Left err -> error err
+ 324 Right cmds -> mkPath cmds
+ 325
+ 326 -- | Create a path from a list of @(x, y)@ coordinates of points along the path.
+ 327 mkLinePath :: [(Double, Double)] -> Tree
+ 328 mkLinePath [] = mkGroup []
+ 329 mkLinePath ((startX, startY):rest) =
+ 330 pathTree $ defaultSvg & pathDefinition .~ cmds
+ 331 where
+ 332 cmds = [ MoveTo OriginAbsolute [V2 startX startY]
+ 333 , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ] ]
+ 334
+ 335 -- | Create a path from a list of @(x, y)@ coordinates of points along the path.
+ 336 mkLinePathClosed :: [(Double, Double)] -> Tree
+ 337 mkLinePathClosed [] = mkGroup []
+ 338 mkLinePathClosed ((startX, startY):rest) =
+ 339 pathTree $ defaultSvg & pathDefinition .~ cmds
+ 340 where
+ 341 cmds = [ MoveTo OriginAbsolute [V2 startX startY]
+ 342 , LineTo OriginAbsolute [ V2 x y | (x, y) <- rest ]
+ 343 , EndPath ]
+ 344
+ 345 -- | Rectangle with a uniform color and the same size as the screen.
+ 346 --
+ 347 -- Example:
+ 348 --
+ 349 -- @
+ 350 -- 'Reanimate.animate' $ 'const' $ 'mkBackground' "yellow"
+ 351 -- @
+ 352 --
+ 353 -- <<docs/gifs/doc_mkBackground.gif>>
+ 354 mkBackground :: String -> Tree
+ 355 mkBackground color = withFillOpacity 1 $ withStrokeWidth 0 $
+ 356 withFillColor color $ mkRect screenWidth screenHeight
+ 357
+ 358 -- | Rectangle with a uniform color and the same size as the screen.
+ 359 mkBackgroundPixel :: PixelRGBA8 -> Tree
+ 360 mkBackgroundPixel pixel =
+ 361 withFillOpacity 1 $ withStrokeWidth 0 $
+ 362 withFillColorPixel pixel $ mkRect screenWidth screenHeight
+ 363
+ 364 -- | Take list of rows, where each row consists of number of images and display them in regular
+ 365 -- grid structure.
+ 366 -- All rows will get equal amount of vertical space.
+ 367 -- The images within each row will get equal amount of horizontal space, independent of the other
+ 368 -- rows. Each row can contain different number of cells.
+ 369 gridLayout :: [[Tree]] -> Tree
+ 370 gridLayout rows = mkGroup
+ 371 [ translate (-screenWidth/2+colSep*nCol + colSep*0.5)
+ 372 (screenHeight/2-rowSep*nRow - rowSep*0.5)
+ 373 elt
+ 374 | (nRow, row) <- zip [0..] rows
+ 375 , let nCols = length row
+ 376 colSep = screenWidth / fromIntegral nCols
+ 377 , (nCol, elt) <- zip [0..] row ]
+ 378 where
+ 379 rowSep = screenHeight / fromIntegral nRows
+ 380 nRows = length rows
+ 381
+ 382 -- | Insert a native text object anchored at the middle.
+ 383 --
+ 384 -- Example:
+ 385 --
+ 386 -- @
+ 387 -- 'Reanimate.mkAnimation' 2 $ \\t -> 'scale' 2 $ 'withStrokeWidth' 0.05 $ 'mkText' (T.take (round $ t*15) "text")
+ 388 -- @
+ 389 --
+ 390 -- <<docs/gifs/doc_mkText.gif>>
+ 391 mkText :: T.Text -> Tree
+ 392 mkText str =
+ 393 flipYAxis
+ 394 (TextTree Nothing $ defaultSvg
+ 395 & textRoot .~ span_
+ 396 & fontSize .~ pure (Num 2))
+ 397 & textAnchor .~ pure TextAnchorMiddle
+ 398 -- Note: TextAnchorMiddle is placed on the 'flipYAxis' group such that it can easily
+ 399 -- be overwritten by the user.
+ 400 where
+ 401 span_ = defaultSvg & spanContent .~ [SpanText str]
+ 402
+ 403 -- | Switch from the default viewbox to a custom viewbox. Nesting custom viewboxes is
+ 404 -- unlikely to give good results. If you need nested custom viewboxes, you will have
+ 405 -- to configure them by hand.
+ 406 --
+ 407 -- The viewbox argument is (min-x, min-y, width, height).
+ 408 --
+ 409 -- Example:
+ 410 --
+ 411 -- @
+ 412 -- 'withViewBox' (0,0,1,1) $ 'mkBackground' "yellow"
+ 413 -- @
+ 414 --
+ 415 -- <<docs/gifs/doc_withViewBox.gif>>
+ 416 withViewBox :: (Double, Double, Double, Double) -> Tree -> Tree
+ 417 withViewBox vbox child = translate (-screenWidth/2) (-screenHeight/2) $
+ 418 svgTree Document
+ 419 { _documentViewBox = Just vbox
+ 420 , _documentWidth = Just (Num screenWidth)
+ 421 , _documentHeight = Just (Num screenHeight)
+ 422 , _documentElements = [child]
+ 423 , _documentDescription = ""
+ 424 , _documentLocation = ""
+ 425 , _documentAspectRatio = PreserveAspectRatio False AlignNone Nothing
+ 426 }
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Svg.LineCommand.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Svg.LineCommand.hs.html
new file mode 100644
index 0000000..595a69a
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Svg.LineCommand.hs.html
@@ -0,0 +1,302 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Copyright : Written by David Himmelstrup
+ 3 License : Unlicense
+ 4 Maintainer : lemmih@gmail.com
+ 5 Stability : experimental
+ 6 Portability : POSIX
+ 7 -}
+ 8 module Reanimate.Svg.LineCommand
+ 9 ( CmdM
+ 10 , LineCommand(..)
+ 11 , lineLength
+ 12 , toLineCommands
+ 13 , lineToPath
+ 14 , lineToPoints
+ 15 , partialSvg
+ 16 ) where
+ 17
+ 18 import Control.Lens ((%~), (&), (.~))
+ 19 import Control.Monad.Fix
+ 20 import Control.Monad.State
+ 21 import Data.Functor
+ 22 import qualified Data.Vector.Unboxed as V
+ 23 import qualified Geom2D.CubicBezier.Linear as Bezier
+ 24 import Graphics.SvgTree
+ 25 import Linear.Metric
+ 26 import Linear.V2 hiding (angle)
+ 27 import Linear.Vector
+ 28
+ 29 -- | Line command monad used for keeping track of the current location.
+ 30 type CmdM a = State RPoint a
+ 31
+ 32 -- | Simplified version of a PathCommand where all points are absolute.
+ 33 data LineCommand
+ 34 = LineMove RPoint
+ 35 -- | LineDraw RPoint
+ 36 | LineBezier [RPoint]
+ 37 | LineEnd RPoint
+ 38 deriving (Show)
+ 39
+ 40 -- | Convert from line commands to path commands.
+ 41 lineToPath :: [LineCommand] -> [PathCommand]
+ 42 lineToPath = map worker
+ 43 where
+ 44 worker (LineMove p) = MoveTo OriginAbsolute [p]
+ 45 -- worker (LineDraw p) = LineTo OriginAbsolute [p]
+ 46 worker (LineBezier [a,b,c]) = CurveTo OriginAbsolute [(a,b,c)]
+ 47 worker (LineBezier [a,b]) = QuadraticBezier OriginAbsolute [(a,b)]
+ 48 worker (LineBezier [a]) = LineTo OriginAbsolute [a]
+ 49 worker LineBezier{} = error "Reanimate.Svg.lineToPath: invalid bezier curve"
+ 50 worker LineEnd{} = EndPath
+ 51
+ 52 -- | Using @n@ control points, approximate the path of the curves.
+ 53 lineToPoints :: Int -> [LineCommand] -> [RPoint]
+ 54 lineToPoints nPoints cmds =
+ 55 map lineEnd lineSegments
+ 56 where
+ 57 lineSegments = [ partialLine (fromIntegral n/ fromIntegral nPoints) cmds | n <- [0 .. nPoints-1] ]
+ 58 lineEnd [LineBezier pts] = last pts
+ 59 lineEnd (_:xs) = lineEnd xs
+ 60 lineEnd _ = error "invalid line"
+ 61
+ 62 partialLine :: Double -> [LineCommand] -> [LineCommand]
+ 63 partialLine alpha cmds = evalState (worker 0 cmds) zero
+ 64 where
+ 65 worker _d [] = pure []
+ 66 worker d (cmd:xs) = do
+ 67 from <- get
+ 68 len <- lineLength cmd
+ 69 let frac = (targetLen-d) / len
+ 70 if len == 0 || frac >= 1
+ 71 then (cmd:) <$> worker (d+len) xs
+ 72 else pure [adjustLineLength frac from cmd]
+ 73 totalLen = evalState (sum <$> mapM lineLength cmds) zero
+ 74 targetLen = totalLen * alpha
+ 75
+ 76 adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand
+ 77 adjustLineLength alpha from cmd =
+ 78 case cmd of
+ 79 LineBezier points -> LineBezier $ drop 1 $ partialBezierPoints (from:points) 0 alpha
+ 80 LineMove p -> LineMove p
+ 81 -- LineDraw t -> LineDraw (lerp alpha t from)
+ 82 LineEnd p -> LineBezier [lerp alpha p from]
+ 83
+ 84 -- | Estimated length of all segments in a line.
+ 85 lineLength :: LineCommand -> CmdM Double
+ 86 lineLength cmd =
+ 87 case cmd of
+ 88 LineMove to -> 0 <$ put to
+ 89 -- Straight line:
+ 90 LineBezier [dst] -> gets (distance dst) <* put dst
+ 91 -- Some kind of curve:
+ 92 LineBezier lst -> do
+ 93 from <- get
+ 94 let bezier = rpointsToBezier (from:lst)
+ 95 tol = 0.0001
+ 96 put (last lst)
+ 97 pure $ Bezier.arcLength bezier 1 tol
+ 98 LineEnd to -> gets (distance to) <* put to
+ 99
+ 100 rpointsToBezier :: [RPoint] -> Bezier.CubicBezier Double
+ 101 rpointsToBezier lst =
+ 102 case lst of
+ 103 [a,b] -> Bezier.CubicBezier a a b b
+ 104 [a,b,c] -> Bezier.quadToCubic (Bezier.QuadBezier a b c)
+ 105 [a,b,c,d] -> Bezier.CubicBezier a b c d
+ 106 _ -> error $ "rpointsToBezier: Invalid list of points: " ++ show lst
+ 107
+ 108 -- | Convert from path commands to line commands.
+ 109 toLineCommands :: [PathCommand] -> [LineCommand]
+ 110 toLineCommands ps = evalState (worker zero Nothing ps) zero
+ 111 where
+ 112 worker _startPos _mbPrevControlPt [] = pure []
+ 113 worker startPos mbPrevControlPt (cmd:cmds) = do
+ 114 lcmds <- toLineCommand startPos mbPrevControlPt cmd
+ 115 let startPos' =
+ 116 case lcmds of
+ 117 [LineMove pos] -> pos
+ 118 _ -> startPos
+ 119 (lcmds++) <$> worker startPos' (cmdToControlPoint $ last lcmds) cmds
+ 120
+ 121 cmdToControlPoint :: LineCommand -> Maybe RPoint
+ 122 cmdToControlPoint (LineBezier points) = Just (last (init points))
+ 123 cmdToControlPoint _ = Nothing
+ 124
+ 125 mkStraightLine :: RPoint -> LineCommand
+ 126 mkStraightLine p = LineBezier [p]
+ 127
+ 128 toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand]
+ 129 toLineCommand startPos mbPrevControlPt cmd =
+ 130 case cmd of
+ 131 MoveTo OriginAbsolute [] -> pure []
+ 132 MoveTo OriginAbsolute lst -> put (last lst) *> gets (pure.LineMove)
+ 133 MoveTo OriginRelative lst -> modify (+ sum lst) *> gets (pure.LineMove)
+ 134 LineTo OriginAbsolute lst -> forM lst (\to -> put to $> mkStraightLine to)
+ 135 LineTo OriginRelative lst -> forM lst (\to -> modify (+to) *> gets mkStraightLine)
+ 136 HorizontalTo OriginAbsolute lst ->
+ 137 forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine
+ 138 HorizontalTo OriginRelative lst ->
+ 139 forM lst $ \x -> modify (_x %~ (+x)) *> gets mkStraightLine
+ 140 VerticalTo OriginAbsolute lst ->
+ 141 forM lst $ \y -> modify (_y .~ y) *> gets mkStraightLine
+ 142 VerticalTo OriginRelative lst ->
+ 143 forM lst $ \y -> modify (_y %~ (+y)) *> gets mkStraightLine
+ 144 CurveTo OriginAbsolute quads ->
+ 145 forM quads $ \(a,b,c) -> put c $> LineBezier [a,b,c]
+ 146 CurveTo OriginRelative quads ->
+ 147 forM quads $ \(a,b,c) -> do
+ 148 from <- get <* modify (+c)
+ 149 pure $ LineBezier $ map (+from) [a,b,c]
+ 150 SmoothCurveTo o lst -> mfix $ \result -> do
+ 151 let ctrl = mbPrevControlPt : map cmdToControlPoint result
+ 152 forM (zip lst ctrl) $ \((c2,to), mbControl) -> do
+ 153 from <- get <* adjustPosition o to
+ 154 let c1 = maybe (makeAbsolute o from c2) (mirrorPoint from) mbControl
+ 155 pure $ LineBezier [c1,makeAbsolute o from c2,makeAbsolute o from to]
+ 156 QuadraticBezier OriginAbsolute pairs ->
+ 157 forM pairs $ \(a,b) -> put b $> LineBezier [a,b]
+ 158 QuadraticBezier OriginRelative pairs ->
+ 159 forM pairs $ \(a,b) -> do
+ 160 from <- get <* modify (+b)
+ 161 pure $ LineBezier $ map (+from) [a,b]
+ 162 SmoothQuadraticBezierCurveTo o lst -> mfix $ \result -> do
+ 163 let ctrl = mbPrevControlPt : map cmdToControlPoint result
+ 164 forM (zip lst ctrl) $ \(to, mbControl) -> do
+ 165 from <- get <* adjustPosition o to
+ 166 let c1 = maybe from (mirrorPoint from) mbControl
+ 167 pure $ LineBezier [c1,makeAbsolute o from to]
+ 168 EllipticalArc o points -> concat <$>
+ 169 forM points (\(rotX, rotY, angle, largeArc, sweepFlag, to) -> do
+ 170 from <- get <* adjustPosition o to
+ 171 return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to))
+ 172 EndPath -> put startPos $> [LineEnd startPos]
+ 173 where
+ 174 mirrorPoint c p = c*2-p
+ 175 adjustPosition OriginRelative p = modify (+p)
+ 176 adjustPosition OriginAbsolute p = put p
+ 177 makeAbsolute OriginAbsolute _from p = p
+ 178 makeAbsolute OriginRelative from p = from+p
+ 179
+ 180
+ 181 calculateVectorAngle :: Double -> Double -> Double -> Double -> Double
+ 182 calculateVectorAngle ux uy vx vy
+ 183 | tb >= ta
+ 184 = tb - ta
+ 185 | otherwise
+ 186 = pi * 2 - (ta - tb)
+ 187 where
+ 188 ta = atan2 uy ux
+ 189 tb = atan2 vy vx
+ 190
+ 191 -- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs
+ 192 {- HLINT ignore convertSvgArc -}
+ 193 convertSvgArc :: RPoint -> Coord -> Coord -> Coord -> Bool -> Bool -> RPoint -> [LineCommand]
+ 194 convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y)
+ 195 | x0 == x && y0 == y
+ 196 = []
+ 197 | radiusX == 0.0 && radiusY == 0.0
+ 198 = [LineBezier [V2 x y]]
+ 199 | otherwise
+ 200 = calcSegments x0 y0 theta1' segments'
+ 201 where
+ 202 sinPhi = sin (angle * pi/180)
+ 203 cosPhi = cos (angle * pi/180)
+ 204
+ 205 x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0
+ 206 y1dash = -sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0
+ 207
+ 208 numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash
+ 209
+ 210 s = sqrt(1.0 - numerator / (radiusX * radiusX * radiusY * radiusY))
+ 211 rx = if (numerator < 0.0) then (radiusX * s) else radiusX
+ 212 ry = if (numerator < 0.0) then (radiusY * s) else radiusY
+ 213 root = if (numerator < 0.0)
+ 214 then (0.0)
+ 215 else ((if ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) then (-1.0) else 1.0) *
+ 216 sqrt(numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash)))
+ 217
+ 218 cxdash = root * rx * y1dash / ry
+ 219 cydash = -root * ry * x1dash / rx
+ 220
+ 221 cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0
+ 222 cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0
+ 223
+ 224 theta1' = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry)
+ 225 dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((-x1dash - cxdash) / rx) ((-y1dash - cydash) / ry)
+ 226 dtheta = if (not sweepFlag && dtheta' > 0)
+ 227 then (dtheta' - 2 * pi)
+ 228 else (if (sweepFlag && dtheta' < 0) then dtheta' + 2 * pi else dtheta')
+ 229
+ 230 segments' = ceiling (abs (dtheta / (pi / 2.0)))
+ 231 delta = dtheta / fromInteger segments'
+ 232 t = 8.0 / 3.0 * sin(delta / 4.0) * sin(delta / 4.0) / sin(delta / 2.0)
+ 233
+ 234 calcSegments startX startY theta1 segments
+ 235 | segments == 0
+ 236 = []
+ 237 | otherwise
+ 238 = LineBezier [ V2 (startX + dx1) (startY + dy1)
+ 239 , V2 (endpointX + dxe) (endpointY + dye)
+ 240 , V2 endpointX endpointY ] : calcSegments endpointX endpointY theta2 (segments - 1)
+ 241 where
+ 242 cosTheta1 = cos theta1
+ 243 sinTheta1 = sin theta1
+ 244 theta2 = theta1 + delta
+ 245 cosTheta2 = cos theta2
+ 246 sinTheta2 = sin theta2
+ 247
+ 248 endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx
+ 249 endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy
+ 250
+ 251 dx1 = t * (-cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1)
+ 252 dy1 = t * (-sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1)
+ 253
+ 254 dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2)
+ 255 dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2)
+ 256
+ 257 partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint]
+ 258 partialBezierPoints ps a b =
+ 259 let c1 = Bezier.AnyBezier (V.fromList ps)
+ 260 Bezier.AnyBezier os = Bezier.bezierSubsegment c1 a b
+ 261 in V.toList os
+ 262
+ 263 {- | Create an image showing portion of a path.
+ 264 Note that this only affects paths (see 'Reanimate.Svg.Constructors.mkPath').
+ 265 You can also use this with other SVG shapes if you convert them to path first (see 'Reanimate.Svg.pathify').
+ 266
+ 267 Typical usage:
+ 268
+ 269 > animate $ \t -> partialSvg t myPath
+ 270 -}
+ 271 partialSvg :: Double -- ^ number between 0 and 1 inclusively, determining what portion of the path to show
+ 272 -> Tree -- ^ Image representing a path, of which we only want to display a portion determined by the first argument
+ 273 -> Tree
+ 274 partialSvg alpha | alpha >= 1 = id
+ 275 partialSvg alpha = mapTree worker
+ 276 where
+ 277 worker (PathTree path) =
+ 278 PathTree $ path & pathDefinition %~ lineToPath . partialLine alpha . toLineCommands
+ 279 worker t = t
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Svg.Unuse.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Svg.Unuse.hs.html
new file mode 100644
index 0000000..cfb9aeb
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Svg.Unuse.hs.html
@@ -0,0 +1,92 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Copyright : Written by David Himmelstrup
+ 3 License : Unlicense
+ 4 Maintainer : lemmih@gmail.com
+ 5 Stability : experimental
+ 6 Portability : POSIX
+ 7 -}
+ 8 module Reanimate.Svg.Unuse
+ 9 ( replaceUses
+ 10 , unbox
+ 11 , embedDocument
+ 12 ) where
+ 13
+ 14 import Control.Lens ((%~), (&), (.~), (?~), (^.))
+ 15 import qualified Data.Map as Map
+ 16 import Data.Maybe
+ 17 import Graphics.SvgTree
+ 18 import Reanimate.Constants
+ 19 import Reanimate.Svg.Constructors
+ 20
+ 21 -- | Replace all @<use>@ nodes with their definition.
+ 22 replaceUses :: Document -> Document
+ 23 replaceUses doc = doc & documentElements %~ map (mapTree replace)
+ 24 where
+ 25 replaceDefinition PathTree{} = None
+ 26 replaceDefinition t = t
+ 27
+ 28 replace t@DefinitionTree{} = mapTree replaceDefinition t
+ 29 replace (UseTree _ Just{}) = error "replaceUses: subtree in use?"
+ 30 replace (UseTree use Nothing) =
+ 31 case Map.lookup (use^.useName) idMap of
+ 32 Nothing -> error $ "Unknown id: " ++ (use^.useName)
+ 33 Just tree -> mapTree replace $
+ 34 groupTree (defaultSvg & groupChildren .~ [tree])
+ 35 & transform ?~
+ 36 fromMaybe [] (use^.transform) ++
+ 37 [baseToTransformation (use^.useBase)]
+ 38 replace x = x
+ 39 baseToTransformation (x,y) =
+ 40 case (toUserUnit defaultDPI x, toUserUnit defaultDPI y) of
+ 41 (Num a, Num b) -> Translate a b
+ 42 _ -> TransformUnknown
+ 43 docTree = mkGroup (doc^.documentElements)
+ 44 idMap = foldTree updMap Map.empty docTree
+ 45 updMap m tree =
+ 46 case tree^.attrId of
+ 47 Nothing -> m
+ 48 Just tid -> Map.insert tid tree m
+ 49
+ 50 -- FIXME: the viewbox is ignored. Can we use the viewbox as a mask?
+ 51 -- | Transform out viewbox. Definitions and CSS rules are discarded.
+ 52 unbox :: Document -> Tree
+ 53 unbox doc@Document{_documentViewBox = Just (_minx, _minw, _width, _height)} =
+ 54 groupTree $ defaultSvg
+ 55 & groupChildren .~ doc^.documentElements
+ 56 unbox doc =
+ 57 groupTree $ defaultSvg
+ 58 & groupChildren .~ doc^.documentElements
+ 59
+ 60 -- | Embed 'Document'. This keeps the entire document intact but makes
+ 61 -- it more difficult to use, say, `Reanimate.Svg.pathify` on it.
+ 62 embedDocument :: Document -> Tree
+ 63 embedDocument doc =
+ 64 translate (-screenWidth/2) (screenHeight/2) $
+ 65 withFillOpacity 1 $
+ 66 withStrokeWidth 0 $
+ 67 flipYAxis $
+ 68 svgTree $ doc & documentWidth .~ Nothing
+ 69 & documentHeight .~ Nothing
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Svg.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Svg.hs.html
new file mode 100644
index 0000000..bfe0cba
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Svg.hs.html
@@ -0,0 +1,370 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE LambdaCase #-}
+ 2 {-|
+ 3 Copyright : Written by David Himmelstrup
+ 4 License : Unlicense
+ 5 Maintainer : lemmih@gmail.com
+ 6 Stability : experimental
+ 7 Portability : POSIX
+ 8 -}
+ 9 module Reanimate.Svg
+ 10 ( module Reanimate.Svg
+ 11 , module Reanimate.Svg.Constructors
+ 12 , module Reanimate.Svg.LineCommand
+ 13 , module Reanimate.Svg.BoundingBox
+ 14 , module Reanimate.Svg.Unuse
+ 15 ) where
+ 16
+ 17 import Control.Lens ((%~), (&), (.~), (^.), (?~))
+ 18 import Control.Monad.State
+ 19 import Graphics.SvgTree
+ 20 import Linear.V2 hiding (angle)
+ 21 import Reanimate.Constants
+ 22 import Reanimate.Animation (SVG)
+ 23 import Reanimate.Svg.Constructors
+ 24 import Reanimate.Svg.LineCommand
+ 25 import Reanimate.Svg.BoundingBox
+ 26 import Reanimate.Svg.Unuse
+ 27 import qualified Reanimate.Transform as Transform
+ 28
+ 29 -- | Remove transformations (such as translations, rotations, scaling)
+ 30 -- and apply them directly to the SVG nodes. Note, this function
+ 31 -- may convert nodes (such as Circle or Rect) to paths. Also note
+ 32 -- that /does/ change how the SVG is rendered. Particularly, stroke
+ 33 -- width is affected by directly applying scaling.
+ 34 --
+ 35 -- @lowerTransformations (scale 2 (mkCircle 1)) = mkCircle 2@
+ 36 lowerTransformations :: SVG -> SVG
+ 37 lowerTransformations = worker False Transform.identity
+ 38 where
+ 39 updLineCmd m cmd =
+ 40 case cmd of
+ 41 LineMove p -> LineMove $ Transform.transformPoint m p
+ 42 -- LineDraw p -> LineDraw $ Transform.transformPoint m p
+ 43 LineBezier ps -> LineBezier $ map (Transform.transformPoint m) ps
+ 44 LineEnd p -> LineEnd $ Transform.transformPoint m p
+ 45 updPath m = lineToPath . map (updLineCmd m) . toLineCommands
+ 46 updPoint m (Num a,Num b) =
+ 47 case Transform.transformPoint m (V2 a b) of
+ 48 V2 x y -> (Num x, Num y)
+ 49 updPoint _ other = other -- XXX: Can we do better here?
+ 50 worker hasPathified m t =
+ 51 let m' = m * Transform.mkMatrix (t^.transform) in
+ 52 case t of
+ 53 PathTree path -> PathTree $
+ 54 path & pathDefinition %~ updPath m'
+ 55 & transform .~ Nothing
+ 56 GroupTree g -> GroupTree $
+ 57 g & groupChildren %~ map (worker hasPathified m')
+ 58 & transform .~ Nothing
+ 59 LineTree line ->
+ 60 LineTree $
+ 61 line & linePoint1 %~ updPoint m
+ 62 & linePoint2 %~ updPoint m
+ 63 ClipPathTree{} -> t
+ 64 -- If we encounter an unknown node and we've already tried to convert
+ 65 -- to paths, give up and insert an explicit transformation.
+ 66 _ | hasPathified ->
+ 67 mkGroup [t] & transform ?~ [ Transform.toTransformation m ]
+ 68 -- If we haven't tried to pathify, run pathify only once.
+ 69 _ -> worker True m (pathify t)
+ 70
+ 71 -- | Remove all @id@ attributes.
+ 72 lowerIds :: SVG -> SVG
+ 73 lowerIds = mapTree worker
+ 74 where
+ 75 worker t@GroupTree{} = t & attrId .~ Nothing
+ 76 worker t@PathTree{} = t & attrId .~ Nothing
+ 77 worker t = t
+ 78
+ 79 -- | Optimize SVG tree without affecting how it is rendered.
+ 80 simplify :: SVG -> SVG
+ 81 simplify root =
+ 82 case worker root of
+ 83 [] -> None
+ 84 [x] -> x
+ 85 xs -> mkGroup xs
+ 86 where
+ 87 worker None = []
+ 88 worker (DefinitionTree d) =
+ 89 concatMap dropNulls
+ 90 [DefinitionTree $ d & groupChildren %~ concatMap worker]
+ 91 worker (GroupTree g)
+ 92 | g^.drawAttributes == defaultSvg =
+ 93 concatMap dropNulls $
+ 94 concatMap worker (g^.groupChildren)
+ 95 | otherwise =
+ 96 dropNulls $
+ 97 GroupTree $ g & groupChildren %~ concatMap worker
+ 98 worker t = dropNulls t
+ 99
+ 100 dropNulls None = []
+ 101 dropNulls (DefinitionTree d)
+ 102 | null (d^.groupChildren) = []
+ 103 dropNulls (GroupTree g)
+ 104 | null (g^.groupChildren) = []
+ 105 dropNulls t = [t]
+ 106
+ 107 -- | Separate grouped items. This is required by clip nodes.
+ 108 --
+ 109 -- @removeGroups (withFillColor "blue" $ mkGroup [mkCircle 1, mkRect 1 1])
+ 110 -- = [ withFillColor "blue" $ mkCircle 1
+ 111 -- , withFillColor "blue" $ mkRect 1 1 ]@
+ 112 removeGroups :: SVG -> [SVG]
+ 113 removeGroups = worker defaultSvg
+ 114 where
+ 115 worker _attr None = []
+ 116 worker _attr (DefinitionTree d) =
+ 117 concatMap dropNulls
+ 118 [DefinitionTree $ d & groupChildren %~ concatMap (worker defaultSvg)]
+ 119 worker attr (GroupTree g)
+ 120 | g^.drawAttributes == defaultSvg =
+ 121 concatMap dropNulls $
+ 122 concatMap (worker attr) (g^.groupChildren)
+ 123 | otherwise =
+ 124 concatMap (worker (attr <> g^.drawAttributes)) (g^.groupChildren)
+ 125 worker attr t = dropNulls (t & drawAttributes .~ attr)
+ 126
+ 127 dropNulls None = []
+ 128 dropNulls (DefinitionTree d)
+ 129 | null (d^.groupChildren) = []
+ 130 dropNulls (GroupTree g)
+ 131 | null (g^.groupChildren) = []
+ 132 dropNulls t = [t]
+ 133
+ 134 -- | Extract all path commands from a node (and its children) and concatenate them.
+ 135 extractPath :: SVG -> [PathCommand]
+ 136 extractPath = worker . simplify . lowerTransformations . pathify
+ 137 where
+ 138 worker (GroupTree g) = concatMap worker (g^.groupChildren)
+ 139 worker (PathTree p) = p^.pathDefinition
+ 140 worker _ = []
+ 141
+ 142 -- | Map over indexed symbols.
+ 143 --
+ 144 -- @withSubglyphs [0,2] (scale 2) (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2])
+ 145 -- = mkGroup [scale 2 (mkCircle 1), mkRect 2, scale 2 (mkEllipse 1 2)]@
+ 146 withSubglyphs :: [Int] -> (SVG -> SVG) -> SVG -> SVG
+ 147 withSubglyphs target fn = \t -> evalState (worker t) 0
+ 148 where
+ 149 worker :: Tree -> State Int Tree
+ 150 worker t =
+ 151 case t of
+ 152 GroupTree g -> do
+ 153 cs <- mapM worker (g ^. groupChildren)
+ 154 return $ GroupTree $ g & groupChildren .~ cs
+ 155 PathTree{} -> handleGlyph t
+ 156 CircleTree{} -> handleGlyph t
+ 157 PolyLineTree{} -> handleGlyph t
+ 158 PolygonTree{} -> handleGlyph t
+ 159 EllipseTree{} -> handleGlyph t
+ 160 LineTree{} -> handleGlyph t
+ 161 RectangleTree{} -> handleGlyph t
+ 162 _ -> return t
+ 163 handleGlyph :: Tree -> State Int Tree
+ 164 handleGlyph svg = do
+ 165 n <- get <* modify (+1)
+ 166 if n `elem` target
+ 167 then return $ fn svg
+ 168 else return svg
+ 169
+ 170 -- | Split symbols.
+ 171 --
+ 172 -- @splitGlyphs [0,2] (mkGroup [mkCircle 1, mkRect 2, mkEllipse 1 2])
+ 173 -- = ([mkRect 2], [mkCircle 1, mkEllipse 1 2])@
+ 174 splitGlyphs :: [Int] -> SVG -> (SVG, SVG)
+ 175 splitGlyphs target = \t ->
+ 176 let (_, l, r) = execState (worker id t) (0, [], [])
+ 177 in (mkGroup l, mkGroup r)
+ 178 where
+ 179 handleGlyph :: SVG -> State (Int, [SVG], [SVG]) ()
+ 180 handleGlyph t = do
+ 181 (n, l, r) <- get
+ 182 if n `elem` target
+ 183 then put (n+1, l, t:r)
+ 184 else put (n+1, t:l, r)
+ 185 worker :: (SVG -> SVG) -> SVG -> State (Int, [SVG], [SVG]) ()
+ 186 worker acc t =
+ 187 case t of
+ 188 GroupTree g -> do
+ 189 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
+ 190 mapM_ (worker acc') (g ^. groupChildren)
+ 191 PathTree{} -> handleGlyph $ acc t
+ 192 CircleTree{} -> handleGlyph $ acc t
+ 193 PolyLineTree{} -> handleGlyph $ acc t
+ 194 PolygonTree{} -> handleGlyph $ acc t
+ 195 EllipseTree{} -> handleGlyph $ acc t
+ 196 LineTree{} -> handleGlyph $ acc t
+ 197 RectangleTree{} -> handleGlyph $ acc t
+ 198 DefinitionTree{} -> return ()
+ 199 _ ->
+ 200 modify $ \(n, l, r) -> (n, acc t:l, r)
+ 201 {-
+ 202 <g transform="translate(10,10)">
+ 203 <g transform="scale(2)">
+ 204 <circle/>
+ 205 </g>
+ 206 <g transform="scale(0.5)">
+ 207 <rect/>
+ 208 </g>
+ 209 </g>
+ 210
+ 211 [ (\svg -> <g transform="translate(10,10)"><g transform="scale(2)">svg</g></g>, <circle/>)
+ 212 , (\svg -> <g transform="translate(10,10)"><g transform="scale(0.5)">svg</g></g>, <rect/>)]
+ 213 -}
+ 214 -- | Split symbols and include their context and drawing attributes.
+ 215 svgGlyphs :: SVG -> [(SVG -> SVG, DrawAttributes, SVG)]
+ 216 svgGlyphs = worker id defaultSvg
+ 217 where
+ 218 worker acc attr =
+ 219 \case
+ 220 None -> []
+ 221 GroupTree g ->
+ 222 let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
+ 223 attr' = (g^.drawAttributes) `mappend` attr
+ 224 in concatMap (worker acc' attr') (g ^. groupChildren)
+ 225 t -> [(acc, (t^.drawAttributes) `mappend` attr, t)]
+ 226
+ 227 {-| Convert primitive SVG shapes (like those created by 'mkCircle', 'mkRect', 'mkLine' or
+ 228 'mkEllipse') into SVG path. This can be useful for creating animations of these shapes being
+ 229 drawn progressively with 'partialSvg'.
+ 230
+ 231 Example:
+ 232
+ 233 > pathifyExample :: Animation
+ 234 > pathifyExample = animate $ \t -> gridLayout
+ 235 > [ [ partialSvg t $ pathify $ mkCircle 1
+ 236 > , partialSvg t $ pathify $ mkRect 2 2
+ 237 > ]
+ 238 > , [ partialSvg t $ pathify $ mkEllipse 1 0.5
+ 239 > , partialSvg t $ pathify $ mkLine (-1, -1) (1, 1)
+ 240 > ]
+ 241 > ]
+ 242
+ 243 <<docs/gifs/doc_pathify.gif>>
+ 244 -}
+ 245 pathify :: SVG -> SVG
+ 246 pathify = mapTree worker
+ 247 where
+ 248 worker =
+ 249 \case
+ 250 RectangleTree rect | Just (x,y,w,h) <- unpackRect rect ->
+ 251 PathTree $ defaultSvg
+ 252 & drawAttributes .~ rect ^. drawAttributes
+ 253 & strokeLineCap .~ pure CapSquare
+ 254 & pathDefinition .~
+ 255 [MoveTo OriginAbsolute [V2 x y]
+ 256 ,HorizontalTo OriginRelative [w]
+ 257 ,VerticalTo OriginRelative [h]
+ 258 ,HorizontalTo OriginRelative [-w]
+ 259 ,EndPath ]
+ 260 LineTree line | Just (x1,y1, x2, y2) <- unpackLine line ->
+ 261 PathTree $ defaultSvg
+ 262 & drawAttributes .~ line ^. drawAttributes
+ 263 & pathDefinition .~
+ 264 [MoveTo OriginAbsolute [V2 x1 y1]
+ 265 ,LineTo OriginAbsolute [V2 x2 y2] ]
+ 266 CircleTree circ | Just (x, y, r) <- unpackCircle circ ->
+ 267 PathTree $ defaultSvg
+ 268 & drawAttributes .~ circ ^. drawAttributes
+ 269 & pathDefinition .~
+ 270 [MoveTo OriginAbsolute [V2 (x-r) y]
+ 271 ,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0)
+ 272 ,(r, r, 0,True,False,V2 (-r*2) 0)]]
+ 273 PolyLineTree pl ->
+ 274 let points = pl ^. polyLinePoints
+ 275 in PathTree $ defaultSvg
+ 276 & drawAttributes .~ pl ^. drawAttributes
+ 277 & pathDefinition .~ pointsToPathCommands points
+ 278 PolygonTree pg ->
+ 279 let points = pg ^. polygonPoints
+ 280 in PathTree $ defaultSvg
+ 281 & drawAttributes .~ pg ^. drawAttributes
+ 282 -- Polygon automatically connects the last point to the first. For path we must do
+ 283 -- it explicitly
+ 284 & pathDefinition .~ (pointsToPathCommands points ++ [EndPath])
+ 285 EllipseTree elip | Just (cx,cy,rx,ry) <- unpackEllipse elip ->
+ 286 PathTree $ defaultSvg
+ 287 & drawAttributes .~ elip ^. drawAttributes
+ 288 & pathDefinition .~
+ 289 [ MoveTo OriginAbsolute [V2 (cx-rx) cy]
+ 290 , EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0)
+ 291 ,(rx, ry, 0,True,False,V2 (-rx*2) 0)]]
+ 292 t -> t
+ 293 unpackCircle circ = do
+ 294 let (x,y) = circ ^. circleCenter
+ 295 liftM3 (,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ circ ^. circleRadius)
+ 296 unpackEllipse elip = do
+ 297 let (x,y) = elip ^. ellipseCenter
+ 298 liftM4 (,,,) (unpackNumber x) (unpackNumber y) (unpackNumber $ elip ^. ellipseXRadius)
+ 299 (unpackNumber $ elip ^. ellipseYRadius)
+ 300 unpackLine line = do
+ 301 let (x1,y1) = line ^. linePoint1
+ 302 (x2,y2) = line ^. linePoint2
+ 303 liftM4 (,,,) (unpackNumber x1) (unpackNumber y1) (unpackNumber x2) (unpackNumber y2)
+ 304 unpackRect rect = do
+ 305 let (x', y') = rect ^. rectUpperLeftCorner
+ 306 x <- unpackNumber x'
+ 307 y <- unpackNumber y'
+ 308 w <- unpackNumber =<< rect ^. rectWidth
+ 309 h <- unpackNumber =<< rect ^. rectHeight
+ 310 return (x,y,w,h)
+ 311 pointsToPathCommands points = case points of
+ 312 [] -> []
+ 313 (p:ps) -> [ MoveTo OriginAbsolute [p]
+ 314 , LineTo OriginAbsolute ps ]
+ 315 unpackNumber n =
+ 316 case toUserUnit defaultDPI n of
+ 317 Num d -> Just d
+ 318 _ -> Nothing
+ 319
+ 320 -- | Map over all recursively-found path commands.
+ 321 mapSvgPaths :: ([PathCommand] -> [PathCommand]) -> SVG -> SVG
+ 322 mapSvgPaths fn = mapTree worker
+ 323 where
+ 324 worker =
+ 325 \case
+ 326 PathTree path -> PathTree $
+ 327 path & pathDefinition %~ fn
+ 328 t -> t
+ 329
+ 330 -- | Map over all recursively-found line commands.
+ 331 mapSvgLines :: ([LineCommand] -> [LineCommand]) -> SVG -> SVG
+ 332 mapSvgLines fn = mapSvgPaths (lineToPath . fn . toLineCommands)
+ 333
+ 334 -- Only maps points in paths
+ 335 -- | Map over all line command control points.
+ 336 mapSvgPoints :: (RPoint -> RPoint) -> SVG -> SVG
+ 337 mapSvgPoints fn = mapSvgLines (map worker)
+ 338 where
+ 339 worker (LineMove p) = LineMove (fn p)
+ 340 worker (LineBezier ps) = LineBezier (map fn ps)
+ 341 worker (LineEnd p) = LineEnd (fn p)
+ 342
+ 343 -- | Convert coordinate system from degrees to radians.
+ 344 svgPointsToRadians :: SVG -> SVG
+ 345 svgPointsToRadians = mapSvgPoints worker
+ 346 where
+ 347 worker (V2 x y) = V2 (x/180*pi) (y/180*pi)
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Transform.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Transform.hs.html
new file mode 100644
index 0000000..a1b9996
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Transform.hs.html
@@ -0,0 +1,92 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-# LANGUAGE BangPatterns #-}
+ 2 {-|
+ 3 2D transformation matrices capable of translating, scaling,
+ 4 rotating, and skewing.
+ 5 -}
+ 6 module Reanimate.Transform
+ 7 ( identity
+ 8 , transformPoint
+ 9 , mkMatrix
+ 10 , toTransformation
+ 11 ) where
+ 12
+ 13 -- XXX: Use Linear.Matrix instead of Data.Matrix to drop the 'matrix' dependency.
+ 14 import Data.List
+ 15 import Data.Matrix (Matrix)
+ 16 import qualified Data.Matrix as M
+ 17 import Data.Maybe
+ 18 import Graphics.SvgTree
+ 19 import Linear.V2
+ 20
+ 21 -- | Identity matrix.
+ 22 --
+ 23 -- @transformPoints identity x = x@
+ 24 identity :: Matrix Coord
+ 25 identity = M.identity 3
+ 26
+ 27 fromList :: [Coord] -> Matrix Coord
+ 28 fromList [a,b,c,d,e,f] = M.fromList 3 3 [a,c,e,b,d,f,0,0,1]
+ 29 fromList _ = error "Reanimate.Transform.fromList: bad input"
+ 30
+ 31 -- | Apply a transformation matrix to a 2D point.
+ 32 transformPoint :: Matrix Coord -> RPoint -> RPoint
+ 33 transformPoint m (V2 x y) = V2 (a*x +c*y + e) (b*x + d*y +f)
+ 34 where
+ 35 !a = M.unsafeGet 1 1 m
+ 36 !c = M.unsafeGet 1 2 m
+ 37 !e = M.unsafeGet 1 3 m
+ 38 !b = M.unsafeGet 2 1 m
+ 39 !d = M.unsafeGet 2 2 m
+ 40 !f = M.unsafeGet 2 3 m
+ 41 -- (a:c:e:b:d:f:_) = M.toList m
+ 42
+ 43 -- | Convert multiple SVG transformations into a single transformation matrix.
+ 44 mkMatrix :: Maybe [Transformation] -> Matrix Coord
+ 45 mkMatrix Nothing = identity
+ 46 mkMatrix (Just ts) = foldl' (*) identity (map transformationMatrix ts)
+ 47
+ 48 -- | Convert an SVG transformation into a transformation matrix.
+ 49 transformationMatrix :: Transformation -> Matrix Coord
+ 50 transformationMatrix transformation =
+ 51 case transformation of
+ 52 TransformMatrix a b c d e f -> fromList [a,b,c,d,e,f]
+ 53 Translate x y -> translate x y
+ 54 Scale sx mbSy -> fromList [sx,0,0,fromMaybe sx mbSy,0,0]
+ 55 Rotate a Nothing -> rotate a
+ 56 Rotate a (Just (x,y)) -> translate x y * rotate a * translate (-x) (-y)
+ 57 SkewX a -> fromList [1,0,tan (a*pi/180),1,0,0]
+ 58 SkewY a -> fromList [1,tan (a*pi/180),0,1,0,0]
+ 59 TransformUnknown -> identity
+ 60 where
+ 61 translate x y = fromList [1,0,0,1,x,y]
+ 62 rotate a = fromList [cos r,sin r,-sin r,cos r,0,0]
+ 63 where r = a * pi / 180
+ 64
+ 65 -- | Convert a transformation matrix back into an SVG transformation.
+ 66 toTransformation :: Matrix Coord -> Transformation
+ 67 toTransformation m = TransformMatrix a b c d e f
+ 68 where
+ 69 [a,c,e,b,d,f,_,_,_] = M.toList m
+
+
+
+
diff --git a/reanimate-0.5.0.1-inplace/Reanimate.Transition.hs.html b/reanimate-0.5.0.1-inplace/Reanimate.Transition.hs.html
new file mode 100644
index 0000000..c18c28d
--- /dev/null
+++ b/reanimate-0.5.0.1-inplace/Reanimate.Transition.hs.html
@@ -0,0 +1,105 @@
+
+
+
+
+
+
+
+never executed always true always false
+
+
+ 1 {-|
+ 2 Copyright : Written by David Himmelstrup
+ 3 License : Unlicense
+ 4 Maintainer : lemmih@gmail.com
+ 5 Stability : experimental
+ 6 Portability : POSIX
+ 7 -}
+ 8 module Reanimate.Transition
+ 9 ( Transition
+ 10 , signalT
+ 11 , mapT
+ 12 , overlapT
+ 13 , chainT
+ 14 , effectT
+ 15 , fadeT
+ 16 ) where
+ 17
+ 18 import Reanimate.Animation
+ 19 import Reanimate.Ease
+ 20 import Reanimate.Effect
+ 21
+ 22 -- | A transition transforms one animation into another.
+ 23 type Transition = Animation -> Animation -> Animation
+ 24
+ 25 -- | Apply a signal to the timing of a transition.
+ 26 signalT :: Signal -> Transition -> Transition
+ 27 signalT = mapT . signalA
+ 28
+ 29 -- | Map the result of a transition.
+ 30 mapT :: (Animation -> Animation) -> Transition -> Transition
+ 31 mapT fn t a b = fn (t a b)
+ 32
+ 33 -- | Apply transition only to @N@ seconds of the first
+ 34 -- animation and to the last @N@ seconds of the second animation.
+ 35 --
+ 36 -- Example:
+ 37 --
+ 38 -- @
+ 39 -- 'overlapT' 0.5 'fadeT' 'Reanimate.Builtin.Documentation.drawBox' 'Reanimate.Builtin.Documentation.drawCircle'
+ 40 -- @
+ 41 --
+ 42 -- <<docs/gifs/doc_overlapT.gif>>
+ 43 overlapT :: Double -> Transition -> Transition
+ 44 overlapT overlap t a b =
+ 45 aBefore `seqA` t aOverlap bOverlap `seqA` bAfter
+ 46 where
+ 47 aBefore = takeA (duration a - overlap) a
+ 48 aOverlap = lastA overlap a
+ 49 bOverlap = takeA overlap b
+ 50 bAfter = dropA overlap b
+ 51
+ 52
+ 53 -- | Create a transition between two animations by applying an effect to each respective animation.
+ 54 effectT :: Effect -- ^ Effect to be applied to the first animation.
+ 55 -> Effect -- ^ Effect to be applied to the second animation.
+ 56 -> Transition
+ 57 effectT eA eB a b = applyE eA a `parA` applyE eB b
+ 58
+ 59 -- | Combine a list of animations using a given transition.
+ 60 --
+ 61 -- Example:
+ 62 --
+ 63 -- @
+ 64 -- 'chainT' ('overlapT' 0.5 'fadeT') ['Reanimate.Builtin.Documentation.drawBox', 'Reanimate.Builtin.Documentation.drawCircle', 'Reanimate.Builtin.Documentation.drawProgress']
+ 65 -- @
+ 66 --
+ 67 -- <<docs/gifs/doc_chainT.gif>>
+ 68 chainT :: Transition -> [Animation] -> Animation
+ 69 chainT _ [] = pause 0
+ 70 chainT t (x:xs) = foldl t x xs
+ 71
+ 72 -- | Fade out left-hand-side animation while fading in right-hand-side animation.
+ 73 --
+ 74 -- Example:
+ 75 --
+ 76 -- @
+ 77 -- 'Reanimate.Builtin.Documentation.drawBox' `'fadeT'` 'Reanimate.Builtin.Documentation.drawCircle'
+ 78 -- @
+ 79 --
+ 80 -- <<docs/gifs/doc_fadeT.gif>>
+ 81 fadeT :: Transition
+ 82 fadeT = effectT fadeOutE fadeInE
+
+
+
+
