{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
{-# LANGUAGE RecursiveDo #-}
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, 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

{-$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 { unE :: [Maybe a] } deriving (Show)

-- | Behavior is modeled by an /infinite/ list of values.
-- It is isomorphic to @Time -> a@.
newtype Behavior a = B { unB :: [a] } deriving (Show)

interpret :: (Event a -> Moment (Event b)) -> [Maybe a] -> [Maybe b]
interpret f as =
    take (length as) . unE . (\m -> unM m 0) . f . E $ (as ++ repeat Nothing)

{-----------------------------------------------------------------------------
    First-order
------------------------------------------------------------------------------}
instance Functor Event where
    fmap f (E xs) = E (fmap (fmap f) xs)

instance Functor Behavior where
    fmap f (B xs) = B (fmap f xs)

instance Applicative Behavior where
    pure x          = B $ repeat x
    (B f) <*> (B x) = B $ zipWith ($) f x

never :: Event a
never = E $ repeat Nothing

unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a
unionWith f (E xs) (E ys) = E $ zipWith combine xs ys
    where
    combine (Just x) (Just y) = Just $ f x y
    combine (Just x) Nothing  = Just x
    combine Nothing  (Just y) = Just y
    combine Nothing  Nothing  = Nothing

filterJust :: Event (Maybe a) -> Event a
filterJust = E . fmap join . unE

apply :: Behavior (a -> b) -> Event a -> Event b
apply (B fs) = E . zipWith (\f mx -> fmap f mx) fs . unE

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

instance Functor     Moment where fmap f = M . fmap f . unM
instance Applicative Moment where
    pure   = M . const
    (<*>)  = ap
instance Monad Moment where
    return = pure
    (M m) >>= k = M $ \time -> unM (k $ m time) time

instance MonadFix Moment where
    mfix f = M $ mfix (unM . f)

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

stepper :: a -> Event a -> Moment (Behavior a)
stepper i e = M $ \time -> B $ replicate time i ++ step i (forgetE time e)
    where
    step i ~(x:xs) = i : step next xs
        where next = case x of
                        Just i  -> i
                        Nothing -> i

-- Expressed using recursion and the other primitives
-- FIXME: Strictness!
accumE :: a -> Event (a -> a) -> Moment (Event a)
accumE a e1 = mdo
    let e2 = ((\a f -> f a) <$> b) `apply` e1
    b <- stepper a e2
    return e2

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

observeE :: Event (Moment a) -> Event a
observeE = E . zipWith (\time -> fmap (\m -> unM m time)) [0..] . unE

switchE :: Event (Event a) -> Moment (Event a)
switchE es = M $ \t -> E $
    replicate t Nothing ++ switch (unE never) (forgetE t (forgetDiagonalE es))
    where
    switch (x:xs) (Nothing : ys) = x : switch xs ys
    switch (x: _) (Just xs : ys) = x : switch (tail xs) ys

forgetDiagonalE :: Event (Event a) -> Event [Maybe a]
forgetDiagonalE = E . zipWith (\time -> fmap (forgetE time)) [0..] . unE

switchB :: Behavior a -> Event (Behavior a) -> Moment (Behavior a)
switchB b e = diagonalB <$> stepper b e

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