Displacement.hs

{- |
Copyright   :  (c) Henning Thielemann 2008-2009
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.Amplitude as Amp

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, asks, )
import Control.Applicative (liftA2, )

import PreludeBase
import NumericPrelude
import Prelude ()


type DN v y = Amp.Numeric (DN.T v y)
type Context v y = Reader (DN.T v y)

{- * 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 v y, DN v y) (DN v y) (yv,yv) yv)
mix =
   Proc.pure $
   fromAmplitudeReader $ \(Amp.Numeric amp0, Amp.Numeric 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 v y, DN v y) (DN v y) (yv,yv) yv)
mixVolume amp =
   Proc.pure $
   fromAmplitudeReader $ \(Amp.Numeric amp0, Amp.Numeric 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 ->
   Context v y (Causal.T (yv,yv) yv)
mixCore amp0 amp1 =
   liftA2
      (\toSamp0 toSamp1 ->
         Causal.map (\(y0,y1) -> toSamp0 y0 + toSamp1 y1))
      (toAmplitudeVector amp0)
      (toAmplitudeVector amp1)


{- |
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 v y) yvIn yv)] ->
   Proc.T s u t (CausalD.T s ampIn (DN 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 v y) yvIn yv] ->
   CausalD.T s ampIn (DN v y) yvIn yv
fanoutAndMixMultiPlain cs =
   fromAmplitudeReader $ \ampIn ->
      let ampCs = map (\(CausalD.Cons f) -> f ampIn) cs
      in  (maximum (map (\(Amp.Numeric amp,_) -> amp) 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 v y) yvIn yv)] ->
   Proc.T s u t (CausalD.T s ampIn (DN 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 v y) yvIn yv] ->
   CausalD.T s ampIn (DN 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 v y, Causal.T yvIn yv)] ->
   Context v y (Causal.T yvIn yv)
fanoutAndMixMultiVolumeCore cs =
   foldr
      (\(Amp.Numeric ampX, c) ->
         liftA2
            (\toSamp rest ->
               uncurry (+) ^<< (toSamp ^<< c) &&& rest)
            (toAmplitudeVector ampX))
      (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 v y) (DN v y) yv yv)
raise y' yv =
   Proc.pure $
   fromAmplitudeReader $ \(Amp.Numeric amp) ->
      (amp, fmap (\toSamp -> Causal.map (toSamp yv +)) (toAmplitudeVector y'))

{- |
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 v y, DN v y) (DN v y) (y,yv) yv)
distort f =
   Proc.pure $
   fromAmplitudeReader $ \(Amp.Numeric ampCtrl, Amp.Numeric ampIn) ->
      (ampIn,
       fmap (\toSamp ->
          Causal.map (\(c,y) ->
             let c' = toSamp c
             in  c' *> f (recip c' *> y)))
          (toAmplitudeScalar ampCtrl))


{-# INLINE toAmplitudeScalar #-}
toAmplitudeScalar ::
   (Field.C y, Dim.C u) =>
   DN.T u y -> Reader (DN.T u y) (y -> y)
toAmplitudeScalar ampIn =
   asks (\ampOut -> (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 =
   asks (\ampOut -> (DN.divToScalar ampIn ampOut *> ))

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