{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
{-# LANGUAGE RecursiveDo #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Reactive.Banana.Model (
    -- * Synopsis
    -- | Model implementation for learning and testing.

    -- * Overview
    -- $overview

    -- * Core Combinators
    -- ** Event and Behavior
    Nat, Time,
    Event(..), Behavior(..),
    interpret,
    -- ** First-order
    module Control.Applicative,
    never, unionWith, mergeWith, filterJust, apply,
    -- ** Moment and accumulation
    Moment(..), accumE, stepper,
    -- ** Higher-order
    valueB, observeE, switchE, switchB,
    ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Data.These (These(..), these)
import Data.Maybe (fromMaybe)

{-$overview

This module reimplements the key FRP types and functions from the module
"Reactive.Banana.Combinators" in a way that is hopefully easier to understand.
Thereby, this model also specifies the semantics of the library.
Of course, the real implementation is much more efficient than this model here.

To understand the model in detail, look at the source code!
(If there is no link to the source code at every type signature,
then you have to run cabal with --hyperlink-source flag.)

This model is /authoritative/:
Event functions that have been constructed using the same combinators
/must/ give the same results when run with the @interpret@ function
from either the module "Reactive.Banana.Combinators"
or the module "Reactive.Banana.Model".
This must also hold for recursive and partial definitions
(at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@).

-}

{-----------------------------------------------------------------------------
    Event and Behavior
------------------------------------------------------------------------------}
-- | Natural numbers (poorly represented).
type Nat = Int

-- | The FRP model used in this library is actually a model with continuous time.
--
-- However, it can be shown that this model is observationally
-- equivalent to a particular model with (seemingly) discrete time steps,
-- which is implemented here.
-- The main reason for doing this is to be able to handle recursion correctly.
-- Details will be explained elsewhere.
type Time = Nat -- begins at t = 0

-- | Event is modeled by an /infinite/ list of 'Maybe' values.
-- It is isomorphic to @Time -> Maybe a@.
--
-- 'Nothing' indicates that no occurrence happens,
-- while 'Just' indicates that an occurrence happens.
newtype Event a = E { forall a. Event a -> [Maybe a]
unE :: [Maybe a] } deriving (Int -> Event a -> ShowS
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)

-- | Behavior is modeled by an /infinite/ list of values.
-- It is isomorphic to @Time -> a@.
newtype Behavior a = B { forall a. Behavior a -> [a]
unB :: [a] } deriving (Int -> Behavior a -> ShowS
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 :: forall a b. (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]
interpret Event a -> Moment (Event b)
f [Maybe a]
as =
    forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe a]
as) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Event a -> [Maybe a]
unE forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Moment (Event b)
m -> forall a. Moment a -> Int -> a
unM Moment (Event b)
m Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Moment (Event b)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> Event a
E forall a b. (a -> b) -> a -> b
$ ([Maybe a]
as forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat forall a. Maybe a
Nothing)

{-----------------------------------------------------------------------------
    First-order
------------------------------------------------------------------------------}
instance Functor Event where
    fmap :: forall a b. (a -> b) -> Event a -> Event b
fmap a -> b
f (E [Maybe a]
xs) = forall a. [Maybe a] -> Event a
E (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Maybe a]
xs)

instance Functor Behavior where
    fmap :: forall a b. (a -> b) -> Behavior a -> Behavior b
fmap a -> b
f (B [a]
xs) = forall a. [a] -> Behavior 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 :: forall a. a -> Behavior a
pure a
x          = forall a. [a] -> Behavior a
B forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat a
x
    (B [a -> b]
f) <*> :: forall a b. Behavior (a -> b) -> Behavior a -> Behavior b
<*> (B [a]
x) = forall a. [a] -> Behavior a
B forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. (a -> b) -> a -> b
($) [a -> b]
f [a]
x

never :: Event a
never :: forall a. Event a
never = forall a. [Maybe a] -> Event a
E forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat forall a. Maybe a
Nothing

unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a
unionWith :: forall a. (a -> a -> a) -> Event a -> Event a -> Event a
unionWith = forall a c b.
(a -> c)
-> (b -> c) -> (a -> b -> c) -> Event a -> Event b -> Event c
mergeWith forall a. a -> a
id forall a. a -> a
id

mergeWith
  :: (a -> c)
  -> (b -> c)
  -> (a -> b -> c)
  -> Event a
  -> Event b
  -> Event c
mergeWith :: forall a c b.
(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 = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 :: forall a b. Event a -> Event b -> Event (These a b)
merge (E [Maybe a]
xs) (E [Maybe b]
ys) = forall a. [Maybe a] -> Event a
E forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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  = forall a. Maybe a
Nothing
    combine (Just a
x) Maybe b
Nothing  = forall a. a -> Maybe a
Just (forall a b. a -> These a b
This a
x)
    combine Maybe a
Nothing  (Just b
y) = forall a. a -> Maybe a
Just (forall a b. b -> These a b
That b
y)
    combine (Just a
x) (Just b
y) = forall a. a -> Maybe a
Just (forall a b. a -> b -> These a b
These a
x b
y)

filterJust :: Event (Maybe a) -> Event a
filterJust :: forall a. Event (Maybe a) -> Event a
filterJust = forall a. [Maybe a] -> Event a
E forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Event a -> [Maybe a]
unE

apply :: Behavior (a -> b) -> Event a -> Event b
apply :: forall a b. Behavior (a -> b) -> Event a -> Event b
apply (B [a -> b]
fs) = forall a. [Maybe a] -> Event a
E forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\a -> b
f Maybe a
mx -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe a
mx) [a -> b]
fs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Event a -> [Maybe a]
unE

