{-# 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.FusionList.Control where

import qualified Synthesizer.Plain.Control as Ctrl
import qualified Synthesizer.Piecewise as Piecewise

-- import Synthesizer.FusionList.Displacement (raise)
import qualified Synthesizer.FusionList.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 qualified Algebra.Additive              as Additive

import Algebra.Module((*>))

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

import qualified Prelude as P
import PreludeBase
import NumericPrelude


{- * Control curve generation -}

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

{-# INLINE linear #-}
linear :: Additive.C a =>
      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 #-}
linearMultiscale :: Additive.C y =>
      y
   -> y
   -> Sig.T y
linearMultiscale = curveMultiscale (+)

{- |
Linear curve starting at zero.
-}
{-# INLINE linearMultiscaleNeutral #-}
linearMultiscaleNeutral :: Additive.C y =>
      y
   -> Sig.T y
linearMultiscaleNeutral slope =
   curveMultiscaleNeutral (+) slope zero

{-# 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/2)+(1-y)*(y1/2))
         (cosine t0 (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))

raise :: Additive.C a => a -> Sig.T a -> Sig.T a
raise = Sig.map . (+)

-- * 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)