{-# LANGUAGE Rank2Types #-}
module Control.Varying.Tween
(
Easing
, TweenT
, Tween
, runTweenT
, scanTween
, tweenStream
, tween
, tween_
, constant
, withTween
, withTween_
, linear
, easeInCirc
, easeOutCirc
, easeInExpo
, easeOutExpo
, easeInSine
, easeOutSine
, easeInOutSine
, easeInPow
, easeOutPow
, easeInCubic
, easeOutCubic
, easeInQuad
, easeOutQuad
) where
import Control.Varying.Core
import Control.Varying.Event
import Control.Varying.Spline
import Control.Arrow
import Control.Applicative
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.Functor.Identity
easeInQuad :: (Num t, Fractional t, Real f) => Easing t f
easeInQuad c t b = c * realToFrac (t*t) + b
easeOutQuad :: (Num t, Fractional t, Real f) => Easing t f
easeOutQuad c t b = (-c) * realToFrac (t * (t - 2)) + b
easeInCubic :: (Num t, Fractional t, Real f) => Easing t f
easeInCubic c t b = c * realToFrac (t*t*t) + b
easeOutCubic :: (Num t, Fractional t, Real f) => Easing t f
easeOutCubic c t b = let t' = realToFrac t - 1 in c * (t'*t'*t' + 1) + b
easeInPow :: (Num t, Fractional t, Real f) => Int -> Easing t f
easeInPow power c t b = c * (realToFrac t^power) + b
easeOutPow :: (Num t, Fractional t, Real f) => Int -> Easing t f
easeOutPow power c t b =
let t' = realToFrac t - 1
c' = if power `mod` 2 == 1 then c else -c
i = if power `mod` 2 == 1 then 1 else -1
in c' * ((t'^power) + i) + b
easeInSine :: (Floating t, Real f) => Easing t f
easeInSine c t b = let cos' = cos (realToFrac t * (pi / 2))
in -c * cos' + c + b
easeOutSine :: (Floating t, Real f) => Easing t f
easeOutSine c t b = let cos' = cos (realToFrac t * (pi / 2)) in c * cos' + b
easeInOutSine :: (Floating t, Real f) => Easing t f
easeInOutSine c t b = let cos' = cos (pi * realToFrac t)
in (-c / 2) * (cos' - 1) + b
easeInExpo :: (Floating t, Real f) => Easing t f
easeInExpo c t b = let e = 10 * (realToFrac t - 1) in c * (2**e) + b
easeOutExpo :: (Floating t, Real f) => Easing t f
easeOutExpo c t b = let e = -10 * realToFrac t in c * (-(2**e) + 1) + b
easeInCirc :: (Floating t, Real f, Floating f) => Easing t f
easeInCirc c t b = let s = realToFrac $ sqrt (1 - t*t) in -c * (s - 1) + b
easeOutCirc :: (Floating t, Real f) => Easing t f
easeOutCirc c t b = let t' = (realToFrac t - 1)
s = sqrt (1 - t'*t')
in c * s + b
linear :: (Floating t, Real f) => Easing t f
linear c t b = c * (realToFrac t) + b
type TweenT f t m = SplineT f t (StateT f m)
type Tween f t = TweenT f t Identity
runTweenT :: (Monad m, Num f)
=> TweenT f t m x -> f -> f -> m (Either x (t, TweenT f t m x), f)
runTweenT s dt = runStateT (runSplineT s dt)
scanTween :: (Functor m, Applicative m, Monad m, Num f)
=> TweenT f t m a -> t -> [f] -> m [t]
scanTween s t dts = evalStateT (scanSpline s t dts) 0
tweenStream :: (Applicative m, Monad m, Num f)
=> TweenT f t m x -> t -> VarT m f t
tweenStream s0 t0 = VarT $ f s0 t0 0
where f s t l i = do (e, l1) <- runTweenT s i l
case e of
Left _ -> return (t, done t)
Right (b, s1) -> return (b, VarT $ f s1 b l1)
tween :: (Applicative m, Monad m, Real f, Fractional f, Real t, Fractional t)
=> Easing t f -> t -> t -> f -> TweenT f t m t
tween f start end dur = SplineT g
where c = end - start
b = start
g dt = do
leftover <- get
let t = dt + leftover
if t == dur
then do put 0
return $ Right (end, return end)
else if t > dur
then do put $ t - dur - dt
return $ Left end
else do put t
return $ Right (f c (t/dur) b, SplineT g)
tween_ :: (Applicative m, Monad m, Real t, Fractional t, Real f, Fractional f)
=> Easing t f -> t -> t -> f -> TweenT f t m ()
tween_ f a b c = tween f a b c >> return ()
withTween :: (Applicative m, Monad m, Real t, Fractional t, Real a, Fractional a)
=> Easing t a -> t -> t -> a -> (t -> x) -> TweenT a x m t
withTween ease from to dur f = mapOutput (pure f) $ tween ease from to dur
withTween_ :: (Applicative m, Monad m, Real t, Fractional t, Real a, Fractional a)
=> Easing t a -> t -> t -> a -> (t -> x) -> TweenT a x m ()
withTween_ ease from to dur f = withTween ease from to dur f >> return ()
constant :: (Applicative m, Monad m, Num t, Ord t)
=> a -> t -> TweenT t a m a
constant value duration = pure value `untilEvent_` after duration
type Easing t f = t -> f -> t -> t