{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{- |
Copyright   :  (c) Henning Thielemann 2008
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes
-}
module Synthesizer.State.Control (
   constant,
   line,
   linear, linearMultiscale, linearMultiscaleNeutral,
   exponential, exponentialMultiscale, exponentialMultiscaleNeutral,
   exponential2, exponential2Multiscale, exponential2MultiscaleNeutral,
   exponentialFromTo, exponentialFromToMultiscale,
   vectorExponential,
   vectorExponential2,
   cosine,
   cubicHermite,

   -- used in Analysis
   curveMultiscale,
   curveMultiscaleNeutral,
   ) where

import qualified Synthesizer.Plain.Control as Ctrl

import qualified Synthesizer.State.Signal as Sig

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

import NumericPrelude.Numeric
import NumericPrelude.Base


{- * Control curve generation -}

{-# INLINE constant #-}
constant :: a -> Sig.T a
constant :: forall a. a -> T a
constant = a -> T a
forall a. a -> T a
Sig.repeat

{-# INLINE linear #-}
linear :: Additive.C a =>
      a   {-^ steepness -}
   -> a   {-^ initial value -}
   -> Sig.T a
          {-^ linear progression -}
linear :: forall a. C a => a -> a -> T a
linear a
d a
y0 = (a -> a) -> a -> T a
forall a. (a -> a) -> a -> T a
Sig.iterate (a
da -> a -> a
forall a. C a => a -> a -> a
+) a
y0

{- |
As stable as the addition of time values.
-}
{-# INLINE linearMultiscale #-}
linearMultiscale :: Additive.C y =>
      y
   -> y
   -> Sig.T y
linearMultiscale :: forall a. C a => a -> a -> T a
linearMultiscale = (y -> y -> y) -> y -> y -> T y
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale y -> y -> y
forall a. C a => a -> a -> a
(+)

{- |
Linear curve starting at zero.
-}
{-# INLINE linearMultiscaleNeutral #-}
linearMultiscaleNeutral :: Additive.C y =>
      y
   -> Sig.T y
linearMultiscaleNeutral :: forall y. C y => y -> T y
linearMultiscaleNeutral y
slope =
   (y -> y -> y) -> y -> y -> T y
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscaleNeutral 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.
-}
{-# INLINE line #-}
line :: Field.C y =>
      Int     {-^ length -}
   -> (y,y)   {-^ initial and final value -}
   -> Sig.T y {-^ linear progression -}
line :: forall y. C y => Int -> (y, y) -> T y
line Int
n (y
y0,y
y1) =
   Int -> T y -> T y
forall a. Int -> T a -> T a
Sig.take Int
n (T y -> T y) -> T y -> T y
forall a b. (a -> b) -> a -> b
$ y -> y -> T y
forall a. C a => a -> a -> T a
linear ((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


{-# INLINE exponential #-}
{-# INLINE exponentialMultiscale #-}
exponential, exponentialMultiscale :: Trans.C a =>
      a   {-^ time where the function reaches 1\/e of the initial value -}
   -> a   {-^ initial value -}
   -> Sig.T a
          {-^ exponential decay -}
exponential :: forall a. C a => a -> a -> T a
exponential a
time =
   (a -> a) -> a -> T a
forall a. (a -> a) -> a -> T a
Sig.iterate (a -> a
forall a. C a => a -> a
exp (- a -> a
forall a. C a => a -> a
recip a
time) a -> a -> a
forall a. C a => a -> a -> a
*)

exponentialMultiscale :: forall a. C a => a -> a -> T a
exponentialMultiscale a
time = (a -> a -> a) -> a -> a -> T a
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale a -> a -> a
forall a. C a => a -> a -> a
(*) (a -> a
forall a. C a => a -> a
exp (- a -> a
forall a. C a => a -> a
recip a
time))

{-# INLINE exponentialMultiscaleNeutral #-}
exponentialMultiscaleNeutral :: Trans.C y =>
      y   {-^ time where the function reaches 1\/e of the initial value -}
   -> Sig.T y {-^ exponential decay -}
exponentialMultiscaleNeutral :: forall y. C y => y -> T y
exponentialMultiscaleNeutral y
time =
   (y -> y -> y) -> y -> y -> T y
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscaleNeutral 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


{-# INLINE exponential2 #-}
{-# INLINE exponential2Multiscale #-}
exponential2, exponential2Multiscale :: Trans.C a =>
      a   {-^ half life -}
   -> a   {-^ initial value -}
   -> Sig.T a
          {-^ exponential decay -}
exponential2 :: forall a. C a => a -> a -> T a
exponential2 a
halfLife =
   (a -> a) -> a -> T a
forall a. (a -> a) -> a -> T a
Sig.iterate (((a
forall a. C a => a
Ring.onea -> a -> a
forall a. C a => a -> a -> a
+a
forall a. C a => a
Ring.one) a -> a -> a
forall a. C a => a -> a -> a
** (- a -> a
forall a. C a => a -> a
recip a
halfLife)) a -> a -> a
forall a. C a => a -> a -> a
*)
--   Sig.iterate (((Ring.one/(Ring.one+Ring.one)) ** recip halfLife) *)

exponential2Multiscale :: forall a. C a => a -> a -> T a
exponential2Multiscale a
halfLife = (a -> a -> a) -> a -> a -> T a
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale a -> a -> a
forall a. C a => a -> a -> a
(*) (a
0.5 a -> a -> a
forall a. C a => a -> a -> a
** a -> a
forall a. C a => a -> a
recip a
halfLife)

{- the 0.5 constant seems to block fusion
   Sig.iterate ((0.5 ** recip halfLife) *)
-}
{- dito fromInteger
   Sig.iterate ((fromInteger 2 ** (- recip halfLife)) *)
-}

{-# INLINE exponential2MultiscaleNeutral #-}
exponential2MultiscaleNeutral :: Trans.C y =>
      y   {-^ half life -}
   -> Sig.T y {-^ exponential decay -}
exponential2MultiscaleNeutral :: forall y. C y => y -> T y
exponential2MultiscaleNeutral y
halfLife =
   (y -> y -> y) -> y -> y -> T y
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscaleNeutral 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


{-# INLINE exponentialFromTo #-}
{-# INLINE exponentialFromToMultiscale #-}
exponentialFromTo, exponentialFromToMultiscale :: Trans.C y =>
      y   {-^ time where the function reaches 1\/e of the initial value -}
   -> y   {-^ initial value -}
   -> y   {-^ value after given time -}
   -> Sig.T y {-^ exponential decay -}
exponentialFromTo :: forall y. C y => y -> y -> y -> T y
exponentialFromTo y
time y
y0 y
y1 =
   (y -> y) -> y -> T y
forall a. (a -> a) -> a -> T a
Sig.iterate (y -> y -> y
forall a. C a => a -> a -> a
*  (y
y1y -> y -> y
forall a. C a => a -> a -> a
/y
y0) y -> y -> y
forall a. C a => a -> a -> a
** y -> y
forall a. C a => a -> a
recip y
time) y
y0
exponentialFromToMultiscale :: forall y. C y => y -> y -> y -> T y
exponentialFromToMultiscale y
time y
y0 y
y1 =
   (y -> y -> y) -> y -> y -> T y
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale y -> y -> y
forall a. C a => a -> a -> a
(*) ((y
y1y -> y -> y
forall a. C a => a -> a -> a
/y
y0) y -> y -> y
forall a. C a => a -> a -> a
** y -> y
forall a. C a => a -> a
recip y
time) y
y0




{-| 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. -}
{-# INLINE vectorExponential #-}
vectorExponential :: (Trans.C a, Module.C a v) =>
       a  {-^ time where the function reaches 1\/e of the initial value -}
   ->  v  {-^ initial value -}
   -> Sig.T v
          {-^ exponential decay -}
vectorExponential :: forall a v. (C a, C a v) => a -> v -> T v
vectorExponential a
time v
y0 =
   (v -> v) -> v -> T v
forall a. (a -> a) -> a -> T a
Sig.iterate (a -> a
forall a. C a => a -> a
exp (-a
1a -> a -> a
forall a. C a => a -> a -> a
/a
time) a -> v -> v
forall a v. C a v => a -> v -> v
*>) v
y0

{-# INLINE vectorExponential2 #-}
vectorExponential2 :: (Trans.C a, Module.C a v) =>
       a  {-^ half life -}
   ->  v  {-^ initial value -}
   -> Sig.T v
          {-^ exponential decay -}
vectorExponential2 :: forall a v. (C a, C a v) => a -> v -> T v
vectorExponential2 a
halfLife v
y0 =
   (v -> v) -> v -> T v
forall a. (a -> a) -> a -> T a
Sig.iterate (a
0.5a -> a -> a
forall a. C a => a -> a -> a
**(a
1a -> a -> a
forall a. C a => a -> a -> a
/a
halfLife) a -> v -> v
forall a v. C a v => a -> v -> v
*>) v
y0



{-# INLINE cosine #-}
cosine :: Trans.C a =>
       a  {-^ time t0 where  1 is approached -}
   ->  a  {-^ time t1 where -1 is approached -}
   -> Sig.T a
          {-^ a cosine wave where one half wave is between t0 and t1 -}
cosine :: forall a. C a => a -> a -> T a
cosine = (a -> a -> T a) -> a -> a -> T a
forall y signal. C y => (y -> y -> signal) -> y -> y -> signal
Ctrl.cosineWithSlope ((a -> a -> T a) -> a -> a -> T a)
-> (a -> a -> T a) -> a -> a -> T a
forall a b. (a -> b) -> a -> b
$
   \a
d a
x -> (a -> a) -> T a -> T a
forall a b. (a -> b) -> T a -> T b
Sig.map a -> a
forall a. C a => a -> a
cos (a -> a -> T a
forall a. C a => a -> a -> T a
linear a
d a
x)



{-# INLINE cubicHermite #-}
cubicHermite :: Field.C a => (a, (a,a)) -> (a, (a,a)) -> Sig.T a
cubicHermite :: forall a. C a => (a, (a, a)) -> (a, (a, a)) -> T a
cubicHermite (a, (a, a))
node0 (a, (a, a))
node1 =
   (a -> a) -> T a -> T a
forall a b. (a -> b) -> T a -> T b
Sig.map ((a, (a, a)) -> (a, (a, a)) -> a -> a
forall y. C y => (y, (y, y)) -> (y, (y, y)) -> y -> y
Ctrl.cubicFunc (a, (a, a))
node0 (a, (a, a))
node1) (a -> a -> T a
forall a. C a => a -> a -> T a
linear a
1 a
0)


-- * auxiliary functions

{-# INLINE curveMultiscale #-}
curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y
curveMultiscale :: forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale y -> y -> y
op y
d y
y0 =
   y -> T y -> T y
forall a. a -> T a -> T a
Sig.cons y
y0 ((y -> y) -> T y -> T y
forall a b. (a -> b) -> T a -> T b
Sig.map (y -> y -> y
op y
y0) ((y -> y -> y) -> y -> T y
forall a. (a -> a -> a) -> a -> T a
Sig.iterateAssociative y -> y -> y
op y
d))

{-# INLINE curveMultiscaleNeutral #-}
curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y
curveMultiscaleNeutral :: forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscaleNeutral y -> y -> y
op y
d y
neutral =
   y -> T y -> T y
forall a. a -> T a -> T a
Sig.cons y
neutral ((y -> y -> y) -> y -> T y
forall a. (a -> a -> a) -> a -> T a
Sig.iterateAssociative y -> y -> y
op y
d)