{-# LANGUAGE Arrows     #-}
{-# LANGUAGE CPP        #-}
{-# LANGUAGE RankNTypes #-}
-- The following warning is disabled so that we do not see warnings due to
-- using ListT on an MSF to implement parallelism with broadcasting.
#if __GLASGOW_HASKELL__ < 800
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
#else
{-# OPTIONS_GHC -Wno-deprecations #-}
#endif
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |
-- Copyright  : (c) Ivan Perez, 2019-2022
--              (c) Ivan Perez and Manuel Baerenz, 2016-2018
-- License    : BSD3
-- Maintainer : ivan.perez@keera.co.uk
--
-- Implementation of Yampa using Monadic Stream Processing library.
module FRP.BearRiver
    (module FRP.BearRiver, module X)
  where

-- External imports
import Control.Arrow         as X
import Control.Monad.Random  (MonadRandom)
import Data.Functor.Identity (Identity (..))
import Data.Maybe            (fromMaybe)
import Data.VectorSpace      as X

-- Internal imports (dunai)
import           Control.Monad.Trans.MSF                 hiding (dSwitch)
import qualified Control.Monad.Trans.MSF                 as MSF
import           Data.MonadicStreamFunction              as X hiding (iPre,
                                                               once, reactimate,
                                                               repeatedly,
                                                               switch, trace)
import qualified Data.MonadicStreamFunction              as MSF
import           Data.MonadicStreamFunction.InternalCore (MSF (MSF, unMSF))
import           FRP.BearRiver.Arrow                     as X
import           FRP.BearRiver.Basic                     as X
import           FRP.BearRiver.Conditional               as X
import           FRP.BearRiver.Delays                    as X
import           FRP.BearRiver.Event                     as X
import           FRP.BearRiver.EventS                    as X
import           FRP.BearRiver.Hybrid                    as X
import           FRP.BearRiver.Integration               as X
import           FRP.BearRiver.InternalCore              as X
import           FRP.BearRiver.Scan                      as X
import           FRP.BearRiver.Switches                  as X
import           FRP.BearRiver.Time                      as X

-- Internal imports (dunai, instances)
import Data.MonadicStreamFunction.Instances.ArrowLoop () -- not needed, just
                                                         -- re-exported

-- ** Relation to other types

-- | Convert an 'Event' into a 'Maybe' value.
--
-- Both types are isomorphic, where a value containing an event is mapped to a
-- 'Just', and 'NoEvent' is mapped to 'Nothing'. There is, however, a semantic
-- difference: a signal carrying a Maybe may change constantly, but, for a
-- signal carrying an 'Event', there should be a bounded frequency such that
-- sampling the signal faster does not render more event occurrences.
eventToMaybe :: Event a -> Maybe a
eventToMaybe :: forall a. Event a -> Maybe a
eventToMaybe = Maybe a -> (a -> Maybe a) -> Event a -> Maybe a
forall a b. a -> (b -> a) -> Event b -> a
event Maybe a
forall a. Maybe a
Nothing a -> Maybe a
forall a. a -> Maybe a
Just

-- | Create an event if a 'Bool' is 'True'.
boolToEvent :: Bool -> Event ()
boolToEvent :: Bool -> Event ()
boolToEvent Bool
True  = () -> Event ()
forall a. a -> Event a
Event ()
boolToEvent Bool
False = Event ()
forall a. Event a
NoEvent

-- * State keeping combinators

-- ** Loops with guaranteed well-defined feedback

-- | Loop with an initial value for the signal being fed back.
loopPre :: Monad m => c -> SF m (a, c) (b, c) -> SF m a b
loopPre :: forall (m :: * -> *) c a b.
Monad m =>
c -> SF m (a, c) (b, c) -> SF m a b
loopPre = c -> MSF (ClockInfo m) (a, c) (b, c) -> MSF (ClockInfo m) a b
forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback

-- * Noise (random signal) sources and stochastic event sources

-- | Stochastic event source with events occurring on average once every tAvg
-- seconds. However, no more than one event results from any one sampling
-- interval in the case of relatively sparse sampling, thus avoiding an "event
-- backlog" should sampling become more frequent at some later point in time.
occasionally :: MonadRandom m
             => Time -- ^ The time /q/ after which the event should be produced
                     -- on average
             -> b    -- ^ Value to produce at time of event
             -> SF m a (Event b)
occasionally :: forall (m :: * -> *) b a.
MonadRandom m =>
Time -> b -> SF m a (Event b)
occasionally Time
tAvg b
b
    | Time
tAvg Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
0
    = [Char] -> SF m a (Event b)
forall a. HasCallStack => [Char] -> a
error [Char]
"bearriver: Non-positive average interval in occasionally."

    | Bool
otherwise = proc a
_ -> do
        Time
r   <- (Time, Time) -> MSF (ClockInfo m) () Time
forall (m :: * -> *) b a.
(MonadRandom m, Random b) =>
(b, b) -> MSF m a b
getRandomRS (Time
0, Time
1) -< ()
        Time
dt  <- MSF (ClockInfo m) () Time
forall (m :: * -> *) a. Monad m => SF m a Time
timeDelta          -< ()
        let p :: Time
p = Time
1 Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time -> Time
forall a. Floating a => a -> a
exp (-(Time
dt Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
tAvg))
        MSF (ClockInfo m) (Event b) (Event b)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< if Time
r Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
p then b -> Event b
forall a. a -> Event a
Event b
b else Event b
forall a. Event a
NoEvent
  where
    timeDelta :: Monad m => SF m a DTime
    timeDelta :: forall (m :: * -> *) a. Monad m => SF m a Time
timeDelta = ClockInfo m Time -> MSF (ClockInfo m) a Time
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM ClockInfo m Time
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

-- * Execution/simulation

-- ** 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
           -> (Bool -> m (DTime, Maybe a))
           -> (Bool -> b -> m Bool)
           -> SF Identity a b
           -> m ()
reactimate :: forall (m :: * -> *) a b.
Monad m =>
m a
-> (Bool -> m (Time, Maybe a))
-> (Bool -> b -> m Bool)
-> SF Identity a b
-> m ()
reactimate m a
senseI Bool -> m (Time, Maybe a)
sense Bool -> b -> m Bool
actuate SF Identity 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 () (Time, a)
forall {a}. MSF m a (Time, a)
senseSF MSF m () (Time, a) -> MSF m (Time, 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 (Time, a) b
sfIO MSF m (Time, a) b -> MSF m b Bool -> MSF m (Time, 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 (Time, a) b
sfIO = (forall c. Identity c -> m c)
-> MSF Identity (Time, a) b -> MSF m (Time, a) b
forall (m2 :: * -> *) (m1 :: * -> *) a b.
(Monad m2, Monad m1) =>
(forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS (c -> m c
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return(c -> m c) -> (Identity c -> c) -> Identity c -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Identity c -> c
forall a. Identity a -> a
runIdentity) (SF Identity a b -> MSF Identity (Time, a) b
forall (m :: * -> *) r a b.
Monad m =>
MSF (ReaderT r m) a b -> MSF m (r, a) b
runReaderS SF Identity a b
sf)

    -- Sense
    senseSF :: MSF m a (Time, a)
senseSF = MSF m a ((Time, a), Maybe a)
-> (a -> MSF m a (Time, a)) -> MSF m a (Time, 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 ((Time, a), Maybe a)
forall {a}. MSF m a ((Time, a), Maybe a)
senseFirst a -> MSF m a (Time, a)
forall {a}. a -> MSF m a (Time, a)
senseRest

    -- Sense: First sample
    senseFirst :: MSF m a ((Time, 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 ((Time, a), Maybe a) -> MSF m a ((Time, 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 -> ((Time, a), Maybe a)) -> MSF m a ((Time, 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 -> ((Time
0, a
x), a -> Maybe a
forall a. a -> Maybe a
Just a
x))

    -- Sense: Remaining samples
    senseRest :: a -> MSF m a (Time, a)
senseRest a
a = m (Time, Maybe a) -> MSF m a (Time, Maybe a)
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM (Bool -> m (Time, Maybe a)
sense Bool
True) MSF m a (Time, Maybe a)
-> MSF m (Time, Maybe a) (Time, a) -> MSF m a (Time, a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Time -> Time) -> MSF m Time Time
forall b c. (b -> c) -> MSF m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Time -> Time
forall a. a -> a
id MSF m Time Time
-> MSF m (Maybe a) a -> MSF m (Time, Maybe a) (Time, 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)

-- * 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 Time Identity (b, SF Identity a b)
-> Time -> Identity (b, SF Identity a b)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SF Identity a b -> a -> ReaderT Time 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) Time
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 -> Time -> a -> (b, SF Identity a b)
evalAt SF Identity a b
sf Time
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 Time Identity (b, SF Identity a b)
-> Time -> Identity (b, SF Identity a b)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SF Identity a b -> a -> ReaderT Time 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) Time
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 -> Time -> (b, SF Identity a b)
evalFuture SF Identity a b
sf = (Time -> a -> (b, SF Identity a b))
-> a -> Time -> (b, SF Identity a b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SF Identity a b -> Time -> a -> (b, SF Identity a b)
forall a b. SF Identity a b -> Time -> a -> (b, SF Identity a b)
evalAt SF Identity a b
sf)