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