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