Add animation effects. (#9)

* latex-wheel and MonadFix for Scene.

* Add Effects module.


Former-commit-id: 824ebe9919e57fcc3af7c8c4d6afa0e9899564f8

examples/latex_wheel.hs

@@ -0,0 +1,89 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo       #-}
+module Main (main) where
+
+import           Codec.Picture.Types
+import           Control.Monad       (forM_)
+import           Data.Fixed          (mod')
+import           Graphics.SvgTree    (Number (..), Tree)
+import           Reanimate.Driver    (reanimate)
+import           Reanimate.Effect
+import           Reanimate.LaTeX     (latex)
+import           Reanimate.Monad
+import           Reanimate.Scene
+import           Reanimate.Signal    (signalLinear)
+import           Reanimate.Svg
+
+main :: IO ()
+main = reanimate $ mkAnimation 0 (emit $ mkBackground "black") `sim`
+  mainScene
+
+mainScene :: Animation
+mainScene = sceneAnimation $ mdo
+    play $ drawCircle
+      # setDuration drawCircleT
+    fork $ play $ drawCircle
+      # freezeAtPercentage 1
+      # setDuration rotDur
+    rotDur <- withSceneDuration $ waitAll $
+      forM_ svgs $ \svg -> do
+        fork $ play $ drawTick
+          # setDuration rotateT
+          # repeatAnimation rotateN
+          # applyE (overBeginning 0.5 drawInE)
+          # applyE (overEnding 0.5 drawOutE)
+        fork $ play $ drawSVG svg
+          # setDuration rotateT
+          # repeatAnimation rotateN
+          # applyE (overBeginning rotateT drawInE)
+          # applyE (delayE rotateT $ overBeginning 1 fillInE)
+          # applyE (overEnding 0.5 fadeOutE)
+        wait (rotateT / fromIntegral (1+length svgs))
+    play $ drawCircle
+      # setDuration drawCircleT
+      # reverseAnimation
+      # applyE (constE $ scaleXY (-1) 1)
+    return ()
+  where
+    drawCircleT = 1
+    rotateT     = 5
+    rotateN     = 3
+
+    svg = center $ latex "\\LaTeX"
+    getNth n = snd (splitGlyphs [n] svg)
+    svgs = [
+        scale 5 $
+        translate 0 (-tickLength*1.1) $
+        withStrokeWidth (Num 0.2) $
+        withStrokeColor "white" $
+        withFillColor "white" $
+        center $ getNth n
+      | n <- [0..4]]
+
+radius = 25
+tickLength = 5
+
+drawCircle :: Animation
+drawCircle = mkAnimation 1 $ do
+  n <- getSignal signalLinear
+  emit $
+    withFillOpacity 0 $
+    withStrokeColor "white" $
+    rotate 90 $
+    partialSvg n circPath
+  where
+    circPath = pathify $ mkCircle (Num radius)
+
+drawTick :: Animation
+drawTick = drawSVG $ mkLine (Num 0, Num 0) (Num 0, Num $ -tickLength)
+
+drawSVG :: Tree -> Animation
+drawSVG t = mkAnimation 1 $ do
+  n <- getSignal signalLinear
+  emit $
+    withStrokeColor "white" $
+    rotate (-n*360) $
+    translate 0 (-radius) $
+    t

reanimate.cabal

@@ -56,6 +56,7 @@ library
                       Reanimate.Memo
                       Reanimate.Scene
                       Reanimate.Povray
+                      Reanimate.Effect
   other-modules:      Reanimate.Cache
                       Reanimate.Driver.Check
                       Reanimate.Driver.CLI

src/Reanimate/Effect.hs

@@ -0,0 +1,55 @@
+module Reanimate.Effect where
+
+import           Graphics.SvgTree    (Tree)
+import           Reanimate.Monad
+import           Reanimate.Svg
+
+askTime :: Frame Time
+askTime = Frame $ \_dur t -> return t
+
+type Effect = Double -> Double -> Tree -> Tree
+
+overBeginning :: Double -> Effect -> Effect
+overBeginning maxT fn = \_d t ->
+  if t < maxT
+    then fn maxT t
+    else id
+
+overEnding :: Double -> Effect -> Effect
+overEnding minT fn d t =
+  if t >= blankDur
+    then fn minT (t-blankDur)
+    else id
+  where
+    blankDur = d-minT
+
+reverseE :: Effect -> Effect
+reverseE fn = \d t -> fn d (d-t)
+
+delayE :: Double -> Effect -> Effect
+delayE delayT fn = \d t -> overEnding (d-delayT) fn d t
+
+applyE :: Effect -> Animation -> Animation
+applyE fn (Animation d genFrame) = Animation d $ do
+  t <- askTime
+  mapF (fn d t) genFrame
+
+constE :: (Tree -> Tree) -> Effect
+constE fn _d _t = fn
+
+fadeInE :: Effect
+fadeInE d t = withGroupOpacity (t/d)
+
+fadeOutE :: Effect
+fadeOutE = reverseE fadeInE
+
+drawInE :: Effect
+drawInE d t = withFillOpacity 0 . partialSvg (t/d) . pathify
+
+drawOutE :: Effect
+drawOutE = reverseE drawInE
+
+fillInE :: Effect
+fillInE d t = withFillOpacity f
+  where
+    f = t/d

src/Reanimate/Monad.hs

@@ -149,3 +149,7 @@ oscillate f = Frame $ \d t -> do
 repeatAnimation :: Double -> Animation -> Animation
 repeatAnimation n (Animation d f) = Animation (d*n) $ Frame $ \_ t ->
   unFrame f d (t `mod'` d)
+
+freezeAtPercentage :: Double -> Animation -> Animation
+freezeAtPercentage frac (Animation d genFrame) =
+  Animation d $ Frame $ \_ _ -> unFrame genFrame d (d*frac)

src/Reanimate/Scene.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE RankNTypes #-}
 module Reanimate.Scene where
 
+import           Control.Monad.Fix
 import           Control.Monad.ST
 import           Data.List
 import           Data.Ord
@@ -10,6 +11,9 @@ import           Reanimate.Monad
 data World
 type ZIndex = Int
 
+(#) :: a -> (a -> b) -> b
+o # f = f o
+
 -- (seq duration, par duration)
 -- [(Time, Animation, ZIndex)]
 -- Map Time [(Animation, ZIndex)]
@@ -41,6 +45,9 @@ instance Monad (Scene s) where
     (b, s2, p2, tl2) <- unM (g a) (t+s1)
     return (b, s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2)
 
+instance MonadFix (Scene s) where
+  mfix fn = M $ \t -> mfix (\v -> let (a,_s,_p,_tl) = v in unM (fn a) t)
+
 --data Frame a = Frame {unFrame :: Duration -> Time -> State ([Tree] -> [Tree]) a}
 sceneAnimation :: (forall s. Scene s a) -> Animation
 sceneAnimation action = Animation (max s p) $ Frame $ \_ t ->

videos/color-theory/color-theory.hs

@@ -39,8 +39,6 @@ dropA :: Double -> Animation -> Animation
 dropA d1 (Animation d2 f) = Animation (max 0 (d2-d1)) $
   Frame $ \d t -> unFrame f d (t+d1)
 
-o # f = f o
-
 -- screen width 320
 -- screen height 180
 main :: IO ()