{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{- |
Copyright   :  (c) Henning Thielemann 2006
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.Inference.Monad.Signal.Control
   ({- * Primitives -}
    constant, linear, exponential, exponential2,
    {- * Piecewise -}
    piecewise, Control(..), ControlPiece(..),
    (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|),  -- spaces before # for Haddock
    {- * Preparation -}
    mapLinear, mapExponential)
   where


import Synthesizer.Inference.Monad.Signal (toTimeScalar, toAmplitudeScalar, toGradientScalar)
import Synthesizer.Plain.Control
   (Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|))

import qualified Synthesizer.Plain.Control as Ctrl
import qualified Synthesizer.Inference.Monad.Signal.Displacement as SynI

import qualified UniqueLogicNP.Explicit.Process    as Process
import qualified UniqueLogicNP.Explicit.Expression as Expr
import qualified UniqueLogicNP.Explicit.System     as IS
import qualified Synthesizer.Inference.Monad.Signal     as SigI

import qualified Algebra.OccasionallyScalar as OccScalar
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 Control.Monad (liftM, liftM2, liftM4)
import Control.Monad.Fix (mfix)

import NumericPrelude
import PreludeBase as P


constant :: (Field.C q, Real.C q, OccScalar.C a q) =>
      q {-^ value -}
   -> SigI.Process a q a
constant y =
   do sampleRate <- Process.newVariable
      SigI.returnCons sampleRate (IS.constant (abs y))
         (Ctrl.constant (OccScalar.toScalar (signum y)))

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

{- ***** problem: linear curves starting with zero are impossible
   better: Let the user tell a maximum value? -}

{- | Caution: This control curve can contain samples
     with an absolute value greater than 1. -}
linear :: (Field.C a, Field.C q, Real.C q, OccScalar.C a q) =>
      q {-^ steepness of the curve -}
   -> q {-^ initial value -}
   -> SigI.Process a q a
linear steepness y0 =
   mfix (\z ->
      do sampleRate <- Process.newVariable
         steep <- toGradientScalar z (Expr.constant steepness)
         SigI.returnCons sampleRate (IS.constant (abs y0))
            (Ctrl.linearStable steep (OccScalar.toScalar (signum y0))))

exponential :: (Trans.C a, Field.C q, Real.C q, OccScalar.C a q) =>
      q {-^ time where the function reaches 1\/e of the initial value -}
   -> q {-^ initial value -}
   -> SigI.Process a q a
exponential time y0 =
   mfix (\z ->
      do sampleRate <- Process.newVariable
         t <- toTimeScalar z (Expr.constant time)
         SigI.returnCons sampleRate (IS.constant (abs y0))
            (Ctrl.exponentialStable t (OccScalar.toScalar (signum y0))))

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

exponential2 :: (Trans.C a, Field.C q, Real.C q, OccScalar.C a q) =>
      q {-^ half life, time where the function reaches 1\/2 of the initial value -}
   -> q {-^ initial value -}
   -> SigI.Process a q a
exponential2 time y0 =
   mfix (\z ->
      do sampleRate <- Process.newVariable
         t <- toTimeScalar z (Expr.constant time)
         SigI.returnCons sampleRate (IS.constant (abs y0))
            (Ctrl.exponential2Stable t (OccScalar.toScalar (signum y0))))



{- |
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.
-}
piecewise :: (Trans.C a, RealField.C a,
              Real.C q, Field.C q, OccScalar.C a q) =>
      [ControlPiece q]
   -> SigI.Process a q a
piecewise cs =
   mfix (\z ->
      do sampleRate <- Process.newVariable
         let amplitude = maximum
                (map (\c -> max (abs (Ctrl.pieceY0 c))
                                (abs (Ctrl.pieceY1 c))) cs)
         ps <- mapM (\(Ctrl.ControlPiece typ y0 y1 d) ->
                         liftM4 Ctrl.ControlPiece
                            {- We cannot provide an default case,
                               because the returned constructors
                               have different parameter type. -}
                            (case typ of
                               CtrlStep -> return CtrlStep
                               CtrlLin  -> return CtrlLin
                               -- this may exceed value range (-1,1)
                               CtrlCubic d0 d1 ->
                                  liftM2 CtrlCubic
                                     (toGradientScalar z (Expr.constant d0))
                                     (toGradientScalar z (Expr.constant d1))
                               CtrlExp sat ->
                                  liftM CtrlExp
                                     (toAmplitudeScalar z
                                                      (Expr.constant sat))
                               CtrlCos  -> return CtrlCos)
                            (toAmplitudeScalar z (Expr.constant y0))
                            (toAmplitudeScalar z (Expr.constant y1))
                            (toTimeScalar      z (Expr.constant d))) cs
         SigI.returnCons
             sampleRate (IS.constant amplitude)
             (Ctrl.piecewise ps))



{- |
Map a control curve without amplitude unit
by a linear (affine) function with a unit.
-}
mapLinear :: (Ring.C a, Field.C q, Real.C q, OccScalar.C a q) =>
      q  {- ^ range: one is mapped to @center+range@ -}
   -> q  {- ^ center: zero is mapped to @center@ -}
   -> SigI.T a q a
   -> SigI.Process a q a
mapLinear range center x =
   mfix (\z ->
      do let absRange  = abs range
         let absCenter = abs center
         rng <- toAmplitudeScalar z (Expr.constant absRange)
         cnt <- toAmplitudeScalar z (Expr.constant absCenter)
         SynI.mapScalar 1 (absRange + absCenter) (\y -> cnt + rng*y) x)

{- |
Map a control curve without amplitude unit
exponentially to one with a unit.

ToDo: sample values should remain in the range (-1,1)
-}
mapExponential :: (Field.C q, Trans.C a, OccScalar.C a q) =>
      a  {- ^ range: one is mapped to @center*range@ -}
   -> q  {- ^ center: zero is mapped to @center@ -}
   -> SigI.T a q a
   -> SigI.Process a q a
mapExponential range center =
   SynI.mapScalar 1 center (range**)