Event.hs

-- |
-- 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. a -> Wire (Event (a -> a)) (Event a)
accum ee' = accum'
    where
    accum' :: Wire (Event (a -> a)) (Event a)
    accum' =
        mkGen $ \_ ->
            return .
            maybe (Nothing, accum')
                  (\f -> let ee = f ee' in ee `seq` (Just (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 :: forall a. DTime -> Wire a (Event a)
after t' =
    mkGen $ \(wsDTime -> dt) x ->
        let t = t' - dt in
        if t <= 0
          then return (Just (Just x), never)
          else return (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. [(DTime, b)] -> Wire a (Event b)
afterEach = afterEach' 0
    where
    afterEach' :: DTime -> [(DTime, b)] -> Wire 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 (Just (Just x), afterEach' (t - int) ds)
              else return (Just 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. Wire [a] (Event a)
dam = dam' []
    where
    dam' :: [a] -> Wire [a] (Event a)
    dam' xs =
        mkGen $ \_ ys ->
            case xs ++ ys of
              []        -> return (Just Nothing, dam' [])
              (ee:rest) -> return (Just (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 :: Wire (DTime, Event a) (Event a)
delayEvents = delayEvent' Seq.empty 0
    where
    delayEvent' :: Seq (DTime, a) -> Time -> Wire (DTime, 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 (Nothing, delayEvent' es 0)
              (et, ee) :< rest
                  | t >= et   -> return (Just (Just ee), delayEvent' rest t)
                  | otherwise -> return (Just 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 :: Wire (DTime, Int, Event a) (Event a)
delayEventsSafe = delayEventSafe' Seq.empty 0
    where
    delayEventSafe' :: Seq (DTime, a) -> Time -> Wire (DTime, 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 (Nothing, delayEventSafe' es 0)
              (et, ee) :< rest
                  | t >= et   -> return (Just (Just ee), delayEventSafe' rest t)
                  | otherwise -> return (Just Nothing, delayEventSafe' es t)


-- | Decoupled variant of 'hold'.

dHold :: forall a. a -> Wire (Event a) a
dHold x0 = dHold'
    where
    dHold' :: Wire (Event a) a
    dHold' =
        mkGen $ \_ ->
            return . maybe (Just x0, dHold') (\x1 -> (Just x0, dHold x1))


-- | Drop the given number of events, before passing events through.

dropEvents :: forall a. Int -> Wire (Event a) (Event a)
dropEvents 0 = identity
dropEvents n = drop'
    where
    drop' :: Wire (Event a) (Event a)
    drop' =
        mkGen $ \_ ->
            return .
            maybe (Nothing, drop')
                  (const (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. Wire (DTime, Event a) (Event a)
dropFor = dropFor' 0
    where
    dropFor' :: Time -> Wire (DTime, Event a) (Event a)
    dropFor' t' =
        mkGen $ \(wsDTime -> dt) (int, ev) ->
            let t = t' + dt in
            if t >= int
              then return (Just ev, arr snd)
              else return (Just Nothing, dropFor' t)


-- | Produce a single event with the right signal whenever the left
-- signal switches from 'False' to 'True'.

edge :: Wire (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. (a -> Bool) -> (a -> b) -> Wire a (Event b)
edgeBy p f = edgeBy'
    where
    edgeBy' :: Wire a (Event b)
    edgeBy' =
        mkGen $ \_ subject ->
            if p subject
              then return (Just (Just (f subject)), switchBack)
              else return (Just Nothing, edgeBy')

    switchBack :: Wire a (Event b)
    switchBack =
        mkGen $ \_ subject ->
            if p subject
              then return (Just Nothing, switchBack)
              else return (Just Nothing, edgeBy')


-- | Produce a single event carrying the value of the input signal,
-- whenever the input signal switches to 'Just'.

edgeJust :: Wire (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. a -> Wire (Event a) a
hold x0 = hold'
    where
    hold' :: Wire (Event a) a
    hold' =
        mkGen $ \_ ->
            return .
            maybe (Just x0, hold')
                  (\x -> (Just x, hold x))


-- | Never produce an event.

never :: Wire a (Event b)
never = constant Nothing


-- | Suppress the first event occurence.

notYet :: Wire (Event a) (Event a)
notYet = mkGen $ \_ -> return . maybe (Just Nothing, notYet) (const (Just Nothing, identity))


-- | Produce an event at the first instant and never again.

now :: b -> Wire a (Event b)
now x = constantAfter Nothing (Just x)


-- | Pass the first event occurence through and suppress all future
-- events.

once :: Wire (Event a) (Event a)
once =
    mkGen $ \_ ev ->
        case ev of
          Nothing -> return (Just Nothing, once)
          Just _  -> return (Just ev, constant Nothing)


-- | Emit the right signal event each time the left signal interval
-- passes.

repeatedly :: forall a. Wire (DTime, a) (Event a)
repeatedly = repeatedly' 0
    where
    repeatedly' :: Time -> Wire (DTime, 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 (Just (Just x), repeatedly' nextT)
              else return (Just Nothing, repeatedly' t)


-- | Each time the signal interval passes emit the next element from the
-- given list.

repeatedlyList :: forall a. [a] -> Wire DTime (Event a)
repeatedlyList = repeatedly' 0
    where
    repeatedly' :: DTime -> [a] -> Wire DTime (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 (Just (Just x0), repeatedly' nextT xs)
              else return (Just Nothing, repeatedly' t x)


-- | Pass only the first given number of events.  Then suppress events
-- forever.

takeEvents :: Int -> Wire (Event a) (Event a)
takeEvents 0 = constant Nothing
takeEvents n = take'
    where
    take' :: Wire (Event a) (Event a)
    take' =
        mkGen $ \_ ev ->
            case ev of
              Nothing -> return (Just Nothing, take')
              Just _  -> return (Just 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 :: Wire (DTime, Event a) (Event a)
takeFor = takeFor' 0
    where
    takeFor' :: Time -> Wire (DTime, Event a) (Event a)
    takeFor' t' =
        mkGen $ \(wsDTime -> dt) (int, ev) ->
            let t = t' + dt in
            if t >= int
              then return (Just Nothing, constant Nothing)
              else return (Just ev, takeFor' t)


-- | Inhibit the signal, unless an event occurs.

wait :: Wire (Event a) a
wait =
    mkGen $ \_ ev ->
        case ev of
          Nothing -> return (Nothing, wait)
          Just _  -> return (ev, wait)