Event.hs

-- |
-- Module:     FRP.NetWire.Event
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Events.  None of these wires supports feedback, because they all can
-- inhibit.

module FRP.NetWire.Event
    ( -- * Producing events
      after,
      afterEach,
      edge,
      edgeBy,
      edgeJust,
      never,
      once,
      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)


-- | 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)