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