Control.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
module Synthesizer.Generic.Control (
   constant,
   linear,
   linearMultiscale,
   linearMultiscaleNeutral,
   line,
   exponential, exponentialMultiscale,
   exponentialMultiscaleNeutral,
   exponential2, exponential2Multiscale,
   exponential2MultiscaleNeutral,
   vectorExponential,
   vectorExponential2,
   cosine, cosineMultiscaleLinear,
   cosineMultiscale,
   Ctrl.cosineWithSlope,
   cubicHermite,
   ) where

import qualified Synthesizer.Plain.Control as Ctrl

import qualified Synthesizer.Generic.Signal as SigG

import qualified Algebra.Module                as Module
import qualified Algebra.Transcendental        as Trans
import qualified Algebra.Field                 as Field
import qualified Algebra.Additive              as Additive

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

import NumericPrelude.Numeric
import NumericPrelude.Base


{- * Control curve generation -}

constant :: (SigG.Produce sig y) => y -> sig y
constant = SigG.repeat


linear :: (Additive.C y, SigG.Produce sig y) =>
      y   {-^ steepness -}
   -> y   {-^ initial value -}
   -> sig y
          {-^ linear progression -}
linear d y0 = SigG.iterate (d+) y0

{- |
Minimize rounding errors by reducing number of operations per element
to a logarithmuc number.
-}
linearMultiscale ::
   (Additive.C y, SigG.Produce sig y) =>
      y
   -> y
   -> sig y
linearMultiscale =
   curveMultiscale (+)

{- |
Linear curve starting at zero.
-}
linearMultiscaleNeutral :: (Additive.C y, SigG.Produce sig y) =>
      y
   -> sig y
linearMultiscaleNeutral slope =
   curveMultiscaleNeutral (+) slope zero

{- |
Linear curve of a fixed length.
The final value is not actually reached,
instead we stop one step before.
This way we can concatenate several lines
without duplicate adjacent values.
-}
line :: (Field.C y, SigG.Produce sig y) =>
      Int   {-^ length -}
   -> (y,y) {-^ initial and final value -}
   -> sig y
            {-^ linear progression -}
line n (y0,y1) =
   SigG.take n $ linear ((y1-y0) / fromIntegral n) y0


exponential, exponentialMultiscale ::
   (Trans.C y, SigG.Produce sig y) =>
      y   {-^ time where the function reaches 1\/e of the initial value -}
   -> y   {-^ initial value -}
   -> sig y
          {-^ exponential decay -}
exponential time =
   SigG.iterate (* exp (- recip time))
exponentialMultiscale time =
   curveMultiscale (*) (exp (- recip time))

exponentialMultiscaleNeutral :: (Trans.C y, SigG.Produce sig y) =>
      y   {-^ time where the function reaches 1\/e of the initial value -}
   -> sig y
          {-^ exponential decay -}
exponentialMultiscaleNeutral time =
   curveMultiscaleNeutral (*) (exp (- recip time)) one

exponential2, exponential2Multiscale :: (Trans.C y, SigG.Produce sig y) =>
      y   {-^ half life -}
   -> y   {-^ initial value -}
   -> sig y
          {-^ exponential decay -}
exponential2 halfLife =
   SigG.iterate (*  0.5 ** recip halfLife)
exponential2Multiscale halfLife =
   curveMultiscale (*) (0.5 ** recip halfLife)

exponential2MultiscaleNeutral :: (Trans.C y, SigG.Produce sig y) =>
      y   {-^ half life -}
   -> sig y
          {-^ exponential decay -}
exponential2MultiscaleNeutral halfLife =
   curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one




{-| 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. -}
vectorExponential ::
   (Trans.C y, Module.C y v, SigG.Produce sig v) =>
       y  {-^ time where the function reaches 1\/e of the initial value -}
   ->  v  {-^ initial value -}
   -> sig v
          {-^ exponential decay -}
vectorExponential time y0 =
   SigG.iterate (exp (-1/time) *>) y0

vectorExponential2 ::
   (Trans.C y, Module.C y v, SigG.Produce sig v) =>
       y  {-^ half life -}
   ->  v  {-^ initial value -}
   -> sig v
          {-^ exponential decay -}
vectorExponential2 halfLife y0 =
   SigG.iterate (0.5**(1/halfLife) *>) y0



cosine, cosineMultiscaleLinear :: (Trans.C y, SigG.Produce sig y) =>
       y  {-^ time t0 where  1 is approached -}
   ->  y  {-^ time t1 where -1 is approached -}
   -> sig y
          {-^ a cosine wave where one half wave is between t0 and t1 -}
cosine = Ctrl.cosineWithSlope $
   \d x -> SigG.map cos (linear d x)

cosineMultiscaleLinear = Ctrl.cosineWithSlope $
   \d x -> SigG.map cos (linearMultiscale d x)

cosineMultiscale ::
   (Trans.C y, SigG.Produce sig (Complex.T y),
    SigG.Transform sig (Complex.T y), SigG.Transform sig y) =>
       y  {-^ time t0 where  1 is approached -}
   ->  y  {-^ time t1 where -1 is approached -}
   -> sig y
          {-^ a cosine wave where one half wave is between t0 and t1 -}
cosineMultiscale = Ctrl.cosineWithSlope $
   \d x -> SigG.map real (curveMultiscale (*) (cis d) (cis x))


cubicHermite :: (Field.C y, SigG.Produce sig y) =>
      (y, (y,y)) -> (y, (y,y)) -> sig y
cubicHermite node0 node1 =
   SigG.map (Ctrl.cubicFunc node0 node1) $ linear 1 0


{- * Auxiliary functions -}


curveMultiscale :: (SigG.Produce sig y) => (y -> y -> y) -> y -> y -> sig y
curveMultiscale op d y0 =
   SigG.cons y0 . SigG.map (op y0) $ SigG.iterateAssociative op d


curveMultiscaleNeutral :: (SigG.Produce sig y) =>
   (y -> y -> y) -> y -> y -> sig y
curveMultiscaleNeutral op d neutral =
   SigG.cons neutral $ SigG.iterateAssociative op d