-- |
-- Module:     FRP.NetWire.Wire
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- The module contains the main 'Wire' type.

module FRP.NetWire.Wire
    ( -- * Wires
      Wire(..),
      WireState(..),

      -- * Auxilliary types
      DTime,
      Event,
      Time,

      -- * Utilities
      cleanupWireState,
      initWireState,
      mkGen,
      toGen
    )
    where

import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Concurrent.STM
import Prelude hiding ((.), id)
import System.Random.Mersenne


-- | Derivative of time.  In English:  It's the time between two
-- instants of an FRP session.

type DTime = Double


-- | Events are signals, which can be absent.  They usually denote
-- discrete occurences of certain events.

type Event = Maybe


-- | Time.

type Time = Double


-- | A wire is a network of signal transformers.

data Wire a b where
    WArr   :: (a -> b) -> Wire a b
    WConst :: b -> Wire a b
    WGen   :: (WireState -> a -> IO (Maybe b, Wire a b)) -> Wire a b
    WId    :: Wire a a


instance Alternative (Wire a) where
    empty = zeroArrow
    (<|>) = (<+>)


instance Applicative (Wire a) where
    pure = WConst

    wf' <*> wx' =
        WGen $ \ws x' -> do
            (mf, wf) <- toGen wf' ws x'
            (mx, wx) <- toGen wx' ws x'
            return (mf <*> mx, wf <*> wx)


instance Arrow Wire where
    arr = WArr

    first (WGen f) =
        WGen $ \ws (x', y) -> do
            (mx, w) <- f ws x'
            return (fmap (,y) mx, first w)
    first (WArr f) = WArr (first f)
    first (WConst c) = WArr (first (const c))
    first WId = WId

    second (WGen f) =
        WGen $ \ws (x, y') -> do
            (my, w) <- f ws y'
            return (fmap (x,) my, second w)
    second (WArr f) = WArr (second f)
    second (WConst c) = WArr (second (const c))
    second WId = WId

    wf *** WId = first wf
    WId *** wg = second wg
    wf' *** wg' =
        WGen $ \ws (x', y') -> do
            (mx, wf) <- toGen wf' ws x'
            (my, wg) <- toGen wg' ws y'
            return (liftA2 (,) mx my, wf *** wg)

    wf' &&& wg' =
        WGen $ \ws x' -> do
            (mx1, wf) <- toGen wf' ws x'
            (mx2, wg) <- toGen wg' ws x'
            return (liftA2 (,) mx1 mx2, wf &&& wg)


instance ArrowChoice Wire where
    left w' = wl
        where
        wl =
            WGen $ \ws mx' ->
                case mx' of
                  Left x' -> do
                      (mx, w) <- toGen w' ws x'
                      return (fmap Left mx, left w)
                  Right x -> return (Just (Right x), wl)

    right w' = wl
        where
        wl =
            WGen $ \ws mx' ->
                case mx' of
                  Right x' -> do
                      (mx, w) <- toGen w' ws x'
                      return (fmap Right mx, right w)
                  Left x -> return (Just (Left x), wl)

    wf' +++ wg' =
        WGen $ \ws mx' ->
            case mx' of
              Left x' -> do
                  (mx, wf) <- toGen wf' ws x'
                  return (fmap Left mx, wf +++ wg')
              Right x' -> do
                  (mx, wg) <- toGen wg' ws x'
                  return (fmap Right mx, wf' +++ wg)

    wf' ||| wg' =
        WGen $ \ws mx' ->
            case mx' of
              Left x' -> do
                  (mx, wf) <- toGen wf' ws x'
                  return (mx, wf ||| wg')
              Right x' -> do
                  (mx, wg) <- toGen wg' ws x'
                  return (mx, wf' ||| wg)


instance ArrowPlus Wire where
    WGen f <+> wg =
        WGen $ \ws x' -> do
            (mx, w1) <- f ws x'
            case mx of
              Just _  -> return (mx, w1 <+> wg)
              Nothing -> do
                  (mx2, w2) <- toGen wg ws x'
                  return (mx2, w1 <+> w2)

    wf <+> WGen _ = WGen (toGen wf)

    wa@(WArr _)   <+> _ = wa
    wc@(WConst _) <+> _ = wc
    WId           <+> _ = WId


instance ArrowZero Wire where
    zeroArrow = mkGen $ \_ _ -> return (Nothing, zeroArrow)


instance Category Wire where
    id = WId

    -- Combining two general wires.
    wf@(WGen f) . WGen g =
        WGen $ \ws x'' -> do
            (mx', w1) <- g ws x''
            case mx' of
              Nothing -> return (Nothing, wf . w1)
              Just x' -> do
                  (mx, w2) <- f ws x'
                  return (mx, w2 . w1)

    -- Combining a special wire with a general wire.
    wf@(WArr f) . WGen g =
        WGen $ \ws x' -> do
            (mx, w) <- g ws x'
            return (fmap f mx, wf . w)
    wc@(WConst c) . WGen g =
        WGen $ \ws x' -> do
            (mx, w) <- g ws x'
            return (fmap (const c) mx, wc . w)
    WGen f . wg@(WArr g) =
        WGen $ \ws x' -> do
            (mx, w) <- f ws (g x')
            return (mx, w . wg)
    WGen f . wc@(WConst c) =
        WGen $ \ws _ -> do
            (mx, w) <- f ws c
            return (mx, w . wc)

    -- Combining special wires.
    WArr f . WArr g = WArr (f . g)
    WArr f . WConst c = WArr (const (f c))

    WConst c . WArr _ = WConst c
    WConst c . WConst _ = WConst c

    WId . w2 = w2
    w1 . WId = w1


instance Functor (Wire a) where
    fmap f (WGen w') =
        WGen $ \ws x' -> do
            (x, w) <- w' ws x'
            return (fmap f x, fmap f w)
    fmap f (WArr g) = WArr (f . g)
    fmap f (WConst c) = WConst (f c)
    fmap f WId = WArr f


-- | The state of the wire.

data WireState =
    WireState {
      wsDTime  :: Double,   -- ^ Time difference for current instant.
      wsRndGen :: MTGen,    -- ^ Random number generator.
      wsReqVar :: TVar Int  -- ^ Request counter.
    }


-- | Clean up wire state.

cleanupWireState :: WireState -> IO ()
cleanupWireState _ = return ()


-- | Initialize wire state.

initWireState :: IO WireState
initWireState =
    WireState
    <$> pure 0
    <*> getStdGen
    <*> newTVarIO 0


-- | Create a generic wire from the given function.  This is a smart
-- constructor.  Please use it instead of the 'WGen' constructor.

mkGen :: (WireState -> a -> IO (Maybe b, Wire a b)) -> Wire a b
mkGen = WGen


-- | Extract the transition function of a wire.

toGen :: Wire a b -> WireState -> a -> IO (Maybe b, Wire a b)
toGen (WGen f)      ws x = f ws x
toGen wf@(WArr f)   _  x = return (Just (f x), wf)
toGen wc@(WConst c) _  _ = return (Just c, wc)
toGen wi@WId        _  x = return (Just x, wi)