module Synthesizer.Causal.Process (
T,
fromStateMaybe,
fromState,
fromSimpleModifier,
id,
map,
first,
second,
compose,
split,
fanout,
loop,
apply,
applyFst,
applySnd,
applyGeneric,
applyGenericSameType,
applyConst,
apply2,
apply3,
feed,
feedFst,
feedSnd,
feedGenericFst,
feedGenericSnd,
feedConstFst,
feedConstSnd,
crochetL,
scanL,
scanL1,
zipWith,
consInit,
chainControlled,
replicateControlled,
feedback,
feedbackControlled,
applyFst',
applySnd',
) where
import qualified Synthesizer.State.Signal as Sig
import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.Generic.Signal2 as SigG2
import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Control.Category as Cat
import Control.Arrow
(Arrow(..), returnA, (<<<), (>>>), (^>>), ArrowLoop(..),
Kleisli(Kleisli), runKleisli, )
import Control.Monad.Trans.State
(State, state, runState,
StateT(StateT), runStateT, )
import Control.Monad (liftM, )
import Data.Tuple.HT (mapSnd, )
import Data.Function.HT (nest, )
import Prelude hiding (id, 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 =
fromStateMaybe (\x -> StateT (Just . runState (f x)))
fromSimpleModifier ::
Modifier.Simple s ctrl a b -> T (ctrl,a) b
fromSimpleModifier (Modifier.Simple s f) =
fromState (uncurry f) s
instance Cat.Category T where
id = fromState return ()
(.) = flip compose
instance Arrow T where
arr = map
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)
id :: T a a
id = returnA
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 (&&&)
getNext :: StateT (Sig.T a) Maybe a
getNext = StateT Sig.viewL
apply :: T a b -> Sig.T a -> Sig.T b
apply (Cons f s) =
Sig.crochetL (runStateT . f) s
applyFst, applyFst' :: T (a,b) c -> Sig.T a -> T b c
applyFst c as =
c <<< feedFst as
applyFst' (Cons f s) as =
Cons (\b ->
do a <- extendStateFstT getNext
extendStateSndT (f (a,b)))
(s,as)
applySnd, applySnd' :: T (a,b) c -> Sig.T b -> T a c
applySnd c as =
c <<< feedSnd as
applySnd' (Cons f s) bs =
Cons (\a ->
do b <- extendStateFstT getNext
extendStateSndT (f (a,b)))
(s,bs)
applyGeneric :: (SigG2.Transform sig a b) =>
T a b -> sig a -> sig b
applyGeneric (Cons f s) =
SigG2.crochetL (runStateT . f) s
applyGenericSameType :: (SigG.Transform sig a) =>
T a a -> sig a -> sig a
applyGenericSameType (Cons f s) =
SigG.crochetL (runStateT . f) s
applyConst :: T a b -> a -> Sig.T b
applyConst (Cons f s) a =
Sig.unfoldR (runStateT (f a)) s
apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c
apply2 f x y =
apply (applyFst f x) y
apply3 :: T (a,b,c) d -> Sig.T a -> Sig.T b -> Sig.T c -> Sig.T d
apply3 f x y z =
apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z
feed :: Sig.T a -> T () a
feed = fromStateMaybe (const getNext)
feedFst :: Sig.T a -> T b (a,b)
feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext)
feedSnd :: Sig.T a -> T b (b,a)
feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext)
feedConstFst :: a -> T b (a,b)
feedConstFst a = map (\b -> (a,b))
feedConstSnd :: a -> T b (b,a)
feedConstSnd a = map (\b -> (b,a))
feedGenericFst :: (SigG.Read sig a) =>
sig a -> T b (a,b)
feedGenericFst =
feedFst . SigG.toState
feedGenericSnd :: (SigG.Read sig a) =>
sig a -> T b (b,a)
feedGenericSnd =
feedSnd . SigG.toState
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
scanL1 :: (x -> x -> x) -> T x x
scanL1 f =
crochetL (\x acc -> Just (x, Just $ maybe x (flip f x) acc)) Nothing
zipWith :: (a -> b -> c) -> Sig.T a -> T b c
zipWith f = applyFst (map (uncurry f))
consInit :: x -> T x x
consInit =
crochetL (\x acc -> Just (acc, x))
chainControlled :: [T (c,x) x] -> T (c,x) x
chainControlled =
foldr
(\p rest -> map fst &&& p >>> rest)
(map snd)
replicateControlled :: Int -> T (c,x) x -> T (c,x) x
replicateControlled n p =
nest n
(map fst &&& p >>> )
(map snd)
feedback :: T (a,c) b -> T b c -> T a b
feedback forth back =
loop (forth >>> id &&& back)
feedbackControlled :: T ((ctrl,a),c) b -> T (ctrl,b) c -> T (ctrl,a) b
feedbackControlled forth back =
loop (map (fst.fst) &&& forth >>> map snd &&& back)