-- | -- 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 , delayEvent , delayEventCat , edge , iEdge , edgeTag , edgeJust , edgeBy -- * Stateful event suppression , notYet , once , takeEvents , dropEvents -- * Hybrid SF combinators , snap , snapAfter , sample , sampleWindow -- * Repetition and switching , recur , andThen ) 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)) -- Internal imports import FRP.BearRiver.Arrow (dup) import FRP.BearRiver.Basic (constant, identity, (-->), (>--)) import FRP.BearRiver.Event (Event (..), maybeToEvent, tag) import FRP.BearRiver.Hybrid (accumBy) 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. 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 -- | Delay for events. (Consider it a triggered after, hence /basic/.) delayEvent :: Monad m => Time -> SF m (Event a) (Event a) delayEvent q | q < 0 = error "bearriver: delayEvent: Negative delay." | q == 0 = identity | otherwise = delayEventCat q >>> arr (fmap head) -- | Delay an event by a given delta and catenate events that occur so closely -- so as to be /inseparable/. delayEventCat :: Monad m => Time -> SF m (Event a) (Event [a]) delayEventCat q | q < 0 = error "bearriver: delayEventCat: Negative delay." | q == 0 = arr (fmap (:[])) | otherwise = MSF noPendingEvent where noPendingEvent e = return ( NoEvent , case e of NoEvent -> MSF $ noPendingEvent Event x -> MSF (pendingEvents (-q) [] [] (-q) x) ) -- tNext is the present time w.r.t. the next scheduled event. -- tLast is the present time w.r.t. the last scheduled event. -- In the event queues, events are associated with their time -- w.r.t. to preceding event (positive). pendingEvents tLast rqxs qxs tNext x = tf -- True where tf e = do dt <- ask return (tf' dt e) tf' dt e | tNext' >= 0 = emitEventsScheduleNext e tLast' rqxs qxs tNext' [x] | otherwise = (NoEvent, MSF (pendingEvents tLast'' rqxs' qxs tNext' x)) where tNext' = tNext + dt tLast' = tLast + dt (tLast'', rqxs') = case e of NoEvent -> (tLast', rqxs) Event x' -> (-q, (tLast' + q, x') : rqxs) -- tNext is the present time w.r.t. the *scheduled* time of the event that -- is about to be emitted (i.e. >= 0). -- The time associated with any event at the head of the event queue is also -- given w.r.t. the event that is about to be emitted. Thus, tNext - q' is -- the present time w.r.t. the event at the head of the event queue. emitEventsScheduleNext e _ [] [] _ rxs = ( Event (reverse rxs) , case e of NoEvent -> MSF $ noPendingEvent Event x -> MSF $ pendingEvents (-q) [] [] (-q) x ) emitEventsScheduleNext e tLast rqxs [] tNext rxs = emitEventsScheduleNext e tLast [] (reverse rqxs) tNext rxs emitEventsScheduleNext e tLast rqxs ((q', x') : qxs') tNext rxs | q' > tNext = ( Event (reverse rxs) , case e of NoEvent -> MSF $ pendingEvents tLast rqxs qxs' (tNext - q') x' Event x'' -> MSF $ pendingEvents (-q) ((tLast + q, x'') : rqxs) qxs' (tNext - q') x' ) | otherwise = emitEventsScheduleNext e tLast rqxs qxs' (tNext - q') (x' : rxs) -- | 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 -- | Event source with a single occurrence at or as soon after (local) time -- @tEv@ as possible. The value of the event is obtained by sampling the input a -- that time. snapAfter :: Monad m => Time -> SF m a (Event a) snapAfter tEv = switch (never &&& (identity &&& after tEv () >>^ \(a, e) -> e `tag` a)) now -- | Sample a signal at regular intervals. sample :: Monad m => Time -> SF m a (Event a) sample pEv = identity &&& repeatedly pEv () >>^ \(a, e) -> e `tag` a -- | Window sampling. -- -- First argument is the window length wl, second is the sampling interval t. -- The output list should contain (min (truncate (T/t) wl)) samples, where T is -- the time the signal function has been running. This requires some care in -- case of sparse sampling. In case of sparse sampling, the current input value -- is assumed to have been present at all points where sampling was missed. sampleWindow :: Monad m => Int -> Time -> SF m a (Event [a]) sampleWindow wl q = identity &&& afterEachCat (repeat (q, ())) >>> arr (\(a, e) -> fmap (map (const a)) e) >>> accumBy updateWindow [] where updateWindow w as = drop (max (length w' - wl) 0) w' where w' = w ++ as -- * Repetition and switching -- | Makes an event source recurring by restarting it as soon as it has an -- occurrence. recur :: Monad m => SF m a (Event b) -> SF m a (Event b) recur sfe = switch (never &&& sfe) $ \b -> Event b --> recur (NoEvent --> sfe) -- | Apply the first SF until it produces an event, and, afterwards, switch to -- the second SF. This is just a convenience function, used to write what -- sometimes is more understandable switch-based code. andThen :: Monad m => SF m a (Event b) -> SF m a (Event b) -> SF m a (Event b) sfe1 `andThen` sfe2 = dSwitch (sfe1 >>^ dup) (const sfe2)