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