module Reactive.Banana.Model (
Event, Behavior,
never, filterJust, unionWith, mapE, accumE, applyE,
stepperB, pureB, applyB, mapB,
Moment,
initialB, trimE, trimB, observeE, switchE, switchB,
interpret,
) where
import Control.Applicative
import Control.Monad (join)
type Event a = [Maybe a]
data Behavior a = StepperB !a (Event a)
interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]
interpret f e = f e 0
never :: Event a
never = repeat Nothing
filterJust :: Event (Maybe a) -> Event a
filterJust = map join
unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a
unionWith f = zipWith g
where
g (Just x) (Just y) = Just $ f x y
g (Just x) Nothing = Just x
g Nothing (Just y) = Just y
g Nothing Nothing = Nothing
mapE f = applyE (pureB f)
applyE :: Behavior (a -> b) -> Event a -> Event b
applyE _ [] = []
applyE (StepperB f fe) (x:xs) = fmap f x : applyE (step f fe) xs
where
step a (Nothing:b) = stepperB a b
step _ (Just a :b) = stepperB a b
accumE :: a -> Event (a -> a) -> Event a
accumE x [] = []
accumE x (Nothing:fs) = Nothing : accumE x fs
accumE x (Just f :fs) = let y = f x in y `seq` (Just y:accumE y fs)
stepperB :: a -> Event a -> Behavior a
stepperB = StepperB
pureB x = stepperB x never
applyB :: Behavior (a -> b) -> Behavior a -> Behavior b
applyB (StepperB f fe) (StepperB x xe) =
stepperB (f x) $ mapE (uncurry ($)) pair
where
pair = accumE (f,x) $ unionWith (.) (mapE changeL fe) (mapE changeR xe)
changeL f (_,x) = (f,x)
changeR x (f,_) = (f,x)
mapB f = applyB (pureB f)
type Time = Int
type Moment a = Time -> a
initialB :: Behavior a -> Moment a
initialB (StepperB x _) = return x
trimE :: Event a -> Moment (Moment (Event a))
trimE e = \now -> \later -> drop (later now) e
trimB :: Behavior a -> Moment (Moment (Behavior a))
trimB b = \now -> \later -> bTrimmed !! (later now)
where
bTrimmed = iterate drop1 b
drop1 (StepperB x [] ) = StepperB x never
drop1 (StepperB x (Just y :ys)) = StepperB y ys
drop1 (StepperB x (Nothing:ys)) = StepperB x ys
observeE :: Event (Moment a) -> Event a
observeE = zipWith (\time -> fmap ($ time)) [0..]
switchE :: Event (Moment (Event a)) -> Event a
switchE = step never . observeE
where
step ys [] = ys
step (y:ys) (Nothing:xs) = y : step ys xs
step (y:ys) (Just zs:xs) = y : step (drop 1 zs) xs
switchB :: Behavior a -> Event (Moment (Behavior a)) -> Behavior a
switchB (StepperB x e) = stepperB x . step e . observeE
where
step ys [] = ys
step (y:ys) (Nothing :xs) = y : step ys xs
step (y:ys) (Just (StepperB x zs):xs) = Just value : step (drop 1 zs) xs
where
value = case zs of
Just z : _ -> z
_ -> x