hashirama/reanimate
Watch
1
0
Fork
You've already forked reanimate
 0
mirror of https://github.com/reanimate/reanimate.git synced 2026-09-09 15:12:21 +00:00
Code Issues Projects Releases Wiki Activity

Efficient time variables. (#145)

Browse source 
Co-authored-by: shaurya gupta <shauryab98@gmail.com>
This commit is contained in:
David Himmelstrup 2020-09-08 17:35:00 +08:00 • committed by GitHub
commit 1c7fa10f86
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
10 changed files with 1689 additions and 1326 deletions
Download patch file Download diff file Expand all files Collapse all files

7
.azure/azure-windows-template.yml
View file

@ -7,9 +7,10 @@ jobs:
vmImage: ${{ parameters.vmImage }}
strategy:
matrix:
stack:
BUILD: stack
ARGS: --pedantic
# lts-16.12 fails intermittently on windows. :(
# stack:
# BUILD: stack
# ARGS: --pedantic
# lts-15 fails due to segfaults. Think it is a GHC issue.
# stack-lts-15:
# BUILD: stack

8
reanimate.cabal
View file

@ -93,6 +93,10 @@ library
Reanimate.Driver.Compile
Reanimate.Misc
Paths_reanimate
Reanimate.Scene.Core
Reanimate.Scene.Var
Reanimate.Scene.Sprite
Reanimate.Scene.Object
build-depends:
base >=4.10 && <5,
JuicyPixels >=3.3.3,
@ -145,6 +149,7 @@ test-suite spec
default-language: Haskell2010
other-modules:
UnitTests
TimeVarTests
Properties
Helpers
hs-source-dirs: test
@ -159,4 +164,5 @@ test-suite spec
QuickCheck >= 2.1.0, text,
temporary,
tasty, tasty-golden, tasty-hunit,
tasty-quickcheck, tasty-rerun >= 1.1.17
tasty-quickcheck, tasty-rerun >= 1.1.17,
tasty-expected-failure

1
src/Reanimate.hs
View file

@ -93,7 +93,6 @@ module Reanimate
, writeVar -- :: Var s a -> a -> Scene s ()
, modifyVar -- :: Var s a -> (a -> a) -> Scene s ()
, tweenVar -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()
, tweenVarUnclamped -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()
, simpleVar -- :: (a -> SVG) -> a -> Scene s (Var s a)
, findVar -- :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)
-- *** Sprites

1461
src/Reanimate/Scene.hs
View file

File diff suppressed because it is too large Load diff

163
src/Reanimate/Scene/Core.hs Normal file
View file

