never executed always true always false
1 {-# LANGUAGE ApplicativeDo #-}
2 {-# LANGUAGE ExistentialQuantification #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-|
6 Module : Reanimate.Scene
7 Copyright : Written by David Himmelstrup
8 License : Unlicense
9 Maintainer : lemmih@gmail.com
10 Stability : experimental
11 Portability : POSIX
12
13 Scenes are an imperative way of defining animations.
14
15 -}
16 module Reanimate.Scene
17 ( -- * Scenes
18 Scene
19 , ZIndex
20 , scene -- :: (forall s. Scene s a) -> Animation
21 , sceneAnimation -- :: (forall s. Scene s a) -> Animation
22 , play -- :: Animation -> Scene s ()
23 , fork -- :: Scene s a -> Scene s a
24 , queryNow -- :: Scene s Time
25 , wait -- :: Duration -> Scene s ()
26 , waitUntil -- :: Time -> Scene s ()
27 , waitOn -- :: Scene s a -> Scene s a
28 , adjustZ -- :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
29 , withSceneDuration -- :: Scene s () -> Scene s Duration
30 -- * Variables
31 , Var
32 , newVar -- :: a -> Scene s (Var s a)
33 , readVar -- :: Var s a -> Scene s a
34 , writeVar -- :: Var s a -> a -> Scene s ()
35 , modifyVar -- :: Var s a -> (a -> a) -> Scene s ()
36 , tweenVar -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()
37 , tweenVarUnclamped -- :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()
38 , simpleVar -- :: (a -> SVG) -> a -> Scene s (Var s a)
39 , findVar -- :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)
40 -- * Sprites
41 , Sprite
42 , Frame
43 , unVar -- :: Var s a -> Frame s a
44 , spriteT -- :: Frame s Time
45 , spriteDuration -- :: Frame s Duration
46 , newSprite -- :: Frame s SVG -> Scene s (Sprite s)
47 , newSprite_ -- :: Frame s SVG -> Scene s ()
48 , newSpriteA -- :: Animation -> Scene s (Sprite s)
49 , newSpriteA' -- :: Sync -> Animation -> Scene s (Sprite s)
50 , newSpriteSVG -- :: SVG -> Scene s (Sprite s)
51 , newSpriteSVG_ -- :: SVG -> Scene s ()
52 , destroySprite -- :: Sprite s -> Scene s ()
53 , applyVar -- :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s ()
54 , spriteModify -- :: Sprite s -> Frame s ((SVG,ZIndex) -> (SVG, ZIndex)) -> Scene s ()
55 , spriteMap -- :: Sprite s -> (SVG -> SVG) -> Scene s ()
56 , spriteTween -- :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()
57 , spriteVar -- :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)
58 , spriteE -- :: Sprite s -> Effect -> Scene s ()
59 , spriteZ -- :: Sprite s -> ZIndex -> Scene s ()
60 , spriteScope -- :: Scene s a -> Scene s a
61
62 -- * Object API
63 , Object
64 , ObjectData
65 , oNew
66 , newObject
67 , oModify
68 , oModifyS
69 , oRead
70 , oTween
71 , oTweenS
72 , oTweenV
73 , oTweenVS
74 , Renderable(..)
75 -- ** Object Properties
76 , oTranslate
77 , oSVG
78 , oContext
79 , oMargin
80 , oMarginTop
81 , oMarginRight
82 , oMarginBottom
83 , oMarginLeft
84 , oBB
85 , oBBMinX
86 , oBBMinY
87 , oBBWidth
88 , oBBHeight
89 , oOpacity
90 , oShown
91 , oZIndex
92 , oEasing
93 , oScale
94 , oScaleOrigin
95 , oTopY
96 , oBottomY
97 , oLeftX
98 , oRightX
99 , oCenterXY
100 , oValue
101
102 -- ** Graphics object methods
103 , oShow
104 , oHide
105 , oFadeIn
106 , oFadeOut
107 , oGrow
108 , oShrink
109 , oTransform
110
111 -- ** Pre-defined objects
112 , Circle(..)
113 , circleRadius
114 , Rectangle(..)
115 , rectWidth
116 , rectHeight
117 , Morph(..)
118 , morphDelta
119 , morphSrc
120 , morphDst
121 , Camera(..)
122 , cameraAttach
123 , cameraFocus
124 , cameraSetZoom
125 , cameraZoom
126 , cameraSetPan
127 , cameraPan
128
129 -- * ST internals
130 , liftST
131 , transitionO
132 , evalScene
133 )
134 where
135
136 import Control.Lens
137 import Control.Monad (void)
138 import Control.Monad.Fix
139 import Control.Monad.ST
140 import Control.Monad.State (execState, State)
141 import Data.List
142 import Data.STRef
143 import Graphics.SvgTree (Tree (None))
144 import Reanimate.Animation
145 import Reanimate.Ease (Signal, curveS, fromToS)
146 import Reanimate.Effect
147 import Reanimate.Svg.Constructors
148 import Reanimate.Svg.BoundingBox
149 import Reanimate.Transition
150 import Reanimate.Morph.Common (morph)
151 import Reanimate.Morph.Linear (linear)
152
153 -- | The ZIndex property specifies the stack order of sprites and animations. Elements
154 -- with a higher ZIndex will be drawn on top of elements with a lower index.
155 type ZIndex = Int
156
157
158 -- (seq duration, par duration)
159 -- [(Time, Animation, ZIndex)]
160 -- Map Time [(Animation, ZIndex)]
161 type Gen s = ST s (Duration -> Time -> (SVG, ZIndex))
162 -- | A 'Scene' represents a sequence of animations and variables
163 -- that change over time.
164 newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, [Gen s]) }
165
166 instance Functor (Scene s) where
167 fmap f action = M $ \t -> do
168 (a, d1, d2, gens) <- unM action t
169 return (f a, d1, d2, gens)
170
171 instance Applicative (Scene s) where
172 pure a = M $ \_ -> return (a, 0, 0, [])
173 f <*> g = M $ \t -> do
174 (f', s1, p1, gen1) <- unM f t
175 (g', s2, p2, gen2) <- unM g (t + s1)
176 return (f' g', s1 + s2, max p1 (s1 + p2), gen1 ++ gen2)
177
178 instance Monad (Scene s) where
179 return = pure
180 f >>= g = M $ \t -> do
181 (a, s1, p1, gen1) <- unM f t
182 (b, s2, p2, gen2) <- unM (g a) (t + s1)
183 return (b, s1 + s2, max p1 (s1 + p2), gen1 ++ gen2)
184
185 instance MonadFix (Scene s) where
186 mfix fn = M $ \t -> mfix (\v -> let (a, _s, _p, _gens) = v in unM (fn a) t)
187
188 -- | Lift an ST action into the Scene monad.
189 liftST :: ST s a -> Scene s a
190 liftST action = M $ \_ -> action >>= \a -> return (a, 0, 0, [])
191
192 -- | Evaluate the value of a scene.
193 evalScene :: (forall s . Scene s a) -> a
194 evalScene action = runST $ do
195 (val, _, _ , _) <- unM action 0
196 return val
197
198 -- | Render a 'Scene' to an 'Animation'.
199 scene :: (forall s . Scene s a) -> Animation
200 scene = sceneAnimation
201
202 -- | Render a 'Scene' to an 'Animation'.
203 sceneAnimation :: (forall s . Scene s a) -> Animation
204 sceneAnimation action = runST
205 (do
206 (_, s, p, gens) <- unM action 0
207 let dur = max s p
208 genFns <- sequence gens
209 return $ mkAnimation
210 dur
211 (\t -> mkGroup $ map fst $ sortOn
212 snd
213 [ spriteRender dur (t * dur) | spriteRender <- genFns ]
214 )
215 )
216
217 -- | Execute actions in a scene without advancing the clock. Note that scenes do not end before
218 -- all forked actions have completed.
219 --
220 -- Example:
221 --
222 -- > do fork $ play drawBox
223 -- > play drawCircle
224 --
225 -- <<docs/gifs/doc_fork.gif>>
226 fork :: Scene s a -> Scene s a
227 fork (M action) = M $ \t -> do
228 (a, s, p, gens) <- action t
229 return (a, 0, max s p, gens)
230
231 -- | Play an animation once and then remove it. This advances the clock by the duration of the
232 -- animation.
233 --
234 -- Example:
235 --
236 -- > do play drawBox
237 -- > play drawCircle
238 --
239 -- <<docs/gifs/doc_play.gif>>
240 play :: Animation -> Scene s ()
241 play ani = newSpriteA ani >>= destroySprite
242
243 -- | Query the current clock timestamp.
244 --
245 -- Example:
246 --
247 -- > do now <- play drawCircle *> queryNow
248 -- > play $ staticFrame 1 $ scale 2 $ withStrokeWidth 0.05 $
249 -- > mkText $ "Now=" <> T.pack (show now)
250 --
251 -- <<docs/gifs/doc_queryNow.gif>>
252 queryNow :: Scene s Time
253 queryNow = M $ \t -> return (t, 0, 0, [])
254
255 -- | Advance the clock by a given number of seconds.
256 --
257 -- Example:
258 --
259 -- > do fork $ play drawBox
260 -- > wait 1
261 -- > play drawCircle
262 --
263 -- <<docs/gifs/doc_wait.gif>>
264 wait :: Duration -> Scene s ()
265 wait d = M $ \_ -> return ((), d, 0, [])
266
267 -- | Wait until the clock is equal to the given timestamp.
268 waitUntil :: Time -> Scene s ()
269 waitUntil tNew = do
270 now <- queryNow
271 wait (max 0 (tNew - now))
272
273 -- | Wait until all forked and sequential animations have finished.
274 --
275 -- Example:
276 --
277 -- > do waitOn $ fork $ play drawBox
278 -- > play drawCircle
279 --
280 -- <<docs/gifs/doc_waitOn.gif>>
281 waitOn :: Scene s a -> Scene s a
282 waitOn (M action) = M $ \t -> do
283 (a, s, p, gens) <- action t
284 return (a, max s p, 0, gens)
285
286 -- | Change the ZIndex of a scene.
287 adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
288 adjustZ fn (M action) = M $ \t -> do
289 (a, s, p, gens) <- action t
290 return (a, s, p, map genFn gens)
291 where
292 genFn gen = do
293 frameGen <- gen
294 return $ \d t -> let (svg, z) = frameGen d t in (svg, fn z)
295
296 -- | Query the duration of a scene.
297 withSceneDuration :: Scene s () -> Scene s Duration
298 withSceneDuration s = do
299 t1 <- queryNow
300 s
301 t2 <- queryNow
302 return (t2 - t1)
303
304 addGen :: Gen s -> Scene s ()
305 addGen gen = M $ \_ -> return ((), 0, 0, [gen])
306
307 -- | Time dependent variable.
308 newtype Var s a = Var (STRef s (Time -> a))
309
310 -- | Create a new variable with a default value.
311 -- Variables always have a defined value even if they are read at a timestamp that is
312 -- earlier than when the variable was created. For example:
313 --
314 -- > do v <- fork (wait 10 >> newVar 0) -- Create a variable at timestamp '10'.
315 -- > readVar v -- Read the variable at timestamp '0'.
316 -- > -- The value of the variable will be '0'.
317 newVar :: a -> Scene s (Var s a)
318 newVar def = Var <$> liftST (newSTRef (const def))
319
320 -- | Read the value of a variable at the current timestamp.
321 readVar :: Var s a -> Scene s a
322 readVar (Var ref) = liftST (readSTRef ref) <*> queryNow
323
324 -- | Write the value of a variable at the current timestamp.
325 --
326 -- Example:
327 --
328 -- > do v <- newVar 0
329 -- > newSprite $ mkCircle <$> unVar v
330 -- > writeVar v 1; wait 1
331 -- > writeVar v 2; wait 1
332 -- > writeVar v 3; wait 1
333 --
334 -- <<docs/gifs/doc_writeVar.gif>>
335 writeVar :: Var s a -> a -> Scene s ()
336 writeVar var val = modifyVar var (const val)
337
338 -- | Modify the value of a variable at the current timestamp and all future timestamps.
339 modifyVar :: Var s a -> (a -> a) -> Scene s ()
340 modifyVar (Var ref) fn = do
341 now <- queryNow
342 liftST $ modifySTRef ref $ \prev t -> if t < now then prev t else fn (prev t)
343
344 -- | Modify a variable between @now@ and @now+duration@.
345 -- Note: The modification function is invoked for past timestamps (with a time value of 0) and
346 -- for timestamps after @now+duration@ (with a time value of 1). See 'tweenVarUnclamped'.
347 tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()
348 tweenVar (Var ref) dur fn = do
349 now <- queryNow
350 liftST $ modifySTRef ref $ \prev t ->
351 if t < now
352 then prev t
353 else fn (prev t) (max 0 (min dur $ t - now) / dur)
354 wait dur
355
356 -- | Modify a variable between @now@ and @now+duration@.
357 -- Note: The modification function is invoked for past timestamps (with a negative time value) and
358 -- for timestamps after @now+duration@ (with a time value greater than 1).
359 tweenVarUnclamped :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()
360 tweenVarUnclamped (Var ref) dur fn = do
361 now <- queryNow
362 liftST $ modifySTRef ref $ \prev t -> fn (prev t) ((t - now) / dur)
363 wait dur
364
365 -- | Create and render a variable. The rendering will be born at the current timestamp
366 -- and will persist until the end of the scene.
367 --
368 -- Example:
369 --
370 -- > do var <- simpleVar mkCircle 0
371 -- > tweenVar var 2 $ \val -> fromToS val (screenHeight/2)
372 --
373 -- <<docs/gifs/doc_simpleVar.gif>>
374 simpleVar :: (a -> SVG) -> a -> Scene s (Var s a)
375 simpleVar render def = do
376 v <- newVar def
377 _ <- newSprite $ render <$> unVar v
378 return v
379
380 -- | Helper function for filtering variables.
381 findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)
382 findVar _cond [] = error "Variable not found."
383 findVar cond (v : vs) = do
384 val <- readVar v
385 if cond val then return v else findVar cond vs
386
387 -- | Sprites are animations with a given time of birth as well as a time of death.
388 -- They can be controlled using variables, tweening, and effects.
389 data Sprite s = Sprite Time (STRef s (Duration, ST s (Duration -> Time -> SVG -> (SVG, ZIndex))))
390
391 -- | Sprite frame generator. Generates frames over time in a stateful environment.
392 newtype Frame s a = Frame { unFrame :: ST s (Time -> Duration -> Time -> a) }
393
394 instance Functor (Frame s) where
395 fmap fn (Frame gen) = Frame $ do
396 m <- gen
397 return (\real_t d t -> fn $ m real_t d t)
398
399 instance Applicative (Frame s) where
400 pure v = Frame $ return (\_ _ _ -> v)
401 Frame f <*> Frame g = Frame $ do
402 m1 <- f
403 m2 <- g
404 return $ \real_t d t -> m1 real_t d t (m2 real_t d t)
405
406 -- | Dereference a variable as a Sprite frame.
407 --
408 -- Example:
409 --
410 -- > do v <- newVar 0
411 -- > newSprite $ mkCircle <$> unVar v
412 -- > tweenVar v 1 $ \val -> fromToS val 3
413 -- > tweenVar v 1 $ \val -> fromToS val 0
414 --
415 -- <<docs/gifs/doc_unVar.gif>>
416 unVar :: Var s a -> Frame s a
417 unVar (Var ref) = Frame $ do
418 fn <- readSTRef ref
419 return $ \real_t _d _t -> fn real_t
420
421
422 -- | Dereference seconds since sprite birth.
423 spriteT :: Frame s Time
424 spriteT = Frame $ return (\_real_t _d t -> t)
425
426 -- | Dereference duration of the current sprite.
427 spriteDuration :: Frame s Duration
428 spriteDuration = Frame $ return (\_real_t d _t -> d)
429
430 -- | Create new sprite defined by a frame generator. Unless otherwise specified using
431 -- 'destroySprite', the sprite will die at the end of the scene.
432 --
433 -- Example:
434 --
435 -- > do newSprite $ mkCircle <$> spriteT -- Circle sprite where radius=time.
436 -- > wait 2
437 --
438 -- <<docs/gifs/doc_newSprite.gif>>
439 newSprite :: Frame s SVG -> Scene s (Sprite s)
440 newSprite render = do
441 now <- queryNow
442 ref <- liftST $ newSTRef (-1, return $ \_d _t svg -> (svg, 0))
443 addGen $ do
444 fn <- unFrame render
445 (spriteDur, spriteEffectGen) <- readSTRef ref
446 spriteEffect <- spriteEffectGen
447 return $ \d absT ->
448 let relD = (if spriteDur < 0 then d else spriteDur) - now
449 relT = absT - now
450 -- Sprite is live [now;duration[
451 -- If we're at the end of a scene, sprites
452 -- are live: [now;duration]
453 -- This behavior is difficult to get right. See the 'bug_*' examples for
454 -- automated tests.
455 inTimeSlice = relT >= 0 && relT < relD
456 isLastFrame = d==absT && relT == relD
457 in if inTimeSlice || isLastFrame
458 then spriteEffect relD relT (fn absT relD relT)
459 else (None, 0)
460 return $ Sprite now ref
461
462 -- | Create new sprite defined by a frame generator. The sprite will die at
463 -- the end of the scene.
464 newSprite_ :: Frame s SVG -> Scene s ()
465 newSprite_ = void . newSprite
466
467 -- | Create a new sprite from an animation. This advances the clock by the
468 -- duration of the animation. Unless otherwise specified using
469 -- 'destroySprite', the sprite will die at the end of the scene.
470 --
471 -- Note: If the scene doesn't end immediately after the duration of the
472 -- animation, the animation will be stretched to match the lifetime of the
473 -- sprite. See 'newSpriteA'' and 'play'.
474 --
475 -- Example:
476 --
477 -- > do fork $ newSpriteA drawCircle
478 -- > play drawBox
479 -- > play $ reverseA drawBox
480 --
481 -- <<docs/gifs/doc_newSpriteA.gif>>
482 newSpriteA :: Animation -> Scene s (Sprite s)
483 newSpriteA = newSpriteA' SyncStretch
484
485 -- | Create a new sprite from an animation and specify the synchronization policy. This advances
486 -- the clock by the duration of the animation.
487 --
488 -- Example:
489 --
490 -- > do fork $ newSpriteA' SyncFreeze drawCircle
491 -- > play drawBox
492 -- > play $ reverseA drawBox
493 --
494 -- <<docs/gifs/doc_newSpriteA'.gif>>
495 newSpriteA' :: Sync -> Animation -> Scene s (Sprite s)
496 newSpriteA' sync animation =
497 newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration)
498 <* wait (duration animation)
499
500 -- | Create a sprite from a static SVG image.
501 --
502 -- Example:
503 --
504 -- > do newSpriteSVG $ mkBackground "lightblue"
505 -- > play drawCircle
506 --
507 -- <<docs/gifs/doc_newSpriteSVG.gif>>
508 newSpriteSVG :: SVG -> Scene s (Sprite s)
509 newSpriteSVG = newSprite . pure
510
511 -- | Create a permanent sprite from a static SVG image. Same as `newSpriteSVG`
512 -- but the sprite isn't returned and thus cannot be destroyed.
513 newSpriteSVG_ :: SVG -> Scene s ()
514 newSpriteSVG_ = void . newSpriteSVG
515
516 -- | Change the rendering of a sprite using data from a variable. If data from several variables
517 -- is needed, use a frame generator instead.
518 --
519 -- Example:
520 --
521 -- > do s <- fork $ newSpriteA drawBox
522 -- > v <- newVar 0
523 -- > applyVar v s rotate
524 -- > tweenVar v 2 $ \val -> fromToS val 90
525 --
526 -- <<docs/gifs/doc_applyVar.gif>>
527 applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s ()
528 applyVar var sprite fn = spriteModify sprite $ do
529 varFn <- unVar var
530 return $ \(svg, zindex) -> (fn varFn svg, zindex)
531
532 -- | Destroy a sprite, preventing it from being rendered in the future of the scene.
533 -- If 'destroySprite' is invoked multiple times, the earliest time-of-death is used.
534 --
535 -- Example:
536 --
537 -- > do s <- newSpriteSVG $ withFillOpacity 1 $ mkCircle 1
538 -- > fork $ wait 1 >> destroySprite s
539 -- > play drawBox
540 --
541 -- <<docs/gifs/doc_destroySprite.gif>>
542 destroySprite :: Sprite s -> Scene s ()
543 destroySprite (Sprite _ ref) = do
544 now <- queryNow
545 liftST $ modifySTRef ref $ \(ttl, render) ->
546 (if ttl < 0 then now else min ttl now, render)
547
548 -- | Low-level frame modifier.
549 spriteModify :: Sprite s -> Frame s ((SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s ()
550 spriteModify (Sprite born ref) modFn = liftST $ modifySTRef ref $ \(ttl, renderGen) ->
551 ( ttl
552 , do
553 render <- renderGen
554 modRender <- unFrame modFn
555 return $ \relD relT ->
556 let absT = relT + born in modRender absT relD relT . render relD relT
557 )
558
559 -- | Map the SVG output of a sprite.
560 --
561 -- Example:
562 --
563 -- > do s <- fork $ newSpriteA drawCircle
564 -- > wait 1
565 -- > spriteMap s flipYAxis
566 --
567 -- <<docs/gifs/doc_spriteMap.gif>>
568 spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s ()
569 spriteMap sprite@(Sprite born _) fn = do
570 now <- queryNow
571 let tDelta = now - born
572 spriteModify sprite $ do
573 t <- spriteT
574 return $ \(svg, zindex) -> (if (t - tDelta) < 0 then svg else fn svg, zindex)
575
576 -- | Modify the output of a sprite between @now@ and @now+duration@.
577 --
578 -- Example:
579 --
580 -- > do s <- fork $ newSpriteA drawCircle
581 -- > spriteTween s 1 $ \val -> translate (screenWidth*0.3*val) 0
582 --
583 -- <<docs/gifs/doc_spriteTween.gif>>
584 spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()
585 spriteTween sprite@(Sprite born _) dur fn = do
586 now <- queryNow
587 let tDelta = now - born
588 spriteModify sprite $ do
589 t <- spriteT
590 return $ \(svg, zindex) -> (fn (clamp 0 1 $ (t - tDelta) / dur) svg, zindex)
591 wait dur
592 where
593 clamp a b v | v < a = a
594 | v > b = b
595 | otherwise = v
596
597 -- | Create a new variable and apply it to a sprite.
598 --
599 -- Example:
600 --
601 -- > do s <- fork $ newSpriteA drawBox
602 -- > v <- spriteVar s 0 rotate
603 -- > tweenVar v 2 $ \val -> fromToS val 90
604 --
605 -- <<docs/gifs/doc_spriteVar.gif>>
606 spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)
607 spriteVar sprite def fn = do
608 v <- newVar def
609 applyVar v sprite fn
610 return v
611
612 -- | Apply an effect to a sprite.
613 --
614 -- Example:
615 --
616 -- > do s <- fork $ newSpriteA drawCircle
617 -- > spriteE s $ overBeginning 1 fadeInE
618 -- > spriteE s $ overEnding 0.5 fadeOutE
619 --
620 -- <<docs/gifs/doc_spriteE.gif>>
621 spriteE :: Sprite s -> Effect -> Scene s ()
622 spriteE (Sprite born ref) effect = do
623 now <- queryNow
624 liftST $ modifySTRef ref $ \(ttl, renderGen) ->
625 ( ttl
626 , do
627 render <- renderGen
628 return $ \d t svg ->
629 let (svg', z) = render d t svg
630 in (delayE (max 0 $ now - born) effect d t svg', z)
631 )
632
633 -- | Set new ZIndex of a sprite.
634 --
635 -- Example:
636 --
637 -- > do s1 <- newSpriteSVG $ withFillOpacity 1 $ withFillColor "blue" $ mkCircle 3
638 -- > newSpriteSVG $ withFillOpacity 1 $ withFillColor "red" $ mkRect 8 3
639 -- > wait 1
640 -- > spriteZ s1 1
641 -- > wait 1
642 --
643 -- <<docs/gifs/doc_spriteZ.gif>>
644 spriteZ :: Sprite s -> ZIndex -> Scene s ()
645 spriteZ (Sprite born ref) zindex = do
646 now <- queryNow
647 liftST $ modifySTRef ref $ \(ttl, renderGen) ->
648 ( ttl
649 , do
650 render <- renderGen
651 return $ \d t svg ->
652 let (svg', z) = render d t svg in (svg', if t < now - born then z else zindex)
653 )
654
655 -- | Destroy all local sprites at the end of a scene.
656 --
657 -- Example:
658 --
659 -- > do -- the rect lives through the entire 3s animation
660 -- > newSpriteSVG_ $ translate (-3) 0 $ mkRect 4 4
661 -- > wait 1
662 -- > spriteScope $ do
663 -- > -- the circle only lives for 1 second.
664 -- > local <- newSpriteSVG $ translate 3 0 $ mkCircle 2
665 -- > spriteE local $ overBeginning 0.3 fadeInE
666 -- > spriteE local $ overEnding 0.3 fadeOutE
667 -- > wait 1
668 -- > wait 1
669 --
670 -- <<docs/gifs/doc_spriteScope.gif>>
671 spriteScope :: Scene s a -> Scene s a
672 spriteScope (M action) = M $ \t -> do
673 (a, s, p, gens) <- action t
674 return (a, s, p, map (genFn (t+max s p)) gens)
675 where
676 genFn maxT gen = do
677 frameGen <- gen
678 return $ \_ t ->
679 if t < maxT
680 then frameGen maxT t
681 else (None, 0)
682
683 asAnimation :: (forall s'. Scene s' a) -> Scene s Animation
684 asAnimation s = do
685 now <- queryNow
686 return $ dropA now (sceneAnimation (wait now >> s))
687
688 -- | Apply a transformation with a given overlap. This makes sure
689 -- to keep timestamps intact such that events can still be timed
690 -- by transcripts.
691 transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s ()
692 transitionO t o a b = do
693 aA <- asAnimation a
694 bA <- fork $ do
695 wait (duration aA - o)
696 asAnimation b
697 play $ overlapT o t aA bA
698
699
700
701
702 -------------------------------------------------------
703 -- Objects
704
705 -- | Objects can be any Haskell structure as long as it can be rendered to SVG.
706 class Renderable a where
707 toSVG :: a -> SVG
708
709 instance Renderable Tree where
710 toSVG = id
711
712 -- | Objects are SVG nodes (represented as Haskell values) with
713 -- identity, location, and several other properties that can
714 -- change over time.
715 data Object s a = Object
716 { objectSprite :: Sprite s
717 , objectData :: Var s (ObjectData a)
718 }
719
720 -- | Container for object properties.
721 data ObjectData a = ObjectData
722 { _oTranslate :: (Double, Double)
723 , _oValueRef :: a
724 , _oSVG :: SVG
725 , _oContext :: SVG -> SVG
726 , _oMargin :: (Double, Double, Double, Double)
727 -- ^ Top, right, bottom, left
728 , _oBB :: (Double,Double,Double,Double)
729 , _oOpacity :: Double
730 , _oShown :: Bool
731 , _oZIndex :: Int
732 , _oEasing :: Signal
733 , _oScale :: Double
734 , _oScaleOrigin :: (Double, Double)
735 }
736
737 -- Basic lenses
738
739 -- FIXME: Maybe 'position' is a better name.
740 -- | Object position. Default: \<0,0\>
741 oTranslate :: Lens' (ObjectData a) (Double, Double)
742 oTranslate = lens _oTranslate $ \obj val -> obj { _oTranslate = val }
743
744 -- | Rendered SVG node of an object. Does not include context
745 -- or object properties. Read-only.
746 oSVG :: Getter (ObjectData a) SVG
747 oSVG = to _oSVG
748
749 -- | Custom render context. Is applied to the object for every
750 -- frame that it is shown.
751 oContext :: Lens' (ObjectData a) (SVG -> SVG)
752 oContext = lens _oContext $ \obj val -> obj { _oContext = val }
753
754 -- | Object margins (top, right, bottom, left) in local units.
755 oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double)
756 oMargin = lens _oMargin $ \obj val -> obj { _oMargin = val }
757
758 -- | Object bounding-box (minimal X-coordinate, minimal Y-coordinate,
759 -- width, height). Uses `Reanimate.Svg.BoundingBox.boundingBox`
760 -- and has the same limitations.
761 oBB :: Getter (ObjectData a) (Double, Double, Double, Double)
762 oBB = to _oBB
763
764 -- | Object opacity. Default: 1
765 oOpacity :: Lens' (ObjectData a) Double
766 oOpacity = lens _oOpacity $ \obj val -> obj { _oOpacity = val }
767
768 -- | Toggle for whether or not the object should be rendered.
769 -- Default: False
770 oShown :: Lens' (ObjectData a) Bool
771 oShown = lens _oShown $ \obj val -> obj { _oShown = val }
772
773 -- | Object's z-index.
774 oZIndex :: Lens' (ObjectData a) Int
775 oZIndex = lens _oZIndex $ \obj val -> obj { _oZIndex = val }
776
777 -- | Easing function used when modifying object properties.
778 -- Default: @'Reanimate.Ease.curveS' 2@
779 oEasing :: Lens' (ObjectData a) Signal
780 oEasing = lens _oEasing $ \obj val -> obj { _oEasing = val }
781
782 -- | Object's scale. Default: 1
783 oScale :: Lens' (ObjectData a) Double
784 oScale = lens _oScale $ \obj val -> obj { _oScale = val }
785
786 -- | Origin point for scaling. Default: \<0,0\>
787 oScaleOrigin :: Lens' (ObjectData a) (Double, Double)
788 oScaleOrigin = lens _oScaleOrigin $ \obj val -> obj { _oScaleOrigin = val }
789
790 -- Smart lenses
791
792 -- | Lens for the source value contained in an object.
793 oValue :: Renderable a => Lens' (ObjectData a) a
794 oValue = lens _oValueRef $ \obj newVal ->
795 let svg = toSVG newVal
796 in obj
797 { _oValueRef = newVal
798 , _oSVG = svg
799 , _oBB = boundingBox svg }
800
801 -- | Derived location of the top-most point of an object + margin.
802 oTopY :: Lens' (ObjectData a) Double
803 oTopY = lens getter setter
804 where
805 getter obj =
806 let top = obj ^. oMarginTop
807 miny = obj ^. oBBMinY
808 h = obj ^. oBBHeight
809 dy = obj ^. oTranslate . _2
810 in dy+miny+h+top
811 setter obj val =
812 obj & (oTranslate . _2) +~ val-getter obj
813
814 -- | Derived location of the bottom-most point of an object + margin.
815 oBottomY :: Lens' (ObjectData a) Double
816 oBottomY = lens getter setter
817 where
818 getter obj =
819 let bot = obj ^. oMarginBottom
820 miny = obj ^. oBBMinY
821 dy = obj ^. oTranslate . _2
822 in dy+miny-bot
823 setter obj val =
824 obj & (oTranslate . _2) +~ val-getter obj
825
826 -- | Derived location of the left-most point of an object + margin.
827 oLeftX :: Lens' (ObjectData a) Double
828 oLeftX = lens getter setter
829 where
830 getter obj =
831 let left = obj ^. oMarginLeft
832 minx = obj ^. oBBMinX
833 dx = obj ^. oTranslate . _1
834 in dx+minx-left
835 setter obj val =
836 obj & (oTranslate . _1) +~ val-getter obj
837
838 -- | Derived location of the right-most point of an object + margin.
839 oRightX :: Lens' (ObjectData a) Double
840 oRightX = lens getter setter
841 where
842 getter obj =
843 let right = obj ^. oMarginRight
844 minx = obj ^. oBBMinX
845 w = obj ^. oBBWidth
846 dx = obj ^. oTranslate . _1
847 in dx+minx+w+right
848 setter obj val =
849 obj & (oTranslate . _1) +~ val-getter obj
850
851 -- | Derived location of an object's center point.
852 oCenterXY :: Lens' (ObjectData a) (Double, Double)
853 oCenterXY = lens getter setter
854 where
855 getter obj =
856 let minx = obj ^. oBBMinX
857 miny = obj ^. oBBMinY
858 w = obj ^. oBBWidth
859 h = obj ^. oBBHeight
860 (dx,dy) = obj ^. oTranslate
861 in (dx+minx+w/2, dy+miny+h/2)
862 setter obj (dx, dy) =
863 let (x,y) = getter obj in
864 obj & (oTranslate . _1) +~ dx-x
865 & (oTranslate . _2) +~ dy-y
866
867 -- | Object's top margin.
868 oMarginTop :: Lens' (ObjectData a) Double
869 oMarginTop = oMargin . _1
870
871 -- | Object's right margin.
872 oMarginRight :: Lens' (ObjectData a) Double
873 oMarginRight = oMargin . _2
874
875 -- | Object's bottom margin.
876 oMarginBottom :: Lens' (ObjectData a) Double
877 oMarginBottom = oMargin . _3
878
879 -- | Object's left margin.
880 oMarginLeft :: Lens' (ObjectData a) Double
881 oMarginLeft = oMargin . _4
882
883 -- | Object's minimal X-coordinate..
884 oBBMinX :: Getter (ObjectData a) Double
885 oBBMinX = oBB . _1
886
887 -- | Object's minimal Y-coordinate..
888 oBBMinY :: Getter (ObjectData a) Double
889 oBBMinY = oBB . _2
890
891 -- | Object's width without margin.
892 oBBWidth :: Getter (ObjectData a) Double
893 oBBWidth = oBB . _3
894
895 -- | Object's height without margin.
896 oBBHeight :: Getter (ObjectData a) Double
897 oBBHeight = oBB . _4
898
899 -------------------------------------------------------------------------------
900 -- Object modifiers
901
902 -- | Modify object properties.
903 oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s ()
904 oModify o fn = modifyVar (objectData o) fn
905
906 -- | Modify object properties using a stateful API.
907 oModifyS :: Object s a -> (State (ObjectData a) b) -> Scene s ()
908 oModifyS o fn = oModify o (execState fn)
909
910 -- | Query object property.
911 oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b
912 oRead o l = view l <$> readVar (objectData o)
913
914 -- | Modify object properties over a set duration.
915 oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s ()
916 oTween o d fn = do
917 -- Read 'easing' var here instead of taking it from 'v'.
918 -- This allows different easing functions even at the same timestamp.
919 ease <- oRead o oEasing
920 tweenVar (objectData o) d (\v t -> fn (ease t) v)
921
922 -- | Modify object properties over a set duration using a stateful API.
923 oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s ()
924 oTweenS o d fn = oTween o d (\t -> execState (fn t))
925
926 -- | Modify object value over a set duration. This is a convenience function
927 -- for modifying `oValue`.
928 oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s ()
929 oTweenV o d fn = oTween o d (\t -> oValue %~ fn t)
930
931 -- | Modify object value over a set duration using a stateful API. This is a
932 -- convenience function for modifying `oValue`.
933 oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s ()
934 oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t))
935
936 -- | Create new object.
937 oNew :: Renderable a => a -> Scene s (Object s a)
938 oNew = newObject
939
940 -- | Create new object.
941 newObject :: Renderable a => a -> Scene s (Object s a)
942 newObject val = do
943 ref <- newVar ObjectData
944 { _oTranslate = (0,0)
945 , _oValueRef = val
946 , _oSVG = svg
947 , _oContext = id
948 , _oMargin = (0.5,0.5,0.5,0.5)
949 , _oBB = boundingBox svg
950 , _oOpacity = 1
951 , _oShown = False
952 , _oZIndex = 1
953 , _oEasing = curveS 2
954 , _oScale = 1
955 , _oScaleOrigin = (0,0)
956 }
957 sprite <- newSprite $ do
958 ~ObjectData{..} <- unVar ref
959 pure $
960 if _oShown
961 then
962 uncurry translate _oTranslate $
963 uncurry translate (_oScaleOrigin & both %~ negate) $
964 scale _oScale $
965 uncurry translate _oScaleOrigin $
966 withGroupOpacity _oOpacity $
967 _oContext _oSVG
968 else None
969 spriteModify sprite $ do
970 ~ObjectData{_oZIndex=z} <- unVar ref
971 pure $ \(img,_) -> (img,z)
972 return Object
973 { objectSprite = sprite
974 , objectData = ref }
975 where
976 svg = toSVG val
977
978 -------------------------------------------------------------------------------
979 -- Graphical transformations
980
981 -- | Instantly show object.
982 oShow :: Object s a -> Scene s ()
983 oShow o = oModify o $ oShown .~ True
984
985 -- | Instantly hide object.
986 oHide :: Object s a -> Scene s ()
987 oHide o = oModify o $ oShown .~ False
988
989 -- | Fade in object over a set duration.
990 oFadeIn :: Object s a -> Duration -> Scene s ()
991 oFadeIn o d = do
992 oModify o $
993 oShown .~ True
994 oTweenS o d $ \t ->
995 oOpacity *= t
996
997 -- | Fade out object over a set duration.
998 oFadeOut :: Object s a -> Duration -> Scene s ()
999 oFadeOut o d = do
1000 oModify o $
1001 oShown .~ True
1002 oTweenS o d $ \t ->
1003 oOpacity *= 1-t
1004
1005 -- | Scale in object over a set duration.
1006 oGrow :: Object s a -> Duration -> Scene s ()
1007 oGrow o d = do
1008 oModify o $
1009 oShown .~ True
1010 oTweenS o d $ \t ->
1011 oScale *= t
1012
1013 -- | Scale out object over a set duration.
1014 oShrink :: Object s a -> Duration -> Scene s ()
1015 oShrink o d =
1016 oTweenS o d $ \t ->
1017 oScale *= 1-t
1018
1019 -- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'.
1020 -- | Morph source object into target object over a set duration.
1021 oTransform :: Object s a -> Object s b -> Duration -> Scene s ()
1022 oTransform src dst d = do
1023 srcSvg <- oRead src oSVG
1024 srcCtx <- oRead src oContext
1025 srcEase <- oRead src oEasing
1026 srcLoc <- oRead src oTranslate
1027 oModify src $ oShown .~ False
1028
1029 dstSvg <- oRead dst oSVG
1030 dstCtx <- oRead dst oContext
1031 dstLoc <- oRead dst oTranslate
1032
1033 m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg)
1034 oModifyS m $ do
1035 oShown .= True
1036 oEasing .= srcEase
1037 oTranslate .= srcLoc
1038 fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc
1039 oTweenV m d $ \t -> morphDelta .~ t
1040 oModify m $ oShown .~ False
1041 oModify dst $ oShown .~ True
1042 where
1043 moveTo t (dstX, dstY) (srcX, srcY) =
1044 (fromToS srcX dstX t, fromToS srcY dstY t)
1045
1046
1047 -------------------------------------------------------------------------------
1048 -- Built-in objects
1049
1050 -- | Basic object mapping to \<circle\/\> in SVG.
1051 newtype Circle = Circle {_circleRadius :: Double}
1052
1053 -- | Circle radius in local units.
1054 circleRadius :: Lens' Circle Double
1055 circleRadius = iso _circleRadius Circle
1056
1057 instance Renderable Circle where
1058 toSVG (Circle r) = mkCircle r
1059
1060 -- | Basic object mapping to \<rect\/\> in SVG.
1061 data Rectangle = Rectangle { _rectWidth :: Double, _rectHeight :: Double }
1062
1063 -- | Rectangle width in local units.
1064 rectWidth :: Lens' Rectangle Double
1065 rectWidth = lens _rectWidth $ \obj val -> obj{_rectWidth=val}
1066
1067 -- | Rectangle height in local units.
1068 rectHeight :: Lens' Rectangle Double
1069 rectHeight = lens _rectHeight $ \obj val -> obj{_rectHeight=val}
1070
1071 instance Renderable Rectangle where
1072 toSVG (Rectangle w h) = mkRect w h
1073
1074 -- | Object representing an interpolation between SVG nodes.
1075 data Morph = Morph { _morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG }
1076
1077 -- | Control variable for the interpolation. A value of 0 gives the
1078 -- source SVG and 1 gives the target svg.
1079 morphDelta :: Lens' Morph Double
1080 morphDelta = lens _morphDelta $ \obj val -> obj{_morphDelta = val}
1081
1082 -- | Source shape.
1083 morphSrc :: Lens' Morph SVG
1084 morphSrc = lens _morphSrc $ \obj val -> obj{_morphSrc = val}
1085
1086 -- | Target shape.
1087 morphDst :: Lens' Morph SVG
1088 morphDst = lens _morphDst $ \obj val -> obj{_morphDst = val}
1089
1090 instance Renderable Morph where
1091 toSVG (Morph t src dst) = morph linear src dst t
1092
1093 -- | Cameras can take control of objects and manipulate them
1094 -- with convenient pan and zoom operations.
1095 data Camera = Camera
1096 instance Renderable Camera where
1097 toSVG Camera = None
1098
1099 -- | Connect an object to a camera such that
1100 -- camera settings (position, zoom, and rotation) is
1101 -- applied to the object.
1102 --
1103 -- Example
1104 --
1105 -- > do cam <- newObject Camera
1106 -- > circ <- newObject $ Circle 2
1107 -- > oModifyS circ $
1108 -- > oContext .= withFillOpacity 1 . withFillColor "blue"
1109 -- > oShow circ
1110 -- > cameraAttach cam circ
1111 -- > cameraZoom cam 1 2
1112 -- > cameraZoom cam 1 1
1113 --
1114 -- <<docs/gifs/doc_cameraAttach.gif>>
1115 cameraAttach :: Object s Camera -> Object s a -> Scene s ()
1116 cameraAttach cam obj =
1117 spriteModify (objectSprite obj) $ do
1118 camData <- unVar (objectData cam)
1119 return $ \(svg,zindex) ->
1120 let (x,y) = camData^.oTranslate
1121 ctx =
1122 translate (-x) (-y) .
1123 uncurry translate (camData^.oScaleOrigin) .
1124 scale (camData^.oScale) .
1125 uncurry translate (camData^.oScaleOrigin & both %~ negate)
1126 in (ctx svg, zindex)
1127
1128 -- |
1129 --
1130 -- Example
1131 --
1132 -- > do cam <- newObject Camera
1133 -- > circ <- newObject $ Circle 2; oShow circ
1134 -- > oModify circ $ oTranslate .~ (-3,0)
1135 -- > box <- newObject $ Rectangle 4 4; oShow box
1136 -- > oModify box $ oTranslate .~ (3,0)
1137 -- > cameraAttach cam circ
1138 -- > cameraAttach cam box
1139 -- > cameraFocus cam (-3,0)
1140 -- > cameraZoom cam 2 2 -- Zoom in
1141 -- > cameraZoom cam 2 1 -- Zoom out
1142 -- > cameraFocus cam (3,0)
1143 -- > cameraZoom cam 2 2 -- Zoom in
1144 -- > cameraZoom cam 2 1 -- Zoom out
1145 --
1146 -- <<docs/gifs/doc_cameraFocus.gif>>
1147 cameraFocus :: Object s Camera -> (Double, Double) -> Scene s ()
1148 cameraFocus cam (x,y) = do
1149 (ox, oy) <- oRead cam oScaleOrigin
1150 (tx, ty) <- oRead cam oTranslate
1151 s <- oRead cam oScale
1152 let newLocation = (x-((x-ox)*s+ox-tx), y-((y-oy)*s+oy-ty))
1153 oModifyS cam $ do
1154 oTranslate .= newLocation
1155 oScaleOrigin .= (x,y)
1156
1157 -- | Instantaneously set camera zoom level.
1158 cameraSetZoom :: Object s Camera -> Double -> Scene s ()
1159 cameraSetZoom cam s =
1160 oModifyS cam $
1161 oScale .= s
1162
1163 -- | Change camera zoom level over a set duration.
1164 cameraZoom :: Object s Camera -> Duration -> Double -> Scene s ()
1165 cameraZoom cam d s =
1166 oTweenS cam d $ \t ->
1167 oScale %= \v -> fromToS v s t
1168
1169 -- | Instantaneously set camera location.
1170 cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s ()
1171 cameraSetPan cam location =
1172 oModifyS cam $ do
1173 oTranslate .= location
1174
1175 -- | Change camera location over a set duration.
1176 cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s ()
1177 cameraPan cam d (x,y) =
1178 oTweenS cam d $ \t -> do
1179 oTranslate._1 %= \v -> fromToS v x t
1180 oTranslate._2 %= \v -> fromToS v y t