Displacement.hs

{- |
Copyright   :  (c) Henning Thielemann 2008
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes
-}
module Synthesizer.Dimensional.Causal.Displacement (
   mix, mixVolume,
   fanoutAndMixMulti, fanoutAndMixMultiVolume,
   raise, distort,
   ) where

import qualified Synthesizer.Dimensional.Process as Proc

import qualified Synthesizer.Dimensional.Causal.Process as CausalD
import qualified Synthesizer.Causal.Process as Causal
import Control.Arrow ((^<<), (&&&), )

import qualified Number.DimensionTerm        as DN
import qualified Algebra.DimensionTerm       as Dim

import qualified Algebra.Module         as Module
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 Algebra.Module ((*>))

import Control.Monad.Trans.Reader (Reader, runReader, ask, )

import PreludeBase
import NumericPrelude
import Prelude ()


{- * Mixing -}

{- |
Mix two signals.
In contrast to 'zipWith' the result has the length of the longer signal.
-}
{-# INLINE mix #-}
mix :: (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>
   Proc.T s u t (CausalD.T s (DN.T v y, DN.T v y) (DN.T v y) (yv,yv) yv)
mix =
   Proc.pure $
   fromAmplitudeReader $ \(amp0,amp1) ->
      (DN.abs amp0 + DN.abs amp1, mixCore amp0 amp1)

{-# INLINE mixVolume #-}
mixVolume ::
   (Field.C y, Module.C y yv, Dim.C v) =>
   DN.T v y ->
   Proc.T s u t (CausalD.T s (DN.T v y, DN.T v y) (DN.T v y) (yv,yv) yv)
mixVolume amp =
   Proc.pure $
   fromAmplitudeReader $ \(amp0,amp1) ->
      (amp, mixCore amp0 amp1)

{-# INLINE mixCore #-}
mixCore ::
   (Field.C y, Module.C y yv, Dim.C v) =>
   DN.T v y -> DN.T v y ->
   Reader (DN.T v y) (Causal.T (yv,yv) yv)
mixCore amp0 amp1 =
   do toSamp0 <- toAmplitudeVector amp0
      toSamp1 <- toAmplitudeVector amp1
      return $
         Causal.map (\(y0,y1) -> toSamp0 y0 + toSamp1 y1)

{- |
Mix one or more signals.
-}
{-# INLINE fanoutAndMixMulti #-}
fanoutAndMixMulti ::
   (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>
   [Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)] ->
   Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)
fanoutAndMixMulti =
   fmap fanoutAndMixMultiPlain . sequence

{-# INLINE fanoutAndMixMultiPlain #-}
fanoutAndMixMultiPlain ::
   (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>
   [CausalD.T s ampIn (DN.T v y) yvIn yv] ->
   CausalD.T s ampIn (DN.T v y) yvIn yv
fanoutAndMixMultiPlain cs =
   fromAmplitudeReader $ \ampIn ->
      let ampCs = map (\(CausalD.Cons f) -> f ampIn) cs
      in  (maximum (map fst ampCs),
           fanoutAndMixMultiVolumeCore ampCs)

{-# INLINE fanoutAndMixMultiVolume #-}
fanoutAndMixMultiVolume ::
   (Field.C y, Module.C y yv, Dim.C v) =>
   DN.T v y ->
   [Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)] ->
   Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)
fanoutAndMixMultiVolume amp =
   fmap (fanoutAndMixMultiVolumePlain amp) . sequence

{-# INLINE fanoutAndMixMultiVolumePlain #-}
fanoutAndMixMultiVolumePlain ::
   (Field.C y, Module.C y yv, Dim.C v) =>
   DN.T v y ->
   [CausalD.T s ampIn (DN.T v y) yvIn yv] ->
   CausalD.T s ampIn (DN.T v y) yvIn yv
fanoutAndMixMultiVolumePlain amp cs =
   fromAmplitudeReader $ \ampIn ->
      (amp, fanoutAndMixMultiVolumeCore $
               map (\(CausalD.Cons f) -> f ampIn) cs)

{-# INLINE fanoutAndMixMultiVolumeCore #-}
fanoutAndMixMultiVolumeCore ::
   (Field.C y, Module.C y yv, Dim.C v) =>
   [(DN.T v y, Causal.T yvIn yv)] ->
   Reader (DN.T v y) (Causal.T yvIn yv)
fanoutAndMixMultiVolumeCore cs =
   foldr
      (\(ampX,c) acc ->
         do toSamp <- toAmplitudeVector ampX
            rest   <- acc
            return $ uncurry (+) ^<< (toSamp ^<< c) &&& rest)
      (return $ Causal.map (const zero)) cs


{- |
Add a number to all of the signal values.
This is useful for adjusting the center of a modulation.
-}
{-# INLINE raise #-}
raise :: (Field.C y, Module.C y yv, Dim.C v) =>
   DN.T v y ->
   yv ->
   Proc.T s u t (CausalD.T s (DN.T v y) (DN.T v y) yv yv)
raise y' yv =
   Proc.pure $
   fromAmplitudeReader $ \amp ->
      (amp, do toSamp <- toAmplitudeVector y'
               return $ Causal.map (toSamp yv +))

{- |
Distort the signal using a flat function.
The first signal gives the scaling of the function.
If the scaling is c and the input sample is y,
then @c * f(y/c)@ is output.
This way we can use an (efficient) flat function
and have a simple, yet dimension conform, way of controlling the distortion.
E.g. if the distortion function is @tanh@
then the value @c@ controls the saturation level.
-}
{-# INLINE distort #-}
distort :: (Field.C y, Module.C y yv, Dim.C v) =>
   (yv -> yv) ->
   Proc.T s u t (CausalD.T s (DN.T v y, DN.T v y) (DN.T v y) (y,yv) yv)
distort f =
   Proc.pure $
   fromAmplitudeReader $ \(ampCtrl,ampIn) ->
      (ampIn, do toSamp <- toAmplitudeScalar ampCtrl
                 return $
                    Causal.map (\(c,y) ->
                       let c' = toSamp c
                       in  c' *> f (recip c' *> y)))


{-# INLINE toAmplitudeScalar #-}
toAmplitudeScalar ::
   (Field.C y, Dim.C u) =>
   DN.T u y -> Reader (DN.T u y) (y -> y)
toAmplitudeScalar ampIn =
   do ampOut <- ask
      return (DN.divToScalar ampIn ampOut *)

{-# INLINE toAmplitudeVector #-}
toAmplitudeVector ::
   (Module.C y yv, Field.C y, Dim.C u) =>
   DN.T u y -> Reader (DN.T u y) (yv -> yv)
toAmplitudeVector ampIn =
   do ampOut <- ask
      return (DN.divToScalar ampIn ampOut *> )

{-# INLINE fromAmplitudeReader #-}
fromAmplitudeReader ::
   (ampIn -> (ampOut, Reader ampOut (Causal.T yv0 yv1))) ->
   CausalD.T s ampIn ampOut yv0 yv1
fromAmplitudeReader f =
   CausalD.Cons $ \ampIn ->
      let (ampOut, rd) = f ampIn
      in  (ampOut, runReader rd ampOut)