-- | -- Module: FRP.NetWire.Event -- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> -- -- Events. module FRP.NetWire.Event ( -- * Producing events after, afterEach, edge, edgeBy, edgeJust, never, now, once, repeatedly, repeatedlyList, -- * Wire transformers wait, -- * Event transformers -- ** Delaying events dam, delayEvents, delayEventsSafe, -- ** Selecting events dropEvents, dropFor, notYet, takeEvents, takeFor, -- ** Manipulating events accum, -- ** Mapping to continuous signals hold, dHold ) 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 -- | This function corresponds to the 'iterate' function for lists. -- Begins with an initial output value, which is not emitted. Each time -- an input event is received, its function is applied to the current -- accumulator and the new value is emitted. accum :: forall a m. Monad m => a -> Wire m (Event (a -> a)) (Event a) accum ee' = accum' where accum' :: Wire m (Event (a -> a)) (Event a) accum' = mkGen $ \_ -> return . maybe (Right Nothing, accum') (\f -> let ee = f ee' in ee `seq` (Right (Just ee), accum ee)) -- | Produce an event 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 (Event a) after t' = mkGen $ \(wsDTime -> dt) x -> let t = t' - dt in if t <= 0 then return (Right (Just x), never) else return (Right Nothing, 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 (Event b) afterEach = afterEach' 0 where afterEach' :: Time -> [(Time, b)] -> Wire m a (Event 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 (Just x), afterEach' (t - int) ds) else return (Right Nothing, 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] (Event a) dam = dam' [] where dam' :: [a] -> Wire m [a] (Event a) dam' xs = mkGen $ \_ ys -> case xs ++ ys of [] -> return (Right Nothing, dam' []) (ee:rest) -> return (Right (Just ee), 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, Event a) (Event a) delayEvents = delayEvent' Seq.empty 0 where delayEvent' :: Seq (Time, a) -> Time -> Wire m (Time, Event a) (Event 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 (Right Nothing, delayEvent' es 0) (et, ee) :< rest | t >= et -> return (Right (Just ee), delayEvent' rest t) | otherwise -> return (Right Nothing, 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, Event a) (Event a) delayEventsSafe = delayEventSafe' Seq.empty 0 where delayEventSafe' :: Seq (Time, a) -> Time -> Wire m (Time, Int, Event a) (Event 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 (Right Nothing, delayEventSafe' es 0) (et, ee) :< rest | t >= et -> return (Right (Just ee), delayEventSafe' rest t) | otherwise -> return (Right Nothing, delayEventSafe' es t) -- | Decoupled variant of 'hold'. dHold :: forall a m. Monad m => a -> Wire m (Event a) a dHold x0 = dHold' where dHold' :: Wire m (Event a) a dHold' = mkGen $ \_ -> return . maybe (Right x0, dHold') (\x1 -> (Right x0, dHold x1)) -- | Drop the given number of events, before passing events through. dropEvents :: forall a m. Monad m => Int -> Wire m (Event a) (Event a) dropEvents 0 = identity dropEvents n = drop' where drop' :: Wire m (Event a) (Event a) drop' = mkGen $ \_ -> return . maybe (Right Nothing, drop') (const (Right Nothing, 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, Event a) (Event a) dropFor = dropFor' 0 where dropFor' :: Time -> Wire m (Time, Event a) (Event a) dropFor' t' = mkGen $ \(wsDTime -> dt) (int, ev) -> let t = t' + dt in if t >= int then return (Right ev, arr snd) else return (Right Nothing, 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) (Event 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 (Event b) edgeBy p f = edgeBy' where edgeBy' :: Wire m a (Event b) edgeBy' = mkGen $ \_ subject -> if p subject then return (Right (Just (f subject)), switchBack) else return (Right Nothing, edgeBy') switchBack :: Wire m a (Event b) switchBack = mkGen $ \_ subject -> return (Right Nothing, 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) (Event a) edgeJust = edgeBy isJust fromJust -- | Turn discrete events into continuous signals. Initially produces -- the argument value. Each time an event occurs, the produced value is -- switched to the event's value. hold :: forall a m. Monad m => a -> Wire m (Event a) a hold x0 = hold' where hold' :: Wire m (Event a) a hold' = mkGen $ \_ -> return . maybe (Right x0, hold') (Right &&& hold) -- | Never produce an event. never :: Monad m => Wire m a (Event b) never = constant Nothing -- | Suppress the first event occurence. notYet :: Monad m => Wire m (Event a) (Event a) notYet = mkGen $ \_ -> return . maybe (Right Nothing, notYet) (const (Right Nothing, identity)) -- | Produce an event at the first instant and never again. now :: Monad m => b -> Wire m a (Event b) now x = constantAfter Nothing (Just x) -- | Pass the first event occurence through and suppress all future -- events. once :: Monad m => Wire m (Event a) (Event a) once = mkGen $ \_ ev -> case ev of Nothing -> return (Right Nothing, once) Just _ -> return (Right ev, constant Nothing) -- | Emit the right signal event each time the left signal interval -- passes. repeatedly :: forall a m. Monad m => Wire m (Time, a) (Event a) repeatedly = repeatedly' 0 where repeatedly' :: Time -> Wire m (Time, a) (Event 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 (Just x), repeatedly' nextT) else return (Right Nothing, 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 (Event a) repeatedlyList = repeatedly' 0 where repeatedly' :: Time -> [a] -> Wire m Time (Event a) repeatedly' _ [] = constant Nothing 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 (Just x0), repeatedly' nextT xs) else return (Right Nothing, repeatedly' t x) -- | Pass only the first given number of events. Then suppress events -- forever. takeEvents :: forall a m. Monad m => Int -> Wire m (Event a) (Event a) takeEvents 0 = constant Nothing takeEvents n = take' where take' :: Wire m (Event a) (Event a) take' = mkGen $ \_ ev -> case ev of Nothing -> return (Right Nothing, take') Just _ -> return (Right ev, 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, Event a) (Event a) takeFor = takeFor' 0 where takeFor' :: Time -> Wire m (Time, Event a) (Event a) takeFor' t' = mkGen $ \(wsDTime -> dt) (int, ev) -> let t = t' + dt in if t >= int then return (Right Nothing, constant Nothing) else return (Right ev, takeFor' t) -- | Inhibit the signal, unless an event occurs. wait :: Monad m => Wire m (Event a) a wait = mkGen $ \_ ev -> case ev of Nothing -> return (Left (inhibitEx "Waiting for event"), wait) Just ee -> return (Right ee, wait)