{-----------------------------------------------------------------------------
    Moment and accumulation
------------------------------------------------------------------------------}
newtype Moment a = M { forall a. Moment a -> Int -> a
unM :: Time -> a }

instance Functor     Moment where fmap :: forall a b. (a -> b) -> Moment a -> Moment b
fmap a -> b
f = forall a. (Int -> a) -> Moment a
M forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Moment a -> Int -> a
unM
instance Applicative Moment where
    pure :: forall a. a -> Moment a
pure   = forall a. (Int -> a) -> Moment a
M forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
    <*> :: forall a 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 :: forall a. a -> Moment a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (M Int -> a
m) >>= :: forall a b. Moment a -> (a -> Moment b) -> Moment b
>>= a -> Moment b
k = forall a. (Int -> a) -> Moment a
M forall a b. (a -> b) -> a -> b
$ \Int
time -> forall a. Moment a -> Int -> a
unM (a -> Moment b
k forall a b. (a -> b) -> a -> b
$ Int -> a
m Int
time) Int
time

instance MonadFix Moment where
    mfix :: forall a. (a -> Moment a) -> Moment a
mfix a -> Moment a
f = forall a. (Int -> a) -> Moment a
M forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall a. Moment a -> Int -> a
unM forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Moment a
f)

-- Forget all event occurences before a particular time
forgetE :: Time -> Event a -> [Maybe a]
forgetE :: forall a. Int -> Event a -> [Maybe a]
forgetE Int
time (E [Maybe a]
xs) = forall a. Int -> [a] -> [a]
drop Int
time [Maybe a]
xs

stepper :: a -> Event a -> Moment (Behavior a)
stepper :: forall a. a -> Event a -> Moment (Behavior a)
stepper a
i Event a
e = forall a. (Int -> a) -> Moment a
M forall a b. (a -> b) -> a -> b
$ \Int
time -> forall a. [a] -> Behavior a
B forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
time a
i forall a. [a] -> [a] -> [a]
++ forall {t}. t -> [Maybe t] -> [t]
step a
i (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 forall a. a -> [a] -> [a]
: t -> [Maybe t] -> [t]
step t
next [Maybe t]
xs
        where next :: t
next = forall a. a -> Maybe a -> a
fromMaybe t
i Maybe t
x

-- Expressed using recursion and the other primitives
-- FIXME: Strictness!
accumE :: a -> Event (a -> a) -> Moment (Event a)
accumE :: forall a. 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior a
b) forall a b. Behavior (a -> b) -> Event a -> Event b
`apply` Event (a -> a)
e1
    Behavior a
b <- forall a. a -> Event a -> Moment (Behavior a)
stepper a
a Event a
e2
    forall (m :: * -> *) a. Monad m => a -> m a
return Event a
e2

{-----------------------------------------------------------------------------
    Higher-order
------------------------------------------------------------------------------}
valueB :: Behavior a -> Moment a
valueB :: forall a. Behavior a -> Moment a
valueB (B [a]
b) = forall a. (Int -> a) -> Moment a
M forall a b. (a -> b) -> a -> b
$ \Int
time -> [a]
b forall a. [a] -> Int -> a
!! Int
time

observeE :: Event (Moment a) -> Event a
observeE :: forall a. Event (Moment a) -> Event a
observeE = forall a. [Maybe a] -> Event a
E forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
time -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Moment a
m -> forall a. Moment a -> Int -> a
unM Moment a
m Int
time)) [Int
0..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Event a -> [Maybe a]
unE

switchE :: Event a -> Event (Event a) -> Moment (Event a)
switchE :: forall a. Event a -> Event (Event a) -> Moment (Event a)
switchE Event a
e Event (Event a)
es = forall a. (Int -> a) -> Moment a
M forall a b. (a -> b) -> a -> b
$ \Int
t -> forall a. [Maybe a] -> Event a
E forall a b. (a -> b) -> a -> b
$
    forall a. Int -> a -> [a]
replicate Int
t forall a. Maybe a
Nothing forall a. [a] -> [a] -> [a]
++ forall {a}. [a] -> [Maybe [a]] -> [a]
switch (forall a. Event a -> [Maybe a]
unE Event a
e) (forall a. Int -> Event a -> [Maybe a]
forgetE Int
t (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 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 forall a. a -> [a] -> [a]
: [a] -> [Maybe [a]] -> [a]
switch (forall a. [a] -> [a]
tail [a]
xs) [Maybe [a]]
ys

forgetDiagonalE :: Event (Event a) -> Event [Maybe a]
forgetDiagonalE :: forall a. Event (Event a) -> Event [Maybe a]
forgetDiagonalE = forall a. [Maybe a] -> Event a
E forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
time -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Int -> Event a -> [Maybe a]
forgetE Int
time)) [Int
0..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Event a -> [Maybe a]
unE

switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)
switchB :: forall a. Behavior a -> Event (Behavior a) -> Moment (Behavior a)
switchB Behavior a
b Event (Behavior a)
e = forall a. Behavior (Behavior a) -> Behavior a
diagonalB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> Event a -> Moment (Behavior a)
stepper Behavior a
b Event (Behavior a)
e

diagonalB :: Behavior (Behavior a) -> Behavior a
diagonalB :: forall a. Behavior (Behavior a) -> Behavior a
diagonalB = forall a. [a] -> Behavior a
B forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
time [a]
xs -> [a]
xs forall a. [a] -> Int -> a
!! Int
time) [Int
0..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Behavior a -> [a]
unB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Behavior a -> [a]
unB