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 transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s ()
689 transitionO t o a b = do
690 aA <- asAnimation a
691 bA <- fork $ do
692 wait (duration aA - o)
693 asAnimation b
694 play $ overlapT o t aA bA
695
696
697
698
699 -------------------------------------------------------
700 -- Objects
701
702 class Renderable a where
703 toSVG :: a -> SVG
704
705 instance Renderable Tree where
706 toSVG = id
707
708 -- | Objects are SVG nodes (represented as Haskell values) with
709 -- identity, location, and several other properties that can
710 -- change over time.
711 data Object s a = Object
712 { objectSprite :: Sprite s
713 , objectData :: Var s (ObjectData a)
714 }
715
716 -- | Container for object properties.
717 data ObjectData a = ObjectData
718 { _oTranslate :: (Double, Double)
719 , _oValueRef :: a
720 , _oSVG :: SVG
721 , _oContext :: SVG -> SVG
722 , _oMargin :: (Double, Double, Double, Double)
723 -- ^ Top, right, bottom, left
724 , _oBB :: (Double,Double,Double,Double)
725 , _oOpacity :: Double
726 , _oShown :: Bool
727 , _oZIndex :: Int
728 , _oEasing :: Signal
729 , _oScale :: Double
730 , _oScaleOrigin :: (Double, Double)
731 }
732
733 -- Basic lenses
734
735 -- FIXME: Maybe 'position' is a better name.
736 -- | Object position. Default: \<0,0\>
737 oTranslate :: Lens' (ObjectData a) (Double, Double)
738 oTranslate = lens _oTranslate $ \obj val -> obj { _oTranslate = val }
739
740 -- | Rendered SVG node of an object. Does not include context
741 -- or object properties. Read-only.
742 oSVG :: Getter (ObjectData a) SVG
743 oSVG = to _oSVG
744
745 -- | Custom render context. Is applied to the object for every
746 -- frame that it is shown.
747 oContext :: Lens' (ObjectData a) (SVG -> SVG)
748 oContext = lens _oContext $ \obj val -> obj { _oContext = val }
749
750 -- | Object margins (top, right, bottom, left) in local units.
751 oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double)
752 oMargin = lens _oMargin $ \obj val -> obj { _oMargin = val }
753
754 -- | Object bounding-box (minimal X-coordinate, minimal Y-coordinate,
755 -- width, height). Uses `Reanimate.Svg.BoundingBox.boundingBox`
756 -- and has the same limitations.
757 oBB :: Getter (ObjectData a) (Double, Double, Double, Double)
758 oBB = to _oBB
759
760 -- | Object opacity. Default: 1
761 oOpacity :: Lens' (ObjectData a) Double
762 oOpacity = lens _oOpacity $ \obj val -> obj { _oOpacity = val }
763
764 -- | Toggle for whether or not the object should be rendered.
765 -- Default: False
766 oShown :: Lens' (ObjectData a) Bool
767 oShown = lens _oShown $ \obj val -> obj { _oShown = val }
768
769 -- | Object's z-index.
770 oZIndex :: Lens' (ObjectData a) Int
771 oZIndex = lens _oZIndex $ \obj val -> obj { _oZIndex = val }
772
773 -- | Easing function used when modifying object properties.
774 -- Default: @'Reanimate.Ease.curveS' 2@
775 oEasing :: Lens' (ObjectData a) Signal
776 oEasing = lens _oEasing $ \obj val -> obj { _oEasing = val }
777
778 -- | Object's scale. Default: 1
779 oScale :: Lens' (ObjectData a) Double
780 oScale = lens _oScale $ \obj val -> obj { _oScale = val }
781
782 -- | Origin point for scaling. Default: \<0,0\>
783 oScaleOrigin :: Lens' (ObjectData a) (Double, Double)
784 oScaleOrigin = lens _oScaleOrigin $ \obj val -> obj { _oScaleOrigin = val }
785
786 -- Smart lenses
787
788 -- | Lens for the source value contained in an object.
789 oValue :: Renderable a => Lens' (ObjectData a) a
790 oValue = lens _oValueRef $ \obj newVal ->
791 let svg = toSVG newVal
792 in obj
793 { _oValueRef = newVal
794 , _oSVG = svg
795 , _oBB = boundingBox svg }
796
797 -- | Derived location of the top-most point of an object + margin.
798 oTopY :: Lens' (ObjectData a) Double
799 oTopY = lens getter setter
800 where
801 getter obj =
802 let top = obj ^. oMarginTop
803 miny = obj ^. oBBMinY
804 h = obj ^. oBBHeight
805 dy = obj ^. oTranslate . _2
806 in dy+miny+h+top
807 setter obj val =
808 obj & (oTranslate . _2) +~ val-getter obj
809
810 -- | Derived location of the bottom-most point of an object + margin.
811 oBottomY :: Lens' (ObjectData a) Double
812 oBottomY = lens getter setter
813 where
814 getter obj =
815 let bot = obj ^. oMarginBottom
816 miny = obj ^. oBBMinY
817 dy = obj ^. oTranslate . _2
818 in dy+miny-bot
819 setter obj val =
820 obj & (oTranslate . _2) +~ val-getter obj
821
822 -- | Derived location of the left-most point of an object + margin.
823 oLeftX :: Lens' (ObjectData a) Double
824 oLeftX = lens getter setter
825 where
826 getter obj =
827 let left = obj ^. oMarginLeft
828 minx = obj ^. oBBMinX
829 dx = obj ^. oTranslate . _1
830 in dx+minx-left
831 setter obj val =
832 obj & (oTranslate . _1) +~ val-getter obj
833
834 -- | Derived location of the right-most point of an object + margin.
835 oRightX :: Lens' (ObjectData a) Double
836 oRightX = lens getter setter
837 where
838 getter obj =
839 let right = obj ^. oMarginRight
840 minx = obj ^. oBBMinX
841 w = obj ^. oBBWidth
842 dx = obj ^. oTranslate . _1
843 in dx+minx+w+right
844 setter obj val =
845 obj & (oTranslate . _1) +~ val-getter obj
846
847 -- | Derived location of an object's center point.
848 oCenterXY :: Lens' (ObjectData a) (Double, Double)
849 oCenterXY = lens getter setter
850 where
851 getter obj =
852 let minx = obj ^. oBBMinX
853 miny = obj ^. oBBMinY
854 w = obj ^. oBBWidth
855 h = obj ^. oBBHeight
856 (dx,dy) = obj ^. oTranslate
857 in (dx+minx+w/2, dy+miny+h/2)
858 setter obj (dx, dy) =
859 let (x,y) = getter obj in
860 obj & (oTranslate . _1) +~ dx-x
861 & (oTranslate . _2) +~ dy-y
862
863 -- | Object's top margin.
864 oMarginTop :: Lens' (ObjectData a) Double
865 oMarginTop = oMargin . _1
866
867 -- | Object's right margin.
868 oMarginRight :: Lens' (ObjectData a) Double
869 oMarginRight = oMargin . _2
870
871 -- | Object's bottom margin.
872 oMarginBottom :: Lens' (ObjectData a) Double
873 oMarginBottom = oMargin . _3
874
875 -- | Object's left margin.
876 oMarginLeft :: Lens' (ObjectData a) Double
877 oMarginLeft = oMargin . _4
878
879 -- | Object's minimal X-coordinate..
880 oBBMinX :: Getter (ObjectData a) Double
881 oBBMinX = oBB . _1
882
883 -- | Object's minimal Y-coordinate..
884 oBBMinY :: Getter (ObjectData a) Double
885 oBBMinY = oBB . _2
886
887 -- | Object's width without margin.
888 oBBWidth :: Getter (ObjectData a) Double
889 oBBWidth = oBB . _3
890
891 -- | Object's height without margin.
892 oBBHeight :: Getter (ObjectData a) Double
893 oBBHeight = oBB . _4
894
895 -------------------------------------------------------------------------------
896 -- Object modifiers
897
898 -- | Modify object properties.
899 oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s ()
900 oModify o fn = modifyVar (objectData o) fn
901
902 -- | Modify object properties using a stateful API.
903 oModifyS :: Object s a -> (State (ObjectData a) b) -> Scene s ()
904 oModifyS o fn = oModify o (execState fn)
905
906 -- | Query object property.
907 oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b
908 oRead o l = view l <$> readVar (objectData o)
909
910 -- | Modify object properties over a set duration.
911 oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s ()
912 oTween o d fn = do
913 -- Read 'easing' var here instead of taking it from 'v'.
914 -- This allows different easing functions even at the same timestamp.
915 ease <- oRead o oEasing
916 tweenVar (objectData o) d (\v t -> fn (ease t) v)
917
918 -- | Modify object properties over a set duration using a stateful API.
919 oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s ()
920 oTweenS o d fn = oTween o d (\t -> execState (fn t))
921
922 -- | Modify object value over a set duration. This is a convenience function
923 -- for modifying `oValue`.
924 oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s ()
925 oTweenV o d fn = oTween o d (\t -> oValue %~ fn t)
926
927 -- | Modify object value over a set duration using a stateful API. This is a
928 -- convenience function for modifying `oValue`.
929 oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s ()
930 oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t))
931
932 -- | Create new object.
933 oNew :: Renderable a => a -> Scene s (Object s a)
934 oNew = newObject
935
936 -- | Create new object.
937 newObject :: Renderable a => a -> Scene s (Object s a)
938 newObject val = do
939 ref <- newVar ObjectData
940 { _oTranslate = (0,0)
941 , _oValueRef = val
942 , _oSVG = svg
943 , _oContext = id
944 , _oMargin = (0.5,0.5,0.5,0.5)
945 , _oBB = boundingBox svg
946 , _oOpacity = 1
947 , _oShown = False
948 , _oZIndex = 1
949 , _oEasing = curveS 2
950 , _oScale = 1
951 , _oScaleOrigin = (0,0)
952 }
953 sprite <- newSprite $ do
954 ~ObjectData{..} <- unVar ref
955 pure $
956 if _oShown
957 then
958 uncurry translate _oTranslate $
959 uncurry translate (_oScaleOrigin & both %~ negate) $
960 scale _oScale $
961 uncurry translate _oScaleOrigin $
962 withGroupOpacity _oOpacity $
963 _oContext _oSVG
964 else None
965 spriteModify sprite $ do
966 ~ObjectData{_oZIndex=z} <- unVar ref
967 pure $ \(img,_) -> (img,z)
968 return Object
969 { objectSprite = sprite
970 , objectData = ref }
971 where
972 svg = toSVG val
973
974 -------------------------------------------------------------------------------
975 -- Graphical transformations
976
977 -- | Instantly show object.
978 oShow :: Object s a -> Scene s ()
979 oShow o = oModify o $ oShown .~ True
980
981 -- | Instantly hide object.
982 oHide :: Object s a -> Scene s ()
983 oHide o = oModify o $ oShown .~ False
984
985 -- | Fade in object over a set duration.
986 oFadeIn :: Object s a -> Duration -> Scene s ()
987 oFadeIn o d = do
988 oModify o $
989 oShown .~ True
990 oTweenS o d $ \t ->
991 oOpacity *= t
992
993 -- | Fade out object over a set duration.
994 oFadeOut :: Object s a -> Duration -> Scene s ()
995 oFadeOut o d = do
996 oModify o $
997 oShown .~ True
998 oTweenS o d $ \t ->
999 oOpacity *= 1-t
1000
1001 -- | Scale in object over a set duration.
1002 oGrow :: Object s a -> Duration -> Scene s ()
1003 oGrow o d = do
1004 oModify o $
1005 oShown .~ True
1006 oTweenS o d $ \t ->
1007 oScale *= t
1008
1009 -- | Scale out object over a set duration.
1010 oShrink :: Object s a -> Duration -> Scene s ()
1011 oShrink o d =
1012 oTweenS o d $ \t ->
1013 oScale *= 1-t
1014
1015 -- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'.
1016 -- | Morph source object into target object over a set duration.
1017 oTransform :: Object s a -> Object s b -> Duration -> Scene s ()
1018 oTransform src dst d = do
1019 srcSvg <- oRead src oSVG
1020 srcCtx <- oRead src oContext
1021 srcEase <- oRead src oEasing
1022 srcLoc <- oRead src oTranslate
1023 oModify src $ oShown .~ False
1024
1025 dstSvg <- oRead dst oSVG
1026 dstCtx <- oRead dst oContext
1027 dstLoc <- oRead dst oTranslate
1028
1029 m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg)
1030 oModifyS m $ do
1031 oShown .= True
1032 oEasing .= srcEase
1033 oTranslate .= srcLoc
1034 fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc
1035 oTweenV m d $ \t -> morphDelta .~ t
1036 oModify m $ oShown .~ False
1037 oModify dst $ oShown .~ True
1038 where
1039 moveTo t (dstX, dstY) (srcX, srcY) =
1040 (fromToS srcX dstX t, fromToS srcY dstY t)
1041
1042
1043 -------------------------------------------------------------------------------
1044 -- Built-in objects
1045
1046 newtype Circle = Circle {_circleRadius :: Double}
1047
1048 circleRadius :: Iso' Circle Double
1049 circleRadius = iso _circleRadius Circle
1050
1051 instance Renderable Circle where
1052 toSVG (Circle r) = mkCircle r
1053
1054 data Rectangle = Rectangle { _rectWidth :: Double, _rectHeight :: Double }
1055
1056 rectWidth :: Lens' Rectangle Double
1057 rectWidth = lens _rectWidth $ \obj val -> obj{_rectWidth=val}
1058
1059 rectHeight :: Lens' Rectangle Double
1060 rectHeight = lens _rectHeight $ \obj val -> obj{_rectHeight=val}
1061
1062 instance Renderable Rectangle where
1063 toSVG (Rectangle w h) = mkRect w h
1064
1065 data Morph = Morph { _morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG }
1066
1067 morphDelta :: Lens' Morph Double
1068 morphDelta = lens _morphDelta $ \obj val -> obj{_morphDelta = val}
1069
1070 morphSrc :: Lens' Morph SVG
1071 morphSrc = lens _morphSrc $ \obj val -> obj{_morphSrc = val}
1072
1073 morphDst :: Lens' Morph SVG
1074 morphDst = lens _morphDst $ \obj val -> obj{_morphDst = val}
1075
1076 instance Renderable Morph where
1077 toSVG (Morph t src dst) = morph linear src dst t
1078
1079 data Camera = Camera
1080 instance Renderable Camera where
1081 toSVG Camera = None
1082
1083 -- | Connect an object to a camera such that
1084 -- camera settings (position, zoom, and rotation) is
1085 -- applied to the object.
1086 --
1087 -- Example
1088 --
1089 -- > do cam <- newObject Camera
1090 -- > circ <- newObject $ Circle 2
1091 -- > oModifyS circ $
1092 -- > oContext .= withFillOpacity 1 . withFillColor "blue"
1093 -- > oShow circ
1094 -- > cameraAttach cam circ
1095 -- > cameraZoom cam 1 2
1096 -- > cameraZoom cam 1 1
1097 --
1098 -- <<docs/gifs/doc_cameraAttach.gif>>
1099 cameraAttach :: Object s Camera -> Object s a -> Scene s ()
1100 cameraAttach cam obj =
1101 spriteModify (objectSprite obj) $ do
1102 camData <- unVar (objectData cam)
1103 return $ \(svg,zindex) ->
1104 let (x,y) = camData^.oTranslate
1105 ctx =
1106 translate (-x) (-y) .
1107 uncurry translate (camData^.oScaleOrigin) .
1108 scale (camData^.oScale) .
1109 uncurry translate (camData^.oScaleOrigin & both %~ negate)
1110 in (ctx svg, zindex)
1111
1112 -- |
1113 --
1114 -- Example
1115 --
1116 -- > do cam <- newObject Camera
1117 -- > circ <- newObject $ Circle 2; oShow circ
1118 -- > oModify circ $ oTranslate .~ (-3,0)
1119 -- > box <- newObject $ Rectangle 4 4; oShow box
1120 -- > oModify box $ oTranslate .~ (3,0)
1121 -- > cameraAttach cam circ
1122 -- > cameraAttach cam box
1123 -- > cameraFocus cam (-3,0)
1124 -- > cameraZoom cam 2 2 -- Zoom in
1125 -- > cameraZoom cam 2 1 -- Zoom out
1126 -- > cameraFocus cam (3,0)
1127 -- > cameraZoom cam 2 2 -- Zoom in
1128 -- > cameraZoom cam 2 1 -- Zoom out
1129 --
1130 -- <<docs/gifs/doc_cameraFocus.gif>>
1131 cameraFocus :: Object s Camera -> (Double, Double) -> Scene s ()
1132 cameraFocus cam (x,y) = do
1133 (ox, oy) <- oRead cam oScaleOrigin
1134 (tx, ty) <- oRead cam oTranslate
1135 s <- oRead cam oScale
1136 let newLocation = (x-((x-ox)*s+ox-tx), y-((y-oy)*s+oy-ty))
1137 oModifyS cam $ do
1138 oTranslate .= newLocation
1139 oScaleOrigin .= (x,y)
1140
1141 -- | Instantaneously set camera zoom level.
1142 cameraSetZoom :: Object s Camera -> Double -> Scene s ()
1143 cameraSetZoom cam s =
1144 oModifyS cam $
1145 oScale .= s
1146
1147 -- | Change camera zoom level over a set duration.
1148 cameraZoom :: Object s Camera -> Duration -> Double -> Scene s ()
1149 cameraZoom cam d s =
1150 oTweenS cam d $ \t ->
1151 oScale %= \v -> fromToS v s t
1152
1153 -- | Instantaneously set camera location.
1154 cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s ()
1155 cameraSetPan cam location =
1156 oModifyS cam $ do
1157 oTranslate .= location
1158
1159 -- | Change camera location over a set duration.
1160 cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s ()
1161 cameraPan cam d (x,y) =
1162 oTweenS cam d $ \t -> do
1163 oTranslate._1 %= \v -> fromToS v x t
1164 oTranslate._2 %= \v -> fromToS v y t