{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Reflex.Animation
( Animation (..)
, stretched
, delayed
, Clip (..)
, sampleClip
, toMaybe
, stretchTo
, section
, clamped
, repeat
, replicate
, cropEnd
, cropStart
, crop
, linear
, linearIn
, linearOut
, piecewise
, keyframes
)
where
import Control.Applicative
import Data.Bifunctor
import Data.Profunctor
import Data.Semigroup
import Data.VectorSpace
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Prelude hiding (repeat, replicate)
-- | Infinite animations 'time -> a'
newtype Animation time a = Animation { sampleAt :: time -> a }
deriving (Functor, Applicative, Monad, Profunctor)
stretched :: (Num time) => time -> Animation time a -> Animation time a
stretched factor = lmap (* factor)
delayed :: (Num time) => time -> Animation time a -> Animation time a
delayed t = lmap (subtract t)
-- | Infinite animations, Animation with a period
data Clip time a = Clip { clipAnim :: Animation time a, period :: time }
instance Functor (Clip time) where
fmap f (Clip anim p) = Clip (f <$> anim) p
instance (Num time, Ord time) => Semigroup (Clip time a) where
clip <> clip' = piecewise [clip, clip']
sconcat (clip :| clips) = piecewise (clip : clips)
-- | Constructor for clips to simplify creation
clip :: (time -> a) -> time -> Clip time a
clip anim p = Clip (Animation anim) p
apply :: Clip time (a -> b) -> Animation time a -> Clip time b
apply (Clip anim p) a = Clip (anim <*> a) p
-- | Take a section of an infinite animation as a Clip
section :: (Ord time, Num time) => (time, time) -> Animation time a -> Clip time a
section (s, e) a = Clip (lmap (+s) a) (s - e)
-- | Sample from a clip, returning Nothing outside the domain
sampleClip :: (Ord time, Num time) => Clip time a -> time -> Maybe a
sampleClip clip t | t >= 0 && t <= period clip = Just $ sampleAt (clipAnim clip) t
| otherwise = Nothing
-- | Turn a clip into an infinite Animation by using Maybe
toMaybe :: (Ord time, Num time) => Clip time a -> Animation time (Maybe a)
toMaybe clip = Animation (sampleClip clip)
-- | Make an infinite animation by clamping time to lie within the period
clamped :: (Ord time, Num time) => Clip time a -> Animation time a
clamped (Clip anim p) = lmap (clamp (0, p)) anim
-- | Make an infinite animation by repeating the clip
repeat :: (RealFrac time) => Clip time a -> Animation time a
repeat (Clip anim p) = lmap (`fmod` p) anim
-- | Repeat a clip a fixed number of times to make a new one
replicate :: (RealFrac time) => Int -> Clip time a -> Clip time a
replicate n (Clip anim p) = Clip (lmap time anim) (fromIntegral n * p) where
time t | t < 0 = 0.0
| t >= fromIntegral n * p = p
| otherwise = t `fmod` p
-- | Stretch a clip to a specific size by scaling time
stretchTo :: (RealFrac time) => time -> Clip time a -> Clip time a
stretchTo p clip = Clip (lmap (* factor) (clipAnim clip)) p
where factor = period clip / p
-- | Shorten a clip to a certain period by cropping the end
cropEnd :: (Ord time, Num time) => time -> Clip time a -> Clip time a
cropEnd p' (Clip anim p) = Clip anim (clamp (0, p) p')
-- | Shorten a clip by cropping the start
cropStart :: (Ord time, Num time) => time -> Clip time a -> Clip time a
cropStart s (Clip anim p) = Clip (lmap (+ s') anim) (p - s')
where s' = clamp (0, p) s
-- | Crop the clip to a range
crop :: (Ord time, Num time) => (time, time) -> Clip time a -> Clip time a
crop (s, e) = cropStart s . cropEnd e
-- | Crop the clip to half the period
half :: (RealFrac time) => Clip time a -> Clip time a
half clip = cropStart (0.5 * period clip) clip
type Interpolater time a = time -> (a, a) -> Clip time a
linear :: (VectorSpace v, RealFrac (Scalar v)) => Interpolater (Scalar v) v
linear p (s, e) = clip (\t -> lerp s e (t / p)) p
intervalsWith :: (RealFrac time) => Interpolater time a -> a -> [(time, a)] -> [Clip time a]
intervalsWith interp start [] = [clip (const start) 0]
intervalsWith interp start frames = zipWith toInterval ((0, start) : frames) frames
where toInterval (_, k) (p, k') = interp p (k, k')
keyframesWith :: (RealFrac time) => Interpolater time a -> a -> [(time, a)] -> Clip time a
keyframesWith interp start frames = piecewise $ intervalsWith interp start frames
keyframes :: (VectorSpace v, RealFrac (Scalar v)) => v -> [(Scalar v, v)] -> Clip (Scalar v) v
keyframes = keyframesWith linear
sampleInterval :: (Ord time, Num time) => Animation time a -> Map time (Animation time a) -> time -> a
sampleInterval start m t = sampleAt anim0 (t - t0) where
(t0, anim0) = fromMaybe (0, start) (Map.lookupLT t m)
piecewise :: (Ord time, Num time) => [Clip time a] -> Clip time a
piecewise [] = error "piecewise: empty list"
piecewise [a] = a
piecewise clips = clip (sampleInterval start m) (last times) where
m = Map.fromList (zip times (clipAnim <$> clips))
times = scanl (+) 0 (period <$> clips)
start = clipAnim $ head clips
-- | Predefined clips based on special functions for building up animations
linearIn :: (RealFrac time) => time -> Clip time time
linearIn p = clip (\t -> t / p) p
linearOut :: (RealFrac time) => time -> Clip time time
linearOut p = clip (\t -> 1.0 - t / p) p
sine :: (RealFrac time, Floating time) => time -> Clip time time
sine p = stretchTo p (clip sin pi)
cosine :: (RealFrac time, Floating time) => time -> Clip time time
cosine p = stretchTo p (clip cos pi)
-- | Utility functions
fmod :: RealFrac a => a -> a -> a
fmod x d | x > 0 || frac == 0 = frac * d
| otherwise = (frac + 1) * d
where frac = snd $ properFraction (x / d)
fDivMod :: RealFrac a => a -> a -> (a, a)
fDivMod x d | x > 0 || frac == 0 = (fromIntegral n, frac * d)
| otherwise = (fromIntegral n, (frac + 1) * d)
where (n, frac) = properFraction (x / d)
clamp :: Ord a => (a, a) -> a -> a
clamp (lower, upper) a = max lower (min upper a)