Tools.hs

-- |
-- Module:     FRP.NetWire.Tools
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- The usual FRP tools you'll want to work with.

module FRP.NetWire.Tools
    ( -- * Basic utilities
      constant,
      identity,

      -- * Time
      time,
      timeFrom,

      -- * Signal transformers
      discrete,
      keep,

      -- * Inhibitors
      inhibit,
      require,

      -- * Wire transformers
      exhibit,
      freeze,
      sample,
      swallow,
      (-->),
      (>--),
      (-=>),
      (>=-),

      -- * Switches
      -- ** Unconditional switches
      constantAfter,
      initially,

      -- * Arrow tools
      mapA,

      -- * Convenience functions
      dup,
      fmod,
      swap
    )
    where

import Control.Arrow
import Control.Category hiding ((.))
import FRP.NetWire.Wire
import Prelude hiding (id)


-- | Override the output value at the first non-inhibited instant.

(-->) :: b -> Wire a b -> Wire a b
y --> w' =
    WGen $ \ws x -> do
        (mx, w) <- toGen w' ws x
        case mx of
          Nothing -> return (Nothing, y --> w)
          Just _  -> return (Just y, w)


-- | Override the input value, until the wire starts producing.

(>--) :: a -> Wire a b -> Wire a b
x' >-- w' =
    WGen $ \ws _ -> do
        (mx, w) <- toGen w' ws x'
        return (mx, maybe (x' >-- w) (const w) mx)


-- | Apply a function to the wire's output at the first non-inhibited
-- instant.

(-=>) :: (b -> b) -> Wire a b -> Wire a b
f -=> w' =
    WGen $ \ws x' -> do
        (mx, w) <- toGen w' ws x'
        case mx of
          Nothing -> return (Nothing, f -=> w)
          Just x  -> return (Just (f x), w)


-- | Apply a function to the wire's input, until the wire starts
-- producing.

(>=-) :: (a -> a) -> Wire a b -> Wire a b
f >=- w' =
    WGen $ \ws x' -> do
        (mx, w) <- toGen w' ws (f x')
        case mx of
          Nothing -> return (Nothing, f >=- w)
          Just x  -> return (Just x, w)


-- | The constant wire.  Please use this function instead of @arr (const
-- c)@.

constant :: b -> Wire a b
constant = WConst


-- | Produce the value of the second argument at the first instant.
-- Then produce the second value forever.

constantAfter :: b -> b -> Wire a b
constantAfter x1 x0 =
    mkGen $ \_ _ -> return (Just x0, constant x1)


-- | Turn a continuous signal into a discrete one.  This transformer
-- picks values from the right signal at intervals of the left signal.
--
-- The interval length is followed in real time.  If it's zero, then
-- this wire acts like @second id@.

discrete :: forall a. Wire (DTime, a) a
discrete =
    mkGen $ \(wsDTime -> dt) (_, x0) ->
        return (Just x0, discrete' dt x0)

    where
    discrete' :: Time -> a -> Wire (DTime, a) a
    discrete' t' x' =
        mkGen $ \(wsDTime -> dt) (int, x) ->
            let t = t' + dt in
            if t >= int
              then return (Just x, discrete' (fmod t int) x)
              else return (Just x', discrete' t x')


-- | Duplicate a value to a tuple.

dup :: a -> (a, a)
dup x = (x, x)


-- | This function corresponds to 'try' for exceptions, allowing you to
-- observe inhibited signals.

exhibit :: Wire a b -> Wire a (Maybe b)
exhibit w' =
    WGen $ \ws x' -> do
        (mx, w) <- toGen w' ws x'
        return (Just mx, exhibit w)


-- | Floating point modulo operation.  Note that @fmod n 0@ = 0.

fmod :: Double -> Double -> Double
fmod _ 0 = 0
fmod n d = n - d * realToFrac (floor $ n/d)


-- | Effectively prevent a wire from rewiring itself.  This function
-- will turn any stateful wire into a stateless wire, rendering most
-- wires useless.
--
-- Note:  This function should not be used normally.  Use it only, if
-- you know exactly what you're doing.

freeze :: Wire a b -> Wire a b
freeze w =
    WGen $ \ws x' -> do
        (mx, _) <- toGen w ws x'
        return (mx, w)


-- | Identity signal transformer.  Outputs its input.

identity :: Wire a a
identity = id


-- | Unconditional inhibition.  Equivalent to 'zeroArrow'.

inhibit :: Wire a b
inhibit = zeroArrow


-- | Produce the argument value at the first instant.  Then act as the
-- identity signal transformer forever.

initially :: a -> Wire a a
initially x0 =
    mkGen $ \_ _ -> return (Just x0, identity)


-- | Keep the value in the first instant forever.

keep :: Wire a a
keep = mkGen $ \_ x -> return (Just x, constant x)


-- | Apply an arrow to a list of inputs.

mapA :: ArrowChoice a => a b c -> a [b] [c]
mapA a =
    proc x ->
        case x of
          [] -> returnA -< []
          (x0:xs) -> arr (uncurry (:)) <<< a *** mapA a -< (x0, xs)


-- | Inhibit right signal, when the left signal is false.

require :: Wire (Bool, a) a
require =
    mkGen $ \_ (b, x) ->
        return (if b then Just x else Nothing, require)


-- | Sample the given wire at specific intervals.  Use this instead of
-- 'discrete', if you want to prevent the signal from passing through
-- the wire all the time.
--
-- The left signal interval is allowed to become zero, at which point
-- the signal is passed through the wire at every instant.

sample :: Wire a b -> Wire (DTime, a) b
sample w' =
    WGen $ \ws@(wsDTime -> dt) (_, x') -> do
        (mx, w) <- toGen w' ws x'
        return (mx, sample' dt mx w)

    where
    sample' :: Time -> Maybe b -> Wire a b -> Wire (DTime, a) b
    sample' t' mx' w' =
        WGen $ \ws@(wsDTime -> dt) (int, x'') ->
            let t = t' + dt in
            if t >= int || int <= 0
              then do
                  (mx, w) <- toGen w' ws x''
                  let nextT = fmod t int
                  case mx of
                    Nothing -> nextT `seq` return (mx', sample' nextT mx' w)
                    Just _  -> nextT `seq` return (mx, sample' nextT mx w)
              else
                  return (mx', sample' t mx' w')


-- | Wait for the first signal from the given wire and keep it forever.

swallow :: Wire a b -> Wire a b
swallow w' =
    WGen $ \ws x' -> do
        (mx, w) <- toGen w' ws x'
        case mx of
          Nothing -> return (Nothing, swallow w)
          Just x  -> do
              return (Just x, constant x)


-- | Swap the values in a tuple.

swap :: (a, b) -> (b, a)
swap (x, y) = (y, x)


-- | Get the local time.

time :: Wire a Time
time = timeFrom 0


-- | Get the local time, assuming it starts from the given value.

timeFrom :: Time -> Wire a Time
timeFrom t' =
    mkGen $ \ws _ ->
        let t = t' + wsDTime ws
        in t `seq` return (Just t, timeFrom t)