{-# LANGUAGE ScopedTypeVariables #-}
-- |
-- Module      : FRP.BearRiver.Simulation
-- Copyright   : (c) Ivan Perez, 2014-2024
--               (c) George Giorgidze, 2007-2012
--               (c) Henrik Nilsson, 2005-2006
--               (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004
-- License     : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  : ivan.perez@keera.co.uk
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
--
-- Execution/simulation of signal functions.
--
-- SFs can be executed in two ways: by running them, feeding input samples one
-- by one, obtained from a monadic environment (presumably, @IO@), or by passing
-- an input stream and calculating an output stream. The former is called
-- /reactimation/, and the latter is called /embedding/.
--
-- * Running:
-- Normally, to run an SF, you would use 'reactimate', providing input samples,
-- and consuming the output samples in the 'IO' monad. This function takes over
-- the program, implementing a "main loop". If you want more control over the
-- evaluation loop (for instance, if you are using BearRiver in combination
-- with a backend that also implements some main loop), you may want to use the
-- lower-level API for reactimation ('ReactHandle', 'reactInit', 'react').
--
-- * Embedding:
-- You can use 'embed' for testing, to evaluate SFs in a terminal, and to embed
-- an SF inside a larger system. The helper functions 'deltaEncode' and
-- 'deltaEncodeBy' facilitate producing input /signals/ from plain lists of
-- input samples.
--
-- This module also includes debugging aids needed to execute signal functions
-- step by step, which are used by BearRiver's testing facilities.
module FRP.BearRiver.Simulation
    (
      -- * Reactimation
      reactimate

      -- ** Low-level reactimation interface
    , ReactHandle
    , reactInit
    , react

      -- * Embedding
    , embed
    , embedSynch
    , deltaEncode
    , deltaEncodeBy

      -- * Debugging / Step by step simulation

    , FutureSF
    , evalAtZero
    , evalAt
    , evalFuture
    )
  where

-- External imports
import Control.Arrow             (arr, (***), (>>>))
import Control.Monad             (unless)
import Control.Monad.Fail        (MonadFail)
import Control.Monad.Trans.Class (lift)
import Data.Functor.Identity     (Identity, runIdentity)
import Data.IORef                (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe                (fromMaybe)

-- Internal imports: dunai
import           Control.Monad.Trans.MSF                 hiding (dSwitch)
import qualified Control.Monad.Trans.MSF                 as MSF
import           Data.MonadicStreamFunction              hiding (embed,
                                                          reactimate)
import qualified Data.MonadicStreamFunction              as MSF
import           Data.MonadicStreamFunction.InternalCore (MSF (MSF, unMSF))

-- Internal imports
import FRP.BearRiver.InternalCore (DTime, SF (..))

-- * Reactimation

-- | Convenience function to run a signal function indefinitely, using a IO
-- actions to obtain new input and process the output.
--
-- This function first runs the initialization action, which provides the
-- initial input for the signal transformer at time 0.
--
-- Afterwards, an input sensing action is used to obtain new input (if any) and
-- the time since the last iteration. The argument to the input sensing function
-- indicates if it can block. If no new input is received, it is assumed to be
-- the same as in the last iteration.
--
-- After applying the signal function to the input, the actuation IO action is
-- executed. The first argument indicates if the output has changed, the second
-- gives the actual output). Actuation functions may choose to ignore the first
-- argument altogether. This action should return True if the reactimation must
-- stop, and False if it should continue.
--
-- Note that this becomes the program's /main loop/, which makes using this
-- function incompatible with GLUT, Gtk and other graphics libraries. It may
-- also impose a sizeable constraint in larger projects in which different
-- subparts run at different time steps. If you need to control the main loop
-- yourself for these or other reasons, use 'reactInit' and 'react'.
reactimate :: Monad m
           => m a                          -- ^ Initialization action
           -> (Bool -> m (DTime, Maybe a)) -- ^ Input sensing action
           -> (Bool -> b -> m Bool)        -- ^ Actuation (output processing)
                                           --   action
           -> SF m a b                     -- ^ Signal function
           -> m ()
reactimate :: forall (m :: * -> *) a b.
Monad m =>
m a
-> (Bool -> m (DTime, Maybe a))
-> (Bool -> b -> m Bool)
-> SF m a b
-> m ()
reactimate m a
senseI Bool -> m (DTime, Maybe a)
sense Bool -> b -> m Bool
actuate SF m a b
sf = do
    MSF m () Bool -> m ()
forall (m :: * -> *). Monad m => MSF m () Bool -> m ()
MSF.reactimateB (MSF m () Bool -> m ()) -> MSF m () Bool -> m ()
forall a b. (a -> b) -> a -> b
$ MSF m () (DTime, a)
forall {a}. MSF m a (DTime, a)
senseSF MSF m () (DTime, a) -> MSF m (DTime, a) Bool -> MSF m () Bool
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m (DTime, a) b
sfIO MSF m (DTime, a) b -> MSF m b Bool -> MSF m (DTime, a) Bool
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m b Bool
actuateSF
    () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    sfIO :: MSF m (DTime, a) b
sfIO = SF m a b -> MSF m (DTime, a) b
forall (m :: * -> *) r a b.
Monad m =>
MSF (ReaderT r m) a b -> MSF m (r, a) b
runReaderS SF m a b
sf

    -- Sense
    senseSF :: MSF m a (DTime, a)
senseSF = MSF m a ((DTime, a), Maybe a)
-> (a -> MSF m a (DTime, a)) -> MSF m a (DTime, a)
forall (m :: * -> *) a b c.
Monad m =>
MSF m a (b, Maybe c) -> (c -> MSF m a b) -> MSF m a b
MSF.dSwitch MSF m a ((DTime, a), Maybe a)
forall {a}. MSF m a ((DTime, a), Maybe a)
senseFirst a -> MSF m a (DTime, a)
forall {a}. a -> MSF m a (DTime, a)
senseRest

    -- Sense: First sample
    senseFirst :: MSF m a ((DTime, a), Maybe a)
senseFirst = m a -> MSF m a a
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM m a
senseI MSF m a a
-> MSF m a ((DTime, a), Maybe a) -> MSF m a ((DTime, a), Maybe a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (a -> ((DTime, a), Maybe a)) -> MSF m a ((DTime, a), Maybe a)
forall b c. (b -> c) -> MSF m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\a
x -> ((DTime
0, a
x), a -> Maybe a
forall a. a -> Maybe a
Just a
x))

    -- Sense: Remaining samples
    senseRest :: a -> MSF m a (DTime, a)
senseRest a
a = m (DTime, Maybe a) -> MSF m a (DTime, Maybe a)
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM (Bool -> m (DTime, Maybe a)
sense Bool
True) MSF m a (DTime, Maybe a)
-> MSF m (DTime, Maybe a) (DTime, a) -> MSF m a (DTime, a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((DTime -> DTime) -> MSF m DTime DTime
forall b c. (b -> c) -> MSF m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr DTime -> DTime
forall a. a -> a
id MSF m DTime DTime
-> MSF m (Maybe a) a -> MSF m (DTime, Maybe a) (DTime, a)
forall b c b' c'. MSF m b c -> MSF m b' c' -> MSF m (b, b') (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a -> MSF m (Maybe a) a
forall (m :: * -> *) a. Monad m => a -> MSF m (Maybe a) a
keepLast a
a)

    keepLast :: Monad m => a -> MSF m (Maybe a) a
    keepLast :: forall (m :: * -> *) a. Monad m => a -> MSF m (Maybe a) a
keepLast a
a = (Maybe a -> m (a, MSF m (Maybe a) a)) -> MSF m (Maybe a) a
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF ((Maybe a -> m (a, MSF m (Maybe a) a)) -> MSF m (Maybe a) a)
-> (Maybe a -> m (a, MSF m (Maybe a) a)) -> MSF m (Maybe a) a
forall a b. (a -> b) -> a -> b
$ \Maybe a
ma ->
      let a' :: a
a' = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
a Maybe a
ma
      in a
a' a -> m (a, MSF m (Maybe a) a) -> m (a, MSF m (Maybe a) a)
forall a b. a -> b -> b
`seq` (a, MSF m (Maybe a) a) -> m (a, MSF m (Maybe a) a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a', a -> MSF m (Maybe a) a
forall (m :: * -> *) a. Monad m => a -> MSF m (Maybe a) a
keepLast a
a')

    -- Consume/render
    actuateSF :: MSF m b Bool
actuateSF = (b -> (Bool, b)) -> MSF m b (Bool, b)
forall b c. (b -> c) -> MSF m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\b
x -> (Bool
True, b
x)) MSF m b (Bool, b) -> MSF m (Bool, b) Bool -> MSF m b Bool
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Bool, b) -> m Bool) -> MSF m (Bool, b) Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM ((Bool -> b -> m Bool) -> (Bool, b) -> m Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> b -> m Bool
actuate)

-- An API for animating a signal function when some other library needs to own
-- the top-level control flow:

-- reactimate's state, maintained across samples:
data ReactState a b = ReactState
  { forall a b.
ReactState a b -> ReactHandle a b -> Bool -> b -> IO Bool
rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool
  , forall a b. ReactState a b -> SF Identity a b
rsSF      :: SF Identity a b
  , forall a b. ReactState a b -> a
rsA       :: a
  , forall a b. ReactState a b -> b
rsB       :: b
  }

-- | A reference to reactimate's state, maintained across samples.
newtype ReactHandle a b = ReactHandle
  { forall a b. ReactHandle a b -> IORef (ReactState a b)
reactHandle :: IORef (ReactState a b) }

-- | Initialize a top-level reaction handle.
reactInit :: IO a                                      -- init
          -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate
          -> SF Identity a b
          -> IO (ReactHandle a b)
reactInit :: forall a b.
IO a
-> (ReactHandle a b -> Bool -> b -> IO Bool)
-> SF Identity a b
-> IO (ReactHandle a b)
reactInit IO a
init ReactHandle a b -> Bool -> b -> IO Bool
actuate (MSF a -> ClockInfo Identity (b, MSF (ClockInfo Identity) a b)
tf0) = do
  a
a0 <- IO a
init
  let (b
b0, MSF (ClockInfo Identity) a b
sf) = ClockInfo Identity (b, MSF (ClockInfo Identity) a b)
-> DTime -> (b, MSF (ClockInfo Identity) a b)
forall r a. Reader r a -> r -> a
runReader (a -> ClockInfo Identity (b, MSF (ClockInfo Identity) a b)
tf0 a
a0) DTime
0
  -- TODO: really need to fix this interface, since right now we just ignore
  -- termination at time 0:
  IORef (ReactState a b)
r' <- ReactState a b -> IO (IORef (ReactState a b))
forall a. a -> IO (IORef a)
newIORef (ReactState { rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool
rsActuate = ReactHandle a b -> Bool -> b -> IO Bool
actuate, rsSF :: MSF (ClockInfo Identity) a b
rsSF = MSF (ClockInfo Identity) a b
sf
                             , rsA :: a
rsA = a
a0, rsB :: b
rsB = b
b0
                             }
                 )
  let r :: ReactHandle a b
r = IORef (ReactState a b) -> ReactHandle a b
forall a b. IORef (ReactState a b) -> ReactHandle a b
ReactHandle IORef (ReactState a b)
r'
  Bool
_ <- ReactHandle a b -> Bool -> b -> IO Bool
actuate ReactHandle a b
r Bool
True b
b0
  ReactHandle a b -> IO (ReactHandle a b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ReactHandle a b
r

-- | Process a single input sample.
react :: ReactHandle a b
      -> (DTime, Maybe a)
      -> IO Bool
react :: forall a b. ReactHandle a b -> (DTime, Maybe a) -> IO Bool
react ReactHandle a b
rh (DTime
dt, Maybe a
ma') = do
  ReactState a b
rs <- IORef (ReactState a b) -> IO (ReactState a b)
forall a. IORef a -> IO a
readIORef (ReactHandle a b -> IORef (ReactState a b)
forall a b. ReactHandle a b -> IORef (ReactState a b)
reactHandle ReactHandle a b
rh)
  let ReactState {rsActuate :: forall a b.
ReactState a b -> ReactHandle a b -> Bool -> b -> IO Bool
rsActuate = ReactHandle a b -> Bool -> b -> IO Bool
actuate, rsSF :: forall a b. ReactState a b -> SF Identity a b
rsSF = SF Identity a b
sf, rsA :: forall a b. ReactState a b -> a
rsA = a
a, rsB :: forall a b. ReactState a b -> b
rsB = b
_b } = ReactState a b
rs

  let a' :: a
a' = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
a Maybe a
ma'
      (b
b', SF Identity a b
sf') = Reader DTime (b, SF Identity a b) -> DTime -> (b, SF Identity a b)
forall r a. Reader r a -> r -> a
runReader (SF Identity a b -> a -> Reader DTime (b, SF Identity a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF Identity a b
sf a
a') DTime
dt
  IORef (ReactState a b) -> ReactState a b -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ReactHandle a b -> IORef (ReactState a b)
forall a b. ReactHandle a b -> IORef (ReactState a b)
reactHandle ReactHandle a b
rh) (ReactState a b
rs {rsSF = sf', rsA = a', rsB = b'})
  Bool
done <- ReactHandle a b -> Bool -> b -> IO Bool
actuate ReactHandle a b
rh Bool
True b
b'
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
done

-- * Embedding

-- | Given a signal function and a pair with an initial input sample for the
-- input signal, and a list of sampling times, possibly with new input samples
-- at those times, it produces a list of output samples.
--
-- This is a simplified, purely-functional version of 'reactimate'.
embed :: Monad m => SF m a b -> (a, [(DTime, Maybe a)]) -> m [b]
embed :: forall (m :: * -> *) a b.
Monad m =>
SF m a b -> (a, [(DTime, Maybe a)]) -> m [b]
embed SF m a b
sf0 (a
a0, [(DTime, Maybe a)]
dtas) = do
    (b
b0, SF m a b
sf) <- ReaderT DTime m (b, SF m a b) -> DTime -> m (b, SF m a b)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SF m a b -> a -> ReaderT DTime m (b, SF m a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m a b
sf0 a
a0) DTime
0
    [b]
bs <- a -> SF m a b -> [(DTime, Maybe a)] -> m [b]
forall {m :: * -> *} {a} {r} {a}.
Monad m =>
a -> MSF (ReaderT r m) a a -> [(r, Maybe a)] -> m [a]
loop a
a0 SF m a b
sf [(DTime, Maybe a)]
dtas
    [b] -> m [b]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> m [b]) -> [b] -> m [b]
forall a b. (a -> b) -> a -> b
$ b
b0 b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
bs
  where
    loop :: a -> MSF (ReaderT r m) a a -> [(r, Maybe a)] -> m [a]
loop a
_ MSF (ReaderT r m) a a
_ [] = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    loop a
aPrev MSF (ReaderT r m) a a
sf ((r
dt, Maybe a
ma) : [(r, Maybe a)]
dtas) = do
      let a :: a
a = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
aPrev Maybe a
ma
      (a
b, MSF (ReaderT r m) a a
sf') <- ReaderT r m (a, MSF (ReaderT r m) a a)
-> r -> m (a, MSF (ReaderT r m) a a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (MSF (ReaderT r m) a a
-> a -> ReaderT r m (a, MSF (ReaderT r m) a a)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF MSF (ReaderT r m) a a
sf a
a) r
dt
      [a]
bs <- a -> MSF (ReaderT r m) a a -> [(r, Maybe a)] -> m [a]
loop a
a MSF (ReaderT r m) a a
sf' [(r, Maybe a)]
dtas
      [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ a
a a -> [a] -> [a]
forall a b. a -> b -> b
`seq` a
b a -> [a] -> [a]
forall a b. a -> b -> b
`seq` (a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
bs)

-- | Synchronous embedding. The embedded signal function is run on the supplied
-- input and time stream at a given (but variable) ratio >= 0 to the outer time
-- flow. When the ratio is 0, the embedded signal function is paused.
embedSynch :: forall m a b
            . (Monad m, MonadFail m)
           => SF m a b -> (a, [(DTime, Maybe a)]) -> SF m Double b
embedSynch :: forall (m :: * -> *) a b.
(Monad m, MonadFail m) =>
SF m a b -> (a, [(DTime, Maybe a)]) -> SF m DTime b
embedSynch SF m a b
sf0 (a
a0, [(DTime, Maybe a)]
dtas) = (DTime -> ClockInfo m (b, MSF (ReaderT DTime m) DTime b))
-> MSF (ReaderT DTime m) DTime b
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF DTime -> ClockInfo m (b, MSF (ReaderT DTime m) DTime b)
tf0
  where
    tts :: [DTime]
tts = (DTime -> (DTime, Maybe a) -> DTime)
-> DTime -> [(DTime, Maybe a)] -> [DTime]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\DTime
t (DTime
dt, Maybe a
_) -> DTime
t DTime -> DTime -> DTime
forall a. Num a => a -> a -> a
+ DTime
dt) DTime
0 [(DTime, Maybe a)]
dtas

    tf0 :: Double -> ReaderT DTime m (b, SF m Double b)
    tf0 :: DTime -> ClockInfo m (b, MSF (ReaderT DTime m) DTime b)
tf0 DTime
_ = do
      bbs :: [b]
bbs@(b
b:[b]
_) <- m [b] -> ReaderT DTime m [b]
forall (m :: * -> *) a. Monad m => m a -> ReaderT DTime m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SF m a b -> (a, [(DTime, Maybe a)]) -> m [b]
forall (m :: * -> *) a b.
Monad m =>
SF m a b -> (a, [(DTime, Maybe a)]) -> m [b]
embed SF m a b
sf0 (a
a0, [(DTime, Maybe a)]
dtas))
      (b, MSF (ReaderT DTime m) DTime b)
-> ClockInfo m (b, MSF (ReaderT DTime m) DTime b)
forall a. a -> ReaderT DTime m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, DTime -> [(DTime, b)] -> MSF (ReaderT DTime m) DTime b
esAux DTime
0 ([DTime] -> [b] -> [(DTime, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DTime]
tts [b]
bbs))

    esAux :: Double -> [(DTime, b)] -> SF m Double b
    esAux :: DTime -> [(DTime, b)] -> MSF (ReaderT DTime m) DTime b
esAux DTime
_      []    = [Char] -> MSF (ReaderT DTime m) DTime b
forall a. HasCallStack => [Char] -> a
error [Char]
"BearRiver: embedSynch: Empty list!"
    -- Invarying below since esAux [] is an error.
    esAux DTime
tpPrev [(DTime, b)]
tbtbs = (DTime -> ClockInfo m (b, MSF (ReaderT DTime m) DTime b))
-> MSF (ReaderT DTime m) DTime b
forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF DTime -> ClockInfo m (b, MSF (ReaderT DTime m) DTime b)
forall {m :: * -> *}.
Monad m =>
DTime -> ReaderT DTime m (b, MSF (ReaderT DTime m) DTime b)
tf -- True
      where
        tf :: DTime -> ReaderT DTime m (b, MSF (ReaderT DTime m) DTime b)
tf DTime
r | DTime
r DTime -> DTime -> Bool
forall a. Ord a => a -> a -> Bool
< DTime
0     = [Char] -> ReaderT DTime m (b, MSF (ReaderT DTime m) DTime b)
forall a. HasCallStack => [Char] -> a
error [Char]
"BearRiver: embedSynch: Negative ratio."
             | Bool
otherwise = do
                 DTime
dt <- ReaderT DTime m DTime
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
                 let tp :: DTime
tp          = DTime
tpPrev DTime -> DTime -> DTime
forall a. Num a => a -> a -> a
+ DTime
dt DTime -> DTime -> DTime
forall a. Num a => a -> a -> a
* DTime
r
                     (b
b, [(DTime, b)]
tbtbs') = DTime -> [(DTime, b)] -> (b, [(DTime, b)])
forall {t} {a}. Ord t => t -> [(t, a)] -> (a, [(t, a)])
advance DTime
tp [(DTime, b)]
tbtbs
                 (b, MSF (ReaderT DTime m) DTime b)
-> ReaderT DTime m (b, MSF (ReaderT DTime m) DTime b)
forall a. a -> ReaderT DTime m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, DTime -> [(DTime, b)] -> MSF (ReaderT DTime m) DTime b
esAux DTime
tp [(DTime, b)]
tbtbs')

    -- Advance the time stamped stream to the perceived time tp. Under the
    -- assumption that the perceived time never goes backwards (non-negative
    -- ratio), advance maintains the invariant that the perceived time is always
    -- >= the first time stamp.
    advance :: t -> [(t, a)] -> (a, [(t, a)])
advance t
_  tbtbs :: [(t, a)]
tbtbs@[(t
_, a
b)] = (a
b, [(t, a)]
tbtbs)
    advance t
tp tbtbtbs :: [(t, a)]
tbtbtbs@((t
_, a
b) : tbtbs :: [(t, a)]
tbtbs@((t
t', a
_) : [(t, a)]
_))
      | t
tp t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<  t
t' = (a
b, [(t, a)]
tbtbtbs)
      | t
t' t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
tp = t -> [(t, a)] -> (a, [(t, a)])
advance t
tp [(t, a)]
tbtbs
    advance t
_ [(t, a)]
_ = (a, [(t, a)])
forall a. HasCallStack => a
undefined

-- | Spaces a list of samples by a fixed time delta, avoiding unnecessary
-- samples when the input has not changed since the last sample.
deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncode :: forall a. Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncode DTime
_  []        = [Char] -> (a, [(DTime, Maybe a)])
forall a. HasCallStack => [Char] -> a
error [Char]
"BearRiver: deltaEncode: Empty input list."
deltaEncode DTime
dt aas :: [a]
aas@(a
_:[a]
_) = (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
forall a.
(a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncodeBy a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) DTime
dt [a]
aas

-- | 'deltaEncode' parameterized by the equality test.
deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncodeBy :: forall a.
(a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
deltaEncodeBy a -> a -> Bool
_  DTime
_  []      = [Char] -> (a, [(DTime, Maybe a)])
forall a. HasCallStack => [Char] -> a
error [Char]
"BearRiver: deltaEncodeBy: Empty input list."
deltaEncodeBy a -> a -> Bool
eq DTime
dt (a
a0:[a]
as) = (a
a0, [DTime] -> [Maybe a] -> [(DTime, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (DTime -> [DTime]
forall a. a -> [a]
repeat DTime
dt) (a -> [a] -> [Maybe a]
debAux a
a0 [a]
as))
  where
    debAux :: a -> [a] -> [Maybe a]
debAux a
_     []                    = []
    debAux a
aPrev (a
a:[a]
as) | a
a a -> a -> Bool
`eq` a
aPrev = Maybe a
forall a. Maybe a
Nothing Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: a -> [a] -> [Maybe a]
debAux a
a [a]
as
                        | Bool
otherwise    = a -> Maybe a
forall a. a -> Maybe a
Just a
a  Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: a -> [a] -> [Maybe a]
debAux a
a [a]
as

-- * Debugging / Step by step simulation

-- | A wrapper around an initialized SF (continuation), needed for testing and
-- debugging purposes.
newtype FutureSF m a b = FutureSF { forall (m :: * -> *) a b. FutureSF m a b -> SF m a b
unsafeSF :: SF m a b }

-- * Debugging / Step by step simulation

-- | Evaluate an SF, and return an output and an initialized SF.
--
-- /WARN/: Do not use this function for standard simulation. This function is
-- intended only for debugging/testing. Apart from being potentially slower and
-- consuming more memory, it also breaks the FRP abstraction by making samples
-- discrete and step based.
evalAtZero :: SF Identity a b -> a -> (b, SF Identity a b)
evalAtZero :: forall a b. SF Identity a b -> a -> (b, SF Identity a b)
evalAtZero SF Identity a b
sf a
a = Identity (b, SF Identity a b) -> (b, SF Identity a b)
forall a. Identity a -> a
runIdentity (Identity (b, SF Identity a b) -> (b, SF Identity a b))
-> Identity (b, SF Identity a b) -> (b, SF Identity a b)
forall a b. (a -> b) -> a -> b
$ ReaderT DTime Identity (b, SF Identity a b)
-> DTime -> Identity (b, SF Identity a b)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SF Identity a b -> a -> ReaderT DTime Identity (b, SF Identity a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF Identity a b
sf a
a) DTime
0

-- | Evaluate an initialized SF, and return an output and a continuation.
--
-- /WARN/: Do not use this function for standard simulation. This function is
-- intended only for debugging/testing. Apart from being potentially slower and
-- consuming more memory, it also breaks the FRP abstraction by making samples
-- discrete and step based.
evalAt :: SF Identity a b -> DTime -> a -> (b, SF Identity a b)
evalAt :: forall a b. SF Identity a b -> DTime -> a -> (b, SF Identity a b)
evalAt SF Identity a b
sf DTime
dt a
a = Identity (b, SF Identity a b) -> (b, SF Identity a b)
forall a. Identity a -> a
runIdentity (Identity (b, SF Identity a b) -> (b, SF Identity a b))
-> Identity (b, SF Identity a b) -> (b, SF Identity a b)
forall a b. (a -> b) -> a -> b
$ ReaderT DTime Identity (b, SF Identity a b)
-> DTime -> Identity (b, SF Identity a b)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SF Identity a b -> a -> ReaderT DTime Identity (b, SF Identity a b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF Identity a b
sf a
a) DTime
dt

-- | Given a signal function and time delta, it moves the signal function into
-- the future, returning a new uninitialized SF and the initial output.
--
-- While the input sample refers to the present, the time delta refers to the
-- future (or to the time between the current sample and the next sample).
--
-- /WARN/: Do not use this function for standard simulation. This function is
-- intended only for debugging/testing. Apart from being potentially slower and
-- consuming more memory, it also breaks the FRP abstraction by making samples
-- discrete and step based.
evalFuture :: SF Identity a b -> a -> DTime -> (b, SF Identity a b)
evalFuture :: forall a b. SF Identity a b -> a -> DTime -> (b, SF Identity a b)
evalFuture SF Identity a b
sf = (DTime -> a -> (b, SF Identity a b))
-> a -> DTime -> (b, SF Identity a b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SF Identity a b -> DTime -> a -> (b, SF Identity a b)
forall a b. SF Identity a b -> DTime -> a -> (b, SF Identity a b)
evalAt SF Identity a b
sf)