Displacement.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

-}

module Synthesizer.Inference.Monad.Signal.Displacement (
   {- * Non-linearities -}
   mapScalar,
   mapVector,

   {- * Mixing -}
   mix,
   mixMulti,
) where


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

import UniqueLogicNP.Explicit.Expression ((=!=))
import Synthesizer.Inference.Monad.Signal
   (toAmplitudeScalar,
    sampleRateExpr, amplitudeExpr)

import qualified Synthesizer.Physical.Signal as SigP
import qualified Synthesizer.Plain.Displacement as Syn

import qualified Algebra.OccasionallyScalar as OccScalar
import qualified Algebra.Field          as Field
import qualified Algebra.Ring           as Ring
import qualified Algebra.Additive       as Additive
import qualified Algebra.Module         as Module

import Control.Monad.Fix (mfix)

import NumericPrelude
import PreludeBase
import qualified Data.List as List


{- * Non-linearities -}

{- | Apply a function to the signal values.
     If input and output signal shall have the same global amplitude,
     then it must hold @rateX * ampY = 1@. -}
mapVector :: (Module.C a v0, Field.C q, OccScalar.C a q) =>
      q  {- ^ rateX: If @v@ is the physical value
                     which shall appear as 1 to @f@,
                     then choose @rateX * v == 1@. -}
   -> q  {- ^ ampY: The physical value of the output signal
                    which is associated with the value 1 of @f@. -}
   -> (v0 -> v1)
         {- ^ f, the mapping -}
   -> SigI.T a q v0
   -> SigI.Process a q v1
mapVector rateX ampY f x =
   do samples <- SigI.vectorSamples
         (Process.exprToScalar . (Expr.constant rateX *)) x
      SigI.returnCons (SigP.sampleRate x) (IS.constant ampY)
         (List.map f samples)

mapScalar :: (Ring.C a, Field.C q, OccScalar.C a q) =>
      q  {- ^ rateX: If @v@ is the physical value
                     which shall appear as 1 to @f@,
                     then choose @rateX * v == 1@. -}
   -> q  {- ^ ampY: The physical value of the output signal
                    which is associated with the value 1 of @f@. -}
   -> (a -> a)
         {- ^ f, the mapping -}
   -> SigI.T a q a
   -> SigI.Process a q a
mapScalar rateX ampY f x =
   do samples <- SigI.scalarSamples
         (Process.exprToScalar . (Expr.constant rateX *)) x
      SigI.returnCons (SigP.sampleRate x) (IS.constant ampY)
         (List.map f samples)


{- * Mixing -}

{- | Mix two signals.
     In opposition to 'zipWith' the result has the length of the longer signal. -}
mix :: (Field.C q, Eq q, Module.C a v, OccScalar.C a q) =>
      SigI.T a q v
   -> SigI.T a q v
   -> SigI.Process a q v
mix x y =
   do sampleRate <- Process.fromExpr (sampleRateExpr x =!= sampleRateExpr y)
      amplitude  <- Process.fromExpr (amplitudeExpr  x  +  amplitudeExpr  y)
      mfix (\z ->
         do sampX <- SigI.vectorSamples (toAmplitudeScalar z) x
            sampY <- SigI.vectorSamples (toAmplitudeScalar z) y
            SigI.returnCons sampleRate amplitude
               (sampX + sampY))

{- | Mix one or more signals. -}
mixMulti :: (Field.C q, Eq q, Module.C a v, OccScalar.C a q) =>
      [SigI.T a q v]
   ->  SigI.Process a q v
mixMulti xs =
   do sampleRate <- Process.equalValues (List.map SigP.sampleRate xs)
      let ampExprs = List.map amplitudeExpr xs
      amplitude  <- Process.fromExpr (sum1 ampExprs)
         {- 'sum1' must be used, because 'sum' introduces a zero,
            which will probably have an incompatible unit. -}
      mfix (\z ->
         do samps <- mapM (SigI.vectorSamples (toAmplitudeScalar z)) xs
            SigI.returnCons sampleRate amplitude
               (Syn.mixMulti samps))