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