{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
module Synthesizer.Generic.Control (
   constant,
   linear,
   linearMultiscale,
   linearMultiscaleNeutral,
   line,
   exponential, exponentialMultiscale,
   exponentialMultiscaleNeutral,
   exponential2, exponential2Multiscale,
   exponential2MultiscaleNeutral,
   vectorExponential,
   vectorExponential2,
   cosine, cosineMultiscaleLinear,
   cosineMultiscale,
   Ctrl.cosineWithSlope,
   cubicHermite,
   ) where

import qualified Synthesizer.Plain.Control as Ctrl

import qualified Synthesizer.Generic.Signal as SigG

import qualified Algebra.Module                as Module
import qualified Algebra.Transcendental        as Trans
import qualified Algebra.Field                 as Field
import qualified Algebra.Additive              as Additive

import qualified Number.Complex as Complex
import Number.Complex (cis,real)

import NumericPrelude.Numeric
import NumericPrelude.Base


{- * Control curve generation -}

constant :: (SigG.Write sig y) =>
   SigG.LazySize -> y -> sig y
constant :: forall (sig :: * -> *) y. Write sig y => LazySize -> y -> sig y
constant = LazySize -> y -> sig y
forall y. Storage (sig y) => LazySize -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> y -> sig y
SigG.repeat


linear :: (Additive.C y, SigG.Write sig y) =>
      SigG.LazySize
   -> y   {-^ steepness -}
   -> y   {-^ initial value -}
   -> sig y
          {-^ linear progression -}
linear :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
linear LazySize
size y
d y
y0 = LazySize -> (y -> y) -> y -> sig y
forall y. Storage (sig y) => LazySize -> (y -> y) -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> (y -> y) -> y -> sig y
SigG.iterate LazySize
size (y
dy -> y -> y
forall a. C a => a -> a -> a
+) y
y0

{- |
Minimize rounding errors by reducing number of operations per element
to a logarithmuc number.
-}
linearMultiscale ::
   (Additive.C y, SigG.Write sig y) =>
      SigG.LazySize
   -> y
   -> y
   -> sig y
linearMultiscale :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
linearMultiscale LazySize
size =
   LazySize -> (y -> y -> y) -> y -> y -> sig y
forall (sig :: * -> *) y.
Write sig y =>
LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscale LazySize
size y -> y -> y
forall a. C a => a -> a -> a
(+)

{- |
Linear curve starting at zero.
-}
linearMultiscaleNeutral :: (Additive.C y, SigG.Write sig y) =>
      SigG.LazySize
   -> y
   -> sig y
linearMultiscaleNeutral :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> sig y
linearMultiscaleNeutral LazySize
size y
slope =
   LazySize -> (y -> y -> y) -> y -> y -> sig y
forall (sig :: * -> *) y.
Write sig y =>
LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscaleNeutral LazySize
size y -> y -> y
forall a. C a => a -> a -> a
(+) y
slope y
forall a. C a => a
zero

{- |
Linear curve of a fixed length.
The final value is not actually reached,
instead we stop one step before.
This way we can concatenate several lines
without duplicate adjacent values.
-}
line :: (Field.C y, SigG.Write sig y) =>
      SigG.LazySize
   -> Int   {-^ length -}
   -> (y,y) {-^ initial and final value -}
   -> sig y
            {-^ linear progression -}
line :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> Int -> (y, y) -> sig y
line LazySize
size Int
n (y
y0,y
y1) =
   Int -> sig y -> sig y
forall sig. Transform sig => Int -> sig -> sig
SigG.take Int
n (sig y -> sig y) -> sig y -> sig y
forall a b. (a -> b) -> a -> b
$ LazySize -> y -> y -> sig y
forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
linear LazySize
size ((y
y1y -> y -> y
forall a. C a => a -> a -> a
-y
y0) y -> y -> y
forall a. C a => a -> a -> a
/ Int -> y
forall a b. (C a, C b) => a -> b
fromIntegral Int
n) y
y0


exponential, exponentialMultiscale ::
   (Trans.C y, SigG.Write sig y) =>
      SigG.LazySize
   -> y   {-^ time where the function reaches 1\/e of the initial value -}
   -> y   {-^ initial value -}
   -> sig y
          {-^ exponential decay -}
exponential :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
exponential LazySize
size y
time =
   LazySize -> (y -> y) -> y -> sig y
forall y. Storage (sig y) => LazySize -> (y -> y) -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> (y -> y) -> y -> sig y
SigG.iterate LazySize
size (y -> y -> y
forall a. C a => a -> a -> a
* y -> y
forall a. C a => a -> a
exp (- y -> y
forall a. C a => a -> a
recip y
time))
exponentialMultiscale :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
exponentialMultiscale LazySize
size y
time =
   LazySize -> (y -> y -> y) -> y -> y -> sig y
forall (sig :: * -> *) y.
Write sig y =>
LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscale LazySize
size y -> y -> y
forall a. C a => a -> a -> a
(*) (y -> y
forall a. C a => a -> a
exp (- y -> y
forall a. C a => a -> a
recip y
time))

exponentialMultiscaleNeutral :: (Trans.C y, SigG.Write sig y) =>
      SigG.LazySize
   -> y   {-^ time where the function reaches 1\/e of the initial value -}
   -> sig y
          {-^ exponential decay -}
exponentialMultiscaleNeutral :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> sig y
exponentialMultiscaleNeutral LazySize
size y
time =
   LazySize -> (y -> y -> y) -> y -> y -> sig y
forall (sig :: * -> *) y.
Write sig y =>
LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscaleNeutral LazySize
size y -> y -> y
forall a. C a => a -> a -> a
(*) (y -> y
forall a. C a => a -> a
exp (- y -> y
forall a. C a => a -> a
recip y
time)) y
forall a. C a => a
one

exponential2, exponential2Multiscale :: (Trans.C y, SigG.Write sig y) =>
      SigG.LazySize
   -> y   {-^ half life -}
   -> y   {-^ initial value -}
   -> sig y
          {-^ exponential decay -}
exponential2 :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
exponential2 LazySize
size y
halfLife =
   LazySize -> (y -> y) -> y -> sig y
forall y. Storage (sig y) => LazySize -> (y -> y) -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> (y -> y) -> y -> sig y
SigG.iterate LazySize
size (y -> y -> y
forall a. C a => a -> a -> a
*  y
0.5 y -> y -> y
forall a. C a => a -> a -> a
** y -> y
forall a. C a => a -> a
recip y
halfLife)
exponential2Multiscale :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
exponential2Multiscale LazySize
size y
halfLife =
   LazySize -> (y -> y -> y) -> y -> y -> sig y
forall (sig :: * -> *) y.
Write sig y =>
LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscale LazySize
size y -> y -> y
forall a. C a => a -> a -> a
(*) (y
0.5 y -> y -> y
forall a. C a => a -> a -> a
** y -> y
forall a. C a => a -> a
recip y
halfLife)

exponential2MultiscaleNeutral :: (Trans.C y, SigG.Write sig y) =>
      SigG.LazySize
   -> y   {-^ half life -}
   -> sig y
          {-^ exponential decay -}
exponential2MultiscaleNeutral :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> sig y
exponential2MultiscaleNeutral LazySize
size y
halfLife =
   LazySize -> (y -> y -> y) -> y -> y -> sig y
forall (sig :: * -> *) y.
Write sig y =>
LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscaleNeutral LazySize
size y -> y -> y
forall a. C a => a -> a -> a
(*) (y
0.5 y -> y -> y
forall a. C a => a -> a -> a
** y -> y
forall a. C a => a -> a
recip y
halfLife) y
forall a. C a => a
one




{-| This is an extension of 'exponential' to vectors
    which is straight-forward but requires more explicit signatures.
    But since it is needed rarely I setup a separate function. -}
vectorExponential ::
   (Trans.C y, Module.C y v, SigG.Write sig v) =>
      SigG.LazySize
   ->  y  {-^ time where the function reaches 1\/e of the initial value -}
   ->  v  {-^ initial value -}
   -> sig v
          {-^ exponential decay -}
vectorExponential :: forall y v (sig :: * -> *).
(C y, C y v, Write sig v) =>
LazySize -> y -> v -> sig v
vectorExponential LazySize
size y
time v
y0 =
   LazySize -> (v -> v) -> v -> sig v
forall y. Storage (sig y) => LazySize -> (y -> y) -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> (y -> y) -> y -> sig y
SigG.iterate LazySize
size (y -> y
forall a. C a => a -> a
exp (-y
1y -> y -> y
forall a. C a => a -> a -> a
/y
time) y -> v -> v
forall a v. C a v => a -> v -> v
*>) v
y0

vectorExponential2 ::
   (Trans.C y, Module.C y v, SigG.Write sig v) =>
      SigG.LazySize
   ->  y  {-^ half life -}
   ->  v  {-^ initial value -}
   -> sig v
          {-^ exponential decay -}
vectorExponential2 :: forall y v (sig :: * -> *).
(C y, C y v, Write sig v) =>
LazySize -> y -> v -> sig v
vectorExponential2 LazySize
size y
halfLife v
y0 =
   LazySize -> (v -> v) -> v -> sig v
forall y. Storage (sig y) => LazySize -> (y -> y) -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> (y -> y) -> y -> sig y
SigG.iterate LazySize
size (y
0.5y -> y -> y
forall a. C a => a -> a -> a
**(y
1y -> y -> y
forall a. C a => a -> a -> a
/y
halfLife) y -> v -> v
forall a v. C a v => a -> v -> v
*>) v
y0



cosine, cosineMultiscaleLinear :: (Trans.C y, SigG.Write sig y) =>
      SigG.LazySize
   ->  y  {-^ time t0 where  1 is approached -}
   ->  y  {-^ time t1 where -1 is approached -}
   -> sig y
          {-^ a cosine wave where one half wave is between t0 and t1 -}
cosine :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
cosine LazySize
size = (y -> y -> sig y) -> y -> y -> sig y
forall y signal. C y => (y -> y -> signal) -> y -> y -> signal
Ctrl.cosineWithSlope ((y -> y -> sig y) -> y -> y -> sig y)
-> (y -> y -> sig y) -> y -> y -> sig y
forall a b. (a -> b) -> a -> b
$
   \y
d y
x -> (y -> y) -> sig y -> sig y
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map y -> y
forall a. C a => a -> a
cos (LazySize -> y -> y -> sig y
forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
linear LazySize
size y
d y
x)

cosineMultiscaleLinear :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
cosineMultiscaleLinear LazySize
size = (y -> y -> sig y) -> y -> y -> sig y
forall y signal. C y => (y -> y -> signal) -> y -> y -> signal
Ctrl.cosineWithSlope ((y -> y -> sig y) -> y -> y -> sig y)
-> (y -> y -> sig y) -> y -> y -> sig y
forall a b. (a -> b) -> a -> b
$
   \y
d y
x -> (y -> y) -> sig y -> sig y
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map y -> y
forall a. C a => a -> a
cos (LazySize -> y -> y -> sig y
forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
linearMultiscale LazySize
size y
d y
x)

cosineMultiscale ::
   (Trans.C y, SigG.Write sig (Complex.T y),
    SigG.Transform sig (Complex.T y), SigG.Transform sig y) =>
      SigG.LazySize
   ->  y  {-^ time t0 where  1 is approached -}
   ->  y  {-^ time t1 where -1 is approached -}
   -> sig y
          {-^ a cosine wave where one half wave is between t0 and t1 -}
cosineMultiscale :: forall y (sig :: * -> *).
(C y, Write sig (T y), Transform sig (T y), Transform sig y) =>
LazySize -> y -> y -> sig y
cosineMultiscale LazySize
size = (y -> y -> sig y) -> y -> y -> sig y
forall y signal. C y => (y -> y -> signal) -> y -> y -> signal
Ctrl.cosineWithSlope ((y -> y -> sig y) -> y -> y -> sig y)
-> (y -> y -> sig y) -> y -> y -> sig y
forall a b. (a -> b) -> a -> b
$
   \y
d y
x -> (T y -> y) -> sig (T y) -> sig y
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map T y -> y
forall a. T a -> a
real (LazySize -> (T y -> T y -> T y) -> T y -> T y -> sig (T y)
forall (sig :: * -> *) y.
Write sig y =>
LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscale LazySize
size T y -> T y -> T y
forall a. C a => a -> a -> a
(*) (y -> T y
forall a. C a => a -> T a
cis y
d) (y -> T y
forall a. C a => a -> T a
cis y
x))


cubicHermite :: (Field.C y, SigG.Write sig y) =>
      SigG.LazySize
   -> (y, (y,y)) -> (y, (y,y)) -> sig y
cubicHermite :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> (y, (y, y)) -> (y, (y, y)) -> sig y
cubicHermite LazySize
size (y, (y, y))
node0 (y, (y, y))
node1 =
   (y -> y) -> sig y -> sig y
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map ((y, (y, y)) -> (y, (y, y)) -> y -> y
forall y. C y => (y, (y, y)) -> (y, (y, y)) -> y -> y
Ctrl.cubicFunc (y, (y, y))
node0 (y, (y, y))
node1) (sig y -> sig y) -> sig y -> sig y
forall a b. (a -> b) -> a -> b
$ LazySize -> y -> y -> sig y
forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
linear LazySize
size y
1 y
0


{- * Auxiliary functions -}


curveMultiscale :: (SigG.Write sig y) =>
   SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscale :: forall (sig :: * -> *) y.
Write sig y =>
LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscale LazySize
size y -> y -> y
op y
d y
y0 =
   y -> sig y -> sig y
forall y. Storage (sig y) => y -> sig y -> sig y
forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
y -> sig y -> sig y
SigG.cons y
y0 (sig y -> sig y) -> (sig y -> sig y) -> sig y -> sig y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (y -> y) -> sig y -> sig y
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map (y -> y -> y
op y
y0) (sig y -> sig y) -> sig y -> sig y
forall a b. (a -> b) -> a -> b
$ LazySize -> (y -> y -> y) -> y -> sig y
forall y.
Storage (sig y) =>
LazySize -> (y -> y -> y) -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> (y -> y -> y) -> y -> sig y
SigG.iterateAssociative LazySize
size y -> y -> y
op y
d


curveMultiscaleNeutral :: (SigG.Write sig y) =>
   SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscaleNeutral :: forall (sig :: * -> *) y.
Write sig y =>
LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscaleNeutral LazySize
size y -> y -> y
op y
d y
neutral =
   y -> sig y -> sig y
forall y. Storage (sig y) => y -> sig y -> sig y
forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
y -> sig y -> sig y
SigG.cons y
neutral (sig y -> sig y) -> sig y -> sig y
forall a b. (a -> b) -> a -> b
$ LazySize -> (y -> y -> y) -> y -> sig y
forall y.
Storage (sig y) =>
LazySize -> (y -> y -> y) -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> (y -> y -> y) -> y -> sig y
SigG.iterateAssociative LazySize
size y -> y -> y
op y
d