netwire-3.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
WAfter(..),
WAt(..),
WDelayEvents(..),
WPeriodically(..),
-- ** 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(..), (><))
import Data.VectorSpace
-- | Produces once after the input time interval has passed.
--
-- * Depends: Current instant.
--
-- * Inhibits: Always except at the target instant.
class Arrow (>~) => WAfter t (>~) | (>~) -> t where
after :: Monoid e => Wire e (>~) t ()
instance (AdditiveGroup t, MonadClock t m, Ord t) => WAfter t (Kleisli m) where
after = after0
where
after0 :: forall e. Monoid e => Wire e (Kleisli m) t ()
after0 =
WmGen $ \int -> do
t0 <- getTime
return (int <= zeroV `orGoWith` after' t0)
where
after' :: t -> Wire e (Kleisli m) t ()
after' t0 =
fix $ \again ->
WmGen $ \int -> do
t <- getTime
return (t ^-^ t0 >= int `orGoWith` again)
-- | Produces once as soon as the current global time is later than or
-- equal to the input global time and never again.
--
-- * Depends: Current instant.
--
-- * Inhibits: Always except at the target instant.
class Arrow (>~) => WAt t (>~) | (>~) -> t where
at :: Monoid e => Wire e (>~) t ()
instance (MonadClock t m, Ord t) => WAt t (Kleisli m) where
at =
WmGen $ \tt -> do
t <- getTime
return (t >= tt `orGoWith` at)
-- | Delay incoming events.
class Arrow (>~) => WDelayEvents t (>~) | (>~) -> t where
-- | 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 :: Monoid e => Wire e (>~) ([b], t) b
-- | 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 :: Monoid e => Wire e (>~) (([b], t), Int) b
instance (AdditiveGroup t, MonadClock t m, Ord t) => WDelayEvents t (Kleisli m) where
-- delayEvents
delayEvents = delayEvents' M.empty
where
delayEvents' :: Monoid e => Map t (Seq b) -> Wire e (Kleisli m) ([b], t) b
delayEvents' delayed' =
WmGen $ \(evs, int) -> do
t <- getTime
let delayed = M.insertWith' (><) (t ^+^ int) (S.fromList evs) delayed'
return $
case M.minViewWithKey delayed of
Nothing -> (Left mempty, delayEvents' delayed)
Just ((tt, revs), restMap)
| tt > t -> (Left mempty, delayEvents' delayed)
| 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))
-- delayEventsSafe
delayEventsSafe = delayEvents' 0 M.empty
where
delayEvents' :: Monoid e => Int -> Map t (Seq b) -> Wire e (Kleisli m) (([b], t), Int) b
delayEvents' curNum' delayed' =
WmGen $ \((evs, int), maxNum) -> do
t <- getTime
let addSeq = S.fromList evs
(curNum, delayed) =
if null evs || curNum' >= maxNum
then (curNum', delayed')
else (curNum' + S.length addSeq,
M.insertWith' (><) (t ^+^ int) addSeq delayed')
return $
case M.minViewWithKey delayed of
Nothing -> (Left mempty, delayEvents' curNum delayed)
Just ((tt, revs), restMap)
| tt > t -> (Left mempty, delayEvents' curNum delayed)
| 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, WirePure (>~)) => 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, WirePure (>~)) => 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, WirePure (>~)) => 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 :: WirePure (>~) => Wire e (>~) e b
inhibit = mkPureFix Left
-- | Never produces. Equivalent to 'zeroArrow'.
--
-- * Inhibits: Always.
never :: (Monoid e, WirePure (>~)) => 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, WirePure (>~)) => 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, WirePure (>~)) => 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.
class Arrow (>~) => WPeriodically t (>~) | (>~) -> t where
periodically :: Monoid e => Wire e (>~) t ()
instance (AdditiveGroup t, MonadClock t m, Ord t) => WPeriodically t (Kleisli m) where
periodically =
WmGen $ \int ->
if int <= zeroV
then return (Right (), periodically)
else do
t <- getTime
return (Left mempty, periodically' t)
where
periodically' :: Monoid e => t -> Wire e (Kleisli m) t ()
periodically' t0 =
WmGen $ \int -> do
t <- getTime
let tt = t0 ^+^ int
return $
if t >= tt
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, WirePure (>~)) => 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, WirePure (>~)) => Wire e (>~) Bool ()
while =
mkPure $ \b ->
if b then (Right (), while) else (Left mempty, never)
-- | Produces a single event occurence result, when the given 'Bool' is
-- true.
orGoWith ::
(Monoid e, WirePure (>~))
=> Bool
-> Wire e (>~) a b
-> (Either e (), Wire e (>~) a b)
orGoWith True _ = (Right (), never)
orGoWith False w = (Left mempty, w)
infixl 3 `orGoWith`