@ -0,0 +1,163 @@
{-# LANGUAGE RankNTypes #-}
module Reanimate.Scene.Core where
import Control.Monad.Fix (MonadFix (..))
import Control.Monad.ST
import Data.List
import Reanimate.Animation
import Reanimate.Svg.Constructors
-- | The ZIndex property specifies the stack order of sprites and animations. Elements
-- with a higher ZIndex will be drawn on top of elements with a lower index.
type ZIndex = Int
-- (seq duration, par duration)
-- [(Time, Animation, ZIndex)]
-- Map Time [(Animation, ZIndex)]
type Gen s = ST s (Duration -> Time -> (SVG, ZIndex))
-- | A 'Scene' represents a sequence of animations and variables
-- that change over time.
newtype Scene s a = M {unM :: Time -> ST s (a, Duration, Duration, [Gen s])}
instance Functor (Scene s) where
fmap f action = M $ \t -> do
(a, d1, d2, gens) <- unM action t
return (f a, d1, d2, gens)
instance Applicative (Scene s) where
pure a = M $ \_ -> return (a, 0, 0, [])
f <*> g = M $ \t -> do
(f', s1, p1, gen1) <- unM f t
(g', s2, p2, gen2) <- unM g (t + s1)
return (f' g', s1 + s2, max p1 (s1 + p2), gen1 ++ gen2)
instance Monad (Scene s) where
return = pure
f >>= g = M $ \t -> do
(a, s1, p1, gen1) <- unM f t
(b, s2, p2, gen2) <- unM (g a) (t + s1)
return (b, s1 + s2, max p1 (s1 + p2), gen1 ++ gen2)
instance MonadFix (Scene s) where
mfix fn = M $ \t -> mfix (\v -> let (a, _s, _p, _gens) = v in unM (fn a) t)
liftST :: ST s a -> Scene s a
liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, [])
-- | Evaluate the value of a scene.
evalScene :: (forall s. Scene s a) -> a
evalScene action = runST $ do
(val, _, _, _) <- unM action 0
return val
-- | Render a 'Scene' to an 'Animation'.
scene :: (forall s. Scene s a) -> Animation
scene = sceneAnimation
-- | Render a 'Scene' to an 'Animation'.
sceneAnimation :: (forall s. Scene s a) -> Animation
sceneAnimation action =
runST
( do
(_, s, p, gens) <- unM action 0
let dur = max s p
genFns <- sequence gens
return $
mkAnimation
dur
( \t ->
mkGroup $
map fst $
sortOn
snd
[spriteRender dur (t * dur) | spriteRender <- genFns]
)
)
-- | Execute actions in a scene without advancing the clock. Note that scenes do not end before
-- all forked actions have completed.
--
-- Example:
--
-- @
-- do 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'
-- 'play' 'Reanimate.Builtin.Documentation.drawCircle'
-- @
--
-- <<docs/gifs/doc_fork.gif>>
fork :: Scene s a -> Scene s a
fork (M action) = M $ \t -> do
(a, s, p, gens) <- action t
return (a, 0, max s p, gens)
-- | Query the current clock timestamp.
--
-- Example:
--
-- @
-- do now \<- 'play' 'Reanimate.Builtin.Documentation.drawCircle' *\> 'queryNow'
-- 'play' $ 'staticFrame' 1 $ 'scale' 2 $ 'withStrokeWidth' 0.05 $
-- 'mkText' $ "Now=" <> T.pack (show now)
-- @
--
-- <<docs/gifs/doc_queryNow.gif>>
queryNow :: Scene s Time
queryNow = M $ \t -> return (t, 0, 0, [])
-- | Advance the clock by a given number of seconds.
--
-- Example:
--
-- @
-- do 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'
-- 'wait' 1
-- 'play' 'Reanimate.Builtin.Documentation.drawCircle'
-- @
--
-- <<docs/gifs/doc_wait.gif>>
wait :: Duration -> Scene s ()
wait d = M $ \_ -> return ((), d, 0, [])
-- | Wait until the clock is equal to the given timestamp.
waitUntil :: Time -> Scene s ()
waitUntil tNew = do
now <- queryNow
wait (max 0 (tNew - now))
-- | Wait until all forked and sequential animations have finished.
--
-- Example:
--
-- @
-- do 'waitOn' $ 'fork' $ 'play' 'Reanimate.Builtin.Documentation.drawBox'
-- 'play' 'Reanimate.Builtin.Documentation.drawCircle'
-- @
--
-- <<docs/gifs/doc_waitOn.gif>>
waitOn :: Scene s a -> Scene s a
waitOn (M action) = M $ \t -> do
(a, s, p, gens) <- action t
return (a, max s p, 0, gens)
-- | Change the ZIndex of a scene.
adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
adjustZ fn (M action) = M $ \t -> do
(a, s, p, gens) <- action t
return (a, s, p, map genFn gens)
where
genFn gen = do
frameGen <- gen
return $ \d t -> let (svg, z) = frameGen d t in (svg, fn z)
-- | Query the duration of a scene.
withSceneDuration :: Scene s () -> Scene s Duration
withSceneDuration s = do
t1 <- queryNow
s
t2 <- queryNow
return (t2 - t1)
addGen :: Gen s -> Scene s ()
addGen gen = M $ \_ -> return ((), 0, 0, [gen])

612
src/Reanimate/Scene/Object.hs Normal file
View file

@ -0,0 +1,612 @@
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RecordWildCards #-}
module Reanimate.Scene.Object where
import Control.Lens
import Control.Monad (forM_, void)
import Control.Monad.State (State, execState)
import Data.Monoid ( Last(getLast) )
import Graphics.SvgTree
( Number (..),
Tree,
strokeWidth,
toUserUnit,
pattern None,
)
import Reanimate.Animation
import Reanimate.Constants (defaultDPI, defaultStrokeWidth)
import Reanimate.Ease (Signal, curveS, fromToS)
import Reanimate.Effect ( applyE, fadeLineOutE, overEnding )
import Reanimate.Math.Balloon ( balloon )
import Reanimate.Morph.Common (morph)
import Reanimate.Morph.Linear (linear)
import Reanimate.Svg
import Reanimate.Scene.Core
import Reanimate.Scene.Sprite
import Reanimate.Scene.Var
-------------------------------------------------------
-- Objects
-- | Objects can be any Haskell structure as long as it can be rendered to SVG.
class Renderable a where
toSVG :: a -> SVG
instance Renderable Tree where
toSVG = id
-- | Objects are SVG nodes (represented as Haskell values) with
-- identity, location, and several other properties that can
-- change over time.
data Object s a = Object
{ objectSprite :: Sprite s,
objectData :: Var s (ObjectData a)
}
-- | Container for object properties.
data ObjectData a = ObjectData
{ _oTranslate :: (Double, Double),
_oValueRef :: a,
_oSVG :: SVG,
_oContext :: SVG -> SVG,
-- | Top, right, bottom, left
_oMargin :: (Double, Double, Double, Double),
_oBB :: (Double, Double, Double, Double),
_oOpacity :: Double,
_oShown :: Bool,
_oZIndex :: Int,
_oEasing :: Signal,
_oScale :: Double,
_oScaleOrigin :: (Double, Double)
}
-- Basic lenses
-- FIXME: Maybe 'position' is a better name.
-- | Object position. Default: \<0,0\>
oTranslate :: Lens' (ObjectData a) (Double, Double)
oTranslate = lens _oTranslate $ \obj val -> obj {_oTranslate = val}
-- | Rendered SVG node of an object. Does not include context
-- or object properties. Read-only.
oSVG :: Getter (ObjectData a) SVG
oSVG = to _oSVG
-- | Custom render context. Is applied to the object for every
-- frame that it is shown.
oContext :: Lens' (ObjectData a) (SVG -> SVG)
oContext = lens _oContext $ \obj val -> obj {_oContext = val}
-- | Object margins (top, right, bottom, left) in local units.
oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double)
oMargin = lens _oMargin $ \obj val -> obj {_oMargin = val}
-- | Object bounding-box (minimal X-coordinate, minimal Y-coordinate,
-- width, height). Uses `Reanimate.Svg.BoundingBox.boundingBox`
-- and has the same limitations.
oBB :: Getter (ObjectData a) (Double, Double, Double, Double)
oBB = to _oBB
-- | Object opacity. Default: 1
oOpacity :: Lens' (ObjectData a) Double
oOpacity = lens _oOpacity $ \obj val -> obj {_oOpacity = val}
-- | Toggle for whether or not the object should be rendered.
-- Default: False
oShown :: Lens' (ObjectData a) Bool
oShown = lens _oShown $ \obj val -> obj {_oShown = val}
-- | Object's z-index.
oZIndex :: Lens' (ObjectData a) Int
oZIndex = lens _oZIndex $ \obj val -> obj {_oZIndex = val}
-- | Easing function used when modifying object properties.
-- Default: @'Reanimate.Ease.curveS' 2@
oEasing :: Lens' (ObjectData a) Signal
oEasing = lens _oEasing $ \obj val -> obj {_oEasing = val}
-- | Object's scale. Default: 1
oScale :: Lens' (ObjectData a) Double
oScale = lens _oScale $ \obj val -> oComputeBB obj {_oScale = val}
-- | Origin point for scaling. Default: \<0,0\>
oScaleOrigin :: Lens' (ObjectData a) (Double, Double)
oScaleOrigin = lens _oScaleOrigin $ \obj val -> oComputeBB obj {_oScaleOrigin = val}
-- Smart lenses
-- | Lens for the source value contained in an object.
oValue :: Renderable a => Lens' (ObjectData a) a
oValue = lens _oValueRef $ \obj newVal ->
let svg = toSVG newVal
in oComputeBB
obj
{ _oValueRef = newVal,
_oSVG = svg
}
oComputeBB :: ObjectData a -> ObjectData a
oComputeBB obj =
obj
{ _oBB = boundingBox $ oScaleApply obj (_oSVG obj)
}
-- | Derived location of the top-most point of an object + margin.
oTopY :: Lens' (ObjectData a) Double
oTopY = lens getter setter
where
getter obj =
let top = obj ^. oMarginTop
miny = obj ^. oBBMinY
h = obj ^. oBBHeight
dy = obj ^. oTranslate . _2
in dy + miny + h + top
setter obj val =
obj & (oTranslate . _2) +~ val - getter obj
-- | Derived location of the bottom-most point of an object + margin.
oBottomY :: Lens' (ObjectData a) Double
oBottomY = lens getter setter
where
getter obj =
let bot = obj ^. oMarginBottom
miny = obj ^. oBBMinY
dy = obj ^. oTranslate . _2
in dy + miny - bot
setter obj val =
obj & (oTranslate . _2) +~ val - getter obj
-- | Derived location of the left-most point of an object + margin.
oLeftX :: Lens' (ObjectData a) Double
oLeftX = lens getter setter
where
getter obj =
let left = obj ^. oMarginLeft
minx = obj ^. oBBMinX
dx = obj ^. oTranslate . _1
in dx + minx - left
setter obj val =
obj & (oTranslate . _1) +~ val - getter obj
-- | Derived location of the right-most point of an object + margin.
oRightX :: Lens' (ObjectData a) Double
oRightX = lens getter setter
where
getter obj =
let right = obj ^. oMarginRight
minx = obj ^. oBBMinX
w = obj ^. oBBWidth
dx = obj ^. oTranslate . _1
in dx + minx + w + right
setter obj val =
obj & (oTranslate . _1) +~ val - getter obj
-- | Derived location of an object's center point.
oCenterXY :: Lens' (ObjectData a) (Double, Double)
oCenterXY = lens getter setter
where
getter obj =
let minx = obj ^. oBBMinX
miny = obj ^. oBBMinY
w = obj ^. oBBWidth
h = obj ^. oBBHeight
(dx, dy) = obj ^. oTranslate
in (dx + minx + w / 2, dy + miny + h / 2)
setter obj (dx, dy) =
let (x, y) = getter obj
in obj & (oTranslate . _1) +~ dx - x
& (oTranslate . _2) +~ dy - y
-- | Object's top margin.
oMarginTop :: Lens' (ObjectData a) Double
oMarginTop = oMargin . _1
-- | Object's right margin.
oMarginRight :: Lens' (ObjectData a) Double
oMarginRight = oMargin . _2
-- | Object's bottom margin.
oMarginBottom :: Lens' (ObjectData a) Double
oMarginBottom = oMargin . _3
-- | Object's left margin.
oMarginLeft :: Lens' (ObjectData a) Double
oMarginLeft = oMargin . _4
-- | Object's minimal X-coordinate..
oBBMinX :: Getter (ObjectData a) Double
oBBMinX = oBB . _1
-- | Object's minimal Y-coordinate..
oBBMinY :: Getter (ObjectData a) Double
oBBMinY = oBB . _2
-- | Object's width without margin.
oBBWidth :: Getter (ObjectData a) Double
oBBWidth = oBB . _3
-- | Object's height without margin.
oBBHeight :: Getter (ObjectData a) Double
oBBHeight = oBB . _4
-------------------------------------------------------------------------------
-- Object modifiers
-- | Modify object properties.
oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s ()
oModify o = modifyVar (objectData o)
-- | Modify object properties using a stateful API.
oModifyS :: Object s a -> State (ObjectData a) b -> Scene s ()
oModifyS o = oModify o . execState
-- | Query object property.
oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b
oRead o l = view l <$> readVar (objectData o)
-- | Modify object properties over a set duration.
oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s ()
oTween o d fn = do
-- Read 'easing' var here instead of taking it from 'v'.
-- This allows different easing functions even at the same timestamp.
ease <- oRead o oEasing
tweenVar (objectData o) d (\v t -> fn (ease t) v)
-- | Modify object properties over a set duration using a stateful API.
oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s ()
oTweenS o d fn = oTween o d (execState . fn)
-- | Modify object value over a set duration. This is a convenience function
-- for modifying `oValue`.
oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s ()
oTweenV o d fn = oTween o d (\t -> oValue %~ fn t)
-- | Modify object value over a set duration using a stateful API. This is a
-- convenience function for modifying `oValue`.
oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s ()
oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t))
-- | Create new object.
oNew :: Renderable a => a -> Scene s (Object s a)
oNew = newObject
-- | Create new object.
newObject :: Renderable a => a -> Scene s (Object s a)
newObject val = do
ref <-
newVar
ObjectData
{ _oTranslate = (0, 0),
_oValueRef = val,
_oSVG = svg,
_oContext = id,
_oMargin = (0.5, 0.5, 0.5, 0.5),
_oBB = boundingBox svg,
_oOpacity = 1,
_oShown = False,
_oZIndex = 1,
_oEasing = curveS 2,
_oScale = 1,
_oScaleOrigin = (0, 0)
}
sprite <- newSprite $ do
~obj@ObjectData {..} <- unVar ref
pure $
if _oShown
then
uncurry translate _oTranslate $
oScaleApply obj $
withGroupOpacity _oOpacity $
mkGroup [_oContext _oSVG]
else None
spriteModify sprite $ do
~ObjectData {_oZIndex = z} <- unVar ref
pure $ \(img, _) -> (img, z)
return
Object
{ objectSprite = sprite,
objectData = ref
}
where
svg = toSVG val
oScaleApply :: ObjectData a -> (SVG -> SVG)
oScaleApply ObjectData {..} =
uncurry translate (_oScaleOrigin & both %~ negate)
. scale _oScale
. uncurry translate _oScaleOrigin
-------------------------------------------------------------------------------
-- Graphical transformations
-- | Instantly show object.
oShow :: Object s a -> Scene s ()
oShow o = oModify o $ oShown .~ True
-- | Instantly hide object.
oHide :: Object s a -> Scene s ()
oHide o = oModify o $ oShown .~ False
oShowWith :: Object s a -> (SVG -> Animation) -> Scene s ()
oShowWith o fn = do
oModify o $ oShown .~ True
initSVG <- oRead o oSVG
let ani = fn initSVG
oTween o (duration ani) $ \t obj ->
obj {_oSVG = getAnimationFrame SyncStretch ani t 1}
oModify o $ \obj -> obj {_oSVG = initSVG}
oHideWith :: Object s a -> (SVG -> Animation) -> Scene s ()
oHideWith o fn = do
initSVG <- oRead o oSVG
let ani = fn initSVG
oTween o (duration ani) $ \t obj ->
obj {_oSVG = getAnimationFrame SyncStretch ani t 1}
oModify o $ \obj -> obj {_oSVG = initSVG}
oModify o $ oShown .~ False
-- | Fade in object over a set duration.
oFadeIn :: SVG -> Animation
oFadeIn svg = animate $ \t -> withGroupOpacity t svg
-- | Fade out object over a set duration.
oFadeOut :: SVG -> Animation
oFadeOut = reverseA . oFadeIn
-- | Scale in object over a set duration.
oGrow :: SVG -> Animation
oGrow svg = animate $ \t -> scale t svg
-- | Scale out object over a set duration.
oShrink :: SVG -> Animation
oShrink = reverseA . oGrow
type Origin = (Double, Double)
svgOrigin :: SVG -> Origin -> (Double, Double)
svgOrigin svg (originX, originY) =
case boundingBox svg of
(polyX, polyY, polyWidth, polyHeight) ->
( polyX + polyWidth * originX,
polyY + polyHeight * originY
)
oScaleIn :: SVG -> Animation
oScaleIn = oScaleIn' (curveS 2) (0.5, 1)
oScaleIn' :: Signal -> Origin -> SVG -> Animation
oScaleIn' easing origin = oStagger' 0.05 $ \svg ->
let (cx, cy) = svgOrigin svg origin
in signalA easing $
mkAnimation 0.3 $ \t ->
translate cx cy $
scale t $
translate
(- cx)
(- cy)
svg
oScaleOut :: SVG -> Animation
oScaleOut = reverseA . oStaggerRev' 0.05 (oScaleIn' (curveS 2) (0.5, 0))
oScaleOut' :: Signal -> Origin -> SVG -> Animation
oScaleOut' easing origin = reverseA . oStaggerRev' 0.05 (oScaleIn' easing origin)
oSim :: (SVG -> Animation) -> SVG -> Animation
oSim = oStagger' 0
-- oSim (oStagger fn) = oSim fn
-- oStagger (oStagger fn) = oStagger fn
oStagger :: (SVG -> Animation) -> SVG -> Animation
oStagger = oStagger' 0.2
oStaggerRev :: (SVG -> Animation) -> SVG -> Animation
oStaggerRev = oStaggerRev' 0.2
oStagger' :: Duration -> (SVG -> Animation) -> SVG -> Animation
oStagger' staggerDelay fn svg = scene $
forM_ (svgGlyphs svg) $ \(ctx, _attr, node) -> do
void $ fork $ newSpriteA' SyncFreeze (fn $ ctx node)
wait staggerDelay
oStaggerRev' :: Duration -> (SVG -> Animation) -> SVG -> Animation
oStaggerRev' staggerDelay fn svg = scene $
forM_ (reverse $ svgGlyphs svg) $ \(ctx, _attr, node) -> do
void $ fork $ newSpriteA' SyncFreeze (fn $ ctx node)
wait staggerDelay
oDraw :: SVG -> Animation
oDraw = oStagger $ \svg -> scene $
forM_ (svgGlyphs $ pathify svg) $ \(ctx, attr, node) -> do
let sWidth =
case toUserUnit defaultDPI <$> getLast (attr ^. strokeWidth) of
Just (Num d) -> max defaultStrokeWidth d
_ -> defaultStrokeWidth
-- wait 1
play $
mapA ctx $
applyE (overEnding fillDur $ fadeLineOutE sWidth) $
animate $ \t ->
withStrokeWidth sWidth $
mkGroup
[withFillOpacity 0 $ partialSvg t node]
wait (- fillDur)
newSpriteA' SyncFreeze $
mkAnimation fillDur $ \t ->
withGroupOpacity t $
mkGroup [ctx node]
where
fillDur = 0.3
_oBalloon :: SVG -> Animation
_oBalloon = animate . balloon
-- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'.
-- | Morph source object into target object over a set duration.
oTransform :: Object s a -> Object s b -> Duration -> Scene s ()
oTransform src dst d = do
srcSvg <- oRead src oSVG
srcCtx <- oRead src oContext
srcEase <- oRead src oEasing
srcLoc <- oRead src oTranslate
oModify src $ oShown .~ False
dstSvg <- oRead dst oSVG
dstCtx <- oRead dst oContext
dstLoc <- oRead dst oTranslate
m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg)
oModifyS m $ do
oShown .= True
oEasing .= srcEase
oTranslate .= srcLoc
fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc
oTweenV m d $ \t -> morphDelta .~ t
oModify m $ oShown .~ False
oModify dst $ oShown .~ True
where
moveTo t (dstX, dstY) (srcX, srcY) =
(fromToS srcX dstX t, fromToS srcY dstY t)
-------------------------------------------------------------------------------
-- Built-in objects
-- | Basic object mapping to \<circle\/\> in SVG.
newtype Circle = Circle {_circleRadius :: Double}
-- | Circle radius in local units.
circleRadius :: Lens' Circle Double
circleRadius = iso _circleRadius Circle
instance Renderable Circle where
toSVG (Circle r) = mkCircle r
-- | Basic object mapping to \<rect\/\> in SVG.
data Rectangle = Rectangle {_rectWidth :: Double, _rectHeight :: Double}
-- | Rectangle width in local units.
rectWidth :: Lens' Rectangle Double
rectWidth = lens _rectWidth $ \obj val -> obj {_rectWidth = val}
-- | Rectangle height in local units.
rectHeight :: Lens' Rectangle Double
rectHeight = lens _rectHeight $ \obj val -> obj {_rectHeight = val}
instance Renderable Rectangle where
toSVG (Rectangle w h) = mkRect w h
-- | Object representing an interpolation between SVG nodes.
data Morph = Morph {_morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG}
-- | Control variable for the interpolation. A value of 0 gives the
-- source SVG and 1 gives the target svg.
morphDelta :: Lens' Morph Double
morphDelta = lens _morphDelta $ \obj val -> obj {_morphDelta = val}
-- | Source shape.
morphSrc :: Lens' Morph SVG
morphSrc = lens _morphSrc $ \obj val -> obj {_morphSrc = val}
-- | Target shape.
morphDst :: Lens' Morph SVG
morphDst = lens _morphDst $ \obj val -> obj {_morphDst = val}
instance Renderable Morph where
toSVG (Morph t src dst) = morph linear src dst t
-- | Cameras can take control of objects and manipulate them
-- with convenient pan and zoom operations.
data Camera = Camera
instance Renderable Camera where
toSVG Camera = None
-- | Connect an object to a camera such that
-- camera settings (position, zoom, and rotation) is
-- applied to the object.
--
-- Example
--
-- @
-- do cam \<- 'newObject' 'Camera'
-- circ \<- 'newObject' $ 'Circle' 2
-- 'oModifyS' circ $
-- 'oContext' .= 'withFillOpacity' 1 . 'withFillColor' "blue"
-- 'oShow' circ
-- 'cameraAttach' cam circ
-- 'cameraZoom' cam 1 2
-- 'cameraZoom' cam 1 1
-- @
--
-- <<docs/gifs/doc_cameraAttach.gif>>
cameraAttach :: Object s Camera -> Object s a -> Scene s ()
cameraAttach cam obj =
spriteModify (objectSprite obj) $ do
camData <- unVar (objectData cam)
return $ \(svg, zindex) ->
let (x, y) = camData ^. oTranslate
ctx =
translate (- x) (- y)
. uncurry translate (camData ^. oScaleOrigin)
. scale (camData ^. oScale)
. uncurry translate (camData ^. oScaleOrigin & both %~ negate)
in (ctx svg, zindex)
-- |
--
-- Example
--
-- @
-- do cam \<- 'newObject' 'Camera'
-- circ \<- 'newObject' $ 'Circle' 2; 'oShow' circ
-- 'oModify' circ $ 'oTranslate' .~ (-3,0)
-- box \<- 'newObject' $ 'Rectangle' 4 4; 'oShow' box
-- 'oModify' box $ 'oTranslate' .~ (3,0)
-- 'cameraAttach' cam circ
-- 'cameraAttach' cam box
-- 'cameraFocus' cam (-3,0)
-- 'cameraZoom' cam 2 2 -- Zoom in
-- 'cameraZoom' cam 2 1 -- Zoom out
-- 'cameraFocus' cam (3,0)
-- 'cameraZoom' cam 2 2 -- Zoom in
-- 'cameraZoom' cam 2 1 -- Zoom out
-- @
--
-- <<docs/gifs/doc_cameraFocus.gif>>
cameraFocus :: Object s Camera -> (Double, Double) -> Scene s ()
cameraFocus cam (x, y) = do
(ox, oy) <- oRead cam oScaleOrigin
(tx, ty) <- oRead cam oTranslate
s <- oRead cam oScale
let newLocation = (x - ((x - ox) * s + ox - tx), y - ((y - oy) * s + oy - ty))
oModifyS cam $ do
oTranslate .= newLocation
oScaleOrigin .= (x, y)
-- | Instantaneously set camera zoom level.
cameraSetZoom :: Object s Camera -> Double -> Scene s ()
cameraSetZoom cam s =
oModifyS cam $
oScale .= s
-- | Change camera zoom level over a set duration.
cameraZoom :: Object s Camera -> Duration -> Double -> Scene s ()
cameraZoom cam d s =
oTweenS cam d $ \t ->
oScale %= \v -> fromToS v s t
-- | Instantaneously set camera location.
cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s ()
cameraSetPan cam location =
oModifyS cam $
oTranslate .= location
-- | Change camera location over a set duration.
cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s ()
cameraPan cam d (x, y) =
oTweenS cam d $ \t -> do
oTranslate . _1 %= \v -> fromToS v x t
oTranslate . _2 %= \v -> fromToS v y t

