module Synthesizer.Causal.Process (
T,
fromStateMaybe,
fromState,
fromSimpleModifier,
map,
first,
second,
compose,
split,
fanout,
loop,
apply,
applyFst,
applySnd,
apply2,
feed,
crochetL,
scanL,
zipWith,
) where
import qualified Synthesizer.State.Signal as Sig
import qualified Synthesizer.Plain.Modifier as Modifier
import Control.Arrow
(Arrow(..), ArrowLoop(..),
Kleisli(Kleisli), runKleisli, )
import Control.Monad.State
(State(State), runState,
StateT(StateT), runStateT, liftM, )
import Synthesizer.Utility (mapSnd)
import Prelude hiding (map, zipWith, )
data T a b =
forall s.
Cons !(a -> StateT s Maybe b)
!s
fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b
fromStateMaybe = Cons
fromState :: (a -> State s b) -> s -> T a b
fromState f s0 =
fromStateMaybe (\x -> StateT (Just . runState (f x))) s0
fromSimpleModifier ::
Modifier.Simple s ctrl a b -> T (ctrl,a) b
fromSimpleModifier (Modifier.Simple s f) =
fromState (uncurry f) s
instance Arrow T where
pure = map
(>>>) = compose
first = liftKleisli first
second = liftKleisli second
(***) = split
(&&&) = fanout
instance ArrowLoop T where
loop = liftKleisli loop
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))
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))
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
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)
map :: (a -> b) -> T a b
map f = fromState (return . f) ()
compose :: T a b -> T b c -> T a c
compose = liftKleisli2 (>>>)
split :: T a b -> T c d -> T (a,c) (b,d)
split = liftKleisli2 (***)
fanout :: T a b -> T a c -> T a (b,c)
fanout = liftKleisli2 (&&&)
apply :: T a b -> Sig.T a -> Sig.T b
apply (Cons f s) =
Sig.crochetL (runStateT . f) s
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)
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)
apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c
apply2 f x y =
apply (applyFst f x) y
feed :: Sig.T a -> T () a
feed = fromStateMaybe (const (StateT Sig.viewL))
crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y
crochetL f s = fromStateMaybe (StateT . f) s
scanL :: (acc -> x -> acc) -> acc -> T x acc
scanL f start =
fromState (\x -> State $ \acc -> (acc, f acc x)) start
zipWith :: (a -> b -> c) -> Sig.T a -> T b c
zipWith f = applyFst (map (uncurry f))