-- | -- Module: FRP.NetWire.Event -- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> -- -- Event system. None of these wires except 'event' supports feedback, -- because they all can inhibit. module FRP.NetWire.Event ( -- * Producing events after, afterEach, edge, edgeBy, edgeJust, never, once, periodically, repeatedly, repeatedlyList, -- * Event transformers -- ** Delaying events dam, delayEvents, delayEventsSafe, -- ** Selecting events dropEvents, dropFor, notYet, takeEvents, takeFor, -- ** Tools event ) where import qualified Data.Sequence as Seq import Control.Arrow import Control.Monad import Data.Maybe import Data.Sequence (Seq, (|>), ViewL((:<))) import FRP.NetWire.Tools import FRP.NetWire.Wire -- | Produce a signal once after the specified delay and never again. -- The event's value will be the input signal at that point. after :: Monad m => Time -> Wire m a a after t' = mkGen $ \(wsDTime -> dt) x -> let t = t' - dt in if t <= 0 then return (Right x, never) else return (Left noEvent, after t) -- | Produce an event according to the given list of time deltas and -- event values. The time deltas are relative to each other, hence from -- the perspective of switching in @[(1, 'a'), (2, 'b'), (3, 'c')]@ -- produces the event @'a'@ after one second, @'b'@ after three seconds -- and @'c'@ after six seconds. afterEach :: forall a b m. Monad m => [(Time, b)] -> Wire m a b afterEach = afterEach' 0 where afterEach' :: Time -> [(Time, b)] -> Wire m a b afterEach' _ [] = never afterEach' t' d@((int, x):ds) = mkGen $ \(wsDTime -> dt) _ -> let t = t' + dt in if t >= int then let nextT = t - int in nextT `seq` return (Right x, afterEach' (t - int) ds) else return (Left noEvent, afterEach' t d) -- | Event dam. Collects all values from the input list and emits one -- value at each instant. -- -- Note that this combinator can cause event congestion. If you feed -- values faster than it can produce, it will leak memory. dam :: forall a m. Monad m => Wire m [a] a dam = dam' [] where dam' :: [a] -> Wire m [a] a dam' xs = mkGen $ \_ ys -> case xs ++ ys of [] -> return (Left noEvent, dam' []) (x:rest) -> return (Right x, dam' rest) -- | Delay events by the time interval in the left signal. -- -- Note that this event transformer has to keep all delayed events in -- memory, which can cause event congestion. If events are fed in -- faster than they can be produced (for example when the framerate -- starts to drop), it will leak memory. Use 'delayEventSafe' to -- prevent this. delayEvents :: forall a m. Monad m => Wire m (Time, Maybe a) a delayEvents = delayEvent' Seq.empty 0 where delayEvent' :: Seq (Time, a) -> Time -> Wire m (Time, Maybe a) a delayEvent' es' t' = mkGen $ \(wsDTime -> dt) (int, ev) -> do let t = t' + dt es = t `seq` maybe es' (\ee -> es' |> (t + int, ee)) ev case Seq.viewl es of Seq.EmptyL -> return (Left noEvent, delayEvent' es 0) (et, ee) :< rest | t >= et -> return (Right ee, delayEvent' rest t) | otherwise -> return (Left noEvent, delayEvent' es t) -- | Delay events by the time interval in the left signal. The event -- queue is limited to the maximum number of events given by middle -- signal. If the current queue grows to this size, then temporarily no -- further events are queued. -- -- As suggested by the type, this maximum can change over time. -- However, if it's decreased below the number of currently queued -- events, the events are not deleted. delayEventsSafe :: forall a m. Monad m => Wire m (Time, Int, Maybe a) a delayEventsSafe = delayEventSafe' Seq.empty 0 where delayEventSafe' :: Seq (Time, a) -> Time -> Wire m (Time, Int, Maybe a) a delayEventSafe' es' t' = mkGen $ \(wsDTime -> dt) (int, maxEvs, ev') -> do let t = t' + dt ev = guard (Seq.length es' < maxEvs) >> ev' es = t `seq` maybe es' (\ee -> es' |> (t + int, ee)) ev case Seq.viewl es of Seq.EmptyL -> return (Left noEvent, delayEventSafe' es 0) (et, ee) :< rest | t >= et -> return (Right ee, delayEventSafe' rest t) | otherwise -> return (Left noEvent, delayEventSafe' es t) -- | Drop the given number of events, before passing events through. dropEvents :: forall a m. Monad m => Int -> Wire m a a dropEvents 0 = identity dropEvents n = mkGen $ \_ x -> return (Right x, dropEvents (pred n)) -- | Timed event gate for the right signal, which begins closed and -- opens after the time interval in the left signal has passed. dropFor :: forall a m. Monad m => Wire m (Time, a) a dropFor = dropFor' 0 where dropFor' :: Time -> Wire m (Time, a) a dropFor' t' = mkGen $ \(wsDTime -> dt) (int, x) -> let t = t' + dt in if t >= int then return (Right x, arr snd) else return (Left noEvent, dropFor' t) -- | Produce a single event with the right signal whenever the left -- signal switches from 'False' to 'True'. edge :: Monad m => Wire m (Bool, a) a edge = edgeBy fst snd -- | Whenever the predicate in the first argument switches from 'False' -- to 'True' for the input signal, produce an event carrying the value -- given by applying the second argument function to the input signal. edgeBy :: forall a b m. Monad m => (a -> Bool) -> (a -> b) -> Wire m a b edgeBy p f = edgeBy' where edgeBy' :: Wire m a b edgeBy' = mkGen $ \_ subject -> if p subject then return (Right (f subject), switchBack) else return (Left noEvent, edgeBy') switchBack :: Wire m a b switchBack = mkGen $ \_ subject -> return (Left noEvent, if p subject then switchBack else edgeBy') -- | Produce a single event carrying the value of the input signal, -- whenever the input signal switches to 'Just'. edgeJust :: Monad m => Wire m (Maybe a) a edgeJust = edgeBy isJust fromJust -- | Variant of 'exhibit', which produces a 'Maybe' instead of an -- 'Either'. -- -- Never inhibits. Same feedback properties as argument wire. event :: Monad m => Wire m a b -> Wire m a (Maybe b) event w' = mkGen $ \ws x' -> do (mx, w) <- toGen w' ws x' case mx of Left _ -> return (Right Nothing, event w) Right x -> return (Right (Just x), event w) -- | Never produce an event. This is equivalent to 'inhibit', but with -- a contextually more appropriate exception message. never :: Monad m => Wire m a b never = mkGen $ \_ _ -> return (Left noEvent, never) -- | Suppress the first event occurence. notYet :: Monad m => Wire m a a notYet = mkGen $ \_ _ -> return (Left noEvent, identity) -- | Produce an event at the first instant and never again. once :: Monad m => Wire m a a once = mkGen $ \_ x -> return (Right x, never) -- | Emits a '()' signal each time the signal interval passes. This is -- a simpler variant of 'repeatedly'. periodically :: forall m. Monad m => Wire m Time () periodically = periodically' 0 where periodically' :: Time -> Wire m Time () periodically' t' = mkGen $ \(wsDTime -> dt) int -> let t = t' + dt in if t >= int then let nextT = fmod t int in nextT `seq` return (Right (), periodically' nextT) else return (Left noEvent, periodically' t) -- | Emit the right signal event each time the left signal interval -- passes. repeatedly :: forall a m. Monad m => Wire m (Time, a) a repeatedly = repeatedly' 0 where repeatedly' :: Time -> Wire m (Time, a) a repeatedly' t' = mkGen $ \(wsDTime -> dt) (int, x) -> let t = t' + dt in if t >= int then let nextT = fmod t int in nextT `seq` return (Right x, repeatedly' nextT) else return (Left noEvent, repeatedly' t) -- | Each time the signal interval passes emit the next element from the -- given list. repeatedlyList :: forall a m. Monad m => [a] -> Wire m Time a repeatedlyList = repeatedly' 0 where repeatedly' :: Time -> [a] -> Wire m Time a repeatedly' _ [] = never repeatedly' t' x@(x0:xs) = mkGen $ \(wsDTime -> dt) int -> let t = t' + dt in if t >= int then let nextT = fmod t int in nextT `seq` return (Right x0, repeatedly' nextT xs) else return (Left noEvent, repeatedly' t x) -- | Pass only the first given number of events. Then suppress events -- forever. takeEvents :: forall a m. Monad m => Int -> Wire m a a takeEvents 0 = never takeEvents n = mkGen $ \_ x -> return (Right x, takeEvents (pred n)) -- | Timed event gate for the right signal, which starts open and slams -- shut after the left signal time interval passed. takeFor :: forall a m. Monad m => Wire m (Time, a) a takeFor = takeFor' 0 where takeFor' :: Time -> Wire m (Time, a) a takeFor' t' = mkGen $ \(wsDTime -> dt) (int, x) -> let t = t' + dt in if t >= int then return (Left noEvent, never) else return (Right x, takeFor' t)