module FRP.Helm.Transition (
Transition,
TransitionStatus(..),
Interpolate(..),
waypoint,
startWith,
fromList,
transition,
length
) where
import Control.Applicative
import FRP.Elerea.Simple
import FRP.Helm.Color (Color)
import FRP.Helm.Time (Time, inSeconds)
import Data.List (find)
import Prelude hiding (length)
import Data.Maybe (fromJust)
import GHC.Float
import Data.Word
import Data.Int
import GHC.Generics
import Control.Monad.Writer.Lazy
import Control.Monad.State.Lazy
type Transition a = StateT a (Writer [(a, Time)])
data InternalFrame a =
InternalFrame {
s :: a,
e :: a,
t :: Double,
tend :: Double,
tstart :: Double
} deriving Show
type InternalTransition a = [InternalFrame a]
data TransitionStatus
= Cycle
| Pause
| Once
| Set Time
waypoint :: Interpolate a => a -> Time -> Transition a a
waypoint a t = do
tell [(a, t)]
put a
return a
transFrame :: Interpolate a => InternalFrame a -> Time -> a
transFrame InternalFrame{..} time = interpolate progress s e
where
progress = time / (tend tstart)
transitionAt :: Interpolate a => InternalTransition a -> Time -> a
transitionAt pks timeUnsafe = transFrame currentTransition currentTime
where
currentTime = time tstart currentTransition
currentTransition = fromJust $ find (\InternalFrame { .. } -> tend >= time) pks
time = cycleTime pks timeUnsafe
transition :: Interpolate a => SignalGen (Signal Time) -> SignalGen (Signal TransitionStatus) -> InternalTransition a -> SignalGen (Signal a)
transition _ _ [] = error "empty transitions don't have any default value"
transition dtGen statusGen trans = do
dt <- dtGen
status <- statusGen
time <- transfer2 0 step' status $ inSeconds <$> dt
return $ transitionAt trans <$> time
where
step' Cycle dt t = cycleTime trans (dt + t)
step' Pause _ t = t
step' Once dt t = if newT < length trans then newT
else length trans
where newT = dt + t
step' (Set t) _ _ = inSeconds t
fromList :: Interpolate a => [(a,Time)] -> InternalTransition a
fromList [] = error "empty transitions don't have any default value"
fromList ((v1, d1) : xs) = scanl (\InternalFrame { .. } (v, d) -> InternalFrame e v d (tend + d) tend) first xs
where
first = InternalFrame v1 v1 d1 d1 0
startWith :: Interpolate a => a -> Transition a b -> InternalTransition a
startWith beginning transitionMonad = fromList $ snd $ runWriter $ evalStateT (tell [(beginning, 0)] >> transitionMonad) beginning
cycleTime :: InternalTransition a -> Time -> Time
cycleTime [] = const 0
cycleTime anim = cycleTime' (length anim)
cycleTime' :: Time -> Time -> Time
cycleTime' l t
| t > l = cycleTime' l (tl)
| t < 0 = cycleTime' l (l+t)
| otherwise = t
length :: InternalTransition a -> Double
length = tend . last
class Interpolate a where
interpolate :: Double -> a -> a -> a
default interpolate :: (Generic a, GInterpolate (Rep a)) => Double -> a -> a -> a
interpolate d a b = to $ ginterpolate d (from a) (from b)
class GInterpolate a where
ginterpolate :: Double -> a b -> a b -> a b
instance GInterpolate V1 where
ginterpolate _ _ b = b
instance GInterpolate U1 where
ginterpolate _ _ b = b
instance (GInterpolate a, GInterpolate b) => GInterpolate (a :*: b) where
ginterpolate d (a1 :*: b1) (a2 :*: b2) = ginterpolate d a1 a2 :*: ginterpolate d b1 b2
instance (GInterpolate a, GInterpolate b) => GInterpolate (a :+: b) where
ginterpolate d (L1 a) (L1 b) = L1 $ ginterpolate d a b
ginterpolate d (R1 a) (R1 b) = R1 $ ginterpolate d a b
ginterpolate _ (L1 _) (R1 b) = R1 b
ginterpolate _ (R1 _) (L1 b) = L1 b
instance (GInterpolate a) => GInterpolate (M1 i c a) where
ginterpolate d (M1 a) (M1 b) = M1 $ ginterpolate d a b
instance (Interpolate a) => GInterpolate (K1 i a) where
ginterpolate d (K1 a) (K1 b) = K1 $ interpolate d a b
instance Interpolate Double where
interpolate p a b = b * p + a * (1p)
instance Interpolate Float where
interpolate p a b = b * double2Float p + a * double2Float (1 p)
instance Interpolate Char where
interpolate _ _ b = b
integralInterpolate :: Integral a => Double -> a -> a -> a
integralInterpolate d a b = ceiling $ interpolate d (fromIntegral a :: Double) (fromIntegral b :: Double)
instance Interpolate Word where
interpolate = integralInterpolate
instance Interpolate Word8 where
interpolate = integralInterpolate
instance Interpolate Word16 where
interpolate = integralInterpolate
instance Interpolate Word32 where
interpolate = integralInterpolate
instance Interpolate Word64 where
interpolate = integralInterpolate
instance Interpolate Int where
interpolate = integralInterpolate
instance Interpolate Int8 where
interpolate = integralInterpolate
instance Interpolate Int16 where
interpolate = integralInterpolate
instance Interpolate Int32 where
interpolate = integralInterpolate
instance Interpolate Int64 where
interpolate = integralInterpolate
instance Interpolate Integer where
interpolate = integralInterpolate
instance Interpolate Bool
instance Interpolate (Double, Double)
instance Interpolate Color