module Synthesizer.Dimensional.Map.Displacement (
mix, mixVolume,
fanoutAndMixMulti, fanoutAndMixMultiVolume,
raise, distort,
) where
import qualified Synthesizer.Dimensional.Amplitude as Amp
import qualified Synthesizer.Dimensional.Sample as Sample
import qualified Synthesizer.Dimensional.Arrow as ArrowD
import qualified Control.Arrow as Arrow
import Control.Arrow (Arrow, arr, (^<<), (&&&), )
import qualified Number.DimensionTerm as DN
import qualified Algebra.DimensionTerm as Dim
import qualified Algebra.Module as Module
import qualified Algebra.RealField as RealField
import qualified Algebra.Field as Field
import qualified Algebra.Absolute as Absolute
import Control.Monad.Trans.Reader (Reader, runReader, asks, )
import Control.Applicative (liftA2, )
import NumericPrelude.Base
import NumericPrelude.Numeric
import Prelude ()
type DNS v y yv = Sample.Dimensional v y yv
type Context v y = Reader (DN.T v y)
mix ::
(Absolute.C y, Field.C y, Module.C y yv, Dim.C v, Arrow arrow) =>
ArrowD.T arrow (DNS v y yv, DNS v y yv) (DNS v y yv)
mix =
fromAmplitudeReader $ \(Amp.Numeric amp0, Amp.Numeric amp1) ->
(DN.abs amp0 + DN.abs amp1, mixCore amp0 amp1)
mixVolume ::
(Field.C y, Module.C y yv, Dim.C v, Arrow arrow) =>
DN.T v y ->
ArrowD.T arrow (DNS v y yv, DNS v y yv) (DNS v y yv)
mixVolume amp =
fromAmplitudeReader $ \(Amp.Numeric amp0, Amp.Numeric amp1) ->
(amp, mixCore amp0 amp1)
mixCore ::
(Field.C y, Module.C y yv, Dim.C v, Arrow arrow) =>
DN.T v y -> DN.T v y ->
Context v y (arrow (yv,yv) yv)
mixCore amp0 amp1 =
liftA2
(\toSamp0 toSamp1 ->
arr (\(y0,y1) -> toSamp0 y0 + toSamp1 y1))
(toAmplitudeVector amp0)
(toAmplitudeVector amp1)
fanoutAndMixMulti ::
(RealField.C y, Module.C y yv, Dim.C v, Arrow arrow) =>
[ArrowD.T arrow sample (DNS v y yv)] ->
ArrowD.T arrow sample (DNS v y yv)
fanoutAndMixMulti cs =
fromAmplitudeReader $ \ampIn ->
let ampCs = map (\(ArrowD.Cons f) -> f ampIn) cs
in (maximum (map (\(_, Amp.Numeric amp) -> amp) ampCs),
fanoutAndMixMultiCore ampCs)
fanoutAndMixMultiVolume ::
(Field.C y, Module.C y yv, Dim.C v, Arrow arrow) =>
DN.T v y ->
[ArrowD.T arrow sample (DNS v y yv)] ->
ArrowD.T arrow sample (DNS v y yv)
fanoutAndMixMultiVolume amp cs =
fromAmplitudeReader $ \ampIn ->
(amp, fanoutAndMixMultiCore $
map (\(ArrowD.Cons f) -> f ampIn) cs)
fanoutAndMixMultiCore ::
(Field.C y, Module.C y yv, Dim.C v, Arrow arrow) =>
[(arrow yvIn yv, Amp.Dimensional v y)] ->
Context v y (arrow yvIn yv)
fanoutAndMixMultiCore cs =
foldr
(\(c, Amp.Numeric ampX) ->
liftA2
(\toSamp rest ->
uncurry (+) ^<< (toSamp ^<< c) &&& rest)
(toAmplitudeVector ampX))
(return $ arr (const zero)) cs
raise ::
(Field.C y, Module.C y yv, Dim.C v, Arrow arrow) =>
DN.T v y ->
yv ->
ArrowD.T arrow (DNS v y yv) (DNS v y yv)
raise y' yv =
fromAmplitudeReader $ \(Amp.Numeric amp) ->
(amp, fmap (\toSamp -> arr (toSamp yv +)) (toAmplitudeVector y'))
distort ::
(Field.C y, Module.C y yv, Dim.C v, Arrow arrow) =>
(yv -> yv) ->
ArrowD.T arrow (DNS v y y, DNS v y yv) (DNS v y yv)
distort f =
fromAmplitudeReader $ \(Amp.Numeric ampCtrl, Amp.Numeric ampIn) ->
(ampIn,
fmap (\toSamp ->
arr (\(c,y) ->
let c' = toSamp c
in c' *> f (recip c' *> y)))
(toAmplitudeScalar ampCtrl))
toAmplitudeScalar ::
(Field.C y, Dim.C u) =>
DN.T u y -> Context u y (y -> y)
toAmplitudeScalar ampIn =
asks (\ampOut -> (DN.divToScalar ampIn ampOut *))
toAmplitudeVector ::
(Module.C y yv, Field.C y, Dim.C u) =>
DN.T u y -> Context u y (yv -> yv)
toAmplitudeVector ampIn =
asks (\ampOut -> (DN.divToScalar ampIn ampOut *> ))
fromAmplitudeReader ::
(Sample.Amplitude sampleIn ->
(ampOut,
Reader ampOut (arrow (Sample.Displacement sampleIn) yvOut))) ->
ArrowD.T arrow sampleIn (Sample.Numeric ampOut yvOut)
fromAmplitudeReader f =
ArrowD.Cons $ \ampIn ->
let (ampOut, rd) = f ampIn
in (runReader rd ampOut, Amp.Numeric ampOut)