netwire-2.0.0: Control/Wire/Prefab/Event.hs
-- |
-- Module: Control.Wire.Prefab.Event
-- Copyright: (c) 2011 Ertugrul Soeylemez
-- License: BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Wires for generating and manipulating events.
module Control.Wire.Prefab.Event
( -- * Event generation
-- ** Timed
after,
at,
delayEvents,
delayEventsSafe,
periodically,
-- ** Unconditional inhibition
inhibit,
never,
-- ** Predicate-based
asSoonAs,
edge,
require,
forbid,
while,
-- ** Instant-based
notYet,
once
)
where
import qualified Data.Map as M
import qualified Data.Sequence as S
import Control.Arrow
import Control.Monad.Fix
import Control.Wire.Classes
import Control.Wire.Prefab.Simple
import Control.Wire.Types
import Data.Monoid
import Data.Map (Map)
import Data.Sequence (Seq, ViewL(..), (><))
-- | Produces once after the input time delta has passed.
--
-- * Depends: Current instant.
--
-- * Inhibits: Always except at the target instant.
after ::
forall e t (>~).
(ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)
=> Wire e (>~) t ()
after =
mkGen $ proc dt -> do
t0 <- arrTime -< ()
returnA -<
if dt <= 0
then (Right (), never)
else (Left mempty, after' t0)
where
after' :: t -> Wire e (>~) t ()
after' t0 =
fix $ \again ->
mkGen $ proc dt -> do
t <- arrTime -< ()
returnA -<
if t - t0 >= dt
then (Right (), never)
else (Left mempty, again)
-- | Produces once as soon as the current time is later than or equal to
-- the current time and never again.
--
-- * Depends: Current instant.
--
-- * Inhibits: Always except at the target instant.
at :: (ArrowClock (>~), Monoid e, Ord t, Time (>~) ~ t) => Wire e (>~) t ()
at =
mkGen $ proc tt -> do
t <- arrTime -< ()
returnA -<
if t >= tt
then (Right (), never)
else (Left mempty, at)
-- | Delays each incoming event (left signal) by the given time delta
-- (right signal). The time delta at the instant the event happened is
-- significant.
--
-- * Depends: Current instant.
--
-- * Inhibits: When no delayed event happened.
delayEvents ::
forall b e t (>~).
(ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)
=> Wire e (>~) ([b], t) b
delayEvents = delayEvents' M.empty
where
delayEvents' :: Map t (Seq b) -> Wire e (>~) ([b], t) b
delayEvents' devs' =
mkGen $ proc (evs, dt) -> do
t <- arrTime -< ()
let devs | null evs = devs'
| otherwise = M.insertWith' (><) (t + dt) (S.fromList evs) devs'
returnA -<
devs `seq`
case M.minViewWithKey devs of
Nothing -> (Left mempty, delayEvents' devs)
Just ((tt, revs), restMap)
| tt > t -> (Left mempty, delayEvents' devs)
| otherwise ->
case S.viewl revs of
EmptyL -> (Left mempty, delayEvents' restMap)
rev :< restEvs ->
(Right rev,
delayEvents' (if S.null restEvs
then restMap
else M.insert tt restEvs restMap))
-- | Delays each incoming event (left signal) by the given time delta
-- (middle signal). The time delta at the instant the event happened is
-- significant. The right signal gives a maximum number of events
-- queued. When exceeded, new events are dropped, until there is enough
-- room.
--
-- * Depends: Current instant.
--
-- * Inhibits: When no delayed event happened.
delayEventsSafe ::
forall b e t (>~).
(ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)
=> Wire e (>~) (([b], t), Int) b
delayEventsSafe = delayEvents' 0 M.empty
where
delayEvents' :: Int -> Map t (Seq b) -> Wire e (>~) (([b], t), Int) b
delayEvents' curNum' devs' =
mkGen $ proc ((evs, dt), maxNum) -> do
t <- arrTime -< ()
let addSeq = S.fromList evs
(curNum, devs) =
if null evs || curNum' >= maxNum
then (curNum', devs')
else (curNum' + S.length addSeq,
M.insertWith' (><) (t + dt) addSeq devs')
returnA -<
case M.minViewWithKey devs of
Nothing -> (Left mempty, delayEvents' curNum devs)
Just ((tt, revs), restMap)
| tt > t -> (Left mempty, delayEvents' curNum devs)
| otherwise ->
case S.viewl revs of
EmptyL -> (Left mempty, delayEvents' curNum restMap)
rev :< restEvs ->
(Right rev,
delayEvents' (pred curNum)
(if S.null restEvs
then restMap
else M.insert tt restEvs restMap))
-- | Inhibits as long as the input signal is 'False'. Once it switches
-- to 'True', it produces forever.
--
-- * Depends: Current instant.
--
-- * Inhibits: As long as input signal is 'False', then never again.
asSoonAs :: Monoid e => Wire e (>~) Bool ()
asSoonAs =
mkPure $ \b ->
if b then (Right (), constant ()) else (Left mempty, asSoonAs)
-- | Produces once whenever the input signal switches from 'False' to
-- 'True'.
--
-- * Depends: Current instant.
--
-- * Inhibits: Always except at the above mentioned instants.
edge :: forall e (>~). Monoid e => Wire e (>~) Bool ()
edge =
mkPure $ \b ->
if b then (Right (), switchBack) else (Left mempty, edge)
where
switchBack :: Wire e (>~) Bool ()
switchBack = mkPure $ \b -> (Left mempty, if b then switchBack else edge)
-- | Produces, whenever the current input signal is 'False'.
--
-- * Depends: Current instant.
--
-- * Inhibits: When input is 'True'.
forbid :: Monoid e => Wire e (>~) Bool ()
forbid = mkPureFix (\b -> if b then Left mempty else Right ())
-- | Never produces. Always inhibits with the current input signal.
--
-- * Depends: Current instant.
--
-- * Inhibits: Always.
inhibit :: Wire e (>~) e b
inhibit = mkPureFix Left
-- | Never produces. Equivalent to 'zeroArrow'.
--
-- * Inhibits: Always.
never :: Monoid e => Wire e (>~) a b
never = mkPureFix (const (Left mempty))
-- | Inhibit at the first instant. Then produce forever.
--
-- * Inhibits: At the first instant.
notYet :: Monoid e => Wire e (>~) b b
notYet = mkPure (const (Left mempty, identity))
-- | Acts like the identity function once and never again.
--
-- * Inhibits: After the first instant.
once :: Monoid e => Wire e (>~) b b
once = mkPure $ \x -> (Right x, never)
-- | Periodically produces an event. The period is given by the input
-- time delta and can change over time. The current time delta with
-- respect to the last production is significant. Does not produce at
-- the first instant, unless the first delta is nonpositive.
--
-- * Depends: Current instant.
--
-- * Inhibits: Always except at the periodic ticks.
periodically ::
forall e t (>~).
(ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)
=> Wire e (>~) t ()
periodically =
mkGen $ proc dt -> do
t <- arrTime -< ()
returnA -< (if dt <= 0 then Right () else Left mempty, periodically' t)
where
periodically' :: t -> Wire e (>~) t ()
periodically' t0 =
mkGen $ proc dt -> do
t <- arrTime -< ()
returnA -<
let tt = t0 + dt in
if tt <= t
then (Right (), periodically' tt)
else (Left mempty, periodically' t0)
-- | Produces, whenever the current input signal is 'True'.
--
-- * Depends: Current instant.
--
-- * Inhibits: When input is 'False'.
require :: Monoid e => Wire e (>~) Bool ()
require = mkPureFix (\b -> if b then Right () else Left mempty)
-- | Produce as long as the input signal is 'True'. Once it switches to
-- 'False', never produce again. Corresponds to 'takeWhile' for lists.
--
-- * Depends: Current instant.
--
-- * Inhibits: As soon as input becomes 'False'.
while :: Monoid e => Wire e (>~) Bool ()
while =
mkPure $ \b ->
if b then (Right (), while) else (Left mempty, never)