diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,11 @@ +2023-10-21 Ivan Perez + * Version bump (0.14.5) (#388). + * Offer all definitions from FRP.Yampa.Event (#380). + * Offer all definitions from FRP.Yampa.Conditional (#382). + * Offer all definitions from FRP.Yampa.Scan (#383). + * Offer all definitions from FRP.Yampa.Delays (#384). + * Relax upper version constraint on deepseq (#386). + 2023-08-21 Ivan Perez * Version bump (0.14.4) (#377). * Offer all definitions from FRP.Yampa.Basic (#376). 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.4 +version: 0.14.5 author: Ivan Perez, Manuel Bärenz maintainer: ivan.perez@keera.co.uk homepage: https://github.com/ivanperez-keera/dunai @@ -78,6 +78,12 @@ FRP.BearRiver FRP.BearRiver.Arrow FRP.BearRiver.Basic + FRP.BearRiver.Conditional + FRP.BearRiver.Delays + FRP.BearRiver.Event + FRP.BearRiver.EventS + FRP.BearRiver.Scan + FRP.BearRiver.Switches FRP.Yampa other-modules: @@ -85,8 +91,8 @@ build-depends: base >= 4.6 && <5 - , deepseq >= 1.3.0.0 && < 1.5 - , dunai >= 0.6.0 && < 0.12 + , deepseq >= 1.3.0.0 && < 1.6 + , dunai >= 0.6.0 && < 0.13 , MonadRandom >= 0.2 && < 0.7 , mtl >= 2.1.2 && < 2.3 , simple-affine-space >= 0.1 && < 0.3 diff --git a/src/FRP/BearRiver.hs b/src/FRP/BearRiver.hs --- a/src/FRP/BearRiver.hs +++ b/src/FRP/BearRiver.hs @@ -21,104 +21,35 @@ where -- External imports -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative (..), (<$>)) -#endif -import Control.Applicative (Alternative (..)) -import Control.Arrow as X -import Control.DeepSeq (NFData (..)) -import qualified Control.Monad.Fail as Fail -import Control.Monad.Random (MonadRandom) -import Data.Functor.Identity (Identity (..)) -import Data.Maybe (fromMaybe) -import Data.Traversable as T -import Data.VectorSpace as X +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, - switch) +import Control.Monad.Trans.MSF hiding (dSwitch) import qualified Control.Monad.Trans.MSF as MSF -import Control.Monad.Trans.MSF.List (sequenceS, widthFirst) -import Data.MonadicStreamFunction (iPre) -import Data.MonadicStreamFunction as X hiding - (reactimate, +import Data.MonadicStreamFunction as X hiding (iPre, + once, reactimate, repeatedly, - trace) + 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.InternalCore as X +import FRP.BearRiver.Scan as X +import FRP.BearRiver.Switches as X -- Internal imports (dunai, instances) import Data.MonadicStreamFunction.Instances.ArrowLoop () -- not needed, just -- re-exported - -- --- * Basic definitions - --- | A single possible event occurrence, that is, a value that may or may not --- occur. Events are used to represent values that are not produced --- continuously, such as mouse clicks (only produced when the mouse is clicked, --- as opposed to mouse positions, which are always defined). -data Event a = Event a | NoEvent - deriving (Eq, Ord, Show) - --- | The type 'Event' is isomorphic to 'Maybe'. The 'Functor' instance of --- 'Event' is analogous to the 'Functor' instance of 'Maybe', where the given --- function is applied to the value inside the 'Event', if any. -instance Functor Event where - fmap _ NoEvent = NoEvent - fmap f (Event c) = Event (f c) - --- | The type 'Event' is isomorphic to 'Maybe'. The 'Applicative' instance of --- 'Event' is analogous to the 'Applicative' instance of 'Maybe', where the --- lack of a value (i.e., 'NoEvent') causes '(<*>)' to produce no value --- ('NoEvent'). -instance Applicative Event where - pure = Event - - Event f <*> Event x = Event (f x) - _ <*> _ = NoEvent - --- | The type 'Event' is isomorphic to 'Maybe'. The 'Monad' instance of 'Event' --- is analogous to the 'Monad' instance of 'Maybe', where the lack of a value --- (i.e., 'NoEvent') causes bind to produce no value ('NoEvent'). -instance Monad Event where - return = pure - - Event x >>= f = f x - NoEvent >>= _ = NoEvent - --- | MonadFail instance -instance Fail.MonadFail Event where - -- | Fail with 'NoEvent'. - fail _ = NoEvent - --- | Alternative instance -instance Alternative Event where - -- | An empty alternative carries no event, so it is ignored. - empty = NoEvent - -- | Merge favouring the left event ('NoEvent' only if both are 'NoEvent'). - NoEvent <|> r = r - l <|> _ = l - --- | NFData instance -instance NFData a => NFData (Event a) where - -- | Evaluate value carried by event. - rnf NoEvent = () - rnf (Event a) = rnf a `seq` () - --- ** Lifting - --- | Lifts a pure function into a signal function (applied pointwise). -arrPrim :: Monad m => (a -> b) -> SF m a b -arrPrim = arr - --- | Lifts a pure function into a signal function applied to events (applied --- pointwise). -arrEPrim :: Monad m => (Event a -> b) -> SF m (Event a) b -arrEPrim = arr - -- * Signal functions -- ** Basic signal functions @@ -131,103 +62,6 @@ time :: Monad m => SF m a Time time = localTime - --- * Simple, stateful signal processing - --- | Applies a function point-wise, using the last output as next input. This --- creates a well-formed loop based on a pure, auxiliary function. -sscan :: Monad m => (b -> a -> b) -> b -> SF m a b -sscan f bInit = feedback bInit u - where - u = undefined -- (arr f >>^ dup) - --- | Generic version of 'sscan', in which the auxiliary function produces an --- internal accumulator and an "held" output. --- --- Applies a function point-wise, using the last known 'Just' output to form --- the output, and next input accumulator. If the output is 'Nothing', the last --- known accumulators are used. This creates a well-formed loop based on a --- pure, auxiliary function. -sscanPrim :: Monad m => (c -> a -> Maybe (c, b)) -> c -> b -> SF m a b -sscanPrim f cInit bInit = MSF $ \a -> do - let o = f cInit a - case o of - Nothing -> return (bInit, sscanPrim f cInit bInit) - Just (c', b') -> return (b', sscanPrim f c' b') - --- | Event source that never occurs. -never :: Monad m => SF m a (Event b) -never = constant NoEvent - --- | Event source with a single occurrence at time 0. The value of the event is --- given by the function argument. -now :: Monad m => b -> SF m a (Event b) -now b0 = Event b0 --> never - --- | Event source with a single occurrence at or as soon after (local) time /q/ --- as possible. -after :: Monad m - => Time -- ^ The time /q/ after which the event should be produced - -> b -- ^ Value to produce at that time - -> SF m a (Event b) -after q x = feedback q go - where - go = MSF $ \(_, t) -> do - dt <- ask - let t' = t - dt - e = if t > 0 && t' < 0 then Event x else NoEvent - ct = if t' < 0 then constant (NoEvent, t') else go - return ((e, t'), ct) - --- | Event source with repeated occurrences with interval q. --- --- Note: If the interval is too short w.r.t. the sampling intervals, the result --- will be that events occur at every sample. However, no more than one event --- results from any sampling interval, thus avoiding an "event backlog" should --- sampling become more frequent at some later point in time. -repeatedly :: Monad m => Time -> b -> SF m a (Event b) -repeatedly q x - | q > 0 = afterEach qxs - | otherwise = error "bearriver: repeatedly: Non-positive period." - where - qxs = (q, x):qxs - --- | Event source with consecutive occurrences at the given intervals. --- --- Should more than one event be scheduled to occur in any sampling interval, --- only the first will in fact occur to avoid an event backlog. - --- After all, after, repeatedly etc. are defined in terms of afterEach. -afterEach :: Monad m => [(Time, b)] -> SF m a (Event b) -afterEach qxs = afterEachCat qxs >>> arr (fmap head) - --- | Event source with consecutive occurrences at the given intervals. --- --- Should more than one event be scheduled to occur in any sampling interval, --- the output list will contain all events produced during that interval. -afterEachCat :: Monad m => [(Time, b)] -> SF m a (Event [b]) -afterEachCat = afterEachCat' 0 - where - afterEachCat' :: Monad m => Time -> [(Time, b)] -> SF m a (Event [b]) - afterEachCat' _ [] = never - afterEachCat' t qxs = MSF $ \_ -> do - dt <- ask - let (ev, t', qxs') = fireEvents [] (t + dt) qxs - ev' = if null ev - then NoEvent - else Event (reverse ev) - - return (ev', afterEachCat' t' qxs') - - fireEvents :: [b] -> Time -> [(Time, b)] -> ([b], Time, [(Time, b)]) - fireEvents ev t [] = (ev, t, []) - fireEvents ev t (qx:qxs) - | fst qx < 0 = error "bearriver: afterEachCat: Non-positive period." - | overdue >= 0 = fireEvents (snd qx:ev) overdue qxs - | otherwise = (ev, t, qx:qxs) - where - overdue = t - fst qx - -- * Events -- | Apply an 'MSF' to every input. Freezes temporarily if the input is @@ -254,371 +88,6 @@ boolToEvent True = Event () boolToEvent False = NoEvent --- * Hybrid SF m combinators - --- | A rising edge detector. Useful for things like detecting key presses. It --- is initialised as /up/, meaning that events occurring at time 0 will not be --- detected. -edge :: Monad m => SF m Bool (Event ()) -edge = edgeFrom True - --- | A rising edge detector that can be initialized as up ('True', meaning that --- events occurring at time 0 will not be detected) or down ('False', meaning --- that events occurring at time 0 will be detected). -iEdge :: Monad m => Bool -> SF m Bool (Event ()) -iEdge = edgeFrom - --- | Like 'edge', but parameterized on the tag value. --- --- From Yampa -edgeTag :: Monad m => a -> SF m Bool (Event a) -edgeTag a = edge >>> arr (`tag` a) - --- | Edge detector particularized for detecting transitions on a 'Maybe' --- signal from 'Nothing' to 'Just'. --- --- From Yampa - --- !!! 2005-07-09: To be done or eliminated --- !!! Maybe could be kept as is, but could be easy to implement directly in --- !!! terms of sscan? -edgeJust :: Monad m => SF m (Maybe a) (Event a) -edgeJust = edgeBy isJustEdge (Just undefined) - where - isJustEdge Nothing Nothing = Nothing - isJustEdge Nothing ma@(Just _) = ma - isJustEdge (Just _) (Just _) = Nothing - isJustEdge (Just _) Nothing = Nothing - --- | Edge detector parameterized on the edge detection function and initial --- state, i.e., the previous input sample. The first argument to the edge --- detection function is the previous sample, the second the current one. -edgeBy :: Monad m => (a -> a -> Maybe b) -> a -> SF m a (Event b) -edgeBy isEdge aPrev = MSF $ \a -> - return (maybeToEvent (isEdge aPrev a), edgeBy isEdge a) - --- | Convert a maybe value into a event ('Event' is isomorphic to 'Maybe'). -maybeToEvent :: Maybe a -> Event a -maybeToEvent = maybe NoEvent Event - --- | A rising edge detector that can be initialized as up ('True', meaning that --- events occurring at time 0 will not be detected) or down ('False', meaning --- that events occurring at time 0 will be detected). -edgeFrom :: Monad m => Bool -> SF m Bool (Event()) -edgeFrom prev = MSF $ \a -> do - let res | prev = NoEvent - | a = Event () - | otherwise = NoEvent - ct = edgeFrom a - return (res, ct) - --- * Stateful event suppression - --- | Suppression of initial (at local time 0) event. -notYet :: Monad m => SF m (Event a) (Event a) -notYet = feedback False $ arr (\(e, c) -> - if c then (e, True) else (NoEvent, True)) - --- | Suppress all but the first event. -once :: Monad m => SF m (Event a) (Event a) -once = takeEvents 1 - --- | Suppress all but the first n events. -takeEvents :: Monad m => Int -> SF m (Event a) (Event a) -takeEvents n | n <= 0 = never -takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 1))) - --- | Suppress first n events. - --- Here dSwitch or switch does not really matter. -dropEvents :: Monad m => Int -> SF m (Event a) (Event a) -dropEvents n | n <= 0 = identity -dropEvents n = - dSwitch (never &&& identity) (const (NoEvent >-- dropEvents (n - 1))) - --- * Pointwise functions on events - --- | Make the NoEvent constructor available. Useful e.g. for initialization, --- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []). -noEvent :: Event a -noEvent = NoEvent - --- | Suppress any event in the first component of a pair. -noEventFst :: (Event a, b) -> (Event c, b) -noEventFst (_, b) = (NoEvent, b) - --- | Suppress any event in the second component of a pair. -noEventSnd :: (a, Event b) -> (a, Event c) -noEventSnd (a, _) = (a, NoEvent) - --- | An event-based version of the maybe function. -event :: a -> (b -> a) -> Event b -> a -event _ f (Event x) = f x -event x _ NoEvent = x - --- | Extract the value from an event. Fails if there is no event. -fromEvent :: Event a -> a -fromEvent (Event x) = x -fromEvent _ = error "fromEvent NoEvent" - --- | Tests whether the input represents an actual event. -isEvent :: Event a -> Bool -isEvent (Event _) = True -isEvent _ = False - --- | Negation of 'isEvent'. -isNoEvent :: Event a -> Bool -isNoEvent (Event _) = False -isNoEvent _ = True - --- | Tags an (occurring) event with a value ("replacing" the old value). --- --- Applicative-based definition: --- tag = ($>) -tag :: Event a -> b -> Event b -tag NoEvent _ = NoEvent -tag (Event _) b = Event b - --- | Tags an (occurring) event with a value ("replacing" the old value). Same --- as 'tag' with the arguments swapped. --- --- Applicative-based definition: --- tagWith = (<$) -tagWith :: b -> Event a -> Event b -tagWith = flip tag - --- | Attaches an extra value to the value of an occurring event. -attach :: Event a -> b -> Event (a, b) -e `attach` b = fmap (\a -> (a, b)) e - --- | Left-biased event merge (always prefer left event, if present). -lMerge :: Event a -> Event a -> Event a -lMerge = mergeBy (\e1 _ -> e1) - --- | Right-biased event merge (always prefer right event, if present). -rMerge :: Event a -> Event a -> Event a -rMerge = flip lMerge - --- | Unbiased event merge: simultaneous occurrence is an error. -merge :: Event a -> Event a -> Event a -merge = mergeBy $ error "Bearriver: merge: Simultaneous event occurrence." - --- Applicative-based definition: --- mergeBy f le re = (f <$> le <*> re) <|> le <|> re -mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a -mergeBy _ NoEvent NoEvent = NoEvent -mergeBy _ le@(Event _) NoEvent = le -mergeBy _ NoEvent re@(Event _) = re -mergeBy resolve (Event l) (Event r) = Event (resolve l r) - --- | A generic event merge-map utility that maps event occurrences, merging the --- results. The first three arguments are mapping functions, the third of which --- will only be used when both events are present. Therefore, 'mergeBy' = --- 'mapMerge' 'id' 'id' --- --- Applicative-based definition: --- mapMerge lf rf lrf le re = (f <$> le <*> re) <|> (lf <$> le) <|> (rf <$> re) -mapMerge :: (a -> c) - -- ^ Mapping function used when first event is present. - -> (b -> c) - -- ^ Mapping function used when second event is present. - -> (a -> b -> c) - -- ^ Mapping function used when both events are present. - -> Event a - -- ^ First event - -> Event b - -- ^ Second event - -> Event c -mapMerge _ _ _ NoEvent NoEvent = NoEvent -mapMerge lf _ _ (Event l) NoEvent = Event (lf l) -mapMerge _ rf _ NoEvent (Event r) = Event (rf r) -mapMerge _ _ lrf (Event l) (Event r) = Event (lrf l r) - --- | Merge a list of events; foremost event has priority. --- --- Foldable-based definition: --- mergeEvents :: Foldable t => t (Event a) -> Event a --- mergeEvents = asum -mergeEvents :: [Event a] -> Event a -mergeEvents = foldr lMerge NoEvent - --- | Collect simultaneous event occurrences; no event if none. -catEvents :: [Event a] -> Event [a] -catEvents eas = case [ a | Event a <- eas ] of - [] -> NoEvent - as -> Event as - --- | Join (conjunction) of two events. Only produces an event if both events --- exist. --- --- Applicative-based definition: --- joinE = liftA2 (,) -joinE :: Event a -> Event b -> Event (a, b) -joinE NoEvent _ = NoEvent -joinE _ NoEvent = NoEvent -joinE (Event l) (Event r) = Event (l, r) - --- | Split event carrying pairs into two events. -splitE :: Event (a, b) -> (Event a, Event b) -splitE NoEvent = (NoEvent, NoEvent) -splitE (Event (a, b)) = (Event a, Event b) - ------------------------------------------------------------------------------- --- Event filtering ------------------------------------------------------------------------------- - --- | Filter out events that don't satisfy some predicate. -filterE :: (a -> Bool) -> Event a -> Event a -filterE p e@(Event a) = if p a then e else NoEvent -filterE _ NoEvent = NoEvent - --- | Combined event mapping and filtering. Note: since 'Event' is a 'Functor', --- see 'fmap' for a simpler version of this function with no filtering. -mapFilterE :: (a -> Maybe b) -> Event a -> Event b -mapFilterE _ NoEvent = NoEvent -mapFilterE f (Event a) = case f a of - Nothing -> NoEvent - Just b -> Event b - --- | Enable/disable event occurrences based on an external condition. -gate :: Event a -> Bool -> Event a -_ `gate` False = NoEvent -e `gate` True = e - --- * Switching - --- ** Basic switchers - --- | Basic switch. --- --- By default, the first signal function is applied. Whenever the second value --- in the pair actually is an event, the value carried by the event is used to --- obtain a new signal function to be applied *at that time and at future --- times*. Until that happens, the first value in the pair is produced in the --- output signal. --- --- Important note: at the time of switching, the second signal function is --- applied immediately. If that second SF can also switch at time zero, then a --- double (nested) switch might take place. If the second SF refers to the --- first one, the switch might take place infinitely many times and never be --- resolved. --- --- Remember: The continuation is evaluated strictly at the time --- of switching! -switch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b -switch sf sfC = MSF $ \a -> do - (o, ct) <- unMSF sf a - case o of - (_, Event c) -> local (const 0) (unMSF (sfC c) a) - (b, NoEvent) -> return (b, switch ct sfC) - --- | Switch with delayed observation. --- --- By default, the first signal function is applied. --- --- Whenever the second value in the pair actually is an event, the value --- carried by the event is used to obtain a new signal function to be applied --- *at future times*. --- --- Until that happens, the first value in the pair is produced in the output --- signal. --- --- Important note: at the time of switching, the second signal function is used --- immediately, but the current input is fed by it (even though the actual --- output signal value at time 0 is discarded). --- --- If that second SF can also switch at time zero, then a double (nested) --- switch might take place. If the second SF refers to the first one, the --- switch might take place infinitely many times and never be resolved. --- --- Remember: The continuation is evaluated strictly at the time --- of switching! -dSwitch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b -dSwitch sf sfC = MSF $ \a -> do - (o, ct) <- unMSF sf a - case o of - (b, Event c) -> do (_, ct') <- local (const 0) (unMSF (sfC c) a) - return (b, ct') - (b, NoEvent) -> return (b, dSwitch ct sfC) - --- * Parallel composition and switching - --- ** Parallel composition and switching over collections with broadcasting - -#if MIN_VERSION_base(4,8,0) -parB :: Monad m => [SF m a b] -> SF m a [b] -#else -parB :: (Functor m, Monad m) => [SF m a b] -> SF m a [b] -#endif --- ^ Spatial parallel composition of a signal function collection. Given a --- collection of signal functions, it returns a signal function that broadcasts --- its input signal to every element of the collection, to return a signal --- carrying a collection of outputs. See 'par'. --- --- For more information on how parallel composition works, check --- -parB = widthFirst . sequenceS - --- | Decoupled parallel switch with broadcasting (dynamic collection of signal --- functions spatially composed in parallel). See 'dpSwitch'. --- --- For more information on how parallel composition works, check --- -dpSwitchB :: (Functor m, Monad m, Traversable col) - => col (SF m a b) - -> SF m (a, col b) (Event c) - -> (col (SF m a b) -> c -> SF m a (col b)) - -> SF m a (col b) -dpSwitchB sfs sfF sfCs = MSF $ \a -> do - res <- T.mapM (`unMSF` a) sfs - let bs = fmap fst res - sfs' = fmap snd res - (e, sfF') <- unMSF sfF (a, bs) - ct <- case e of - Event c -> snd <$> unMSF (sfCs sfs c) a - NoEvent -> return (dpSwitchB sfs' sfF' sfCs) - return (bs, ct) - --- ** Parallel composition over collections - --- | Apply an SF to every element of a list. --- --- Example: --- --- >>> embed (parC integral) (deltaEncode 0.1 [[1, 2], [2, 4], [3, 6], [4.0, 8.0 :: Float]]) --- [[0.0,0.0],[0.1,0.2],[0.3,0.6],[0.6,1.2]] --- --- The number of SFs or expected inputs is determined by the first input --- list, and not expected to vary over time. --- --- If more inputs come in a subsequent list, they are ignored. --- --- >>> embed (parC (arr (+1))) (deltaEncode 0.1 [[0], [1, 1], [3, 4], [6, 7, 8], [1, 1], [0, 0], [1, 9, 8]]) --- [[1],[2],[4],[7],[2],[1],[2]] --- --- If less inputs come in a subsequent list, an exception is thrown. --- --- >>> embed (parC (arr (+1))) (deltaEncode 0.1 [[0, 0], [1, 1], [3, 4], [6, 7, 8], [1, 1], [0, 0], [1, 9, 8]]) --- [[1,1],[2,2],[4,5],[7,8],[2,2],[1,1],[2,10]] -parC :: Monad m => SF m a b -> SF m [a] [b] -parC = parC0 - where - parC0 :: Monad m => SF m a b -> SF m [a] [b] - parC0 sf0 = MSF $ \as -> do - os <- T.mapM (\(a, sf) -> unMSF sf a) $ - zip as (replicate (length as) sf0) - - let bs = fmap fst os - cts = fmap snd os - return (bs, parC' cts) - - parC' :: Monad m => [SF m a b] -> SF m [a] [b] - parC' sfs = MSF $ \as -> do - os <- T.mapM (\(a, sf) -> unMSF sf a) $ zip as sfs - let bs = fmap fst os - cts = fmap snd os - return (bs, parC' cts) - -- * Discrete to continuous-time signal functions -- ** Wave-form generation @@ -681,9 +150,9 @@ -- Starts from a given value for the input signal at time zero. derivativeFrom :: (Monad m, Fractional s, VectorSpace a s) => a -> SF m a a derivativeFrom a0 = proc a -> do - dt <- constM ask -< () - aOld <- iPre a0 -< a - returnA -< (a ^-^ aOld) ^/ realToFrac dt + dt <- constM ask -< () + aOld <- MSF.iPre a0 -< a + returnA -< (a ^-^ aOld) ^/ realToFrac dt -- | Integrate using an auxiliary function that takes the current and the last -- input, the time between those samples, and the last output, and returns a diff --git a/src/FRP/BearRiver/Conditional.hs b/src/FRP/BearRiver/Conditional.hs new file mode 100644 --- /dev/null +++ b/src/FRP/BearRiver/Conditional.hs @@ -0,0 +1,70 @@ +-- | +-- Module : FRP.Yampa +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (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) +-- +-- Apply SFs only under certain conditions. +module FRP.BearRiver.Conditional + ( + -- * Guards and automata-oriented combinators + provided + + -- * Variable pause + , pause + ) + where + +-- External imports +import Control.Arrow ((&&&), (^>>)) + +import Data.MonadicStreamFunction.InternalCore (MSF (MSF, unMSF)) + +-- Internal imports +import FRP.BearRiver.Basic (constant) +import FRP.BearRiver.EventS (edge, snap) +import FRP.BearRiver.InternalCore (SF (..)) +import FRP.BearRiver.Switches (switch) + +-- * Guards and automata-oriented combinators + +-- | Runs a signal function only when a given predicate is satisfied, otherwise +-- runs the other signal function. +-- +-- This is similar to 'ArrowChoice', except that this resets the SFs after each +-- transition. +-- +-- For example, the following integrates the incoming input numbers, using one +-- integral if the numbers are even, and another if the input numbers are odd. +-- Note how, every time we "switch", the old value of the integral is discarded. +-- +-- >>> embed (provided (even . round) integral integral) (deltaEncode 1 [1, 1, 1, 2, 2, 2, 1, 1, 1, 2, 2, 2 :: Double]) +-- [0.0,1.0,2.0,0.0,2.0,4.0,0.0,1.0,2.0,0.0,2.0,4.0] +provided :: Monad m => (a -> Bool) -> SF m a b -> SF m a b -> SF m a b +provided p sft sff = + switch (constant undefined &&& snap) $ \a0 -> + if p a0 then stt else stf + where + stt = switch (sft &&& (not . p ^>> edge)) (const stf) + stf = switch (sff &&& (p ^>> edge)) (const stt) + +-- * Variable pause + +-- | Given a value in an accumulator (b), a predicate signal function (sfC), +-- and a second signal function (sf), pause will produce the accumulator b if +-- sfC input is True, and will transform the signal using sf otherwise. It acts +-- as a pause with an accumulator for the moments when the transformation is +-- paused. +pause :: Monad m => b -> SF m a Bool -> SF m a b -> SF m a b +pause b sfC sf = MSF $ \a0 -> do + (p, sfC') <- unMSF sfC a0 + case p of + True -> return (b, pause b sfC' sf) + False -> do (b', sf') <- unMSF sf a0 + return (b', pause b' sfC' sf') diff --git a/src/FRP/BearRiver/Delays.hs b/src/FRP/BearRiver/Delays.hs new file mode 100644 --- /dev/null +++ b/src/FRP/BearRiver/Delays.hs @@ -0,0 +1,107 @@ +-- | +-- Module : FRP.BearRiver.Delays +-- Copyright : (c) Ivan Perez, 2014-2023 +-- (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) +-- +-- SF primitives and combinators to delay signals, introducing new values in +-- them. +module FRP.BearRiver.Delays + ( + -- * Basic delays + pre + , iPre + , fby + + -- * Timed delays + , delay + ) + where + +-- External imports +import Control.Arrow ((>>>)) + +-- Internal imports (dunai) +import Control.Monad.Trans.MSF (ask) +import Data.MonadicStreamFunction.InternalCore (MSF (..)) + +-- Internal imports +import FRP.BearRiver.Basic (identity, (-->)) +import FRP.BearRiver.InternalCore (SF (..), Time) +import FRP.BearRiver.Scan (sscanPrim) + +infixr 0 `fby` + +-- * Delays + +-- | Uninitialized delay operator. +-- +-- The output has an infinitesimal delay (1 sample), and the value at time zero +-- is undefined. +pre :: Monad m => SF m a a +pre = sscanPrim f uninit uninit + where + f c a = Just (a, c) + uninit = error "bearriver: pre: Uninitialized pre operator." + +-- | Initialized delay operator. +-- +-- Creates an SF that delays the input signal, introducing an infinitesimal +-- delay (one sample), using the given argument to fill in the initial output at +-- time zero. +iPre :: Monad m => a -> SF m a a +iPre = (--> pre) + +-- | Lucid-Synchrone-like initialized delay (read "followed by"). +-- +-- Initialized delay combinator, introducing an infinitesimal delay (one sample) +-- in given 'SF', using the given argument to fill in the initial output at time +-- zero. +-- +-- The difference with 'iPre' is that 'fby' takes an 'SF' as argument. +fby :: Monad m => b -> SF m a b -> SF m a b +b0 `fby` sf = b0 --> sf >>> pre + +-- * Timed delays + +-- | Delay a signal by a fixed time 't', using the second parameter to fill in +-- the initial 't' seconds. +delay :: Monad m => Time -> a -> SF m a a +delay q aInit | q < 0 = error "bearriver: delay: Negative delay." + | q == 0 = identity + | otherwise = MSF tf0 + where + tf0 a0 = return (aInit, delayAux [] [(q, a0)] 0 aInit) + + -- Invariants: + -- tDiff measure the time since the latest output sample ideally should have + -- been output. Whenever that equals or exceeds the time delta for the next + -- buffered sample, it is time to output a new sample (although not + -- necessarily the one first in the queue: it might be necessary to "catch + -- up" by discarding samples. 0 <= tDiff < bdt, where bdt is the buffered + -- time delta for the sample on the front of the buffer queue. + -- + -- Sum of time deltas in the queue >= q. + delayAux _ [] _ _ = undefined + delayAux rbuf buf@((bdt, ba) : buf') tDiff aPrev = MSF tf -- True + where + tf a = do + dt <- ask + let tDiff' = tDiff + dt + rbuf' = (dt, a) : rbuf + if (tDiff' < bdt) + then return (aPrev, delayAux rbuf' buf tDiff' aPrev) + else nextSmpl rbuf' buf' (tDiff' - bdt) ba + where + + nextSmpl rbuf [] tDiff a = + nextSmpl [] (reverse rbuf) tDiff a + nextSmpl rbuf buf@((bdt, ba) : buf') tDiff a + | tDiff < bdt = return (a, delayAux rbuf buf tDiff a) + | otherwise = nextSmpl rbuf buf' (tDiff - bdt) ba diff --git a/src/FRP/BearRiver/Event.hs b/src/FRP/BearRiver/Event.hs new file mode 100644 --- /dev/null +++ b/src/FRP/BearRiver/Event.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : FRP.BearRiver.Event +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (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 : portable +-- +-- Events in BearRiver represent discrete time-signals, meaning those that do +-- not change continuously. Examples of event-carrying signals would be mouse +-- clicks (in between clicks it is assumed that there is no click), some +-- keyboard events, button presses on wiimotes or window-manager events. +-- +-- The type 'Event' is isomorphic to 'Maybe' (@Event a = NoEvent | Event a@) +-- but, semantically, a 'Maybe'-carrying signal could change continuously, +-- whereas an 'Event'-carrying signal should not: for two events in subsequent +-- samples, there should be an small enough sampling frequency such that we +-- sample between those two samples and there are no 'Event's between them. +-- Nevertheless, no mechanism in Yampa will check this or misbehave if this +-- assumption is violated. +-- +-- Events are essential for many other BearRiver constructs, like switches (see +-- 'FRP.BearRiver.Switches.switch' for details). +module FRP.BearRiver.Event + ( + -- * The Event type + Event(..) + , noEvent + , noEventFst + , noEventSnd + + -- * Utility functions similar to those available for Maybe + , event + , fromEvent + , isEvent + , isNoEvent + + -- * Event tagging + , tag + , tagWith + , attach + + -- * Event merging (disjunction) and joining (conjunction) + , lMerge + , rMerge + , merge + , mergeBy + , mapMerge + , mergeEvents + , catEvents + , joinE + , splitE + + -- * Event filtering + , filterE + , mapFilterE + , gate + + -- * Utilities for easy event construction + , maybeToEvent + + ) + where + +-- External imports +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative (..), (<$>)) +#endif +import Control.Applicative (Alternative (..)) +import Control.DeepSeq (NFData (..)) +import qualified Control.Monad.Fail as Fail + +infixl 8 `tag`, `attach`, `gate` +infixl 7 `joinE` +infixl 6 `lMerge`, `rMerge`, `merge` + +-- * The Event type + +-- | A single possible event occurrence, that is, a value that may or may not +-- occur. Events are used to represent values that are not produced +-- continuously, such as mouse clicks (only produced when the mouse is clicked, +-- as opposed to mouse positions, which are always defined). +data Event a = Event a | NoEvent + deriving (Eq, Ord, Show) + +-- | Make the NoEvent constructor available. Useful e.g. for initialization, +-- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []). +noEvent :: Event a +noEvent = NoEvent + +-- | Suppress any event in the first component of a pair. +noEventFst :: (Event a, b) -> (Event c, b) +noEventFst (_, b) = (NoEvent, b) + +-- | Suppress any event in the second component of a pair. +noEventSnd :: (a, Event b) -> (a, Event c) +noEventSnd (a, _) = (a, NoEvent) + + +-- | Functor instance (could be derived). +instance Functor Event where + -- | Apply function to value carried by 'Event', if any. + fmap _ NoEvent = NoEvent + fmap f (Event c) = Event (f c) + +-- | Applicative instance (similar to 'Maybe'). +instance Applicative Event where + -- | Wrap a pure value in an 'Event'. + pure = Event + -- | If any value (function or arg) is 'NoEvent', everything is. + Event f <*> Event x = Event (f x) + _ <*> _ = NoEvent + +-- | Monad instance. +instance Monad Event where + -- | Combine events, return 'NoEvent' if any value in the sequence is + -- 'NoEvent'. + Event x >>= f = f x + NoEvent >>= _ = NoEvent + + -- | See 'pure'. + return = pure + +-- | MonadFail instance +instance Fail.MonadFail Event where + -- | Fail with 'NoEvent'. + fail _ = NoEvent + +-- | Alternative instance. +instance Alternative Event where + -- | An empty alternative carries no event, so it is ignored. + empty = NoEvent + -- | Merge favouring the left event ('NoEvent' only if both are 'NoEvent'). + NoEvent <|> r = r + l <|> _ = l + +-- | NFData instance. +instance NFData a => NFData (Event a) where + -- | Evaluate value carried by event. + rnf NoEvent = () + rnf (Event a) = rnf a `seq` () + +-- * Utility functions similar to those available for Maybe + +-- | An event-based version of the maybe function. +event :: a -> (b -> a) -> Event b -> a +event _ f (Event x) = f x +event x _ NoEvent = x + +-- | Extract the value from an event. Fails if there is no event. +fromEvent :: Event a -> a +fromEvent (Event x) = x +fromEvent _ = error "fromEvent NoEvent" + +-- | Tests whether the input represents an actual event. +isEvent :: Event a -> Bool +isEvent (Event _) = True +isEvent _ = False + +-- | Negation of 'isEvent'. +isNoEvent :: Event a -> Bool +isNoEvent = not . isEvent + +-- * Event tagging + +-- | Tags an (occurring) event with a value ("replacing" the old value). +-- +-- Applicative-based definition: tag = ($>) +tag :: Event a -> b -> Event b +e `tag` b = fmap (const b) e + +-- | Tags an (occurring) event with a value ("replacing" the old value). Same as +-- 'tag' with the arguments swapped. +-- +-- Applicative-based definition: tagWith = (<$) +tagWith :: b -> Event a -> Event b +tagWith = flip tag + +-- | Attaches an extra value to the value of an occurring event. +attach :: Event a -> b -> Event (a, b) +e `attach` b = fmap (\a -> (a, b)) e + +-- * Event merging (disjunction) and joining (conjunction) + +-- | Left-biased event merge (always prefer left event, if present). +lMerge :: Event a -> Event a -> Event a +lMerge = (<|>) + +-- | Right-biased event merge (always prefer right event, if present). +rMerge :: Event a -> Event a -> Event a +rMerge = flip (<|>) + +-- | Unbiased event merge: simultaneous occurrence is an error. +merge :: Event a -> Event a -> Event a +merge = mergeBy $ error "Bearriver: merge: Simultaneous event occurrence." + +-- | Event merge parameterized by a conflict resolution function. +-- +-- Applicative-based definition: +-- mergeBy f le re = (f <$> le <*> re) <|> le <|> re +mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a +mergeBy _ NoEvent NoEvent = NoEvent +mergeBy _ le@(Event _) NoEvent = le +mergeBy _ NoEvent re@(Event _) = re +mergeBy resolve (Event l) (Event r) = Event (resolve l r) + +-- | A generic event merge-map utility that maps event occurrences, merging the +-- results. The first three arguments are mapping functions, the third of which +-- will only be used when both events are present. Therefore, 'mergeBy' = +-- 'mapMerge' 'id' 'id'. +-- +-- Applicative-based definition: +-- mapMerge lf rf lrf le re = (f <$> le <*> re) <|> (lf <$> le) <|> (rf <$> re) +mapMerge :: (a -> c) + -- ^ Mapping function used when first event is present. + -> (b -> c) + -- ^ Mapping function used when second event is present. + -> (a -> b -> c) + -- ^ Mapping function used when both events are present. + -> Event a + -- ^ First event + -> Event b + -- ^ Second event + -> Event c +mapMerge _ _ _ NoEvent NoEvent = NoEvent +mapMerge lf _ _ (Event l) NoEvent = Event (lf l) +mapMerge _ rf _ NoEvent (Event r) = Event (rf r) +mapMerge _ _ lrf (Event l) (Event r) = Event (lrf l r) + +-- | Merge a list of events; foremost event has priority. +-- +-- Foldable-based definition: +-- mergeEvents :: Foldable t => t (Event a) -> Event a +-- mergeEvents = asum +mergeEvents :: [Event a] -> Event a +mergeEvents = foldr lMerge NoEvent + +-- | Collect simultaneous event occurrences; no event if none. +catEvents :: [Event a] -> Event [a] +catEvents eas = case [ a | Event a <- eas ] of + [] -> NoEvent + as -> Event as + +-- | Join (conjunction) of two events. Only produces an event if both events +-- exist. +-- +-- Applicative-based definition: +-- joinE = liftA2 (,) +joinE :: Event a -> Event b -> Event (a, b) +joinE NoEvent _ = NoEvent +joinE _ NoEvent = NoEvent +joinE (Event l) (Event r) = Event (l, r) + +-- | Split event carrying pairs into two events. +splitE :: Event (a, b) -> (Event a, Event b) +splitE NoEvent = (NoEvent, NoEvent) +splitE (Event (a, b)) = (Event a, Event b) + +-- * Event filtering + +-- | Filter out events that don't satisfy some predicate. +filterE :: (a -> Bool) -> Event a -> Event a +filterE p e@(Event a) = if p a then e else NoEvent +filterE _ NoEvent = NoEvent + +-- | Combined event mapping and filtering. Note: since 'Event' is a 'Functor', +-- see 'fmap' for a simpler version of this function with no filtering. +mapFilterE :: (a -> Maybe b) -> Event a -> Event b +mapFilterE f e = e >>= (maybeToEvent . f) + +-- | Enable/disable event occurrences based on an external condition. +gate :: Event a -> Bool -> Event a +_ `gate` False = NoEvent +e `gate` True = e + +-- * Utilities for easy event construction + +-- | Convert a maybe value into a event ('Event' is isomorphic to 'Maybe'). +maybeToEvent :: Maybe a -> Event a +maybeToEvent Nothing = NoEvent +maybeToEvent (Just a) = Event a diff --git a/src/FRP/BearRiver/EventS.hs b/src/FRP/BearRiver/EventS.hs new file mode 100644 --- /dev/null +++ b/src/FRP/BearRiver/EventS.hs @@ -0,0 +1,206 @@ +-- | +-- Copyright : (c) Ivan Perez, 2019-2022 +-- (c) Ivan Perez and Manuel Baerenz, 2016-2018 +-- License : BSD3 +-- Maintainer : ivan.perez@keera.co.uk +-- +-- Event Signal Functions and SF combinators. +-- +-- Events represent values that only exist instantaneously, at discrete points +-- in time. Examples include mouse clicks, zero-crosses of monotonic continuous +-- signals, and square waves. +-- +-- For signals that carry events, there should be a limit in the number of +-- events we can observe in a time period, no matter how much we increase the +-- sampling frequency. +module FRP.BearRiver.EventS + ( + -- * Basic event sources + never + , now + , after + , repeatedly + , afterEach + , afterEachCat + , edge + , iEdge + , edgeTag + , edgeJust + , edgeBy + + -- * Stateful event suppression + , notYet + , once + , takeEvents + , dropEvents + + -- * Hybrid SF combinators + , snap + ) + where + +-- External imports +import Control.Arrow (arr, (&&&), (>>>), (>>^)) + +-- Internal imports (dunai) +import Control.Monad.Trans.MSF (ask) +import Data.MonadicStreamFunction (feedback) +import Data.MonadicStreamFunction.InternalCore (MSF (MSF, unMSF)) + +-- Internal imports +import FRP.BearRiver.Arrow (dup) +import FRP.BearRiver.Basic (constant, identity, (-->), (>--)) +import FRP.BearRiver.Event (Event (..), maybeToEvent, tag) +import FRP.BearRiver.InternalCore (SF, Time) +import FRP.BearRiver.Switches (dSwitch, switch) + +-- | Event source that never occurs. +never :: Monad m => SF m a (Event b) +never = constant NoEvent + +-- | Event source with a single occurrence at time 0. The value of the event is +-- given by the function argument. +now :: Monad m => b -> SF m a (Event b) +now b0 = Event b0 --> never + +-- | Event source with a single occurrence at or as soon after (local) time /q/ +-- as possible. +after :: Monad m + => Time -- ^ The time /q/ after which the event should be produced + -> b -- ^ Value to produce at that time + -> SF m a (Event b) +after q x = feedback q go + where + go = MSF $ \(_, t) -> do + dt <- ask + let t' = t - dt + e = if t > 0 && t' < 0 then Event x else NoEvent + ct = if t' < 0 then constant (NoEvent, t') else go + return ((e, t'), ct) + +-- | Event source with repeated occurrences with interval q. +-- +-- Note: If the interval is too short w.r.t. the sampling intervals, the result +-- will be that events occur at every sample. However, no more than one event +-- results from any sampling interval, thus avoiding an "event backlog" should +-- sampling become more frequent at some later point in time. +repeatedly :: Monad m => Time -> b -> SF m a (Event b) +repeatedly q x + | q > 0 = afterEach qxs + | otherwise = error "bearriver: repeatedly: Non-positive period." + where + qxs = (q, x):qxs + +-- | Event source with consecutive occurrences at the given intervals. +-- +-- Should more than one event be scheduled to occur in any sampling interval, +-- only the first will in fact occur to avoid an event backlog. + +-- After all, after, repeatedly etc. are defined in terms of afterEach. +afterEach :: Monad m => [(Time, b)] -> SF m a (Event b) +afterEach qxs = afterEachCat qxs >>> arr (fmap head) + +-- | Event source with consecutive occurrences at the given intervals. +-- +-- Should more than one event be scheduled to occur in any sampling interval, +-- the output list will contain all events produced during that interval. +afterEachCat :: Monad m => [(Time, b)] -> SF m a (Event [b]) +afterEachCat = afterEachCat' 0 + where + afterEachCat' :: Monad m => Time -> [(Time, b)] -> SF m a (Event [b]) + afterEachCat' _ [] = never + afterEachCat' t qxs = MSF $ \_ -> do + dt <- ask + let (ev, t', qxs') = fireEvents [] (t + dt) qxs + ev' = if null ev + then NoEvent + else Event (reverse ev) + + return (ev', afterEachCat' t' qxs') + + fireEvents :: [b] -> Time -> [(Time, b)] -> ([b], Time, [(Time, b)]) + fireEvents ev t [] = (ev, t, []) + fireEvents ev t (qx:qxs) + | fst qx < 0 = error "bearriver: afterEachCat: Non-positive period." + | overdue >= 0 = fireEvents (snd qx:ev) overdue qxs + | otherwise = (ev, t, qx:qxs) + where + overdue = t - fst qx + +-- | A rising edge detector. Useful for things like detecting key presses. It is +-- initialised as /up/, meaning that events occurring at time 0 will not be +-- detected. +edge :: Monad m => SF m Bool (Event ()) +edge = edgeFrom True + +-- | A rising edge detector that can be initialized as up ('True', meaning that +-- events occurring at time 0 will not be detected) or down ('False', meaning +-- that events occurring at time 0 will be detected). +iEdge :: Monad m => Bool -> SF m Bool (Event ()) +iEdge = edgeFrom + +-- | A rising edge detector that can be initialized as up ('True', meaning that +-- events occurring at time 0 will not be detected) or down ('False', meaning +-- that events occurring at time 0 will be detected). +edgeFrom :: Monad m => Bool -> SF m Bool (Event()) +edgeFrom prev = MSF $ \a -> do + let res | prev = NoEvent + | a = Event () + | otherwise = NoEvent + ct = edgeFrom a + return (res, ct) + +-- | Like 'edge', but parameterized on the tag value. +edgeTag :: Monad m => a -> SF m Bool (Event a) +edgeTag a = edge >>> arr (`tag` a) + +-- | Edge detector particularized for detecting transitions on a 'Maybe' signal +-- from 'Nothing' to 'Just'. +edgeJust :: Monad m => SF m (Maybe a) (Event a) +edgeJust = edgeBy isJustEdge (Just undefined) + where + isJustEdge Nothing Nothing = Nothing + isJustEdge Nothing ma@(Just _) = ma + isJustEdge (Just _) (Just _) = Nothing + isJustEdge (Just _) Nothing = Nothing + +-- | Edge detector parameterized on the edge detection function and initial +-- state, i.e., the previous input sample. The first argument to the edge +-- detection function is the previous sample, the second the current one. +edgeBy :: Monad m => (a -> a -> Maybe b) -> a -> SF m a (Event b) +edgeBy isEdge aPrev = MSF $ \a -> + return (maybeToEvent (isEdge aPrev a), edgeBy isEdge a) + +-- * Stateful event suppression + +-- | Suppression of initial (at local time 0) event. +notYet :: Monad m => SF m (Event a) (Event a) +notYet = feedback False $ arr (\(e, c) -> + if c then (e, True) else (NoEvent, True)) + +-- | Suppress all but the first event. +once :: Monad m => SF m (Event a) (Event a) +once = takeEvents 1 + +-- | Suppress all but the first n events. +takeEvents :: Monad m => Int -> SF m (Event a) (Event a) +takeEvents n | n <= 0 = never +takeEvents n = dSwitch (arr dup) (const (NoEvent >-- takeEvents (n - 1))) + +-- | Suppress first n events. +dropEvents :: Monad m => Int -> SF m (Event a) (Event a) +dropEvents n | n <= 0 = identity +dropEvents n = + -- Here dSwitch or switch does not really matter. + dSwitch (never &&& identity) + (const (NoEvent >-- dropEvents (n - 1))) + +-- ** Hybrid continuous-to-discrete SF combinators. + +-- | Event source with a single occurrence at time 0. The value of the event is +-- obtained by sampling the input at that time. +snap :: Monad m => SF m a (Event a) +snap = + -- switch ensures that the entire signal function will become just + -- "constant" once the sample has been taken. + switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now diff --git a/src/FRP/BearRiver/Scan.hs b/src/FRP/BearRiver/Scan.hs new file mode 100644 --- /dev/null +++ b/src/FRP/BearRiver/Scan.hs @@ -0,0 +1,54 @@ +-- | +-- Module : FRP.Yampa.Scan +-- Copyright : (c) Ivan Perez, 2014-2023 +-- (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) +-- +-- Simple, stateful signal processing. +-- +-- Scanning implements elementary, step-based accumulating over signal functions +-- by means of an auxiliary function applied to each input and to an +-- accumulator. For comparison with other FRP libraries and with stream +-- processing abstractions, think of fold. +module FRP.BearRiver.Scan + ( sscan + , sscanPrim + ) + where + +-- Internal imports (dunai) +import Data.MonadicStreamFunction.InternalCore (MSF (..)) + +-- Internal imports +import FRP.BearRiver.InternalCore (SF (..)) + +-- * Simple, stateful signal processing + +-- | Applies a function point-wise, using the last output as next input. This +-- creates a well-formed loop based on a pure, auxiliary function. +sscan :: Monad m => (b -> a -> b) -> b -> SF m a b +sscan f bInit = sscanPrim f' bInit bInit + where + f' b a = Just (b', b') + where + b' = f b a + +-- | Generic version of 'sscan', in which the auxiliary function produces an +-- internal accumulator and an "held" output. +-- +-- Applies a function point-wise, using the last known 'Just' output to form the +-- output, and next input accumulator. If the output is 'Nothing', the last +-- known accumulators are used. This creates a well-formed loop based on a pure, +-- auxiliary function. +sscanPrim :: Monad m => (c -> a -> Maybe (c, b)) -> c -> b -> SF m a b +sscanPrim f cInit bInit = MSF $ \a -> do + let o = f cInit a + case o of + Nothing -> return (bInit, sscanPrim f cInit bInit) + Just (c', b') -> return (b', sscanPrim f c' b') diff --git a/src/FRP/BearRiver/Switches.hs b/src/FRP/BearRiver/Switches.hs new file mode 100644 --- /dev/null +++ b/src/FRP/BearRiver/Switches.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE CPP #-} +-- 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 + +-- | +-- Copyright : (c) Ivan Perez, 2019-2022 +-- (c) Ivan Perez and Manuel Baerenz, 2016-2018 +-- License : BSD3 +-- Maintainer : ivan.perez@keera.co.uk +-- +-- Switches allow you to change the signal function being applied. +-- +-- The basic idea of switching is formed by combining a subordinate signal +-- function and a signal function continuation parameterised over some initial +-- data. +module FRP.BearRiver.Switches + ( + -- * Basic switching + switch, dSwitch + + -- * Parallel composition\/switching (collections) + -- ** With broadcasting + , parB + , dpSwitchB + + -- * Parallel composition\/switching (lists) + + + -- ** With replication + , parC + ) + where + +-- External imports +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative (..), (<$>)) +#endif +import Data.Traversable as T + +-- Internal imports (dunai) +import Control.Monad.Trans.MSF (local) +import Control.Monad.Trans.MSF.List (sequenceS, widthFirst) +import Data.MonadicStreamFunction.InternalCore (MSF (MSF, unMSF)) + +-- Internal imports +import FRP.BearRiver.Event (Event (..)) +import FRP.BearRiver.InternalCore (SF) + +-- * Basic switches + +-- | Basic switch. +-- +-- By default, the first signal function is applied. Whenever the second value +-- in the pair actually is an event, the value carried by the event is used to +-- obtain a new signal function to be applied *at that time and at future +-- times*. Until that happens, the first value in the pair is produced in the +-- output signal. +-- +-- Important note: at the time of switching, the second signal function is +-- applied immediately. If that second SF can also switch at time zero, then a +-- double (nested) switch might take place. If the second SF refers to the +-- first one, the switch might take place infinitely many times and never be +-- resolved. +-- +-- Remember: The continuation is evaluated strictly at the time +-- of switching! +switch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b +switch sf sfC = MSF $ \a -> do + (o, ct) <- unMSF sf a + case o of + (_, Event c) -> local (const 0) (unMSF (sfC c) a) + (b, NoEvent) -> return (b, switch ct sfC) + +-- | Switch with delayed observation. +-- +-- By default, the first signal function is applied. +-- +-- Whenever the second value in the pair actually is an event, the value +-- carried by the event is used to obtain a new signal function to be applied +-- *at future times*. +-- +-- Until that happens, the first value in the pair is produced in the output +-- signal. +-- +-- Important note: at the time of switching, the second signal function is used +-- immediately, but the current input is fed by it (even though the actual +-- output signal value at time 0 is discarded). +-- +-- If that second SF can also switch at time zero, then a double (nested) +-- switch might take place. If the second SF refers to the first one, the +-- switch might take place infinitely many times and never be resolved. +-- +-- Remember: The continuation is evaluated strictly at the time +-- of switching! +dSwitch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b +dSwitch sf sfC = MSF $ \a -> do + (o, ct) <- unMSF sf a + case o of + (b, Event c) -> do (_, ct') <- local (const 0) (unMSF (sfC c) a) + return (b, ct') + (b, NoEvent) -> return (b, dSwitch ct sfC) + +-- * Parallel composition and switching + +-- ** Parallel composition and switching over collections with broadcasting + +#if MIN_VERSION_base(4,8,0) +parB :: Monad m => [SF m a b] -> SF m a [b] +#else +parB :: (Functor m, Monad m) => [SF m a b] -> SF m a [b] +#endif +-- ^ Spatial parallel composition of a signal function collection. Given a +-- collection of signal functions, it returns a signal function that broadcasts +-- its input signal to every element of the collection, to return a signal +-- carrying a collection of outputs. See 'par'. +-- +-- For more information on how parallel composition works, check +-- +parB = widthFirst . sequenceS + +-- | Decoupled parallel switch with broadcasting (dynamic collection of signal +-- functions spatially composed in parallel). See 'dpSwitch'. +-- +-- For more information on how parallel composition works, check +-- +dpSwitchB :: (Functor m, Monad m, Traversable col) + => col (SF m a b) + -> SF m (a, col b) (Event c) + -> (col (SF m a b) -> c -> SF m a (col b)) + -> SF m a (col b) +dpSwitchB sfs sfF sfCs = MSF $ \a -> do + res <- T.mapM (`unMSF` a) sfs + let bs = fmap fst res + sfs' = fmap snd res + (e, sfF') <- unMSF sfF (a, bs) + ct <- case e of + Event c -> snd <$> unMSF (sfCs sfs c) a + NoEvent -> return (dpSwitchB sfs' sfF' sfCs) + return (bs, ct) + +-- ** Parallel composition over collections + +-- | Apply an SF to every element of a list. +-- +-- Example: +-- +-- >>> embed (parC integral) (deltaEncode 0.1 [[1, 2], [2, 4], [3, 6], [4.0, 8.0 :: Float]]) +-- [[0.0,0.0],[0.1,0.2],[0.3,0.6],[0.6,1.2]] +-- +-- The number of SFs or expected inputs is determined by the first input list, +-- and not expected to vary over time. +-- +-- If more inputs come in a subsequent list, they are ignored. +-- +-- >>> embed (parC (arr (+1))) (deltaEncode 0.1 [[0], [1, 1], [3, 4], [6, 7, 8], [1, 1], [0, 0], [1, 9, 8]]) +-- [[1],[2],[4],[7],[2],[1],[2]] +-- +-- If less inputs come in a subsequent list, an exception is thrown. +-- +-- >>> embed (parC (arr (+1))) (deltaEncode 0.1 [[0, 0], [1, 1], [3, 4], [6, 7, 8], [1, 1], [0, 0], [1, 9, 8]]) +-- [[1,1],[2,2],[4,5],[7,8],[2,2],[1,1],[2,10]] +parC :: Monad m => SF m a b -> SF m [a] [b] +parC = parC0 + where + parC0 :: Monad m => SF m a b -> SF m [a] [b] + parC0 sf0 = MSF $ \as -> do + os <- T.mapM (\(a, sf) -> unMSF sf a) $ + zip as (replicate (length as) sf0) + + let bs = fmap fst os + cts = fmap snd os + return (bs, parC' cts) + + parC' :: Monad m => [SF m a b] -> SF m [a] [b] + parC' sfs = MSF $ \as -> do + os <- T.mapM (\(a, sf) -> unMSF sf a) $ zip as sfs + let bs = fmap fst os + cts = fmap snd os + return (bs, parC' cts)