module Synthesizer.Dimensional.Causal.Displacement (
mix, mixVolume,
fanoutAndMixMulti, fanoutAndMixMultiVolume,
raise, distort,
) where
import qualified Synthesizer.Dimensional.Process as Proc
import qualified Synthesizer.Dimensional.Causal.Process as CausalD
import qualified Synthesizer.Causal.Process as Causal
import Control.Arrow ((^<<), (&&&), )
import qualified Number.DimensionTerm as DN
import qualified Algebra.DimensionTerm as Dim
import qualified Algebra.Module as Module
import qualified Algebra.Field as Field
import qualified Algebra.Real as Real
import Control.Monad.Trans.Reader (Reader, runReader, ask, )
import PreludeBase
import NumericPrelude
import Prelude ()
mix :: (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>
Proc.T s u t (CausalD.T s (DN.T v y, DN.T v y) (DN.T v y) (yv,yv) yv)
mix =
Proc.pure $
fromAmplitudeReader $ \(amp0,amp1) ->
(DN.abs amp0 + DN.abs amp1, mixCore amp0 amp1)
mixVolume ::
(Field.C y, Module.C y yv, Dim.C v) =>
DN.T v y ->
Proc.T s u t (CausalD.T s (DN.T v y, DN.T v y) (DN.T v y) (yv,yv) yv)
mixVolume amp =
Proc.pure $
fromAmplitudeReader $ \(amp0,amp1) ->
(amp, mixCore amp0 amp1)
mixCore ::
(Field.C y, Module.C y yv, Dim.C v) =>
DN.T v y -> DN.T v y ->
Reader (DN.T v y) (Causal.T (yv,yv) yv)
mixCore amp0 amp1 =
do toSamp0 <- toAmplitudeVector amp0
toSamp1 <- toAmplitudeVector amp1
return $
Causal.map (\(y0,y1) -> toSamp0 y0 + toSamp1 y1)
fanoutAndMixMulti ::
(Real.C y, Field.C y, Module.C y yv, Dim.C v) =>
[Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)] ->
Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)
fanoutAndMixMulti =
fmap fanoutAndMixMultiPlain . sequence
fanoutAndMixMultiPlain ::
(Real.C y, Field.C y, Module.C y yv, Dim.C v) =>
[CausalD.T s ampIn (DN.T v y) yvIn yv] ->
CausalD.T s ampIn (DN.T v y) yvIn yv
fanoutAndMixMultiPlain cs =
fromAmplitudeReader $ \ampIn ->
let ampCs = map (\(CausalD.Cons f) -> f ampIn) cs
in (maximum (map fst ampCs),
fanoutAndMixMultiVolumeCore ampCs)
fanoutAndMixMultiVolume ::
(Field.C y, Module.C y yv, Dim.C v) =>
DN.T v y ->
[Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)] ->
Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)
fanoutAndMixMultiVolume amp =
fmap (fanoutAndMixMultiVolumePlain amp) . sequence
fanoutAndMixMultiVolumePlain ::
(Field.C y, Module.C y yv, Dim.C v) =>
DN.T v y ->
[CausalD.T s ampIn (DN.T v y) yvIn yv] ->
CausalD.T s ampIn (DN.T v y) yvIn yv
fanoutAndMixMultiVolumePlain amp cs =
fromAmplitudeReader $ \ampIn ->
(amp, fanoutAndMixMultiVolumeCore $
map (\(CausalD.Cons f) -> f ampIn) cs)
fanoutAndMixMultiVolumeCore ::
(Field.C y, Module.C y yv, Dim.C v) =>
[(DN.T v y, Causal.T yvIn yv)] ->
Reader (DN.T v y) (Causal.T yvIn yv)
fanoutAndMixMultiVolumeCore cs =
foldr
(\(ampX,c) acc ->
do toSamp <- toAmplitudeVector ampX
rest <- acc
return $ uncurry (+) ^<< (toSamp ^<< c) &&& rest)
(return $ Causal.map (const zero)) cs
raise :: (Field.C y, Module.C y yv, Dim.C v) =>
DN.T v y ->
yv ->
Proc.T s u t (CausalD.T s (DN.T v y) (DN.T v y) yv yv)
raise y' yv =
Proc.pure $
fromAmplitudeReader $ \amp ->
(amp, do toSamp <- toAmplitudeVector y'
return $ Causal.map (toSamp yv +))
distort :: (Field.C y, Module.C y yv, Dim.C v) =>
(yv -> yv) ->
Proc.T s u t (CausalD.T s (DN.T v y, DN.T v y) (DN.T v y) (y,yv) yv)
distort f =
Proc.pure $
fromAmplitudeReader $ \(ampCtrl,ampIn) ->
(ampIn, do toSamp <- toAmplitudeScalar ampCtrl
return $
Causal.map (\(c,y) ->
let c' = toSamp c
in c' *> f (recip c' *> y)))
toAmplitudeScalar ::
(Field.C y, Dim.C u) =>
DN.T u y -> Reader (DN.T u y) (y -> y)
toAmplitudeScalar ampIn =
do ampOut <- ask
return (DN.divToScalar ampIn ampOut *)
toAmplitudeVector ::
(Module.C y yv, Field.C y, Dim.C u) =>
DN.T u y -> Reader (DN.T u y) (yv -> yv)
toAmplitudeVector ampIn =
do ampOut <- ask
return (DN.divToScalar ampIn ampOut *> )
fromAmplitudeReader ::
(ampIn -> (ampOut, Reader ampOut (Causal.T yv0 yv1))) ->
CausalD.T s ampIn ampOut yv0 yv1
fromAmplitudeReader f =
CausalD.Cons $ \ampIn ->
let (ampOut, rd) = f ampIn
in (ampOut, runReader rd ampOut)