diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,13 @@ +2024-08-21 Ivan Perez + * Version bump (0.14.10) (#430). + * Offer all definitions from FRP.Yampa.Integration (#422). + * Offer all definitions from FRP.Yampa.Random (#423). + * Offer all definitions from FRP.Yampa.Task (#424). + * Increase upper bounds on mtl (#427). + * Offer all definitions from FRP.Yampa.Simulation (#425). + * Implement integral using trapezoid rule (#429). + * Thanks to @tomsmeding. + 2024-06-21 Ivan Perez * Version bump (0.14.9) (#420). * Offer all definitions from FRP.Yampa.Hybrid (#419). diff --git a/bearriver.cabal b/bearriver.cabal --- a/bearriver.cabal +++ b/bearriver.cabal @@ -30,7 +30,7 @@ build-type: Simple name: bearriver -version: 0.14.9 +version: 0.14.10 author: Ivan Perez, Manuel Bärenz maintainer: ivan.perez@keera.co.uk homepage: https://github.com/ivanperez-keera/dunai @@ -88,8 +88,11 @@ FRP.BearRiver.Hybrid FRP.BearRiver.Integration FRP.BearRiver.Loop + FRP.BearRiver.Random FRP.BearRiver.Scan + FRP.BearRiver.Simulation FRP.BearRiver.Switches + FRP.BearRiver.Task FRP.BearRiver.Time FRP.Yampa @@ -100,8 +103,8 @@ base >= 4.6 && <5 , deepseq >= 1.3.0.0 && < 1.6 , dunai >= 0.6.0 && < 0.14 - , MonadRandom >= 0.2 && < 0.7 - , mtl >= 2.1.2 && < 2.3 + , mtl >= 2.1.2 && < 2.4 + , random >= 1.1 && < 1.3 , simple-affine-space >= 0.1 && < 0.3 , transformers >= 0.3 && < 0.7 diff --git a/src/FRP/BearRiver.hs b/src/FRP/BearRiver.hs --- a/src/FRP/BearRiver.hs +++ b/src/FRP/BearRiver.hs @@ -22,7 +22,6 @@ -- 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 @@ -30,8 +29,10 @@ -- 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, +import Data.MonadicStreamFunction as X hiding (count, + embed, iPre, + next, once, + reactimate, repeatedly, switch, trace) import qualified Data.MonadicStreamFunction as MSF @@ -45,8 +46,11 @@ import FRP.BearRiver.Hybrid as X import FRP.BearRiver.Integration as X import FRP.BearRiver.InternalCore as X +import FRP.BearRiver.Random as X import FRP.BearRiver.Scan as X +import FRP.BearRiver.Simulation as X import FRP.BearRiver.Switches as X +import FRP.BearRiver.Task as X import FRP.BearRiver.Time as X -- Internal imports (dunai, instances) @@ -77,115 +81,3 @@ -- | 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 = 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 tAvg b - | tAvg <= 0 - = error "bearriver: Non-positive average interval in occasionally." - - | otherwise = proc _ -> do - r <- getRandomRS (0, 1) -< () - dt <- timeDelta -< () - let p = 1 - exp (-(dt / tAvg)) - returnA -< if r < p then Event b else NoEvent - where - timeDelta :: Monad m => SF m a DTime - timeDelta = constM 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 senseI sense actuate sf = do - MSF.reactimateB $ senseSF >>> sfIO >>> actuateSF - return () - where - sfIO = morphS (return.runIdentity) (runReaderS sf) - - -- Sense - senseSF = MSF.dSwitch senseFirst senseRest - - -- Sense: First sample - senseFirst = constM senseI >>> arr (\x -> ((0, x), Just x)) - - -- Sense: Remaining samples - senseRest a = constM (sense True) >>> (arr id *** keepLast a) - - keepLast :: Monad m => a -> MSF m (Maybe a) a - keepLast a = MSF $ \ma -> - let a' = fromMaybe a ma - in a' `seq` return (a', keepLast a') - - -- Consume/render - actuateSF = arr (\x -> (True, x)) >>> arrM (uncurry 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 sf a = runIdentity $ runReaderT (unMSF sf a) 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 sf dt a = runIdentity $ runReaderT (unMSF sf a) 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 sf = flip (evalAt sf) diff --git a/src/FRP/BearRiver/Integration.hs b/src/FRP/BearRiver/Integration.hs --- a/src/FRP/BearRiver/Integration.hs +++ b/src/FRP/BearRiver/Integration.hs @@ -5,12 +5,31 @@ -- License : BSD3 -- Maintainer : ivan.perez@keera.co.uk -- --- Implementation of integrals and derivatives using Monadic Stream Processing --- library. +-- Integration and derivation of input signals. +-- +-- In continuous time, these primitives define SFs that integrate/derive the +-- input signal. Since this is subject to the sampling resolution, simple +-- versions are implemented (like the rectangle rule for the integral). +-- +-- In discrete time, all we do is count the number of events. +-- +-- The combinator 'iterFrom' gives enough flexibility to program your own +-- leak-free integration and derivation SFs. +-- +-- Many primitives and combinators in this module require instances of +-- simple-affine-spaces's 'VectorSpace'. BearRiver does not enforce the use of a +-- particular vector space implementation, meaning you could use 'integral' for +-- example with other vector types like V2, V1, etc. from the library linear. +-- For an example, see +-- . module FRP.BearRiver.Integration ( -- * Integration integral + , imIntegral + , trapezoidIntegral + , impulseIntegral + , count -- * Differentiation , derivative @@ -19,7 +38,7 @@ where -- External imports -import Control.Arrow (returnA) +import Control.Arrow (returnA, (***), (>>^)) import Data.VectorSpace (VectorSpace, zeroVector, (*^), (^+^), (^-^), (^/)) -- Internal imports (dunai) @@ -28,9 +47,11 @@ import Data.MonadicStreamFunction.InternalCore (MSF (MSF)) -- Internal imports +import FRP.BearRiver.Event (Event) +import FRP.BearRiver.Hybrid (accumBy, accumHoldBy) import FRP.BearRiver.InternalCore (DTime, SF) --- * Integration and differentiation +-- * Integration -- | Integration using the rectangle rule. integral :: (Monad m, Fractional s, VectorSpace a s) => SF m a a @@ -43,6 +64,32 @@ integralFrom a0 = proc a -> do dt <- constM ask -< () accumulateWith (^+^) a0 -< realToFrac dt *^ a + +-- | \"Immediate\" integration (using the function's value at the current time). +imIntegral :: (Fractional s, VectorSpace a s, Monad m) + => a -> SF m a a +imIntegral = ((\_ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`) + +-- | Trapezoid integral (using the average between the value at the last time +-- and the value at the current time). +trapezoidIntegral :: (Fractional s, VectorSpace a s, Monad m) => SF m a a +trapezoidIntegral = + iterFrom (\a a' dt v -> v ^+^ (realToFrac dt / 2) *^ (a ^+^ a')) zeroVector + +-- | Integrate the first input signal and add the /discrete/ accumulation (sum) +-- of the second, discrete, input signal. +impulseIntegral :: (Fractional k, VectorSpace a k, Monad m) + => SF m (a, Event a) a +impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^) + +-- | Count the occurrences of input events. +-- +-- >>> embed count (deltaEncode 1 [Event 'a', NoEvent, Event 'b']) +-- [Event 1,NoEvent,Event 2] +count :: (Integral b, Monad m) => SF m (Event a) (Event b) +count = accumBy (\n _ -> n + 1) 0 + +-- * Differentiation -- | A very crude version of a derivative. It simply divides the value -- difference by the time difference. Use at your own risk. diff --git a/src/FRP/BearRiver/Random.hs b/src/FRP/BearRiver/Random.hs new file mode 100644 --- /dev/null +++ b/src/FRP/BearRiver/Random.hs @@ -0,0 +1,84 @@ +-- | +-- Module : FRP.BearRiver.Random +-- 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 : BSD3 +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Signals and signal functions with noise and randomness. +-- +-- The Random number generators are re-exported from "System.Random". +module FRP.BearRiver.Random + ( + -- * Random number generators + RandomGen(..) + , Random(..) + + -- * Noise, random signals, and stochastic event sources + , noise + , noiseR + , occasionally + ) + where + +-- External imports +import System.Random (Random (..), RandomGen (..)) + +-- Internal imports (dunai) +import Control.Monad.Trans.MSF.Except (dSwitch) +import Control.Monad.Trans.MSF.Reader (readerS) +import Data.MonadicStreamFunction (MSF, constM, feedback) + +-- Internal imports +import FRP.BearRiver.Event (Event (..)) +import FRP.BearRiver.InternalCore (DTime, SF, Time, arr) + +-- * Noise (i.e. random signal generators) and stochastic processes + +-- | Noise (random signal) with default range for type in question; based on +-- "randoms". +noise :: (RandomGen g, Random b, Monad m) => g -> SF m a b +noise g0 = streamToSF (randoms g0) + +-- | Noise (random signal) with specified range; based on "randomRs". +noiseR :: (RandomGen g, Random b, Monad m) => (b, b) -> g -> SF m a b +noiseR range g0 = streamToSF (randomRs range g0) + +-- | Turn an infinite list of elements into an SF producing those elements. The +-- SF ignores its input. +streamToSF :: Monad m => [b] -> SF m a b +streamToSF ls = feedback ls $ arr $ fAux . snd + where + fAux [] = error "BearRiver: streamToSF: Empty list!" + fAux (b:bs) = (b, bs) + +-- | 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 :: (RandomGen g, Monad m) => g -> Time -> b -> SF m a (Event b) +occasionally g tAvg x | tAvg > 0 = tf0 + | otherwise = error $ "BearRiver: occasionally: " + ++ "Non-positive average interval." + where + -- Generally, if events occur with an average frequency of f, the + -- probability of at least one event occurring in an interval of t is given + -- by (1 - exp (-f*t)). The goal in the following is to decide whether at + -- least one event occurred in the interval of size dt preceding the current + -- sample point. For the first point, we can think of the preceding interval + -- as being 0, implying no probability of an event occurring. + tf0 = dSwitch + (constM $ return (NoEvent, Just ())) + (const $ feedback (randoms g :: [Time]) $ readerS $ arr occAux) + + -- occAux :: (DTime, (a, [Time])) -> (Event b, [Time]) + occAux (_, (_, [])) = error "BearRiver: occasionally: Empty list!" + occAux (dt, (_, r:rs)) = + (if r < p then Event x else NoEvent, rs) + where + p = 1 - exp (- (dt / tAvg)) -- Probability for at least one event. diff --git a/src/FRP/BearRiver/Simulation.hs b/src/FRP/BearRiver/Simulation.hs new file mode 100644 --- /dev/null +++ b/src/FRP/BearRiver/Simulation.hs @@ -0,0 +1,292 @@ +{-# 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 senseI sense actuate sf = do + MSF.reactimateB $ senseSF >>> sfIO >>> actuateSF + return () + where + sfIO = runReaderS sf + + -- Sense + senseSF = MSF.dSwitch senseFirst senseRest + + -- Sense: First sample + senseFirst = constM senseI >>> arr (\x -> ((0, x), Just x)) + + -- Sense: Remaining samples + senseRest a = constM (sense True) >>> (arr id *** keepLast a) + + keepLast :: Monad m => a -> MSF m (Maybe a) a + keepLast a = MSF $ \ma -> + let a' = fromMaybe a ma + in a' `seq` return (a', keepLast a') + + -- Consume/render + actuateSF = arr (\x -> (True, x)) >>> arrM (uncurry 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 + { rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool + , rsSF :: SF Identity a b + , rsA :: a + , rsB :: b + } + +-- | A reference to reactimate's state, maintained across samples. +newtype ReactHandle a b = ReactHandle + { 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 init actuate (MSF tf0) = do + a0 <- init + let (b0, sf) = runReader (tf0 a0) 0 + -- TODO: really need to fix this interface, since right now we just ignore + -- termination at time 0: + r' <- newIORef (ReactState { rsActuate = actuate, rsSF = sf + , rsA = a0, rsB = b0 + } + ) + let r = ReactHandle r' + _ <- actuate r True b0 + return r + +-- | Process a single input sample. +react :: ReactHandle a b + -> (DTime, Maybe a) + -> IO Bool +react rh (dt, ma') = do + rs <- readIORef (reactHandle rh) + let ReactState {rsActuate = actuate, rsSF = sf, rsA = a, rsB = _b } = rs + + let a' = fromMaybe a ma' + (b', sf') = runReader (unMSF sf a') dt + writeIORef (reactHandle rh) (rs {rsSF = sf', rsA = a', rsB = b'}) + done <- actuate rh True b' + return 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 sf0 (a0, dtas) = do + (b0, sf) <- runReaderT (unMSF sf0 a0) 0 + bs <- loop a0 sf dtas + return $ b0 : bs + where + loop _ _ [] = return [] + loop aPrev sf ((dt, ma) : dtas) = do + let a = fromMaybe aPrev ma + (b, sf') <- runReaderT (unMSF sf a) dt + bs <- loop a sf' dtas + return $ a `seq` b `seq` (b : 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 sf0 (a0, dtas) = MSF tf0 + where + tts = scanl (\t (dt, _) -> t + dt) 0 dtas + + tf0 :: Double -> ReaderT DTime m (b, SF m Double b) + tf0 _ = do + bbs@(b:_) <- lift (embed sf0 (a0, dtas)) + return (b, esAux 0 (zip tts bbs)) + + esAux :: Double -> [(DTime, b)] -> SF m Double b + esAux _ [] = error "BearRiver: embedSynch: Empty list!" + -- Invarying below since esAux [] is an error. + esAux tpPrev tbtbs = MSF tf -- True + where + tf r | r < 0 = error "BearRiver: embedSynch: Negative ratio." + | otherwise = do + dt <- ask + let tp = tpPrev + dt * r + (b, tbtbs') = advance tp tbtbs + return (b, esAux tp 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 _ tbtbs@[(_, b)] = (b, tbtbs) + advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _)) + | tp < t' = (b, tbtbtbs) + | t' <= tp = advance tp tbtbs + advance _ _ = 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 _ [] = error "BearRiver: deltaEncode: Empty input list." +deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas + +-- | 'deltaEncode' parameterized by the equality test. +deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)]) +deltaEncodeBy _ _ [] = error "BearRiver: deltaEncodeBy: Empty input list." +deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as)) + where + debAux _ [] = [] + debAux aPrev (a:as) | a `eq` aPrev = Nothing : debAux a as + | otherwise = Just a : debAux 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 { 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 sf a = runIdentity $ runReaderT (unMSF sf a) 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 sf dt a = runIdentity $ runReaderT (unMSF sf a) 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 sf = flip (evalAt sf) diff --git a/src/FRP/BearRiver/Task.hs b/src/FRP/BearRiver/Task.hs new file mode 100644 --- /dev/null +++ b/src/FRP/BearRiver/Task.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +-- | +-- Module : FRP.BearRiver.Task +-- 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 : BSD3 +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Task abstraction on top of signal transformers. +module FRP.BearRiver.Task + ( + -- * The Task type + Task + , mkTask + , runTask + , runTask_ + , taskToSF + + -- * Basic tasks + , constT + , sleepT + , snapT + + -- * Basic tasks combinators + , timeOut + , abortWhen + ) + where + +-- External imports +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative (Applicative(..)) +#endif + +-- Internal imports +import FRP.BearRiver.Basic (constant) +import FRP.BearRiver.Event (Event, lMerge) +import FRP.BearRiver.EventS (after, edgeBy, never, snap) +import FRP.BearRiver.InternalCore (SF, Time, arr, first, (&&&), (>>>)) +import FRP.BearRiver.Switches (switch) + +infixl 0 `timeOut`, `abortWhen` + +-- * The Task type + +-- | A task is a partially SF that may terminate with a result. +newtype Task m a b c = + -- CPS-based representation allowing termination to be detected. Note the + -- rank 2 polymorphic type! The representation can be changed if necessary, + -- but the Monad laws follow trivially in this case. + Task (forall d . (c -> SF m a (Either b d)) -> SF m a (Either b d)) + +unTask :: Monad m + => Task m a b c -> ((c -> SF m a (Either b d)) -> SF m a (Either b d)) +unTask (Task f) = f + +-- | Creates a 'Task' from an SF that returns, as a second output, an 'Event' +-- when the SF terminates. See 'switch'. +mkTask :: Monad m => SF m a (b, Event c) -> Task m a b c +mkTask st = Task (switch (st >>> first (arr Left))) + +-- | Runs a task. +-- +-- The output from the resulting signal transformer is tagged with Left while +-- the underlying task is running. Once the task has terminated, the output +-- goes constant with the value Right x, where x is the value of the +-- terminating event. + +-- Check name. +runTask :: Monad m => Task m a b c -> SF m a (Either b c) +runTask tk = (unTask tk) (constant . Right) + +-- | Runs a task that never terminates. +-- +-- The output becomes undefined once the underlying task has terminated. +-- +-- Convenience function for tasks which are known not to terminate. +runTask_ :: Monad m => Task m a b c -> SF m a b +runTask_ tk = + runTask tk + >>> arr (either id (error "BearRiverTask: runTask_: Task terminated!")) + +-- | Creates an SF that represents an SF and produces an event when the task +-- terminates, and otherwise produces just an output. +taskToSF :: Monad m => Task m a b c -> SF m a (b, Event c) +taskToSF tk = + runTask tk + >>> (arr (either id (error "BearRiverTask: runTask_: Task terminated!")) + &&& edgeBy isEdge (Left undefined)) + where + isEdge (Left _) (Right c) = Just c + isEdge _ _ = Nothing + +-- * Functor, Applicative and Monad instance + +instance Monad m => Functor (Task m a b) where + fmap f tk = Task (\k -> unTask tk (k . f)) + +instance Monad m => Applicative (Task m a b) where + pure x = Task (\k -> k x) + f <*> v = Task (\k -> (unTask f) (\c -> unTask v (k . c))) + +instance Monad m => Monad (Task m a b) where + tk >>= f = Task (\k -> unTask tk (\c -> unTask (f c) k)) + return = pure + +-- Let's check the monad laws: +-- +-- t >>= return +-- = \k -> t (\c -> return c k) +-- = \k -> t (\c -> (\x -> \k -> k x) c k) +-- = \k -> t (\c -> (\x -> \k' -> k' x) c k) +-- = \k -> t (\c -> k c) +-- = \k -> t k +-- = t +-- QED +-- +-- return x >>= f +-- = \k -> (return x) (\c -> f c k) +-- = \k -> (\k -> k x) (\c -> f c k) +-- = \k -> (\k' -> k' x) (\c -> f c k) +-- = \k -> (\c -> f c k) x +-- = \k -> f x k +-- = f x +-- QED +-- +-- (t >>= f) >>= g +-- = \k -> (t >>= f) (\c -> g c k) +-- = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k) +-- = \k -> t (\c' -> f c' (\c -> g c k)) +-- = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k) +-- = \k -> t (\c' -> (\x -> f x >>= g) c' k) +-- = t >>= (\x -> f x >>= g) +-- QED +-- +-- No surprises (obviously, since this is essentially just the CPS monad). + +-- * Basic tasks + +-- | Non-terminating task with constant output b. +constT :: Monad m => b -> Task m a b c +constT b = mkTask (constant b &&& never) + +-- | "Sleeps" for t seconds with constant output b. +sleepT :: Monad m => Time -> b -> Task m a b () +sleepT t b = mkTask (constant b &&& after t ()) + +-- | Takes a "snapshot" of the input and terminates immediately with the input +-- value as the result. +-- +-- No time passes; therefore, the following must hold: +-- +-- @snapT >> snapT = snapT@ +snapT :: Monad m => Task m a b a +snapT = mkTask (constant (error "BearRiverTask: snapT: Bad switch?") &&& snap) + +-- * Basic tasks combinators + +-- | Impose a time out on a task. +timeOut :: Monad m => Task m a b c -> Time -> Task m a b (Maybe c) +tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux) + where + aux ((b, ec), et) = (b, lMerge (fmap Just ec) (fmap (const Nothing) et)) + +-- | Run a "guarding" event source (SF m a (Event b)) in parallel with a +-- (possibly non-terminating) task. +-- +-- The task will be aborted at the first occurrence of the event source (if it +-- has not terminated itself before that). +-- +-- Useful for separating sequencing and termination concerns. E.g. we can do +-- something "useful", but in parallel watch for a (exceptional) condition +-- which should terminate that activity, without having to check for that +-- condition explicitly during each and every phase of the activity. +-- +-- Example: @tsk `abortWhen` lbp@ +abortWhen :: Monad m + => Task m a b c -> SF m a (Event d) -> Task m a b (Either c d) +tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux) + where + aux ((b, ec), ed) = (b, lMerge (fmap Left ec) (fmap Right ed)) diff --git a/src/FRP/Yampa.hs b/src/FRP/Yampa.hs --- a/src/FRP/Yampa.hs +++ b/src/FRP/Yampa.hs @@ -9,7 +9,7 @@ import Data.Functor.Identity (Identity) -- Internal imports -import FRP.BearRiver as X hiding (SF) +import FRP.BearRiver as X hiding (FutureSF, SF) import qualified FRP.BearRiver as BR -- | Signal function (conceptually, a function between signals that respects