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 scene,
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' 'Reanimate.Svg.Constructors.mkCircle' 0
45 -- 'Reanimate.Scene.tweenVar' var 2 $ \\val -> 'Reanimate.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' $ 'Reanimate.Svg.Constructors.mkCircle' \<$\> 'unVar' v
102 -- 'Reanimate.Scene.tweenVar' v 1 $ \\val -> 'Reanimate.fromToS' val 3
103 -- 'Reanimate.Scene.tweenVar' v 1 $ \\val -> 'Reanimate.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' $ 'Reanimate.Svg.Constructors.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' $ 'Reanimate.Animation.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'' 'Reanimate.Animation.SyncFreeze' 'Reanimate.Builtin.Documentation.drawCircle'
186 -- 'play' 'Reanimate.Builtin.Documentation.drawBox'
187 -- 'play' $ 'Reanimate.Animation.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' $ 'Reanimate.Svg.Constructors.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 'Reanimate.Svg.Constructors.rotate'
223 -- 'Reanimate.Scene.tweenVar' v 2 $ \\val -> 'Reanimate.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' $ 'Reanimate.Svg.Constructors.withFillOpacity' 1 $ 'Reanimate.Svg.Constructors.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 'Reanimate.Svg.Constructors.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 -> 'Reanimate.Svg.Constructors.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 'Reanimate.Svg.Constructors.rotate'
313 -- 'Reanimate.Scene.tweenVar' v 2 $ \\val -> 'Reanimate.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 $ 'Reanimate.Effect.overBeginning' 1 'Reanimate.Effect.fadeInE'
330 -- 'spriteE' s $ 'Reanimate.Effect.overEnding' 0.5 'Reanimate.Effect.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' $ 'Reanimate.Svg.Constructors.withFillOpacity' 1 $ 'Reanimate.Svg.Constructors.withFillColor' "blue" $ 'Reanimate.Svg.Constructors.mkCircle' 3
353 -- 'newSpriteSVG' $ 'Reanimate.Svg.Constructors.withFillOpacity' 1 $ 'Reanimate.Svg.Constructors.withFillColor' "red" $ 'Reanimate.Svg.Constructors.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_' $ 'Reanimate.Svg.Constructors.translate' (-3) 0 $ 'Reanimate.Svg.Constructors.mkRect' 4 4
379 -- 'wait' 1
380 -- 'spriteScope' $ do
381 -- -- the circle only lives for 1 second.
382 -- local \<- 'newSpriteSVG' $ 'Reanimate.Svg.Constructors.translate' 3 0 $ 'Reanimate.Svg.Constructors.mkCircle' 2
383 -- 'spriteE' local $ 'Reanimate.Effect.overBeginning' 0.3 'Reanimate.Effect.fadeInE'
384 -- 'spriteE' local $ 'Reanimate.Effect.overEnding' 0.3 'Reanimate.Effect.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 (scene (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