synthesizer-inference-0.2: src/Synthesizer/Inference/Monad/Signal/Control.hs
{-# 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**)