module FRP.Reactivity.Combinators (
tick, untilE, eitherOf, holdE, zipE, simultE, intersectE, differenceE, unionE, filterE, justE, duplicateE, withPrev, calmE, count, takeE, dropE, once, everyNth, slowE, rests, startAt, splitE,
Behavior, extractB, duplicateB, time, switcher, stepper, snapshot, flipFlop, history, scanB, delayB, slow, monoid, throttle, sumE, derivative, supersample, integral, threshold) where
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Loops
import Control.Applicative
import Control.Exception
import Control.Parallel.Strategies
import Control.Parallel
import Data.Maybe
import Data.List
import Data.Monoid
import Data.Function
import qualified Data.Map as M
import Data.IORef
import FRP.Reactivity.AlternateEvent
import Data.Time.Clock.POSIX
tick time t = eventFromList (map (\t -> (t, t)) [time,time+t..])
untilE :: (EventStream e) => e t -> e u -> e t
untilE e u = switch (return e `mplus` fmap (const mzero) u)
eitherOf :: (Functor e, MonadPlus e) => e t -> e u -> e (Either t u)
eitherOf e e2 = fmap Left e `mplus` fmap Right e2
holdE :: (EventStream e) => e t -> e u -> u -> e (t, u)
holdE e e2 x = justE
$ scan (\x ei -> either (\y -> (x, Just (y, x))) (\y2 -> (y2, Nothing)) ei) x
$ eitherOf e e2
swap (x, y) = (y, x)
zipE e x e2 y = holdE e e2 y `mplus` fmap swap (holdE e2 e x)
cozip ls = (catMaybes (map (either Just (const Nothing)) ls), catMaybes (map (either (const Nothing) Just) ls))
groupOn ls = map (\ls -> (map fst ls, snd (head ls))) $ groupBy ((==) `on` snd) ls
ungroup ls = [ (y, x) | (l, x) <- ls, y <- l ]
simultE :: (EventStream e) => e t -> e u -> e (t, Maybe u)
simultE e a = justE
$ scan (\(prev, ti) (ei, t) -> if ti < t then
either
(\y -> (([y], t), Nothing))
(\x -> (([], t), Just (x, Nothing)))
ei
else
either
(\y -> ((prev ++ [y], t), Nothing))
(\x -> case prev of { y:ys -> ((ys, t), Just (x, Just y)); [] -> (([], t), Just (x, Nothing)) })
ei)
([], 0)
$ adjoinTime
$ eitherOf a e
differenceE e a = justE $ fmap (\(x, m) -> maybe (Just x) (const Nothing) m) $ simultE e a
intersectE e a = justE $ fmap (uncurry fmap) $ simultE e a
unionE :: (EventStream e, Monoid t) => e t -> e t -> e t
unionE e e2 = intersectE (fmap (<>) e) e2
`mplus` differenceE e e2
`mplus` differenceE e2 e
filterE f e = e >>= \x -> guard (f x) >> return x
justE e = fmap fromJust (filterE isJust e)
duplicateE e = fmap (\(x, e) -> return x `mplus` e) (withRemainder e)
withPrev e = justE $ scan (\may y -> (Just y, fmap (\x -> (x, y)) may)) Nothing e
calmE e = once e
`mplus`
fmap (fst . snd)
(filterE (\((_, t), (_, t1)) -> t < t1)
$ withPrev
$ adjoinTime e)
count e = scan (\n x -> (n + 1, (x, n + 1))) 0 e
dropE n e = fmap fst $ filterE ((>n) . snd) $ count e
takeE :: (EventStream e, Num n, Ord n) => n -> e t -> e t
takeE n e = fmap fst $ filterE ((<=n) . snd) c where
c = count e
once e = takeE 1 e
everyNth :: (EventStream e, Num n, Ord n) => n -> e t -> e t
everyNth n =
justE
. scan (\i x -> if 1 + i >= n then
(0, Just x)
else
(1 + i, Nothing))
n
slowE x e = adjoinTime e >>= \(y, t) -> eventFromList [(y, (x 1) * t)]
rests e a = holdE a (fmap snd (withRemainder e)) e
startAt e a = once (rests e a) >>= snd
splitE e a = fmap (\((_, a), e) -> e `untilE` a) $ rests e (withRemainder a)
sumE :: (Num t) => Event t -> Event t
sumE = scan (\x y -> let x' = x + y in (x', x')) 0
data Behavior e t = Switcher !(POSIXTime -> t) (e (POSIXTime -> t)) deriving Functor
time :: (MonadPlus e) => Behavior e POSIXTime
time = Switcher id mzero
switcher (Switcher f e) e2 = Switcher f (switch $ return e `mplus` fmap (\(Switcher f e) -> return f `mplus` e) e2)
stepper x e = Switcher (const x) (fmap const e)
snapshot e (Switcher f e2) = fmap (\((x, f), t) -> (x, f t))
$ adjoinTime
$ holdE e e2 f
flipFlop e e2 = stepper False (fmap (const True) e `mplus` fmap (const False) e2)
history :: (EventStream e) => Double -> Behavior e t -> Behavior e (POSIXTime -> t)
history t (Switcher f e) = function
<$> stepper [(f, 0)] windowFunctions
<*> time where
tCoerced = fromRational (toRational t)
function ls t1 t2 = if t1 <= t2 then fst (head ls) t1
else maybe (fst (last ls) (t1tCoerced)) (($t2) . fst)
$ find ((<=t2) . snd) ls
windowFunctions = scan (\ls (f, t1) -> let ls' = (f, t1) : map fst (takeWhile ((>=t1tCoerced) . snd . snd) $ zip ls $ tail ls) `using` evalList rseq in
(ls, ls))
[(f, 0)]
$ adjoinTime e
scanB :: (EventStream e) => Behavior e (t -> e t) -> t -> e t
scanB b x = return x `mplus` (snapshot (extractB b x) (duplicateB b) >>= uncurry (flip scanB))
_monoid :: (EventStream e, Monoid t) => e (Behavior e t) -> Behavior e t -> e (Behavior e t)
_monoid e b = return b `mplus` (snapshot (once (withRemainder e)) (duplicateB b) >>= \((x, e), b2) -> _monoid e (x <> b2))
monoid :: (EventStream e, Monoid t) => e (Behavior e t) -> Behavior e t
monoid e = switcher mempty $ _monoid e mempty
throttle :: (EventStream e) => Double -> e t -> Behavior e (Maybe t)
throttle t e = fmap getLast $ monoid (fmap (\(x, ti) -> stepper (Last Nothing) (eventFromList [(Last (Just x), ti), (Last Nothing, tCoerce + ti)])) (adjoinTime e)) where
tCoerce = fromRational (toRational t)
delayB t (Switcher f e) = Switcher (f . subtract t) (fmap (. subtract t) (delay t e))
slow x (Switcher f e) = Switcher (f . (/x)) (slowE x (fmap (. (/x)) e))
instance (EventStream e, Monoid t) => Monoid (Behavior e t) where
mempty = pure mempty
mappend e e2 = mappend <$> e <*> e2
instance (EventStream e) => Alternative (Behavior e) where
empty = error "FRP.Reactivity.empty: use Monoid instead"
(<|>) = error "FRP.Reactivity.<|>: use Monoid instead"
instance (EventStream e) => Applicative (Behavior e) where
pure x = Switcher (const x) mzero
Switcher f e <*> Switcher f2 e2 = Switcher (f <*> f2)
$ fmap (uncurry (<*>))
$ zipE e f e2 f2
cutoff t f t1 = f (max t t1)
extractB (Switcher f _) = f 0
duplicateB (Switcher f e) = Switcher (\t -> Switcher (cutoff t f) e) (fmap (\(f, e) t -> Switcher (cutoff t f) e) (withRemainder e))
epsilon = 0.0001
derivative :: (EventStream e, Real t, Fractional t) => Behavior e t -> Behavior e t
derivative b = (\x x1 -> (x1 x) / fromRational (toRational epsilon)) <$> delayB epsilon b <*> b
supersample :: (EventStream e, Real t, Fractional t) => Double -> Behavior e t -> e (POSIXTime, t)
supersample precision b = scanB
((\t x deriv _ -> eventFromList [((t, x), if t < epsilon then t + epsilon else t + fromRational (toRational precision) / (1 + fromRational (toRational (abs deriv))))]) <$> time <*> b <*> derivative b)
(0, extractB b)
integral precision b =
stepper 0
$ sumE
$ fmap (\((t, x), (t1, x1)) -> 0.5 * (x1 + x) * fromRational (toRational (t1 t)))
$ withPrev
$ supersample precision b
threshold :: (EventStream e, Real t, Fractional t) => Double -> Behavior e t -> t -> e Bool
threshold precision b x = justE
$ scan (\gt (t, y) -> if gt == (y < x) then (not gt, Just (not gt)) else (gt, Nothing)) (extractB b > x)
$ supersample precision b