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

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes
-}
module Synthesizer.State.Control where

import qualified Synthesizer.Plain.Control as Ctrl
import qualified Synthesizer.Piecewise as Piecewise
import Synthesizer.State.Displacement (raise)

import qualified Synthesizer.State.Signal as Sig

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

import Algebra.Module((*>))

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

import Data.Ix (Ix, )

import qualified Prelude as P
import PreludeBase
import NumericPrelude

{- * Control curve generation -}

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

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

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

{- |
Linear curve starting at zero.
-}
{-# INLINE linearMultiscaleNeutral #-}
y
-> Sig.T y
linearMultiscaleNeutral slope =
curveMultiscaleNeutral (+) slope 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
-}
{-# INLINE line #-}
line :: Field.C y =>
Int     {-^ length -}
-> (y,y)   {-^ initial and final value -}
-> Sig.T y {-^ linear progression -}
line n (y0,y1) =
Sig.take n \$ linear ((y1-y0) / fromIntegral n) 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 time =
Sig.iterate (exp (- recip time) *)

exponentialMultiscale time = curveMultiscale (*) (exp (- recip 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 time =
curveMultiscaleNeutral (*) (exp (- recip time)) one

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

exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip 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 halfLife =
curveMultiscaleNeutral (*) (0.5 ** recip halfLife) 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 time y0 y1 =
Sig.iterate (*  (y1/y0) ** recip time) y0
exponentialFromToMultiscale time y0 y1 =
curveMultiscale (*) ((y1/y0) ** recip time) 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 time y0 =
Sig.iterate (exp (-1/time) *>) y0

{-# INLINE vectorExponential2 #-}
vectorExponential2 :: (Trans.C a, Module.C a v) =>
a  {-^ half life -}
->  v  {-^ initial value -}
-> Sig.T v
{-^ exponential decay -}
vectorExponential2 halfLife y0 =
Sig.iterate (0.5**(1/halfLife) *>) 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 = Ctrl.cosineWithSlope \$
\d x -> Sig.map cos (linear d x)

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

-- * piecewise curves

splitDurations :: (RealField.C t) =>
[t] -> [(Int, t)]
splitDurations ts0 =
let (ds,ts) =
unzip \$ scanl
(\(_,fr) d -> splitFraction (fr+d))
(0,1) ts0
in  zip (tail ds) (map (subtract 1) ts)

{-# INLINE piecewise #-}
piecewise :: (RealField.C a) =>
Piecewise.T a a (a -> Sig.T a) -> Sig.T a
piecewise xs =
Sig.concat \$ zipWith
(\(n, t) (Piecewise.PieceData c yi0 yi1 d) ->
Sig.take n \$ Piecewise.computePiece c yi0 yi1 d t)
(splitDurations \$ map Piecewise.pieceDur xs)
xs

type Piece a =
Piecewise.Piece a a
(a {- fractional start time -} -> Sig.T a)

{-# INLINE stepPiece #-}
stepPiece :: Piece a
stepPiece =
Piecewise.pieceFromFunction \$ \ y0 _y1 _d _t0 ->
constant y0

{-# INLINE linearPiece #-}
linearPiece :: (Field.C a) => Piece a
linearPiece =
Piecewise.pieceFromFunction \$ \ y0 y1 d t0 ->
let s = (y1-y0)/d in linear s (y0-t0*s)

{-# INLINE exponentialPiece #-}
exponentialPiece :: (Trans.C a) => a -> Piece a
exponentialPiece saturation =
Piecewise.pieceFromFunction \$ \ y0 y1 d t0 ->
let y0' = y0-saturation
y1' = y1-saturation
yd  = y0'/y1'
in  raise saturation
(exponential (d / log yd) (y0' * yd**(t0/d)))

{-# INLINE cosinePiece #-}
cosinePiece :: (Trans.C a) => Piece a
cosinePiece =
Piecewise.pieceFromFunction \$ \ y0 y1 d t0 ->
Sig.map
(\y -> ((1+y)*y0+(1-y)*y1)/2)
(cosine t0 (t0+d))

data FlatPosition =
FlatLeft | FlatRight
deriving (Show, Eq, Ord, Ix, Enum)

{- |
> Graphics.Gnuplot.Simple.plotList [] \$ Sig.toList \$ piecewise \$ 1 |# (10.9, halfSinePiece FlatRight) #| 2
-}
{-# INLINE halfSinePiece #-}
halfSinePiece :: (Trans.C a) => FlatPosition -> Piece a
halfSinePiece FlatLeft =
Piecewise.pieceFromFunction \$ \ y0 y1 d t0 ->
Sig.map
(\y -> y*y0 + (1-y)*y1)
(cosine t0 (t0+2*d))
halfSinePiece FlatRight =
Piecewise.pieceFromFunction \$ \ y0 y1 d t0 ->
Sig.map
(\y -> (1+y)*y0 - y*y1)
(cosine (t0-d) (t0+d))

{-# INLINE cubicPiece #-}
cubicPiece :: (Field.C a) => a -> a -> Piece a
cubicPiece yd0 yd1 =
Piecewise.pieceFromFunction \$ \ y0 y1 d t0 ->
cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1))

-- * auxiliary functions

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

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