{----------------------------------------------------------------------------- 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