{- |
Copyright   :  (c) Henning Thielemann 2008
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes


Control curves which can be used
as envelopes, for controlling filter parameters and so on.
-}
module Synthesizer.Dimensional.RateAmplitude.Control
   ({- * Primitives -}
    constant, constantVector,
    linear, line,
    exponential, exponential2, exponentialFromTo,
    cubicHermite,
    {- * Piecewise -}
    stepPiece, linearPiece, exponentialPiece, cosinePiece, cubicPiece,
    piecewise, piecewiseVolume, Piece, Piecewise,
    (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|),  -- spaces before # for Haddock
    {- * Preparation -}
    mapLinearDimension, mapExponentialDimension, )
   where

import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlA
import qualified Synthesizer.State.Control as Ctrl
import qualified Synthesizer.Dimensional.Straight.Signal as SigS

import qualified Synthesizer.Piecewise as Piecewise
import Synthesizer.Piecewise ((-|#), ( #|-), (=|#), ( #|=), (|#), ( #|), )

import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA
import qualified Synthesizer.Dimensional.Process as Proc
-- import Synthesizer.Dimensional.Process (($:), ($#), )
import Synthesizer.Dimensional.RateAmplitude.Signal
          (toTimeScalar, toAmplitudeScalar, toGradientScalar, DimensionGradient)

import qualified Synthesizer.State.Signal as Sig

import qualified Number.DimensionTerm        as DN
import qualified Algebra.DimensionTerm       as Dim

-- import Number.DimensionTerm ((&*&))

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

-- import Control.Monad.Fix (mfix, )
import Control.Monad (liftM3, )

import NumericPrelude
import PreludeBase
import Prelude ()



{-# INLINE constant #-}
constant :: (Real.C y, Dim.C u, Dim.C v) =>
      DN.T v y {-^ value -}
   -> Proc.T s u t (SigA.R s v y y)
constant y = Proc.pure $ CtrlA.constant y

{- |
The amplitude must be positive!
This is not checked.
-}
{-# INLINE constantVector #-}
constantVector :: -- (Field.C y', Real.C y', Dim.C v) =>
      DN.T v y {-^ amplitude -}
   -> yv       {-^ value -}
   -> Proc.T s u t (SigA.R s v y yv)
constantVector y yv = Proc.pure $ CtrlA.constantVector y yv

{- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable'
   the type class constraints would be weaker.
linear :: (Additive.C y, Field.C y', Real.C y', Dim.C v) =>
-}

{- |
Caution: This control curve can contain samples
with an absolute value greater than 1.

Linear curves starting with zero are impossible.
Maybe you prefer using 'line'.
-}
{-# INLINE linear #-}
linear ::
   (Field.C q, Real.C q, Dim.C u, Dim.C v) =>
      DN.T (DimensionGradient u v) q
               {-^ slope of the curve -}
   -> DN.T v q {-^ initial value -}
   -> Proc.T s u q (SigA.R s v q q)
linear slope y0 =
   let (amp,sgn) = DN.absSignum y0
   in  do steep <- toGradientScalar amp slope
          return (SigA.fromSamples amp (Ctrl.linearMultiscale steep sgn))

{- |
Generates a finite ramp.
-}
{-# INLINE line #-}
line ::
   (RealField.C q, Dim.C u, Dim.C v) =>
      DN.T u q      {-^ duration of the ramp -}
   -> (DN.T v q, DN.T v q)
                    {-^ initial and final value -}
   -> Proc.T s u q (SigA.R s v q q)
line dur' (y0',y1') =
   (toTimeScalar dur') >>= \dur -> return $
      let amp = max (DN.abs y0') (DN.abs y1')
          y0  = toAmplitudeScalar z y0'
          y1  = toAmplitudeScalar z y1'
          z = SigA.fromSamples amp
                 (Sig.take (floor dur)
                    (Ctrl.linearMultiscale ((y1-y0)/dur) y0))
      in  z

{-# INLINE exponential #-}
exponential :: (Trans.C q, Real.C q, Dim.C u, Dim.C v) =>
      DN.T u q {-^ time where the function reaches 1\/e of the initial value -}
   -> DN.T v q {-^ initial value -}
   -> Proc.T s u q (SigA.R s v q q)
exponential time y0 =
   (toTimeScalar time) >>= \t -> return $
      let (amp,sgn) = DN.absSignum y0
      in  SigA.fromSamples amp (Ctrl.exponentialMultiscale t sgn)

{-
  take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble)
-}

{-# INLINE exponential2 #-}
exponential2 :: (Trans.C q, Real.C q, Dim.C u, Dim.C v) =>
      DN.T u q {-^ half life, time where the function reaches 1\/2 of the initial value -}
   -> DN.T v q {-^ initial value -}
   -> Proc.T s u q (SigA.R s v q q)
exponential2 time y0 =
   (toTimeScalar time) >>= \t -> return $
      let (amp,sgn) = DN.absSignum y0
      in  SigA.fromSamples amp (Ctrl.exponential2Multiscale t sgn)

{- |
Generate an exponential curve through two nodes.
-}
{-# INLINE exponentialFromTo #-}
exponentialFromTo ::
   (Trans.C q, RealField.C q, Dim.C u, Dim.C v) =>
      DN.T u q      {-^ duration of the ramp -}
   -> (DN.T v q, DN.T v q)
                    {-^ initial and final value -}
   -> Proc.T s u q (SigA.R s v q q)
exponentialFromTo dur' (y0',y1') =
   (toTimeScalar dur') >>= \dur -> return $
      let amp = max (DN.abs y0') (DN.abs y1')
          y0  = toAmplitudeScalar z y0'
          y1  = toAmplitudeScalar z y1'
          z = SigA.fromSamples amp
                 (Sig.take (floor dur)
                    (Ctrl.exponentialFromTo dur y0 y1))
      in  z



{-# INLINE cubicHermite #-}
cubicHermite ::
   (Field.C q, Real.C q, Dim.C u, Dim.C v) =>
      (DN.T u q, (DN.T v q, DN.T (DimensionGradient u v) q))
   -> (DN.T u q, (DN.T v q, DN.T (DimensionGradient u v) q))
   -> Proc.T s u q (SigA.R s v q q)
cubicHermite (t0', (y0',dy0')) (t1', (y1',dy1')) =
   let amp = max (DN.abs y0') (DN.abs y1')
   in  do t0  <- toTimeScalar t0'
          t1  <- toTimeScalar t1'
          dy0 <- toGradientScalar amp dy0'
          dy1 <- toGradientScalar amp dy1'
          return $
             let y0 = toAmplitudeScalar z y0'
                 y1 = toAmplitudeScalar z y1'
                 z = SigA.fromSamples amp (Ctrl.cubicHermite (t0, (y0,dy0)) (t1, (y1,dy1)))
              in z




-- * piecewise curves

type Piece s u v q =
   Piecewise.Piece
      (DN.T u q) (DN.T v q)
      (DN.T v q -> q -> Proc.T s u q (SigS.R s q))

type Piecewise s u v q =
   Piecewise.T
      (DN.T u q) (DN.T v q)
      (DN.T v q -> q -> Proc.T s u q (SigS.R s q))


{- |
Since this function looks for the maximum node value,
and since the signal parameter inference phase must be completed before signal processing,
infinite descriptions cannot be used here.
-}
{-# INLINE piecewise #-}
piecewise :: (Trans.C q, RealField.C q, Dim.C u, Dim.C v) =>
      Piecewise s u v q
   -> Proc.T s u q (SigA.R s v q q)
piecewise cs =
   let amplitude = maximum
         (map (\c -> max (DN.abs (Piecewise.pieceY0 c))
                         (DN.abs (Piecewise.pieceY1 c))) cs)
   in  piecewiseVolume cs amplitude


{-# INLINE piecewiseVolume #-}
piecewiseVolume ::
   (Trans.C q, RealField.C q, Dim.C u, Dim.C v) =>
      Piecewise s u v q
   -> DN.T v q
   -> Proc.T s u q (SigA.R s v q q)
piecewiseVolume cs amplitude =
   -- it would be nice if we could re-use Ctrl.piecewise
   do ts0 <- mapM (toTimeScalar . Piecewise.pieceDur) cs
      fmap (SigA.fromSamples amplitude . Sig.concat) $
         sequence $ zipWith
            (\(n,t) (Piecewise.PieceData c yi0 yi1 d) ->
                 fmap (Sig.take n . SigS.toSamples) $
                 Piecewise.computePiece c yi0 yi1 d amplitude t)
            (Ctrl.splitDurations ts0)
            cs


{-# INLINE makePiece #-}
makePiece :: (Field.C q, Dim.C u, Dim.C v) =>
   Ctrl.Piece q -> Piece s u v q
makePiece piece =
   Piecewise.pieceFromFunction $ \ y0 y1 d amplitude t0 ->
      flip fmap (toTimeScalar d) (\d' ->
         let za = SigA.fromSignal amplitude z
             z  = SigS.fromSamples $
                  Piecewise.computePiece piece
                     (toAmplitudeScalar za y0)
                     (toAmplitudeScalar za y1)
                     d' t0
         in  z)

{-# INLINE stepPiece #-}
stepPiece :: (Field.C q, Dim.C u, Dim.C v) => Piece s u v q
stepPiece =
   makePiece Ctrl.stepPiece

{-# INLINE linearPiece #-}
linearPiece :: (Field.C q, Dim.C u, Dim.C v) => Piece s u v q
linearPiece =
   makePiece Ctrl.linearPiece

{-# INLINE exponentialPiece #-}
exponentialPiece :: (Trans.C q, Dim.C u, Dim.C v) =>
   DN.T v q -> Piece s u v q
exponentialPiece saturation =
   Piecewise.pieceFromFunction $ \ y0 y1 d amplitude t0 ->
      flip fmap (toTimeScalar d) (\d' ->
         let za = SigA.fromSignal amplitude z
             z  = SigS.fromSamples $
                  Piecewise.computePiece
                     (Ctrl.exponentialPiece (toAmplitudeScalar za saturation))
                     (toAmplitudeScalar za y0)
                     (toAmplitudeScalar za y1)
                     d' t0
         in  z)

{-# INLINE cosinePiece #-}
cosinePiece :: (Trans.C q, Dim.C u, Dim.C v) => Piece s u v q
cosinePiece =
   makePiece Ctrl.cosinePiece

{-# INLINE cubicPiece #-}
cubicPiece :: (Field.C q, Dim.C u, Dim.C v) =>
   DN.T (DimensionGradient u v) q ->
   DN.T (DimensionGradient u v) q ->
   Piece s u v q
cubicPiece yd0 yd1 =
   Piecewise.pieceFromFunction $ \ y0 y1 d amplitude t0 ->
      liftM3 (\d' yd0' yd1' ->
         let za = SigA.fromSignal amplitude z
             z  = SigS.fromSamples $
                  Piecewise.computePiece
                     (Ctrl.cubicPiece yd0' yd1')
                     (toAmplitudeScalar za y0)
                     (toAmplitudeScalar za y1)
                     d' t0
         in  z)
            (toTimeScalar d)
            (toGradientScalar amplitude yd0)
            (toGradientScalar amplitude yd1)


-- * convert values to different graduations

{- |
Map a control curve without amplitude unit
by a linear (affine) function with a unit.
-}
{-# INLINE mapLinearDimension #-}
mapLinearDimension :: (Field.C y, Real.C y, Dim.C u, Dim.C v) =>
      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@ -}
   -> Proc.T s u t (
        SigA.R s u y y
     -> SigA.R s (Dim.Mul v u) y y)
mapLinearDimension range center =
   Proc.pure $ CtrlA.mapLinearDimension range center

{- |
Map a control curve without amplitude unit
exponentially to one with a unit.
-}
{-# INLINE mapExponentialDimension #-}
mapExponentialDimension :: (Trans.C y, Dim.C u) =>
      y         {- ^ range: one is mapped to @center*range@, must be positive -}
   -> DN.T u y  {- ^ center: zero is mapped to @center@ -}
   -> Proc.T s u t (
        SigA.R s Dim.Scalar y y
     -> SigA.R s u y y)
mapExponentialDimension range center =
   Proc.pure $ CtrlA.mapExponential range center