Control.hs

{- |
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.SampleRateContext.Control
   ({- * Primitives -}
    constant, constantVector, linear, line, exponential, exponential2,
    {- * Piecewise -}
    piecewise, piecewiseVolume, Control(..), ControlPiece(..),
    (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|),  -- spaces before # for Haddock
    {- * Preparation -}
    mapLinear, mapExponential, )
   where

import Synthesizer.Plain.Control
   (Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|))

import qualified Synthesizer.Amplitude.Control as CtrlV
import qualified Synthesizer.Plain.Control as Ctrl

import qualified Synthesizer.SampleRateContext.Signal as SigC
import qualified Synthesizer.SampleRateContext.Rate as Rate
import Synthesizer.SampleRateContext.Signal
          (toTimeScalar, toAmplitudeScalar, toGradientScalar)

import qualified Algebra.OccasionallyScalar as OccScalar
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 NumericPrelude
import PreludeBase as P
import Prelude ()


constant :: (Field.C y', Real.C y', OccScalar.C y y') =>
      y' {-^ value -}
   -> Rate.T t t' -> SigC.T y y' y
constant y = Rate.pure $ CtrlV.constant y

{- |
The amplitude must be positive!
This is not checked.
-}
constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') =>
      y' {-^ amplitude -}
   -> yv {-^ value -}
   -> Rate.T t t' -> SigC.T y y' yv
constantVector y yv = Rate.pure $ CtrlV.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', OccScalar.C y y') =>
-}

{- |
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'.
-}
linear ::
   (Additive.C q, Field.C q',
    Real.C q', OccScalar.C q q') =>
      q' {-^ slope of the curve -}
   -> q' {-^ initial value -}
   -> Rate.T q q' -> SigC.T q q' q
linear slope y0 sr =
   let amp = abs y0
       steep = toGradientScalar amp sr slope
   in  SigC.Cons amp
          (Ctrl.linearMultiscale steep (OccScalar.toScalar (signum y0)))

{- |
Generates a finite ramp.
-}
line ::
   (RealField.C q, Field.C q',
    Real.C q', OccScalar.C q q') =>
      q'      {-^ duration of the ramp -}
   -> (q',q') {-^ initial and final value -}
   -> Rate.T q q' -> SigC.T q q' q
line dur' (y0',y1') sr =
   let amp = max (abs y0') (abs y1')
       dur = toTimeScalar sr dur'
       y0  = toAmplitudeScalar z y0'
       y1  = toAmplitudeScalar z y1'
       z = SigC.Cons amp
              (take (floor dur)
                 (Ctrl.linearMultiscale ((y1-y0)/dur) y0))
   in  z

exponential :: (Trans.C q, Ring.C q', Real.C q', OccScalar.C q q') =>
      q' {-^ time where the function reaches 1\/e of the initial value -}
   -> q' {-^ initial value -}
   -> Rate.T q q' -> SigC.T q q' q
exponential time y0 sr =
   SigC.Cons (abs y0)
      (Ctrl.exponentialMultiscale
         (toTimeScalar sr time) (OccScalar.toScalar (signum y0)))

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

exponential2 :: (Trans.C q, Ring.C q', Real.C q', OccScalar.C q q') =>
      q' {-^ half life, time where the function reaches 1\/2 of the initial value -}
   -> q' {-^ initial value -}
   -> Rate.T q q' -> SigC.T q q' q
exponential2 time y0 sr =
   SigC.Cons (abs y0)
      (Ctrl.exponential2Multiscale
         (toTimeScalar sr time) (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 q, RealField.C q,
              Real.C q', Field.C q', OccScalar.C q q') =>
      [ControlPiece q']
   -> Rate.T q q' -> SigC.T q q' q
piecewise cs =
   let amplitude = maximum
         (map (\c -> max (abs (Ctrl.pieceY0 c))
                         (abs (Ctrl.pieceY1 c))) cs)
   in  piecewiseVolume cs amplitude


piecewiseVolume ::
   (Trans.C q, RealField.C q,
    Real.C q', Field.C q', OccScalar.C q q') =>
      [ControlPiece q']
   -> q'
   -> Rate.T q q' -> SigC.T q q' q
piecewiseVolume cs amplitude sr =
   let ps = map (\(Ctrl.ControlPiece typ y0 y1 d) ->
          Ctrl.ControlPiece
             {- We cannot provide an default case like "_ -> typ",
                because the returned constructors
                have different parameter type. -}
             (case typ of
                CtrlStep -> CtrlStep
                CtrlLin  -> CtrlLin
                -- this may exceed value range (-1,1)
                CtrlCubic d0 d1 ->
                   CtrlCubic
                      (toGradientScalar amplitude sr d0)
                      (toGradientScalar amplitude sr d1)
                CtrlExp sat ->
                   CtrlExp
                      (toAmplitudeScalar z sat)
                CtrlCos  -> CtrlCos)
             (toAmplitudeScalar z y0)
             (toAmplitudeScalar z y1)
             (toTimeScalar sr d)) cs
       z = SigC.Cons amplitude (Ctrl.piecewise ps)
   in  z



{- |
Map a control curve without amplitude unit
by a linear (affine) function with a unit.
-}
mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') =>
      y'  {- ^ range: one is mapped to @center+range@ -}
   -> y'  {- ^ center: zero is mapped to @center@ -}
   -> Rate.T t t'
   -> SigC.T y y' y
   -> SigC.T y y' y
mapLinear range center =
   Rate.pure $ CtrlV.mapLinear range center

{- |
Map a control curve without amplitude unit
exponentially to one with a unit.
-}
mapExponential :: (Field.C y', Trans.C y, Module.C y y') =>
      y   {- ^ range: one is mapped to @center*range@, must be positive -}
   -> y'  {- ^ center: zero is mapped to @center@ -}
   -> Rate.T t t'
   -> SigC.T y y  y
   -> SigC.T y y' y
mapExponential range center =
   Rate.pure $ CtrlV.mapExponential range center