module Control.FRPNow.Time(localTime,timeFrac, lastInputs, bufferBehavior,delayBy, delayByN) where
import Control.FRPNow.Core
import Control.FRPNow.Lib
import Control.FRPNow.EvStream
import Data.Sequence
import Control.Applicative hiding (empty)
import Data.Foldable
import Debug.Trace
localTime :: (Floating time, Ord time) => Behavior time -> Behavior (Behavior time)
localTime t = do n <- t
return ((\x -> x n) <$> t)
timeFrac :: (Floating time, Ord time) => Behavior time -> time -> Behavior (Behavior time)
timeFrac t d = do t' <- localTime t
e <- when $ (>= d) <$> t'
let frac = (\x -> min 1.0 (x / d)) <$> t'
return (frac `switch` (pure 1.0 <$ e))
tagTime :: (Floating time, Ord time) => Behavior time -> EvStream a -> EvStream (time,a)
tagTime c s = ((,) <$> c) <@@> s
lastInputs :: (Floating time, Ord time) =>
Behavior time
-> time
-> EvStream a
-> Behavior (Behavior [a])
lastInputs clock dur s = do s' <- bufferStream clock dur s
bs <- fromChanges [] s'
let dropIt cur s = dropWhile (\(t,_) -> t + dur < cur) s
return $ (fmap snd) <$> (dropIt <$> clock <*> bs)
bufferStream :: (Floating time, Ord time) => Behavior time -> time -> EvStream a -> Behavior (EvStream [(time,a)])
bufferStream clock dur s = do s' <- scanlEv addDrop empty $ tagTime clock s
return $ toList <$> s' where
addDrop ss s@(last,v) = dropWhileL (\(tn,_) -> tn + dur < last) (ss |> s)
data TimeTag t a = TimeTag t a
instance Eq t => Eq (TimeTag t a) where
(TimeTag t1 _) == (TimeTag t2 _) = t1 == t2
bufferBehavior :: (Floating time, Ord time) =>
Behavior time
-> time
-> Behavior a
-> Behavior (Behavior [(time,a)])
bufferBehavior clock dur b = fmap toList <$> foldB update empty (TimeTag <$> clock <*> b)
where update l (TimeTag now x) = trimList (l |> (now,x)) (now dur)
trimList l after = loop l where
loop l =
case viewl l of
EmptyL -> empty
(t1,v1) :< tail1
| after <= t1 -> l
| otherwise ->
case viewl tail1 of
(t2,v2) :< tail2
| t2 <= after -> loop tail2
| otherwise -> l
delayBy :: (Floating time, Ord time) =>
Behavior time
-> time
-> Behavior a
-> Behavior (Behavior a)
delayBy time d b = fmap (snd . head) <$> bufferBehavior time d b
delayByN :: (Floating time, Ord time) =>
Behavior time
-> time
-> Integer
-> Behavior a
-> Behavior (Behavior [a])
delayByN clock dur n b =
let durN = (fromIntegral n) * dur
in do samples <- bufferBehavior clock durN b
return $ interpolateFromList <$> clock <*> samples where
interpolateFromList now l= loop (n 1) l where
loop n l =
if n < 0 then []
else let sampleTime = now (fromIntegral n * dur)
in case l of
[] -> []
[(_,v)] -> v : loop (n1) l
((t1,v1) : (t2,v2) : rest)
| sampleTime >= t2 -> loop n ((t2,v2) : rest)
| otherwise -> v1 : loop (n1) l