-- |
-- Module:     Control.Wire.Trans.Sample
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Wire transformers for sampling wires.

module Control.Wire.Trans.Sample
    ( -- * Sampling
      WHold(..),
      WSample(..),
      WSampleInt(..),
      WSwallow(..)
    )
    where

import Control.Arrow
import Control.Monad
import Control.Wire.Classes
import Control.Wire.Prefab.Simple
import Control.Wire.Types
import Data.AdditiveGroup


-- | Hold signals.

class Arrow (>~) => WHold (>~) where
    -- | Keeps the latest produced value.
    --
    -- * Depends: Like argument wire.
    --
    -- * Inhibits: Until first production.
    hold :: Wire e (>~) a b -> Wire e (>~) a b

    -- | Keeps the latest produced value.  Produces the argument value until
    -- the argument wire starts producing.
    --
    -- * Depends: Like argument wire.
    holdWith :: b -> Wire e (>~) a b -> Wire e (>~) a b

instance Monad m => WHold (Kleisli m) where
    -- hold
    hold (WmPure f) =
        WmPure $ \x' ->
            let (mx, w) = f x' in
            case mx of
              Left ex -> (Left ex, hold w)
              Right x -> (Right x, holdWith x w)
    hold (WmGen c) =
        WmGen $ \x' -> do
            (mx, w) <- c x'
            return $
                case mx of
                  Left ex -> (Left ex, hold w)
                  Right x -> (Right x, holdWith x w)

    -- holdWith
    holdWith x0 (WmPure f) =
        WmPure $ \x' ->
            let (mx, w) = f x' in
            case mx of
              Left _  -> (Right x0, holdWith x0 w)
              Right x -> (Right x, holdWith x w)
    holdWith x0 (WmGen c) =
        WmGen $ \x' -> do
            (mx, w) <- c x'
            return $
                case mx of
                  Left _  -> (Right x0, holdWith x0 w)
                  Right x -> (Right x, holdWith x w)


-- | Samples the given wire at discrete time intervals.  Only runs the
-- input through the wire, when the next sampling interval starts.
--
-- * Depends: Current instant (left), like argument wire at sampling
--   intervals (right).
--
-- * Inhibits: Starts inhibiting when argument wire inhibits.  Keeps
--   inhibiting until next sampling interval.

class Arrow (>~) => WSample t (>~) | (>~) -> t where
    sample :: Wire e (>~) a b -> Wire e (>~) (a, t) b

instance (AdditiveGroup t, MonadClock t m, Ord t) => WSample t (Kleisli m) where
    sample w' =
        WmGen $ \(x', int) ->
            if int <= zeroV
              then liftM (second sample) (toGenM w' x')
              else do
                  t0 <- getTime
                  (mx, w) <- toGenM w' x'
                  return (mx, sample' t0 mx w)

        where
        sample' :: Ord t => t -> Either e b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) (a, t) b
        sample' t0 mx0 w' =
            WmGen $ \(x', int) ->
                if int <= zeroV
                  then liftM (second sample) (toGenM w' x')
                  else do
                      t <- getTime
                      let tt = t0 ^+^ int
                      if t >= tt
                        then do
                            (mx, w) <- toGenM w' x'
                            return (mx, sample' tt mx w)
                        else return (mx0, sample' t0 mx0 w')


-- | Samples the given wire at discrete frame count intervals.  Only
-- runs the input through the wire, when the next sampling interval
-- starts.
--
-- * Depends: Current instant (left), like argument wire at sampling
--   intervals (right).
--
-- * Inhibits: Starts inhibiting when argument wire inhibits.  Keeps
--   inhibiting until next sampling interval.

class Arrow (>~) => WSampleInt (>~) where
    sampleInt :: Wire e (>~) a b -> Wire e (>~) (a, Int) b

instance Monad m => WSampleInt (Kleisli m) where
    sampleInt w' =
        WmGen $ \(x', _) -> do
            (mx, w) <- toGenM w' x'
            return (mx, sample' 0 mx w)

        where
        sample' :: Int -> Either e b -> Wire e (Kleisli m) a b -> Wire e (Kleisli m) (a, Int) b
        sample' (succ -> n) mx0 w' =
            WmGen $ \(x', int) ->
                if n >= int
                  then do
                      (mx, w) <- toGenM w' x'
                      return (mx, sample' 0 mx w)
                  else return (mx0, sample' n mx0 w')


-- | Waits for the argument wire to produce and then keeps the first
-- produced value forever.
--
-- * Depends: Like argument wire until first production.  Then stops
--   depending.
--
-- * Inhibits: Until the argument wire starts producing.

class Arrow (>~) => WSwallow (>~) where
    swallow :: Wire e (>~) a b -> Wire e (>~) a b

instance Monad m => WSwallow (Kleisli m) where
    swallow (WmPure f) =
        WmPure $ \x' ->
            let (mx, w) = f x' in
            (mx, either (const $ swallow w) constant mx)
    swallow (WmGen c) =
        WmGen $ \x' -> do
            (mx, w) <- c x'
            return (mx, either (const $ swallow w) constant mx)