416
src/Reanimate/Scene/Sprite.hs Normal file
View file

@ -0,0 +1,416 @@
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
module Reanimate.Scene.Sprite where
import Control.Monad (void)
import Control.Monad.ST (ST)
import Data.Bifunctor (Bifunctor (first))
import Data.STRef (STRef, modifySTRef, newSTRef, readSTRef)
import Graphics.SvgTree
( pattern None,
)
import Reanimate.Animation
( Animation,
Duration,
SVG,
Sync (SyncStretch),
Time,
dropA,
duration,
getAnimationFrame,
)
import Reanimate.Effect (Effect, delayE)
import Reanimate.Scene.Core
( Scene (M),
ZIndex,
addGen,
fork,
liftST,
queryNow,
sceneAnimation,
wait,
)
import Reanimate.Scene.Var (unpackVar, Var (..), newVar, readVar)
import Reanimate.Transition (Transition, overlapT)
-- | Create and render a variable. The rendering will be born at the current timestamp
-- and will persist until the end of the scene.
--
-- Example:
--
-- @
-- do var \<- 'simpleVar' 'mkCircle' 0
-- 'tweenVar' var 2 $ \\val -> 'fromToS' val ('Reanimate.Constants.screenHeight'/2)
-- @
--
-- <<docs/gifs/doc_simpleVar.gif>>
simpleVar :: (a -> SVG) -> a -> Scene s (Var s a)
simpleVar render def = do
v <- newVar def
_ <- newSprite $ render <$> unVar v
return v
-- | Helper function for filtering variables.
findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)
findVar _cond [] = error "Variable not found."
findVar cond (v : vs) = do
val <- readVar v
if cond val then return v else findVar cond vs
-- | Play an animation once and then remove it. This advances the clock by the duration of the
-- animation.
--
-- Example:
--
-- @
-- do 'play' 'Reanimate.Builtin.Documentation.drawBox'
-- 'play' 'Reanimate.Builtin.Documentation.drawCircle'
-- @
--
-- <<docs/gifs/doc_play.gif>>
play :: Animation -> Scene s ()
play ani = newSpriteA ani >>= destroySprite
-- | Sprites are animations with a given time of birth as well as a time of death.
-- They can be controlled using variables, tweening, and effects.
data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex))))
-- | Sprite frame generator. Generates frames over time in a stateful environment.
newtype Frame s a = Frame {unFrame :: ST s (Time -> Duration -> Time -> a)}
instance Functor (Frame s) where
fmap fn (Frame gen) = Frame $ do
m <- gen
return (\real_t d t -> fn $ m real_t d t)
instance Applicative (Frame s) where
pure v = Frame $ return (\_ _ _ -> v)
Frame f <*> Frame g = Frame $ do
m1 <- f
m2 <- g
return $ \real_t d t -> m1 real_t d t (m2 real_t d t)
-- | Dereference a variable as a Sprite frame.
--
-- Example:
--
-- @
-- do v \<- 'newVar' 0
-- 'newSprite' $ 'mkCircle' \<$\> 'unVar' v
-- 'tweenVar' v 1 $ \\val -> 'fromToS' val 3
-- 'tweenVar' v 1 $ \\val -> 'fromToS' val 0
-- @
--
-- <<docs/gifs/doc_unVar.gif>>
unVar :: Var s a -> Frame s a
unVar var = Frame $ do
fn <- unpackVar var
return $ \real_t _d _t -> fn real_t
-- | Dereference seconds since sprite birth.
spriteT :: Frame s Time
spriteT = Frame $ return (\_real_t _d t -> t)
-- | Dereference duration of the current sprite.
spriteDuration :: Frame s Duration
spriteDuration = Frame $ return (\_real_t d _t -> d)
-- | Create new sprite defined by a frame generator. Unless otherwise specified using
-- 'destroySprite', the sprite will die at the end of the scene.
--
-- Example:
--
-- @
-- do 'newSprite' $ 'mkCircle' \<$\> 'spriteT' -- Circle sprite where radius=time.
-- 'wait' 2
-- @
--
-- <<docs/gifs/doc_newSprite.gif>>
newSprite :: Frame s SVG -> Scene s (Sprite s)
newSprite render = do
now <- queryNow
ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0))
addGen $ do
fn <- unFrame render
(spriteDur, spriteEffectGen) <- readSTRef ref
spriteEffect <- spriteEffectGen
return $ \d absT ->
let relD = (if spriteDur < 0 then d else spriteDur) - now
relT = absT - now
-- Sprite is live [now;duration[
-- If we're at the end of a scene, sprites
-- are live: [now;duration]
-- This behavior is difficult to get right. See the 'bug_*' examples for
-- automated tests.
inTimeSlice = relT >= 0 && relT < relD
isLastFrame = d == absT && relT == relD
in if inTimeSlice || isLastFrame
then spriteEffect relD relT (fn absT relD relT)
else (None, 0)
return $ Sprite now ref
-- | Create new sprite defined by a frame generator. The sprite will die at
-- the end of the scene.
newSprite_ :: Frame s SVG -> Scene s ()
newSprite_ = void . newSprite
-- | Create a new sprite from an animation. This advances the clock by the
-- duration of the animation. Unless otherwise specified using
-- 'destroySprite', the sprite will die at the end of the scene.
--
-- Note: If the scene doesn't end immediately after the duration of the
-- animation, the animation will be stretched to match the lifetime of the
-- sprite. See 'newSpriteA'' and 'play'.
--
-- Example:
--
-- @
-- do 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
-- 'play' 'Reanimate.Builtin.Documentation.drawBox'
-- 'play' $ 'reverseA' 'Reanimate.Builtin.Documentation.drawBox'
-- @
--
-- <<docs/gifs/doc_newSpriteA.gif>>
newSpriteA :: Animation -> Scene s (Sprite s)
newSpriteA = newSpriteA' SyncStretch
-- | Create a new sprite from an animation and specify the synchronization policy. This advances
-- the clock by the duration of the animation.
--
-- Example:
--
-- @
-- do 'fork' $ 'newSpriteA'' 'SyncFreeze' 'Reanimate.Builtin.Documentation.drawCircle'
-- 'play' 'Reanimate.Builtin.Documentation.drawBox'
-- 'play' $ 'reverseA' 'Reanimate.Builtin.Documentation.drawBox'
-- @
--
-- <<docs/gifs/doc_newSpriteA'.gif>>
newSpriteA' :: Sync -> Animation -> Scene s (Sprite s)
newSpriteA' sync animation =
newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration)
<* wait (duration animation)
-- | Create a sprite from a static SVG image.
--
-- Example:
--
-- @
-- do 'newSpriteSVG' $ 'mkBackground' "lightblue"
-- 'play' 'Reanimate.Builtin.Documentation.drawCircle'
-- @
--
-- <<docs/gifs/doc_newSpriteSVG.gif>>
newSpriteSVG :: SVG -> Scene s (Sprite s)
newSpriteSVG = newSprite . pure
-- | Create a permanent sprite from a static SVG image. Same as `newSpriteSVG`
-- but the sprite isn't returned and thus cannot be destroyed.
newSpriteSVG_ :: SVG -> Scene s ()
newSpriteSVG_ = void . newSpriteSVG
-- | Change the rendering of a sprite using data from a variable. If data from several variables
-- is needed, use a frame generator instead.
--
-- Example:
--
-- @
-- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawBox'
-- v \<- 'newVar' 0
-- 'applyVar' v s 'rotate'
-- 'tweenVar' v 2 $ \\val -> 'fromToS' val 90
-- @
--
-- <<docs/gifs/doc_applyVar.gif>>
applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s ()
applyVar var sprite fn = spriteModify sprite $ do
varFn <- unVar var
return $ first $ fn varFn
-- | Destroy a sprite, preventing it from being rendered in the future of the scene.
-- If 'destroySprite' is invoked multiple times, the earliest time-of-death is used.
--
-- Example:
--
-- @
-- do s <- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'mkCircle' 1
-- 'fork' $ 'wait' 1 \>\> 'destroySprite' s
-- 'play' 'Reanimate.Builtin.Documentation.drawBox'
-- @
--
-- <<docs/gifs/doc_destroySprite.gif>>
destroySprite :: Sprite s -> Scene s ()
destroySprite (Sprite _ ref) = do
now <- queryNow
liftST $
modifySTRef ref $ \(ttl, render) ->
(if ttl < 0 then now else min ttl now, render)
-- | Low-level frame modifier.
spriteModify :: Sprite s -> Frame s ((SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s ()
spriteModify (Sprite born ref) modFn = liftST $
modifySTRef ref $ \(ttl, renderGen) ->
( ttl,
do
render <- renderGen
modRender <- unFrame modFn
return $ \relD relT ->
let absT = relT + born in modRender absT relD relT . render relD relT
)
-- | Map the SVG output of a sprite.
--
-- Example:
--
-- @
-- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
-- 'wait' 1
-- 'spriteMap' s 'flipYAxis'
-- @
--
-- <<docs/gifs/doc_spriteMap.gif>>
spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s ()
spriteMap sprite@(Sprite born _) fn = do
now <- queryNow
let tDelta = now - born
spriteModify sprite $ do
t <- spriteT
return $ \(svg, zindex) -> (if (t - tDelta) < 0 then svg else fn svg, zindex)
-- | Modify the output of a sprite between @now@ and @now+duration@.
--
-- Example:
--
-- @
-- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
-- 'spriteTween' s 1 $ \\val -> 'translate' ('Reanimate.Constants.screenWidth'*0.3*val) 0
-- @
--
-- <<docs/gifs/doc_spriteTween.gif>>
spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()
spriteTween sprite@(Sprite born _) dur fn = do
now <- queryNow
let tDelta = now - born
spriteModify sprite $ do
t <- spriteT
return $ first $ \svg -> fn (clamp 0 1 $ (t - tDelta) / dur) svg
wait dur
where
clamp a b v
| v < a = a
| v > b = b
| otherwise = v
-- | Create a new variable and apply it to a sprite.
--
-- Example:
--
-- @
-- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawBox'
-- v \<- 'spriteVar' s 0 'rotate'
-- 'tweenVar' v 2 $ \\val -> 'fromToS' val 90
-- @
--
-- <<docs/gifs/doc_spriteVar.gif>>
spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)
spriteVar sprite def fn = do
v <- newVar def
applyVar v sprite fn
return v
-- | Apply an effect to a sprite.
--
-- Example:
--
-- @
-- do s <- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
-- 'spriteE' s $ 'overBeginning' 1 'fadeInE'
-- 'spriteE' s $ 'overEnding' 0.5 'fadeOutE'
-- @
--
-- <<docs/gifs/doc_spriteE.gif>>
spriteE :: Sprite s -> Effect -> Scene s ()
spriteE (Sprite born ref) effect = do
now <- queryNow
liftST $
modifySTRef ref $ \(ttl, renderGen) ->
( ttl,
do
render <- renderGen
return $ \d t svg ->
let (svg', z) = render d t svg
in (delayE (max 0 $ now - born) effect d t svg', z)
)
-- | Set new ZIndex of a sprite.
--
-- Example:
--
-- @
-- do s1 \<- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'withFillColor' "blue" $ 'mkCircle' 3
-- 'newSpriteSVG' $ 'withFillOpacity' 1 $ 'withFillColor' "red" $ 'mkRect' 8 3
-- 'wait' 1
-- 'spriteZ' s1 1
-- 'wait' 1
-- @
--
-- <<docs/gifs/doc_spriteZ.gif>>
spriteZ :: Sprite s -> ZIndex -> Scene s ()
spriteZ (Sprite born ref) zindex = do
now <- queryNow
liftST $
modifySTRef ref $ \(ttl, renderGen) ->
( ttl,
do
render <- renderGen
return $ \d t svg ->
let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex)
)
-- | Destroy all local sprites at the end of a scene.
--
-- Example:
--
-- @
-- do -- the rect lives through the entire 3s animation
-- 'newSpriteSVG_' $ 'translate' (-3) 0 $ 'mkRect' 4 4
-- 'wait' 1
-- 'spriteScope' $ do
-- -- the circle only lives for 1 second.
-- local \<- 'newSpriteSVG' $ 'translate' 3 0 $ 'mkCircle' 2
-- 'spriteE' local $ 'overBeginning' 0.3 'fadeInE'
-- 'spriteE' local $ 'overEnding' 0.3 'fadeOutE'
-- 'wait' 1
-- 'wait' 1
-- @
--
-- <<docs/gifs/doc_spriteScope.gif>>
spriteScope :: Scene s a -> Scene s a
spriteScope (M action) = M $ \t -> do
(a, s, p, gens) <- action t
return (a, s, p, map (genFn (t + max s p)) gens)
where
genFn maxT gen = do
frameGen <- gen
return $ \_ t ->
if t < maxT
then frameGen maxT t
else (None, 0)
asAnimation :: (forall s'. Scene s' a) -> Scene s Animation
asAnimation s = do
now <- queryNow
return $ dropA now (sceneAnimation (wait now >> s))
-- | Apply a transformation with a given overlap. This makes sure
-- to keep timestamps intact such that events can still be timed
-- by transcripts.
transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s ()
transitionO t o a b = do
aA <- asAnimation a
bA <- fork $ do
wait (duration aA - o)
asAnimation b
play $ overlapT o t aA bA

170
src/Reanimate/Scene/Var.hs Normal file
View file

@ -0,0 +1,170 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Reanimate.Scene.Var where
import Control.Monad.ST (ST)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.STRef
import Reanimate.Animation (Duration, Time)
import Reanimate.Scene.Core (Scene, liftST, queryNow, wait)
-- | Time dependent variable.
newtype Var s a = Var (STRef s (VarData a))
-- Note: We must ensure that upon transforming an VarData,
-- 1. evarDefault old == evarDefault new
-- 2. isNothing (evarLastTime old) || isJust (evarLastTime new) i.e. once evarLastValue has a Just value,
-- it shouldn't be Nothing again.
-- 3. isNothing (evarLastTime var) => M.null (evarTimeline var)
data VarData a = VarData
{ evarDefault :: a,
evarTimeline :: Timeline a,
evarLastTime :: Maybe Time,
evarLastValue :: a
}
data Modifier a = StaticValue a | TweenValue Duration (a -> Time -> a)
type Timeline a = M.Map Time (Modifier a)
-- | Create a new variable with a default value.
-- Variables always have a defined value even if they are read at a timestamp that is
-- earlier than when the variable was created. For example:
--
-- @
-- do v \<- 'fork' ('wait' 10 \>\> 'newVar' 0) -- Create a variable at timestamp '10'.
-- 'readVar' v -- Read the variable at timestamp '0'.
-- -- The value of the variable will be '0'.
-- @
newVar :: a -> Scene s (Var s a)
newVar def = Var <$> liftST (newSTRef $ VarData def M.empty Nothing def)
-- | Read the value of a variable at the current timestamp.
readVar :: Var s a -> Scene s a
readVar (Var ref) = readVarData <$> liftST (readSTRef ref) <*> queryNow
unpackVar :: Var s a -> ST s (Time -> a)
unpackVar (Var ref) = readVarData <$> readSTRef ref
-- | Write the value of a variable at the current timestamp.
--
-- Example:
--
-- @
-- do v \<- 'newVar' 0
-- 'newSprite' $ 'mkCircle' \<$\> 'unVar' v
-- 'writeVar' v 1; 'wait' 1
-- 'writeVar' v 2; 'wait' 1
-- 'writeVar' v 3; 'wait' 1
-- @
--
-- <<docs/gifs/doc_writeVar.gif>>
writeVar :: Var s a -> a -> Scene s ()
writeVar (Var ref) val = do
now <- queryNow
liftST $ modifySTRef ref $ writeVarData now val
-- | Modify the value of a variable at the current timestamp and all future timestamps.
modifyVar :: Var s a -> (a -> a) -> Scene s ()
modifyVar (Var ref) fn = do
now <- queryNow
liftST $ modifySTRef ref $ modifyVarData now fn
-- | Modify a variable between @now@ and @now+duration@.
tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()
tweenVar _ dur _ | dur < 0 = error "Reanimate.tweenVar: durations must be non-negative"
tweenVar (Var ref) dur fn = do
now <- queryNow
liftST $ modifySTRef ref $ tweenVarData now dur fn
wait dur
readVarData :: VarData a -> Time -> a
readVarData (VarData def _ Nothing _) _ = def
readVarData (VarData def timeline (Just lastTime) lastValue) now
| now < lastTime = lookupTimeline timeline def now
| otherwise = lastValue
lookupTimeline :: Timeline a -> a -> Time -> a
lookupTimeline timeline def now = case M.lookupLE now timeline of
Just (_, StaticValue sVal) -> sVal
Just (t, TweenValue dur f)
| t + dur > now -> f def now
_ -> def
writeVarData :: Time -> a -> VarData a -> VarData a
writeVarData now x var =
let before = keepBefore now var
after = VarData (evarDefault var) M.empty (Just now) x
in after `elseVar` before
modifyVarData :: Time -> (a -> a) -> VarData a -> VarData a
modifyVarData now fn var =
let before = keepBefore now var
after = keepFrom now var
timeline = flip M.map (evarTimeline after) $ \case
StaticValue s -> StaticValue $ fn s
TweenValue dur f -> TweenValue dur $ \a t -> fn (f a t)
in after {evarTimeline = timeline, evarLastValue = fn $ evarLastValue after} `elseVar` before
-- Note: The function passed here takes time on the scale 0 to 1
-- while the function in `TweenValue` takes time on an absolute scale.
tweenVarData :: Time -> Duration -> (a -> Time -> a) -> VarData a -> VarData a
tweenVarData st dur fn var@VarData {..} =
let nd = st + dur
before = keepBefore st var
during = keepInRange (Just st) (Just nd) var
tweenFn a t =
let idx = (t - st) / dur
idx' = if isNaN idx then 1 else idx
in fn (readVarData (during {evarDefault = a}) t) idx'
valueTweenEnd = tweenFn evarDefault nd -- we'll never use the def here, replace with error?
after = VarData evarDefault (M.singleton st $ TweenValue dur tweenFn) (Just nd) valueTweenEnd
in after `elseVar` before
-- Returns the union of two vars such that we use the second var if first var doesn't have a value.
-- Assumes both vars have same default value.
elseVar :: VarData a -> VarData a -> VarData a
elseVar var1 var2
| Just t <- evarLastTime var1 =
let afterTimeline = evarTimeline var1
joinAt = fromMaybe t . fmap fst $ M.lookupMin afterTimeline
beforeTimeline = case keepBefore joinAt var2 of
x
| Just lastTime <- evarLastTime x, lastTime < joinAt -> M.insert lastTime (StaticValue $ evarLastValue x) $ evarTimeline x
| otherwise -> evarTimeline x
in var1 {evarTimeline = M.union afterTimeline beforeTimeline}
| otherwise = var2
-- Restrict a var to a given time interval.
keepInRange :: Maybe Time -> Maybe Time -> VarData a -> VarData a
keepInRange st nd = fromMaybe id (keepFrom <$> st) . fromMaybe id (keepBefore <$> nd)
-- Restrict a var to start at given timestamp.
keepFrom :: Time -> VarData a -> VarData a
keepFrom st VarData {..} =
let timeline' = M.dropWhileAntitone (< st) evarTimeline
-- if there is no modifier in timeline starting at st,
-- we must get the modifier that starts before and truncate it to start at st.
timeline'' = case M.lookupLE st evarTimeline of
Just (t, val@(StaticValue _))
| t < st -> M.insert st val timeline'
Just (t, TweenValue dur fn)
| t < st, t + dur > st -> M.insert st (TweenValue (t + dur - st) fn) timeline'
_ -> timeline'
in VarData evarDefault timeline'' (max evarLastTime $ Just st) evarLastValue
-- Restrict a var to end(clamp) at given timestamp.
keepBefore :: Time -> VarData a -> VarData a
keepBefore nd var@VarData {..} =
let timeline' = M.takeWhileAntitone (< nd) evarTimeline
lastModifier = M.lookupMax timeline'
timeline'' = case lastModifier of
Just (t, TweenValue dur fn)
| t + dur > nd -> M.insert t (TweenValue (nd - t) fn) timeline'
_ -> timeline'
lastTime = case lastModifier of
Just (t, TweenValue dur _) -> Just $ min nd (t + dur)
_ -> min nd <$> evarLastTime
in VarData evarDefault timeline'' lastTime (fromMaybe evarDefault $ fmap (readVarData var) lastTime)

3
test/Spec.hs
View file

@ -5,10 +5,11 @@ import Test.Tasty.Ingredients.Rerun (defaultMainWithRerun)
import Properties
import UnitTests
import TimeVarTests
main :: IO ()
main = do
tests1 <- unitTestFolder "examples/"
tests2 <- compileTestFolder "examples/"
tests3 <- compileVideoFolder "videos/"
defaultMainWithRerun $ testGroup "tests" [tests1, tests2, tests3, all_props]
defaultMainWithRerun $ testGroup "tests" [tests1, tests2, tests3, all_props, timeVarTests]

166
test/TimeVarTests.hs Normal file
View file

@ -0,0 +1,166 @@
{-# LANGUAGE RankNTypes #-}
module TimeVarTests
( timeVarTests
) where
import Control.Exception
import Control.Monad.ST.Unsafe
import Data.IORef
import System.IO.Unsafe
import Test.Tasty
import Test.Tasty.ExpectedFailure
import Test.Tasty.HUnit
import Reanimate
import Reanimate.Scene
timeVarTests :: TestTree
timeVarTests =
testGroup "Time variables"
[ expectFail $ tc "Error check1" $ do
v <- newVar (0::Double)
checkAt v
[ (0,0), (0.25, 0.25), (0.5, 0.5), (1,0) ]
, expectFail $ tc "Error check2" $ do
io $ True @?= False
, tc "Default value" $ do
v <- newVar True
checkAt v
[ (-1, True), (0, True), (1, True) ]
, tc "Modified value" $ do
v <- newVar False
writeVar v True
checkAt v
[(-1, False), (0, True), (1, True)]
, tc "Modified value" $ do
v <- newVar False
writeVar v True
writeVar v False
checkAt v
[(-1, False), (0, False), (1, False)]
, tc "Overwrite future" $ do
v <- newVar "def"
fork $ do
wait 1
writeVar v "written in the future"
writeVar v "overwrite"
checkAt v
[ (-1, "def"), (0, "overwrite"), (1, "overwrite") ]
, tc "Interrupt tween" $ do
v <- newVar 0
fork $ tweenVar v 1 $ \prev t -> fromToS prev 1 t
checkAt v
[ (0,0), (0.25, 0.25), (0.5, 0.5), (1,1) ]
fork $ do
wait 0.5
writeVar v 0.5
checkAt v
[ (0,0), (0.25, 0.25), (0.5, 0.5), (1,0.5) ]
, tc "Double tween" $ do
v <- newVar 0
fork $ tweenVar v 1 $ \prev t -> fromToS prev 1 t
fork $ tweenVar v 1 $ \prev t -> fromToS prev 0 t
checkAt v
[ (0,0), (0.25, 0.25*0.75), (0.5, 0.5*0.5), (1,1*0) ]
, expectFail $ tc "Negative tween duration" $ do
v <- newVar 0
tweenVar v (-1) $ \prev t -> fromToS prev 1 t
, tc "Tween 1" $ do
v <- newVar 0
wait 1
tweenVar v 1 $ \prev t -> fromToS prev 1 t
checkAt v
[ (0,0), (1,0), (1.5,0.5), (2,1), (3,1) ]
, tc "Tween 2" $ do
v <- newVar (0::Int)
wait 1
tweenVar v 1 $ \_prev _t -> 1
checkAt v
[ (0,0), (1,1), (1.5,1), (2,1), (3,1) ]
, tc "Tween 3" $ do
v <- newVar (0::Int)
wait 1
tweenVar v 0 $ \_prev _t -> 1
checkAt v
[ (0,0), (1,1), (2,1)]
, tc "Tween 4" $ do
v <- newVar (0::Double)
tweenVar v 1 $ \prev t -> fromToS prev 1 t
tweenVar v 1 $ \prev t -> fromToS prev 0 t
checkAt v
[ (0,0), (0.5,0.5), (1,1), (1.5,0.5), (2,0)]
, tc "Tween 5" $ do
v <- newVar (0::Double)
tweenVar v 1 $ \prev t -> fromToS prev 1 t
tweenVar v 1 $ \prev t -> fromToS prev 0 t
wait (-1)
writeVar v 2
checkAt v
[ (0,0), (0.5,0.5), (1,2), (1.5,2), (2,2)]
, tc "Tween zero duration" $ do
v <- newVar 0
wait 1
tweenVar v 0 $ \_prev t -> t
checkAt v
[ (0,0), (1,1), (2,1)]
, tc "Performance/writeVar" $ do
v <- newVar (0::Int)
ref <- io $ newIORef (0::Int)
modifyVar v $ \old -> unsafePerformIO (modifyIORef ref (+1) >> return 1) + old
at0 <- readVar v
wait 1
at1 <- readVar v
io $ at0+at1 @?= 2
counter <- io $ readIORef ref
io $ counter @?= 1
, tc "Performance/tweenVar" $ do
v <- newVar (0::Double)
ref <- io $ newIORef (0::Int)
let expensive prev t = unsafePerformIO $ do
modifyIORef ref (+1)
evaluate (fromToS prev 1 t)
tweenVar v 1 expensive
-- Reading at 0.5 and 1 should call the expensive function.
-- Reading at 2 and 3 should reuse the result from 1.
-- The count should therefore be 2 and not 4.
checkAt v
[ (0.5,0.5), (1,1), (2,1), (3,1) ]
counter <- io $ readIORef ref
io $ counter @?= 2
, tc "Performance/tweenVar 2" $ do
v <- newVar (0::Double)
fork $ wait 10 >> writeVar v 1
ref <- io $ newIORef (0::Int)
let expensive prev t = unsafePerformIO $ do
modifyIORef ref (+1)
evaluate (fromToS prev 1 t)
tweenVar v 1 expensive
wait 2
writeVar v 2
-- Reading at 0.5 and 1 should call the expensive function.
-- Reading at 2 should reuse the result from 1.
-- The count should therefore be 2 and not 4.
checkAt v
[ (0.5,0.5), (1,1), (2,1), (3,2), (4,2) ]
counter <- io $ readIORef ref
io $ counter @?= 2
]
checkAt :: (Eq a, Show a) => Var s a -> [(Time, a)] -> Scene s ()
checkAt _ [] = pure ()
checkAt v ((d,expected):xs) = do
fork $ do
now <- queryNow
wait (d-now)
val <- readVar v
io $ val @?= expected
checkAt v xs
tc :: TestName -> (forall s. Scene s ()) -> TestTree
tc name action = testCase name $
(evalScene action @?= ())
`catch` \(ErrorCall err) -> assertFailure err
io :: IO a -> Scene s a
io action = liftST (unsafeIOToST action)