module Synthesizer.Dimensional.Map.Displacement (
mix, mixVolume,
fanoutAndMixMulti, fanoutAndMixMultiVolume,
raise, distort,
mapLinear, mapExponential, mapLinearDimension,
) where
import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat
import qualified Synthesizer.Dimensional.Amplitude as Amp
import qualified Synthesizer.Dimensional.Sample as Sample
import qualified Synthesizer.Dimensional.Arrow as ArrowD
import Control.Arrow (Arrow, arr, (<<<), (^<<), (&&&), )
import qualified Number.DimensionTerm as DN
import qualified Algebra.DimensionTerm as Dim
import Number.DimensionTerm ((&*&))
import qualified Algebra.Transcendental as Trans
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 qualified Algebra.Ring as Ring
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)
{-# INLINE mix #-}
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 :: forall y yv v (arrow :: * -> * -> *).
(C y, C y, C y yv, C v, Arrow arrow) =>
T arrow (DNS v y yv, DNS v y yv) (DNS v y yv)
mix =
forall sampleIn ampOut (arrow :: * -> * -> *) yvOut.
(Amplitude sampleIn
-> (ampOut, Reader ampOut (arrow (Displacement sampleIn) yvOut)))
-> T arrow sampleIn (Numeric ampOut yvOut)
fromAmplitudeReader forall a b. (a -> b) -> a -> b
$ \(Amp.Numeric T v y
amp0, Amp.Numeric T v y
amp1) ->
(forall u a. (C u, C a) => T u a -> T u a
DN.abs T v y
amp0 forall a. C a => a -> a -> a
+ forall u a. (C u, C a) => T u a -> T u a
DN.abs T v y
amp1, forall y yv v (arrow :: * -> * -> *).
(C y, C y yv, C v, Arrow arrow) =>
T v y -> T v y -> Context v y (arrow (yv, yv) yv)
mixCore T v y
amp0 T v y
amp1)
{-# INLINE mixVolume #-}
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 :: forall y yv v (arrow :: * -> * -> *).
(C y, C y yv, C v, Arrow arrow) =>
T v y -> T arrow (DNS v y yv, DNS v y yv) (DNS v y yv)
mixVolume T v y
amp =
forall sampleIn ampOut (arrow :: * -> * -> *) yvOut.
(Amplitude sampleIn
-> (ampOut, Reader ampOut (arrow (Displacement sampleIn) yvOut)))
-> T arrow sampleIn (Numeric ampOut yvOut)
fromAmplitudeReader forall a b. (a -> b) -> a -> b
$ \(Amp.Numeric T v y
amp0, Amp.Numeric T v y
amp1) ->
(T v y
amp, forall y yv v (arrow :: * -> * -> *).
(C y, C y yv, C v, Arrow arrow) =>
T v y -> T v y -> Context v y (arrow (yv, yv) yv)
mixCore T v y
amp0 T v y
amp1)
{-# INLINE mixCore #-}
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 :: forall y yv v (arrow :: * -> * -> *).
(C y, C y yv, C v, Arrow arrow) =>
T v y -> T v y -> Context v y (arrow (yv, yv) yv)
mixCore T v y
amp0 T v y
amp1 =
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
(\yv -> yv
toSamp0 yv -> yv
toSamp1 ->
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(yv
y0,yv
y1) -> yv -> yv
toSamp0 yv
y0 forall a. C a => a -> a -> a
+ yv -> yv
toSamp1 yv
y1))
(forall y yv u.
(C y yv, C y, C u) =>
T u y -> Context u y (yv -> yv)
toAmplitudeVector T v y
amp0)
(forall y yv u.
(C y yv, C y, C u) =>
T u y -> Context u y (yv -> yv)
toAmplitudeVector T v y
amp1)
{-# INLINE fanoutAndMixMulti #-}
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 :: forall y yv v (arrow :: * -> * -> *) sample.
(C y, C y yv, C v, Arrow arrow) =>
[T arrow sample (DNS v y yv)] -> T arrow sample (DNS v y yv)
fanoutAndMixMulti [T arrow sample (DNS v y yv)]
cs =
forall sampleIn ampOut (arrow :: * -> * -> *) yvOut.
(Amplitude sampleIn
-> (ampOut, Reader ampOut (arrow (Displacement sampleIn) yvOut)))
-> T arrow sampleIn (Numeric ampOut yvOut)
fromAmplitudeReader forall a b. (a -> b) -> a -> b
$ \Amplitude sample
ampIn ->
let ampCs :: [(arrow (Displacement sample) yv, Numeric (T v y))]
ampCs = forall a b. (a -> b) -> [a] -> [b]
map (\(ArrowD.Cons Amplitude sample
-> (arrow (Displacement sample) (Displacement (DNS v y yv)),
Amplitude (DNS v y yv))
f) -> Amplitude sample
-> (arrow (Displacement sample) (Displacement (DNS v y yv)),
Amplitude (DNS v y yv))
f Amplitude sample
ampIn) [T arrow sample (DNS v y yv)]
cs
in (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map (\(arrow (Displacement sample) yv
_, Amp.Numeric T v y
amp) -> T v y
amp) [(arrow (Displacement sample) yv, Numeric (T v y))]
ampCs),
forall y yv v (arrow :: * -> * -> *) yvIn.
(C y, C y yv, C v, Arrow arrow) =>
[(arrow yvIn yv, Dimensional v y)] -> Context v y (arrow yvIn yv)
fanoutAndMixMultiCore [(arrow (Displacement sample) yv, Numeric (T v y))]
ampCs)
{-# INLINE fanoutAndMixMultiVolume #-}
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 :: forall y yv v (arrow :: * -> * -> *) sample.
(C y, C y yv, C v, Arrow arrow) =>
T v y
-> [T arrow sample (DNS v y yv)] -> T arrow sample (DNS v y yv)
fanoutAndMixMultiVolume T v y
amp [T arrow sample (DNS v y yv)]
cs =
forall sampleIn ampOut (arrow :: * -> * -> *) yvOut.
(Amplitude sampleIn
-> (ampOut, Reader ampOut (arrow (Displacement sampleIn) yvOut)))
-> T arrow sampleIn (Numeric ampOut yvOut)
fromAmplitudeReader forall a b. (a -> b) -> a -> b
$ \Amplitude sample
ampIn ->
(T v y
amp, forall y yv v (arrow :: * -> * -> *) yvIn.
(C y, C y yv, C v, Arrow arrow) =>
[(arrow yvIn yv, Dimensional v y)] -> Context v y (arrow yvIn yv)
fanoutAndMixMultiCore forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\(ArrowD.Cons Amplitude sample
-> (arrow (Displacement sample) (Displacement (DNS v y yv)),
Amplitude (DNS v y yv))
f) -> Amplitude sample
-> (arrow (Displacement sample) (Displacement (DNS v y yv)),
Amplitude (DNS v y yv))
f Amplitude sample
ampIn) [T arrow sample (DNS v y yv)]
cs)
{-# INLINE fanoutAndMixMultiCore #-}
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 :: forall y yv v (arrow :: * -> * -> *) yvIn.
(C y, C y yv, C v, Arrow arrow) =>
[(arrow yvIn yv, Dimensional v y)] -> Context v y (arrow yvIn yv)
fanoutAndMixMultiCore [(arrow yvIn yv, Dimensional v y)]
cs =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\(arrow yvIn yv
c, Amp.Numeric T v y
ampX) ->
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
(\yv -> yv
toSamp arrow yvIn yv
rest ->
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. C a => a -> a -> a
(+) forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<< (yv -> yv
toSamp forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<< arrow yvIn yv
c) forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& arrow yvIn yv
rest)
(forall y yv u.
(C y yv, C y, C u) =>
T u y -> Context u y (yv -> yv)
toAmplitudeVector T v y
ampX))
(forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b. a -> b -> a
const forall a. C a => a
zero)) [(arrow yvIn yv, Dimensional v y)]
cs
{-# INLINE raise #-}
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 :: forall y yv v (arrow :: * -> * -> *).
(C y, C y yv, C v, Arrow arrow) =>
T v y -> yv -> T arrow (DNS v y yv) (DNS v y yv)
raise T v y
y' yv
yv =
forall sampleIn ampOut (arrow :: * -> * -> *) yvOut.
(Amplitude sampleIn
-> (ampOut, Reader ampOut (arrow (Displacement sampleIn) yvOut)))
-> T arrow sampleIn (Numeric ampOut yvOut)
fromAmplitudeReader forall a b. (a -> b) -> a -> b
$ \(Amp.Numeric T v y
amp) ->
(T v y
amp, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\yv -> yv
toSamp -> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (yv -> yv
toSamp yv
yv forall a. C a => a -> a -> a
+)) (forall y yv u.
(C y yv, C y, C u) =>
T u y -> Context u y (yv -> yv)
toAmplitudeVector T v y
y'))
{-# INLINE distort #-}
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 :: forall y yv v (arrow :: * -> * -> *).
(C y, C y yv, C v, Arrow arrow) =>
(yv -> yv) -> T arrow (DNS v y y, DNS v y yv) (DNS v y yv)
distort yv -> yv
f =
forall sampleIn ampOut (arrow :: * -> * -> *) yvOut.
(Amplitude sampleIn
-> (ampOut, Reader ampOut (arrow (Displacement sampleIn) yvOut)))
-> T arrow sampleIn (Numeric ampOut yvOut)
fromAmplitudeReader forall a b. (a -> b) -> a -> b
$ \(Amp.Numeric T v y
ampCtrl, Amp.Numeric T v y
ampIn) ->
(T v y
ampIn,
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\y -> y
toSamp ->
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(y
c,yv
y) ->
let c' :: y
c' = y -> y
toSamp y
c
in y
c' forall a v. C a v => a -> v -> v
*> yv -> yv
f (forall a. C a => a -> a
recip y
c' forall a v. C a v => a -> v -> v
*> yv
y)))
(forall y u. (C y, C u) => T u y -> Context u y (y -> y)
toAmplitudeScalar T v y
ampCtrl))
{-# INLINE mapLinear #-}
mapLinear ::
(Flat.C y flat, Ring.C y, Dim.C u, Arrow arrow) =>
y ->
DN.T u y ->
ArrowD.T arrow (Sample.T flat y) (DNS u y y)
mapLinear :: forall y flat u (arrow :: * -> * -> *).
(C y flat, C y, C u, Arrow arrow) =>
y -> T u y -> T arrow (T flat y) (DNS u y y)
mapLinear y
depth T u y
center =
forall (arrow :: * -> * -> *) sample0 sample1.
(Amplitude sample0
-> (arrow (Displacement sample0) (Displacement sample1),
Amplitude sample1))
-> T arrow sample0 sample1
ArrowD.Cons (\Flat y
Amplitude (T (Flat y) y)
Amp.Flat ->
(forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\y
x -> forall a. C a => a
oneforall a. C a => a -> a -> a
+y
xforall a. C a => a -> a -> a
*y
depth), forall amp. amp -> Numeric amp
Amp.Numeric T u y
center))
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<
forall y flat (arrow :: * -> * -> *).
(C y flat, Arrow arrow) =>
Single arrow flat (Flat y) y y
ArrowD.canonicalizeFlat
{-# INLINE mapExponential #-}
mapExponential ::
(Flat.C y flat, Trans.C y, Dim.C u, Arrow arrow) =>
y ->
DN.T u q ->
ArrowD.T arrow (Sample.T flat y) (DNS u q y)
mapExponential :: forall y flat u (arrow :: * -> * -> *) q.
(C y flat, C y, C u, Arrow arrow) =>
y -> T u q -> T arrow (T flat y) (DNS u q y)
mapExponential y
depth T u q
center =
let logDepth :: y
logDepth = forall a. C a => a -> a
log y
depth
in forall (arrow :: * -> * -> *) sample0 sample1.
(Amplitude sample0
-> (arrow (Displacement sample0) (Displacement sample1),
Amplitude sample1))
-> T arrow sample0 sample1
ArrowD.Cons (\Flat y
Amplitude (T (Flat y) y)
Amp.Flat ->
(forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a. C a => a -> a
exp forall b c a. (b -> c) -> (a -> b) -> a -> c
. (y
logDepthforall a. C a => a -> a -> a
*)), forall amp. amp -> Numeric amp
Amp.Numeric T u q
center))
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<
forall y flat (arrow :: * -> * -> *).
(C y flat, Arrow arrow) =>
Single arrow flat (Flat y) y y
ArrowD.canonicalizeFlat
{-# INLINE mapLinearDimension #-}
mapLinearDimension ::
(Field.C y, Absolute.C y, Dim.C u, Dim.C v, Arrow arrow) =>
DN.T v y
-> DN.T (Dim.Mul v u) y
-> ArrowD.T arrow (DNS u y y) (DNS (Dim.Mul v u) y y)
mapLinearDimension :: forall y u v (arrow :: * -> * -> *).
(C y, C y, C u, C v, Arrow arrow) =>
T v y -> T (Mul v u) y -> T arrow (DNS u y y) (DNS (Mul v u) y y)
mapLinearDimension T v y
range T (Mul v u) y
center =
forall (arrow :: * -> * -> *) sample0 sample1.
(Amplitude sample0
-> (arrow (Displacement sample0) (Displacement sample1),
Amplitude sample1))
-> T arrow sample0 sample1
ArrowD.Cons forall a b. (a -> b) -> a -> b
$ \(Amp.Numeric T u y
ampIn) ->
let absRange :: T (Mul v u) y
absRange = forall u a. (C u, C a) => T u a -> T u a
DN.abs T v y
range forall u v a. (C u, C v, C a) => T u a -> T v a -> T (Mul u v) a
&*& T u y
ampIn
absCenter :: T (Mul v u) y
absCenter = forall u a. (C u, C a) => T u a -> T u a
DN.abs T (Mul v u) y
center
ampOut :: T (Mul v u) y
ampOut = T (Mul v u) y
absRange forall a. C a => a -> a -> a
+ T (Mul v u) y
absCenter
rng :: y
rng = forall u a. (C u, C a) => T u a -> T u a -> a
DN.divToScalar T (Mul v u) y
absRange T (Mul v u) y
ampOut
cnt :: y
cnt = forall u a. (C u, C a) => T u a -> T u a -> a
DN.divToScalar T (Mul v u) y
absCenter T (Mul v u) y
ampOut
in (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\y
y -> y
cnt forall a. C a => a -> a -> a
+ y
rngforall a. C a => a -> a -> a
*y
y), forall amp. amp -> Numeric amp
Amp.Numeric T (Mul v u) y
ampOut)
{-# INLINE toAmplitudeScalar #-}
toAmplitudeScalar ::
(Field.C y, Dim.C u) =>
DN.T u y -> Context u y (y -> y)
toAmplitudeScalar :: forall y u. (C y, C u) => T u y -> Context u y (y -> y)
toAmplitudeScalar T u y
ampIn =
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (\T u y
ampOut -> (forall u a. (C u, C a) => T u a -> T u a -> a
DN.divToScalar T u y
ampIn T u y
ampOut forall a. C a => a -> a -> a
*))
{-# INLINE toAmplitudeVector #-}
toAmplitudeVector ::
(Module.C y yv, Field.C y, Dim.C u) =>
DN.T u y -> Context u y (yv -> yv)
toAmplitudeVector :: forall y yv u.
(C y yv, C y, C u) =>
T u y -> Context u y (yv -> yv)
toAmplitudeVector T u y
ampIn =
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (\T u y
ampOut -> (forall u a. (C u, C a) => T u a -> T u a -> a
DN.divToScalar T u y
ampIn T u y
ampOut forall a v. C a v => a -> v -> v
*> ))
{-# INLINE fromAmplitudeReader #-}
fromAmplitudeReader ::
(Sample.Amplitude sampleIn ->
(ampOut,
Reader ampOut (arrow (Sample.Displacement sampleIn) yvOut))) ->
ArrowD.T arrow sampleIn (Sample.Numeric ampOut yvOut)
fromAmplitudeReader :: forall sampleIn ampOut (arrow :: * -> * -> *) yvOut.
(Amplitude sampleIn
-> (ampOut, Reader ampOut (arrow (Displacement sampleIn) yvOut)))
-> T arrow sampleIn (Numeric ampOut yvOut)
fromAmplitudeReader Amplitude sampleIn
-> (ampOut, Reader ampOut (arrow (Displacement sampleIn) yvOut))
f =
forall (arrow :: * -> * -> *) sample0 sample1.
(Amplitude sample0
-> (arrow (Displacement sample0) (Displacement sample1),
Amplitude sample1))
-> T arrow sample0 sample1
ArrowD.Cons forall a b. (a -> b) -> a -> b
$ \Amplitude sampleIn
ampIn ->
let (ampOut
ampOut, Reader ampOut (arrow (Displacement sampleIn) yvOut)
rd) = Amplitude sampleIn
-> (ampOut, Reader ampOut (arrow (Displacement sampleIn) yvOut))
f Amplitude sampleIn
ampIn
in (forall r a. Reader r a -> r -> a
runReader Reader ampOut (arrow (Displacement sampleIn) yvOut)
rd ampOut
ampOut, forall amp. amp -> Numeric amp
Amp.Numeric ampOut
ampOut)