module Reactive.Banana.Model (
Time, Event, Behavior, Moment,
never, filterJust, unionWith, mapE, accumE, applyE,
stepperB, pureB, applyB, mapB,
valueB, observeE, switchE, switchB,
interpret,
) where
import Control.Applicative
import Control.Monad (join)
import Data.List (splitAt)
type Time = Int
data Event a = E Time [Maybe a]
deriving (Show)
data Behavior a = B Time a [a]
deriving (Show)
type Moment a = Time -> a
epoch :: Time
epoch = 0
trimE :: Event a -> Moment (Event a)
trimE (E t xs) s
| s <= t = E s $ replicate (ts) Nothing ++ xs
| s > t = E s $ drop (st) xs
trimB :: Behavior a -> Moment (Behavior a)
trimB (B t x xs) s
| s <= t = B s x $ replicate (ts) x ++ xs
| s > t = B s (last ys) zs
where
(ys,zs) = splitAt (st) xs
syncEE ~ex@(E tx _) ~ey@(E ty _) = (ex `trimE` t, ey `trimE` t)
where t = min tx ty
syncBE ~bx@(B tx _ _) ~ey@(E ty _) = (bx `trimB` t, ey `trimE` t)
where t = min tx ty
syncBB ~bx@(B tx _ _) ~by@(B ty _ _) = (bx `trimB` t, by `trimB` t)
where t = min tx ty
interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]
interpret f as = zipWith const bs as
where
input = E epoch (as ++ repeat Nothing)
output = f input (epoch7) `trimE` epoch
E _ bs = output
never :: Event a
never = E epoch (repeat Nothing)
filterJust :: Event (Maybe a) -> Event a
filterJust (E t xs) = E t (map join xs)
unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a
unionWith f ex ey = E t $ zipWith g xs ys
where
(E t xs, E _ ys) = syncEE ex ey
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 bf ex = E t $ zipWith (\f x -> fmap f x) (f:fs) xs
where
(B t f fs, E _ xs) = syncBE bf ex
pureB x = B epoch x (repeat x)
applyB :: Behavior (a -> b) -> Behavior a -> Behavior b
applyB bf bx = B t (f x) $ zipWith ($) fs xs
where
(B t f fs, B _ x xs) = syncBB bf bx
mapB f = applyB (pureB f)
smotherFirst :: Event a -> Event a
smotherFirst (E t (_:xs)) = E t (Nothing:xs)
accumE :: a -> Event (a -> a) -> Moment (Event a)
accumE x e time = E time $ go x xs
where
E _ xs = smotherFirst $ e `trimE` time
go x (Nothing:fs) = Nothing : go x fs
go x (Just f :fs) = let y = f x in y `seq` (Just y:go y fs)
stepperB :: a -> Event a -> Moment (Behavior a)
stepperB x e time = B time x $ go x xs
where
E _ xs = smotherFirst $ e `trimE` time
go x (Nothing:ys) = x : go x ys
go x (Just y :ys) = y : go y ys
valueB :: Behavior a -> Moment a
valueB b time = x
where B _ x _ = b `trimB` time
observeE :: Event (Moment a) -> Event a
observeE (E t xs) = E t $ zipWith (\time -> fmap ($ time)) [t..] xs
switchE :: Event (Event a) -> Event a
switchE (E t xs) = E t $ go t (repeat Nothing) xs
where
go time (y:ys) (Nothing:es) = y : go (time+1) ys es
go time (y:ys) (Just e :es) = y : go (time+1) zs es
where
E _ zs = e `trimE` (time + 1)
switchB :: Behavior a -> Event (Behavior a) -> Behavior a
switchB b x = B t y $ go t ys es
where
(B t y ys, E _ es) = syncBE b x
go time (y:ys) (Nothing:es) = y : go (time+1) ys es
go time _ (Just b :es) = z : go (time+1) zs es
where B _ z zs = b `trimB` (time+1)