Process.hs

{-# OPTIONS -fglasgow-exts #-}
{- |
Processes that use only the current and past data.
Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function.
-}
module Synthesizer.Causal.Process (
   T,
   fromStateMaybe,
   fromState,
   fromSimpleModifier,

   map,
   first,
   second,
   compose,
   split,
   fanout,
   loop,

{-
   We don't re-export these identifiers
   because people could abuse them for other Arrows.

   (>>>), (***), (&&&),
   (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^),
-}

   apply,
   applyFst,
   applySnd,
   apply2,
   feed,

   crochetL,
   scanL,
   zipWith,
) where

import qualified Synthesizer.State.Signal as Sig

import qualified Synthesizer.Plain.Modifier as Modifier

-- import qualified Control.Arrow as Arrow

import Control.Arrow
          (Arrow(..), {- ArrowApply(..), -} ArrowLoop(..),
           Kleisli(Kleisli), runKleisli, )
import Control.Monad.State
          (State(State), runState,
           StateT(StateT), runStateT, liftM, )

import Synthesizer.Utility (mapSnd)
import Prelude hiding (map, zipWith, )



-- TODO: include ST monad for mutable arrays

-- | Cf. StreamFusion  'Synthesizer.State.Signal.T'
data T a b =
   forall s. -- Seq s =>
      Cons !(a -> StateT s Maybe b)  -- compute next value
           !s                        -- initial state



{-# INLINE fromStateMaybe #-}
fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b
fromStateMaybe = Cons

{-# INLINE fromState #-}
fromState :: (a -> State s b) -> s -> T a b
fromState f s0 =
   fromStateMaybe (\x -> StateT (Just . runState (f x))) s0

{-# INLINE fromSimpleModifier #-}
fromSimpleModifier ::
   Modifier.Simple s ctrl a b -> T (ctrl,a) b
fromSimpleModifier (Modifier.Simple s f) =
   fromState (uncurry f) s


{-
It's almost a Kleisli Arrow,
but the hidden type of the state disturbs.
-}
instance Arrow T where
   {-# INLINE pure #-}
   {-# INLINE (>>>) #-}
   {-# INLINE first #-}
   {-# INLINE second #-}
   {-# INLINE (***) #-}
   {-# INLINE (&&&) #-}

   pure   = map
   (>>>)  = compose
   first  = liftKleisli first
   second = liftKleisli second
   (***)  = split
   (&&&)  = fanout


{-
I think we cannot define an ArrowApply instance,
because we must extract the initial state somehow
from the inner (T a b) which is not possible.

instance ArrowApply T where
--   app = Cons (runKleisli undefined) ()
   app = first (arr (flip Cons () . runKleisli)) >>> app
-}


instance ArrowLoop T where
   {-# INLINE loop #-}
   loop = liftKleisli loop


{-# INLINE extendStateFstT #-}
extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a
extendStateFstT st =
   StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0))

{-# INLINE extendStateSndT #-}
extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a
extendStateSndT st =
   StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0))


{-# INLINE liftKleisli #-}
liftKleisli ::
   (forall s.
    Kleisli (StateT s Maybe) a0 a1 ->
    Kleisli (StateT s Maybe) b0 b1) ->
   T a0 a1 -> T b0 b1
liftKleisli op (Cons f s) =
   Cons (runKleisli $ op $ Kleisli f) s

{-# INLINE liftKleisli2 #-}
liftKleisli2 ::
   (forall s.
      Kleisli (StateT s Maybe) a0 a1 ->
      Kleisli (StateT s Maybe) b0 b1 ->
      Kleisli (StateT s Maybe) c0 c1) ->
   T a0 a1 -> T b0 b1 -> T c0 c1
liftKleisli2 op (Cons f s) (Cons g t) =
   Cons
      (runKleisli
         (Kleisli (extendStateSndT . f) `op`
          Kleisli (extendStateFstT . g)))
      (s,t)


{-# INLINE map #-}
map :: (a -> b) -> T a b
map f = fromState (return . f) ()

{-# INLINE compose #-}
compose :: T a b -> T b c -> T a c
compose = liftKleisli2 (>>>)

{-# INLINE split #-}
split :: T a b -> T c d -> T (a,c) (b,d)
split = liftKleisli2 (***)

{-# INLINE fanout #-}
fanout :: T a b -> T a c -> T a (b,c)
fanout = liftKleisli2 (&&&)


{-# INLINE apply #-}
apply :: T a b -> Sig.T a -> Sig.T b
apply (Cons f s) =
   Sig.crochetL (runStateT . f) s

{-# INLINE applyFst #-}
applyFst :: T (a,b) c -> Sig.T a -> T b c
applyFst (Cons f s) x =
   Cons (\b ->
           do a <- extendStateFstT $ StateT $ Sig.viewL
              extendStateSndT (f (a,b)))
        (s,x)

{-# INLINE applySnd #-}
applySnd :: T (a,b) c -> Sig.T b -> T a c
applySnd (Cons f s) x =
   Cons (\b ->
           do a <- extendStateFstT $ StateT $ Sig.viewL
              extendStateSndT (f (b,a)))
        (s,x)

{-# INLINE apply2 #-}
apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c
apply2 f x y =
   apply (applyFst f x) y


{-# INLINE feed #-}
feed :: Sig.T a -> T () a
feed = fromStateMaybe (const (StateT Sig.viewL))


{-# INLINE crochetL #-}
crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y
crochetL f s = fromStateMaybe (StateT . f) s

{-# INLINE scanL #-}
scanL :: (acc -> x -> acc) -> acc -> T x acc
scanL f start =
   fromState (\x -> State $ \acc -> (acc, f acc x)) start

{-# INLINE zipWith #-}
zipWith :: (a -> b -> c) -> Sig.T a -> T b c
zipWith f = applyFst (map (uncurry f))