{-# LANGUAGE RecursiveDo #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Reactive.Banana.Model (
Nat, Time,
Event(..), Behavior(..),
interpret,
module Control.Applicative,
never, unionWith, mergeWith, filterJust, apply,
Moment(..), accumE, stepper,
valueB, observeE, switchE, switchB,
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Data.These (These(..), these)
import Data.Maybe (fromMaybe)
type Nat = Int
type Time = Nat
newtype Event a = E { Event a -> [Maybe a]
unE :: [Maybe a] } deriving (Int -> Event a -> ShowS
[Event a] -> ShowS
Event a -> String
(Int -> Event a -> ShowS)
-> (Event a -> String) -> ([Event a] -> ShowS) -> Show (Event a)
forall a. Show a => Int -> Event a -> ShowS
forall a. Show a => [Event a] -> ShowS
forall a. Show a => Event a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event a] -> ShowS
$cshowList :: forall a. Show a => [Event a] -> ShowS
show :: Event a -> String
$cshow :: forall a. Show a => Event a -> String
showsPrec :: Int -> Event a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Event a -> ShowS
Show)
newtype Behavior a = B { Behavior a -> [a]
unB :: [a] } deriving (Int -> Behavior a -> ShowS
[Behavior a] -> ShowS
Behavior a -> String
(Int -> Behavior a -> ShowS)
-> (Behavior a -> String)
-> ([Behavior a] -> ShowS)
-> Show (Behavior a)
forall a. Show a => Int -> Behavior a -> ShowS
forall a. Show a => [Behavior a] -> ShowS
forall a. Show a => Behavior a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Behavior a] -> ShowS
$cshowList :: forall a. Show a => [Behavior a] -> ShowS
show :: Behavior a -> String
$cshow :: forall a. Show a => Behavior a -> String
showsPrec :: Int -> Behavior a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Behavior a -> ShowS
Show)
interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]
interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]
interpret Event a -> Moment (Event b)
f [Maybe a]
as =
Int -> [Maybe b] -> [Maybe b]
forall a. Int -> [a] -> [a]
take ([Maybe a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe a]
as) ([Maybe b] -> [Maybe b])
-> ([Maybe a] -> [Maybe b]) -> [Maybe a] -> [Maybe b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event b -> [Maybe b]
forall a. Event a -> [Maybe a]
unE (Event b -> [Maybe b])
-> ([Maybe a] -> Event b) -> [Maybe a] -> [Maybe b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Moment (Event b)
m -> Moment (Event b) -> Int -> Event b
forall a. Moment a -> Int -> a
unM Moment (Event b)
m Int
0) (Moment (Event b) -> Event b)
-> ([Maybe a] -> Moment (Event b)) -> [Maybe a] -> Event b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Moment (Event b)
f (Event a -> Moment (Event b))
-> ([Maybe a] -> Event a) -> [Maybe a] -> Moment (Event b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe a] -> Event a
forall a. [Maybe a] -> Event a
E ([Maybe a] -> [Maybe b]) -> [Maybe a] -> [Maybe b]
forall a b. (a -> b) -> a -> b
$ ([Maybe a]
as [Maybe a] -> [Maybe a] -> [Maybe a]
forall a. [a] -> [a] -> [a]
++ Maybe a -> [Maybe a]
forall a. a -> [a]
repeat Maybe a
forall a. Maybe a
Nothing)
instance Functor Event where
fmap :: (a -> b) -> Event a -> Event b
fmap a -> b
f (E [Maybe a]
xs) = [Maybe b] -> Event b
forall a. [Maybe a] -> Event a
E ((Maybe a -> Maybe b) -> [Maybe a] -> [Maybe b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Maybe a]
xs)
instance Functor Behavior where
fmap :: (a -> b) -> Behavior a -> Behavior b
fmap a -> b
f (B [a]
xs) = [b] -> Behavior b
forall a. [a] -> Behavior a
B ((a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f [a]
xs)
instance Applicative Behavior where
pure :: a -> Behavior a
pure a
x = [a] -> Behavior a
forall a. [a] -> Behavior a
B ([a] -> Behavior a) -> [a] -> Behavior a
forall a b. (a -> b) -> a -> b
$ a -> [a]
forall a. a -> [a]
repeat a
x
(B [a -> b]
f) <*> :: Behavior (a -> b) -> Behavior a -> Behavior b
<*> (B [a]
x) = [b] -> Behavior b
forall a. [a] -> Behavior a
B ([b] -> Behavior b) -> [b] -> Behavior b
forall a b. (a -> b) -> a -> b
$ ((a -> b) -> a -> b) -> [a -> b] -> [a] -> [b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($) [a -> b]
f [a]
x
never :: Event a
never :: Event a
never = [Maybe a] -> Event a
forall a. [Maybe a] -> Event a
E ([Maybe a] -> Event a) -> [Maybe a] -> Event a
forall a b. (a -> b) -> a -> b
$ Maybe a -> [Maybe a]
forall a. a -> [a]
repeat Maybe a
forall a. Maybe a
Nothing
unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a
unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a
unionWith = (a -> a)
-> (a -> a) -> (a -> a -> a) -> Event a -> Event a -> Event a
forall a c b.
(a -> c)
-> (b -> c) -> (a -> b -> c) -> Event a -> Event b -> Event c
mergeWith a -> a
forall a. a -> a
id a -> a
forall a. a -> a
id
mergeWith
:: (a -> c)
-> (b -> c)
-> (a -> b -> c)
-> Event a
-> Event b
-> Event c
mergeWith :: (a -> c)
-> (b -> c) -> (a -> b -> c) -> Event a -> Event b -> Event c
mergeWith a -> c
f b -> c
g a -> b -> c
h Event a
xs Event b
ys = (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these a -> c
f b -> c
g a -> b -> c
h (These a b -> c) -> Event (These a b) -> Event c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event a -> Event b -> Event (These a b)
forall a b. Event a -> Event b -> Event (These a b)
merge Event a
xs Event b
ys
merge :: Event a -> Event b -> Event (These a b)
merge :: Event a -> Event b -> Event (These a b)
merge (E [Maybe a]
xs) (E [Maybe b]
ys) = [Maybe (These a b)] -> Event (These a b)
forall a. [Maybe a] -> Event a
E ([Maybe (These a b)] -> Event (These a b))
-> [Maybe (These a b)] -> Event (These a b)
forall a b. (a -> b) -> a -> b
$ (Maybe a -> Maybe b -> Maybe (These a b))
-> [Maybe a] -> [Maybe b] -> [Maybe (These a b)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe a -> Maybe b -> Maybe (These a b)
forall a b. Maybe a -> Maybe b -> Maybe (These a b)
combine [Maybe a]
xs [Maybe b]
ys
where
combine :: Maybe a -> Maybe b -> Maybe (These a b)
combine Maybe a
Nothing Maybe b
Nothing = Maybe (These a b)
forall a. Maybe a
Nothing
combine (Just a
x) Maybe b
Nothing = These a b -> Maybe (These a b)
forall a. a -> Maybe a
Just (a -> These a b
forall a b. a -> These a b
This a
x)
combine Maybe a
Nothing (Just b
y) = These a b -> Maybe (These a b)
forall a. a -> Maybe a
Just (b -> These a b
forall a b. b -> These a b
That b
y)
combine (Just a
x) (Just b
y) = These a b -> Maybe (These a b)
forall a. a -> Maybe a
Just (a -> b -> These a b
forall a b. a -> b -> These a b
These a
x b
y)
filterJust :: Event (Maybe a) -> Event a
filterJust :: Event (Maybe a) -> Event a
filterJust = [Maybe a] -> Event a
forall a. [Maybe a] -> Event a
E ([Maybe a] -> Event a)
-> (Event (Maybe a) -> [Maybe a]) -> Event (Maybe a) -> Event a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Maybe a) -> Maybe a) -> [Maybe (Maybe a)] -> [Maybe a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([Maybe (Maybe a)] -> [Maybe a])
-> (Event (Maybe a) -> [Maybe (Maybe a)])
-> Event (Maybe a)
-> [Maybe a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event (Maybe a) -> [Maybe (Maybe a)]
forall a. Event a -> [Maybe a]
unE
apply :: Behavior (a -> b) -> Event a -> Event b
apply :: Behavior (a -> b) -> Event a -> Event b
apply (B [a -> b]
fs) = [Maybe b] -> Event b
forall a. [Maybe a] -> Event a
E ([Maybe b] -> Event b)
-> (Event a -> [Maybe b]) -> Event a -> Event b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> b) -> Maybe a -> Maybe b)
-> [a -> b] -> [Maybe a] -> [Maybe b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\a -> b
f Maybe a
mx -> (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe a
mx) [a -> b]
fs ([Maybe a] -> [Maybe b])
-> (Event a -> [Maybe a]) -> Event a -> [Maybe b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> [Maybe a]
forall a. Event a -> [Maybe a]
unE
newtype Moment a = M { Moment a -> Int -> a
unM :: Time -> a }
instance Functor Moment where fmap :: (a -> b) -> Moment a -> Moment b
fmap a -> b
f = (Int -> b) -> Moment b
forall a. (Int -> a) -> Moment a
M ((Int -> b) -> Moment b)
-> (Moment a -> Int -> b) -> Moment a -> Moment b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> (Int -> a) -> Int -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ((Int -> a) -> Int -> b)
-> (Moment a -> Int -> a) -> Moment a -> Int -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Moment a -> Int -> a
forall a. Moment a -> Int -> a
unM
instance Applicative Moment where
pure :: a -> Moment a
pure = (Int -> a) -> Moment a
forall a. (Int -> a) -> Moment a
M ((Int -> a) -> Moment a) -> (a -> Int -> a) -> a -> Moment a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int -> a
forall a b. a -> b -> a
const
<*> :: Moment (a -> b) -> Moment a -> Moment b
(<*>) = Moment (a -> b) -> Moment a -> Moment b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Moment where
return :: a -> Moment a
return = a -> Moment a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(M Int -> a
m) >>= :: Moment a -> (a -> Moment b) -> Moment b
>>= a -> Moment b
k = (Int -> b) -> Moment b
forall a. (Int -> a) -> Moment a
M ((Int -> b) -> Moment b) -> (Int -> b) -> Moment b
forall a b. (a -> b) -> a -> b
$ \Int
time -> Moment b -> Int -> b
forall a. Moment a -> Int -> a
unM (a -> Moment b
k (a -> Moment b) -> a -> Moment b
forall a b. (a -> b) -> a -> b
$ Int -> a
m Int
time) Int
time
instance MonadFix Moment where
mfix :: (a -> Moment a) -> Moment a
mfix a -> Moment a
f = (Int -> a) -> Moment a
forall a. (Int -> a) -> Moment a
M ((Int -> a) -> Moment a) -> (Int -> a) -> Moment a
forall a b. (a -> b) -> a -> b
$ (a -> Int -> a) -> Int -> a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (Moment a -> Int -> a
forall a. Moment a -> Int -> a
unM (Moment a -> Int -> a) -> (a -> Moment a) -> a -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Moment a
f)
forgetE :: Time -> Event a -> [Maybe a]
forgetE :: Int -> Event a -> [Maybe a]
forgetE Int
time (E [Maybe a]
xs) = Int -> [Maybe a] -> [Maybe a]
forall a. Int -> [a] -> [a]
drop Int
time [Maybe a]
xs
stepper :: a -> Event a -> Moment (Behavior a)
stepper :: a -> Event a -> Moment (Behavior a)
stepper a
i Event a
e = (Int -> Behavior a) -> Moment (Behavior a)
forall a. (Int -> a) -> Moment a
M ((Int -> Behavior a) -> Moment (Behavior a))
-> (Int -> Behavior a) -> Moment (Behavior a)
forall a b. (a -> b) -> a -> b
$ \Int
time -> [a] -> Behavior a
forall a. [a] -> Behavior a
B ([a] -> Behavior a) -> [a] -> Behavior a
forall a b. (a -> b) -> a -> b
$ Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
time a
i [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a -> [Maybe a] -> [a]
forall t. t -> [Maybe t] -> [t]
step a
i (Int -> Event a -> [Maybe a]
forall a. Int -> Event a -> [Maybe a]
forgetE Int
time Event a
e)
where
step :: t -> [Maybe t] -> [t]
step t
i ~(Maybe t
x:[Maybe t]
xs) = t
i t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [Maybe t] -> [t]
step t
next [Maybe t]
xs
where next :: t
next = t -> Maybe t -> t
forall a. a -> Maybe a -> a
fromMaybe t
i Maybe t
x
accumE :: a -> Event (a -> a) -> Moment (Event a)
accumE :: a -> Event (a -> a) -> Moment (Event a)
accumE a
a Event (a -> a)
e1 = mdo
let e2 :: Event a
e2 = ((\a
a a -> a
f -> a -> a
f a
a) (a -> (a -> a) -> a) -> Behavior a -> Behavior ((a -> a) -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior a
b) Behavior ((a -> a) -> a) -> Event (a -> a) -> Event a
forall a b. Behavior (a -> b) -> Event a -> Event b
`apply` Event (a -> a)
e1
Behavior a
b <- a -> Event a -> Moment (Behavior a)
forall a. a -> Event a -> Moment (Behavior a)
stepper a
a Event a
e2
Event a -> Moment (Event a)
forall (m :: * -> *) a. Monad m => a -> m a
return Event a
e2
valueB :: Behavior a -> Moment a
valueB :: Behavior a -> Moment a
valueB (B [a]
b) = (Int -> a) -> Moment a
forall a. (Int -> a) -> Moment a
M ((Int -> a) -> Moment a) -> (Int -> a) -> Moment a
forall a b. (a -> b) -> a -> b
$ \Int
time -> [a]
b [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
time
observeE :: Event (Moment a) -> Event a
observeE :: Event (Moment a) -> Event a
observeE = [Maybe a] -> Event a
forall a. [Maybe a] -> Event a
E ([Maybe a] -> Event a)
-> (Event (Moment a) -> [Maybe a]) -> Event (Moment a) -> Event a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Maybe (Moment a) -> Maybe a)
-> [Int] -> [Maybe (Moment a)] -> [Maybe a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
time -> (Moment a -> a) -> Maybe (Moment a) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Moment a
m -> Moment a -> Int -> a
forall a. Moment a -> Int -> a
unM Moment a
m Int
time)) [Int
0..] ([Maybe (Moment a)] -> [Maybe a])
-> (Event (Moment a) -> [Maybe (Moment a)])
-> Event (Moment a)
-> [Maybe a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event (Moment a) -> [Maybe (Moment a)]
forall a. Event a -> [Maybe a]
unE
switchE :: Event a -> Event (Event a) -> Moment (Event a)
switchE :: Event a -> Event (Event a) -> Moment (Event a)
switchE Event a
e Event (Event a)
es = (Int -> Event a) -> Moment (Event a)
forall a. (Int -> a) -> Moment a
M ((Int -> Event a) -> Moment (Event a))
-> (Int -> Event a) -> Moment (Event a)
forall a b. (a -> b) -> a -> b
$ \Int
t -> [Maybe a] -> Event a
forall a. [Maybe a] -> Event a
E ([Maybe a] -> Event a) -> [Maybe a] -> Event a
forall a b. (a -> b) -> a -> b
$
Int -> Maybe a -> [Maybe a]
forall a. Int -> a -> [a]
replicate Int
t Maybe a
forall a. Maybe a
Nothing [Maybe a] -> [Maybe a] -> [Maybe a]
forall a. [a] -> [a] -> [a]
++ [Maybe a] -> [Maybe [Maybe a]] -> [Maybe a]
forall a. [a] -> [Maybe [a]] -> [a]
switch (Event a -> [Maybe a]
forall a. Event a -> [Maybe a]
unE Event a
e) (Int -> Event [Maybe a] -> [Maybe [Maybe a]]
forall a. Int -> Event a -> [Maybe a]
forgetE Int
t (Event (Event a) -> Event [Maybe a]
forall a. Event (Event a) -> Event [Maybe a]
forgetDiagonalE Event (Event a)
es))
where
switch :: [a] -> [Maybe [a]] -> [a]
switch (a
x:[a]
xs) (Maybe [a]
Nothing : [Maybe [a]]
ys) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [Maybe [a]] -> [a]
switch [a]
xs [Maybe [a]]
ys
switch (a
x: [a]
_) (Just [a]
xs : [Maybe [a]]
ys) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [Maybe [a]] -> [a]
switch ([a] -> [a]
forall a. [a] -> [a]
tail [a]
xs) [Maybe [a]]
ys
forgetDiagonalE :: Event (Event a) -> Event [Maybe a]
forgetDiagonalE :: Event (Event a) -> Event [Maybe a]
forgetDiagonalE = [Maybe [Maybe a]] -> Event [Maybe a]
forall a. [Maybe a] -> Event a
E ([Maybe [Maybe a]] -> Event [Maybe a])
-> (Event (Event a) -> [Maybe [Maybe a]])
-> Event (Event a)
-> Event [Maybe a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Maybe (Event a) -> Maybe [Maybe a])
-> [Int] -> [Maybe (Event a)] -> [Maybe [Maybe a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
time -> (Event a -> [Maybe a]) -> Maybe (Event a) -> Maybe [Maybe a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Event a -> [Maybe a]
forall a. Int -> Event a -> [Maybe a]
forgetE Int
time)) [Int
0..] ([Maybe (Event a)] -> [Maybe [Maybe a]])
-> (Event (Event a) -> [Maybe (Event a)])
-> Event (Event a)
-> [Maybe [Maybe a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event (Event a) -> [Maybe (Event a)]
forall a. Event a -> [Maybe a]
unE
switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)
switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)
switchB Behavior a
b Event (Behavior a)
e = Behavior (Behavior a) -> Behavior a
forall a. Behavior (Behavior a) -> Behavior a
diagonalB (Behavior (Behavior a) -> Behavior a)
-> Moment (Behavior (Behavior a)) -> Moment (Behavior a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior a -> Event (Behavior a) -> Moment (Behavior (Behavior a))
forall a. a -> Event a -> Moment (Behavior a)
stepper Behavior a
b Event (Behavior a)
e
diagonalB :: Behavior (Behavior a) -> Behavior a
diagonalB :: Behavior (Behavior a) -> Behavior a
diagonalB = [a] -> Behavior a
forall a. [a] -> Behavior a
B ([a] -> Behavior a)
-> (Behavior (Behavior a) -> [a])
-> Behavior (Behavior a)
-> Behavior a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [a] -> a) -> [Int] -> [[a]] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
time [a]
xs -> [a]
xs [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
time) [Int
0..] ([[a]] -> [a])
-> (Behavior (Behavior a) -> [[a]]) -> Behavior (Behavior a) -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Behavior a -> [a]) -> [Behavior a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Behavior a -> [a]
forall a. Behavior a -> [a]
unB ([Behavior a] -> [[a]])
-> (Behavior (Behavior a) -> [Behavior a])
-> Behavior (Behavior a)
-> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Behavior (Behavior a) -> [Behavior a]
forall a. Behavior a -> [a]
unB