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 qualified Algebra.Additive       as Additive

-- import Algebra.Module ((*>))

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)


-- * Mixing

{- |
Mix two signals.
In contrast to 'zipWith' the result has the length of the longer signal.
-}
{-# 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)


{- |
Mix one or more signals.
-}
{-# 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)

{- |
Mix zero or more signals.
-}
{-# 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


-- * Miscellaneous

{- |
Add a number to all of the signal values.
This is useful for adjusting the center of a modulation.
-}
{-# 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'))

{- |
Distort the signal using a flat function.
The first signal gives the scaling of the function.
If the scaling is @c@ and the input sample is @y@,
then @c * f(y/c)@ is emitted.
This way we can use an (efficient) flat function
and have a simple, yet dimension conform, way of controlling the distortion.
E.g. if the distortion function is @tanh@
then the value @c@ controls the saturation level.
-}
{-# 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))



{- |
Map a control curve without amplitude unit
by a linear (affine) function with a unit.
This is a combination of 'raise' and 'amplify'.

It is not quite correct in the sense,
that it does not produce low-level sample values in the range (-1,1).
Instead it generates values around 1.
-}
{-# 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 =
   {-
   X86 processors only have (logBase 2) and (2**).
   Thus on those machines computing with respect to base 2
   can be more efficient and more precise.
   -}
   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              {- ^ range: one is mapped to @center + range * ampX@ -}
   -> DN.T (Dim.Mul v u) y  {- ^ center: zero is mapped to @center@ -}
   -> 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)


-- auxiliary functions

{-# 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)