Process.hs

{-# LANGUAGE FlexibleContexts #-}
module Synthesizer.Dimensional.Causal.Process where

import qualified Synthesizer.Dimensional.Arrow as ArrowD
import qualified Synthesizer.Dimensional.Map as Map

import qualified Synthesizer.Dimensional.Signal.Private as SigA
import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat
import qualified Synthesizer.Dimensional.Amplitude as Amp
import qualified Synthesizer.Dimensional.Rate as Rate

import qualified Synthesizer.Causal.Process as Causal

import Control.Applicative (Applicative, liftA, liftA2, )

import qualified Synthesizer.State.Signal as Sig
import qualified Synthesizer.Generic.Signal2 as SigG2

import qualified Algebra.Module as Module
import qualified Algebra.Field  as Field
import qualified Algebra.Ring   as Ring
import Algebra.Module ((*>))

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

import qualified Control.Arrow as Arrow

import Data.Tuple.HT as TupleHT (mapSnd, )

import NumericPrelude (one)
import Prelude hiding (map, id, fst, snd, )



{-
Note that @amp@ can also be a pair of amplitudes
or a more complicated ensemble of amplitudes.
-}
newtype T s amp0 amp1 yv0 yv1 =
   Cons (amp0 -> (amp1, Causal.T yv0 yv1))

instance ArrowD.C (T s) where
   map = map
   (>>>) = (>>>)
   first = first
   second = second
   (***) = (***)
   (&&&) = (&&&)


type Signal s amp yv = SigA.T (Rate.Phantom s) amp (Sig.T yv)

{-# INLINE apply #-}
apply ::
   T s amp0 amp1 yv0 yv1 ->
   Signal s amp0 yv0 ->
   Signal s amp1 yv1
apply (Cons f) (SigA.Cons rate xAmp samples) =
   let (yAmp, causal) = f xAmp
   in  SigA.Cons rate yAmp (Causal.apply causal samples)

{-# INLINE applyFlat #-}
applyFlat ::
   (Flat.C yv0 amp0) =>
   T s (Amp.Flat yv0) amp1 yv0 yv1 ->
   Signal s amp0 yv0 ->
   Signal s amp1 yv1
applyFlat f =
   apply f . Flat.canonicalize

{-# INLINE applyGeneric #-}
applyGeneric ::
   (SigG2.Transform storage yv0 yv1) =>
   T s amp0 amp1 yv0 yv1 ->
   Signal s amp0 yv0 ->
   Signal s amp1 yv1
applyGeneric (Cons f) (SigA.Cons rate xAmp samples) =
   let (yAmp, causal) = f xAmp
   in  SigA.Cons rate yAmp (Causal.applyGeneric causal samples)


{-# INLINE applyConst #-}
applyConst :: (Amp.C amp1, Ring.C y0) =>
   T s (Amp.Numeric amp0) amp1 y0 yv1 ->
   amp0 ->
   Signal s amp1 yv1
applyConst (Cons f) x =
   let (yAmp, causal) = f (Amp.Numeric x)
   in  SigA.Cons Rate.Phantom yAmp (Causal.applyConst causal one)


infixl 0 $/:, $/-

{-# INLINE ($/:) #-}
($/:) :: (Applicative f) =>
   f (T s amp0 amp1 yv0 yv1) ->
   f (Signal s amp0 yv0) ->
   f (Signal s amp1 yv1)
($/:) = liftA2 apply

{-# INLINE ($/-) #-}
($/-) :: (Amp.C amp1, Applicative f, Ring.C y0) =>
   f (T s (Amp.Numeric amp0) amp1 y0 yv1) ->
   amp0 ->
   f (Signal s amp1 yv1)
($/-) p x = liftA (flip applyConst x) p


infixl 9 `apply`, `applyFst`

{-# INLINE applyFst #-}
applyFst, applyFst' ::
   (Amp.C amp) =>
   T s (amp, restAmpIn) restAmpOut (yv, restSampIn) restSampOut ->
   Signal s amp yv ->
   T s restAmpIn restAmpOut restSampIn restSampOut
applyFst c x = c <<< feedFst x

applyFst' (Cons f) x =
   Cons $ \yAmp ->
      let (zAmp, causal) = f (SigA.amplitude x, yAmp)
      in  (zAmp, Causal.applyFst causal (SigA.body x))

{-# INLINE applyFlatFst #-}
applyFlatFst ::
   (Flat.C yv amp) =>
   T s (Amp.Flat yv, restAmpIn) restAmpOut (yv, restSampIn) restSampOut ->
   Signal s amp yv ->
   T s restAmpIn restAmpOut restSampIn restSampOut
applyFlatFst c =
   applyFst c . Flat.canonicalize


{-# INLINE feedFst #-}
feedFst ::
   (Amp.C amp) =>
   Signal s amp yv ->
   T s restAmp (amp, restAmp) restSamp (yv, restSamp)
feedFst x =
   Cons $ \yAmp ->
      ((SigA.amplitude x, yAmp), Causal.feedFst (SigA.body x))



{-# INLINE map #-}
map ::
   Map.T amp0 amp1 yv0 yv1 ->
   T s amp0 amp1 yv0 yv1
map (Map.Cons f) =
   Cons $ mapSnd Causal.map . f


{- |
We restrict the amplitude types to those of class 'Amplitude'.
Otherwise 'mapAmplitude' could be abused
for bringing amplitudes and respective sample values out of sync.
For mapping amplitudes that are nested in some pairs,
use it in combination with 'first' and 'second'.

FIXME:
Using this function is however still unsafe,
since normally it should not be observable
how the volume is balanced between amplitude and signal.
This function allows to replace an actual amplitude by 'Flat',
which is also unsafe.
This may only be used for proportional mappings.
See 'SigA.T'.
-}
{-# INLINE mapAmplitude #-}
mapAmplitude ::
   (Amp.C amp0, Amp.C amp1) =>
   (amp0 -> amp1) ->
   T s amp0 amp1 yv yv
mapAmplitude f =
   Cons $ \ xAmp -> (f xAmp, Causal.id)

{- |
FIXME: This function is unsafe.
Only use it for proportional mappings.
See 'SigA.T'.
-}
{-# INLINE mapAmplitudeSameType #-}
mapAmplitudeSameType ::
   (amp -> amp) ->
   T s amp amp yv yv
mapAmplitudeSameType f =
   Cons $ \ xAmp -> (f xAmp, Causal.id)

{- |
Lift a low-level homogeneous process to a dimensional one.

Note that the @amp@ type variable is unrestricted.
This way we show, that the amplitude is not touched,
which also means that the underlying low-level process must be homogeneous.
-}
{-# INLINE homogeneous #-}
homogeneous ::
   Causal.T yv0 yv1 ->
   T s amp amp yv0 yv1
homogeneous c =
   Cons $ \ xAmp -> (xAmp, c)


infixr 3 ***
infixr 3 &&&
infixr 1 >>>, ^>>, >>^
infixr 1 <<<, ^<<, <<^


{-# INLINE compose #-}
{-# INLINE (>>>) #-}
compose, (>>>) ::
   T s amp0 amp1 yv0 yv1 ->
   T s amp1 amp2 yv1 yv2 ->
   T s amp0 amp2 yv0 yv2
compose (Cons f) (Cons g) =
   Cons $ \ xAmp ->
      let (yAmp, causalXY) = f xAmp
          (zAmp, causalYZ) = g yAmp
      in  (zAmp, Causal.compose causalXY causalYZ)

(>>>) = compose

{-# INLINE (<<<) #-}
(<<<) ::
   T s amp1 amp2 yv1 yv2 ->
   T s amp0 amp1 yv0 yv1 ->
   T s amp0 amp2 yv0 yv2
(<<<) = flip (>>>)


{-# INLINE first #-}
first ::
   T s amp0 amp1 yv0 yv1 ->
   T s (amp0, amp) (amp1, amp) (yv0, yv) (yv1, yv)
first (Cons f) =
   Cons $ \ (xAmp, amp) ->
      let (yAmp, causal) = f xAmp
      in  ((yAmp, amp), Causal.first causal)

{-# INLINE second #-}
second ::
   T s amp0 amp1 yv0 yv1 ->
   T s (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1)
second (Cons f) =
   Cons $ \ (amp, xAmp) ->
      let (yAmp, causal) = f xAmp
      in  ((amp, yAmp), Causal.second causal)

{-# INLINE split #-}
{-# INLINE (***) #-}
split, (***) ::
   T s amp0 amp1 yv0 yv1 ->
   T s amp2 amp3 yv2 yv3 ->
   T s (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)
split f g =
   compose (first f) (second g)

(***) = split

{-# INLINE fanout #-}
{-# INLINE (&&&) #-}
fanout, (&&&) ::
   T s amp amp0 yv yv0 ->
   T s amp amp1 yv yv1 ->
   T s amp (amp0, amp1) yv (yv0, yv1)
fanout f g =
   compose (map Map.double) (split f g)

(&&&) = fanout


-- * map functions

{-# INLINE (^>>) #-}
-- | Precomposition with a pure function.
(^>>) ::
   Map.T amp0 amp1 yv0 yv1 ->
   T s amp1 amp2 yv1 yv2 ->
   T s amp0 amp2 yv0 yv2
f ^>> a = map f >>> a

{-# INLINE (>>^) #-}
-- | Postcomposition with a pure function.
(>>^) ::
   T s amp0 amp1 yv0 yv1 ->
   Map.T amp1 amp2 yv1 yv2 ->
   T s amp0 amp2 yv0 yv2
a >>^ f = a >>> map f

{-# INLINE (<<^) #-}
-- | Precomposition with a pure function (right-to-left variant).
(<<^) ::
   T s amp1 amp2 yv1 yv2 ->
   Map.T amp0 amp1 yv0 yv1 ->
   T s amp0 amp2 yv0 yv2
a <<^ f = a <<< map f

{-# INLINE (^<<) #-}
-- | Postcomposition with a pure function (right-to-left variant).
(^<<) ::
   Map.T amp1 amp2 yv1 yv2 ->
   T s amp0 amp1 yv0 yv1 ->
   T s amp0 amp2 yv0 yv2
f ^<< a = map f <<< a



{-# INLINE loop #-}
-- loop :: a (b, d) (c, d) -> a b c
loop ::
   (Field.C y, Module.C y yv, Dim.C v) =>
   DN.T v y ->
   T s (restAmpIn, Amp.Numeric (DN.T v y))
       (restAmpOut, Amp.Numeric (DN.T v y))
       (restSampIn, yv) (restSampOut, yv) ->
   T s restAmpIn restAmpOut restSampIn restSampOut
loop ampIn (Cons f) =
   Cons $ \restAmpIn ->
      let ((restAmpOut, Amp.Numeric ampOut), causal) =
             f (restAmpIn, Amp.Numeric ampIn)
      in  (restAmpOut,
           Causal.loop (causal Arrow.>>^
              mapSnd (DN.divToScalar ampOut ampIn *>)))

{-# INLINE loop2 #-}
-- loop2 :: a (b, (d,e)) (c, (d,e)) -> a b c
loop2 (amp0,amp1) p =
   loop amp0 $
   loop amp1 $
   (Map.balanceRight ^>> p >>^ Map.balanceLeft)

loop2, loop2' ::
   (Field.C y0, Module.C y0 yv0, Dim.C v0,
    Field.C y1, Module.C y1 yv1, Dim.C v1) =>
   (DN.T v0 y0, DN.T v1 y1) ->
   T s
     (restAmpIn,  (Amp.Numeric (DN.T v0 y0), Amp.Numeric (DN.T v1 y1)))
     (restAmpOut, (Amp.Numeric (DN.T v0 y0), Amp.Numeric (DN.T v1 y1)))
     (restSampIn,  (yv0,yv1))
     (restSampOut, (yv0,yv1)) ->
   T s restAmpIn restAmpOut restSampIn restSampOut
loop2' (ampIn0,ampIn1) (Cons f) =
   Cons $ \restAmpIn ->
      let ((restAmpOut, (Amp.Numeric ampOut0, Amp.Numeric ampOut1)), causal) =
             f (restAmpIn, (Amp.Numeric ampIn0, Amp.Numeric ampIn1))
      in  (restAmpOut,
           Causal.loop (causal Arrow.>>^
              Arrow.second ((DN.divToScalar ampOut0 ampIn0 *>) Arrow.***
                            (DN.divToScalar ampOut1 ampIn1 *>))))



{-# INLINE id #-}
id ::
   T s amp amp yv yv
id =
   homogeneous Causal.id