module Synthesizer.Dimensional.Causal.Process where
import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA
import qualified Algebra.Module as Module
import qualified Algebra.Field as Field
import Algebra.Module ((*>))
import qualified Number.DimensionTerm as DN
import qualified Algebra.DimensionTerm as Dim
import qualified Control.Arrow as Arrow
import Prelude hiding (map, )
newtype T amp0 amp1 yv0 yv1 =
Cons (amp0 -> (amp1, Causal.T yv0 yv1))
apply :: (Dim.C v0) =>
T (DN.T v0 y0) (DN.T v1 y1) yv0 yv1 ->
SigA.R s v0 y0 yv0 -> SigA.R s v1 y1 yv1
apply (Cons f) x =
let (yAmp, causal) = f (SigA.amplitude x)
in SigA.fromSamples yAmp (Causal.apply causal (SigA.samples x))
applyFst :: (Dim.C v0) =>
T (DN.T v0 y0, restAmp) (DN.T v1 y1) (yv0, restSamp) yv1 ->
SigA.R s v0 y0 yv0 ->
T restAmp (DN.T v1 y1) restSamp yv1
applyFst (Cons f) x =
Cons $ \yAmp ->
let (zAmp, causal) = f (SigA.amplitude x, yAmp)
in (zAmp, Causal.applyFst causal (SigA.samples x))
map ::
(amp0 -> amp1) ->
(yv0 -> yv1) ->
T amp0 amp1 yv0 yv1
map f g =
Cons $ \ xAmp -> (f xAmp, Causal.map g)
infixr 3 ***
infixr 3 &&&
infixr 1 >>>, ^>>, >>^
infixr 1 <<<, ^<<, <<^
compose, (>>>) ::
T amp0 amp1 yv0 yv1 ->
T amp1 amp2 yv1 yv2 ->
T amp0 amp2 yv0 yv2
compose (Cons f) (Cons g) =
Cons $ \ xAmp ->
let (yAmp, causalXY) = f xAmp
(zAmp, causalYZ) = g yAmp
in (zAmp, Causal.compose causalXY causalYZ)
(>>>) = compose
(<<<) ::
T amp1 amp2 yv1 yv2 ->
T amp0 amp1 yv0 yv1 ->
T amp0 amp2 yv0 yv2
(<<<) = flip (>>>)
first ::
T amp0 amp1 yv0 yv1 ->
T (amp0, amp) (amp1, amp) (yv0, yv) (yv1, yv)
first (Cons f) =
Cons $ \ (xAmp, amp) ->
let (yAmp, causal) = f xAmp
in ((yAmp, amp), Causal.first causal)
second ::
T amp0 amp1 yv0 yv1 ->
T (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1)
second (Cons f) =
Cons $ \ (amp, xAmp) ->
let (yAmp, causal) = f xAmp
in ((amp, yAmp), Causal.second causal)
split, (***) ::
T amp0 amp1 yv0 yv1 ->
T amp2 amp3 yv2 yv3 ->
T (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)
split f g =
compose (first f) (second g)
(***) = split
fanout, (&&&) ::
T amp amp0 yv yv0 ->
T amp amp1 yv yv1 ->
T amp (amp0, amp1) yv (yv0, yv1)
fanout f g =
compose (map (\amp -> (amp,amp)) (\y -> (y,y))) (split f g)
(&&&) = fanout
(^>>) ::
(amp0 -> amp1, yv0 -> yv1) ->
T amp1 amp2 yv1 yv2 ->
T amp0 amp2 yv0 yv2
f ^>> a = uncurry map f >>> a
(>>^) ::
T amp0 amp1 yv0 yv1 ->
(amp1 -> amp2, yv1 -> yv2) ->
T amp0 amp2 yv0 yv2
a >>^ f = a >>> uncurry map f
(<<^) ::
T amp1 amp2 yv1 yv2 ->
(amp0 -> amp1, yv0 -> yv1) ->
T amp0 amp2 yv0 yv2
a <<^ f = a <<< uncurry map f
(^<<) ::
(amp1 -> amp2, yv1 -> yv2) ->
T amp0 amp1 yv0 yv1 ->
T amp0 amp2 yv0 yv2
f ^<< a = uncurry map f <<< a
loop ::
(Field.C y, Module.C y yv, Dim.C v) =>
DN.T v y ->
T (restAmp0, DN.T v y) (restAmp1, DN.T v y) (restSamp0, yv) (restSamp1, yv) ->
T restAmp0 restAmp1 restSamp0 restSamp1
loop ampIn (Cons f) =
Cons $ \restAmp0 ->
let ((restAmp1, ampOut), causal) = f (restAmp0, ampIn)
in (restAmp1,
Causal.loop (causal Arrow.>>^
Arrow.second (DN.divToScalar ampOut ampIn *>)))