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