Process.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
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.Arrow as CausalArrow
import qualified Synthesizer.Causal.Process as Causal
import qualified Control.Arrow as Arrow
import Control.Arrow (Arrow, ArrowLoop, )
import Control.Category (Category, )

import Control.Applicative (Applicative, )

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

import qualified Algebra.Module as Module
import qualified Algebra.Field  as Field
import qualified Algebra.Ring   as Ring

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

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

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.
-}
type T s amp0 amp1 yv0 yv1 =
   ArrowD.T amp0 amp1 (Core s yv0 yv1)

newtype Core s yv0 yv1 =
   Core (Causal.T yv0 yv1)
   deriving (Category, Arrow, ArrowLoop, CausalArrow.C)

instance ArrowD.Applicable (Core s) (Rate.Phantom s)


consFlip ::
   (amp0 -> (amp1, Causal.T yv0 yv1)) ->
   T s amp0 amp1 yv0 yv1
consFlip f =
   ArrowD.Cons $ \ampIn ->
      let (ampOut, causal) = f ampIn
      in  (Core causal, ampOut)


infixl 9 `apply`

{-# INLINE apply #-}
apply ::
   (SigG2.Transform sig yv0 yv1) =>
   T s amp0 amp1 yv0 yv1 ->
   SigA.T (Rate.Phantom s) amp0 (sig yv0) ->
   SigA.T (Rate.Phantom s) amp1 (sig yv1)
apply = ArrowD.apply

{-# INLINE applyFlat #-}
applyFlat ::
   (Flat.C yv0 amp0, SigG2.Transform sig yv0 yv1) =>
   T s (Amp.Flat yv0) amp1 yv0 yv1 ->
   SigA.T (Rate.Phantom s) amp0 (sig yv0) ->
   SigA.T (Rate.Phantom s) amp1 (sig yv1)
applyFlat = ArrowD.applyFlat

{-# INLINE canonicalizeFlat #-}
canonicalizeFlat ::
   (Flat.C y flat) =>
   T s flat (Amp.Flat y) y y
canonicalizeFlat =
   ArrowD.canonicalizeFlat


{-# INLINE applyConst #-}
applyConst ::
   (Amp.C amp1, Ring.C y0) =>
   T s (Amp.Numeric amp0) amp1 y0 yv1 ->
   amp0 ->
   SigA.T (Rate.Phantom s) amp1 (Sig.T yv1)
applyConst = ArrowD.applyConst



infixl 0 $/:, $/-

{-# INLINE ($/:) #-}
($/:) ::
   (Applicative f, SigG2.Transform sig yv0 yv1) =>
   f (T s amp0 amp1 yv0 yv1) ->
   f (SigA.T (Rate.Phantom s) amp0 (sig yv0)) ->
   f (SigA.T (Rate.Phantom s) amp1 (sig yv1))
($/:) = (ArrowD.$/:)

{-# INLINE ($/-) #-}
($/-) ::
   (Amp.C amp1, Functor f, Ring.C y0) =>
   f (T s (Amp.Numeric amp0) amp1 y0 yv1) ->
   amp0 ->
   f (SigA.T (Rate.Phantom s) amp1 (Sig.T yv1))
($/-) = (ArrowD.$/-)



infixl 9 `applyFst`

{-# INLINE applyFst #-}
applyFst ::
   (Amp.C amp, SigG.Read sig yv) =>
   T s (amp, restAmpIn) restAmpOut (yv, restSampIn) restSampOut ->
   SigA.T (Rate.Phantom s) amp (sig yv) ->
   T s restAmpIn restAmpOut restSampIn restSampOut
applyFst c x = c <<< feedFst x

{-# INLINE applyFlatFst #-}
applyFlatFst ::
   (Flat.C yv amp, SigG.Read sig yv) =>
   T s (Amp.Flat yv, restAmpIn) restAmpOut (yv, restSampIn) restSampOut ->
   SigA.T (Rate.Phantom s) amp (sig yv) ->
   T s restAmpIn restAmpOut restSampIn restSampOut
applyFlatFst c =
   applyFst (c <<< first canonicalizeFlat)


{-# INLINE feedFst #-}
feedFst ::
   (Amp.C amp, SigG.Read sig yv) =>
   SigA.T (Rate.Phantom s) amp (sig yv) ->
   T s restAmp (amp, restAmp) restSamp (yv, restSamp)
feedFst x =
   ArrowD.Cons $ \yAmp ->
      (Core $ Causal.feedFst (SigA.body x), (SigA.amplitude x, yAmp))


{-# INLINE applySnd #-}
applySnd ::
   (Amp.C amp, SigG.Read sig yv) =>
   T s (restAmpIn, amp) restAmpOut (restSampIn, yv) restSampOut ->
   SigA.T (Rate.Phantom s) amp (sig yv) ->
   T s restAmpIn restAmpOut restSampIn restSampOut
applySnd c x = c <<< feedSnd x

{-# INLINE feedSnd #-}
feedSnd ::
   (Amp.C amp, SigG.Read sig yv) =>
   SigA.T (Rate.Phantom s) amp (sig yv) ->
   T s restAmp (restAmp, amp) restSamp (restSamp, yv)
feedSnd x =
   ArrowD.Cons $ \yAmp ->
      (Core $ Causal.feedSnd (SigA.body x), (yAmp, SigA.amplitude x))


{-# INLINE map #-}
map ::
   Map.T amp0 amp1 yv0 yv1 ->
   T s amp0 amp1 yv0 yv1
map (ArrowD.Cons f) =
   ArrowD.Cons $ mapFst Arrow.arr . f


{- |
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 =
   ArrowD.Cons $ \ xAmp -> (Core c, xAmp)


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


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 = ArrowD.compose

(>>>) = 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 = ArrowD.first

{-# INLINE second #-}
second ::
   T s amp0 amp1 yv0 yv1 ->
   T s (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1)
second = ArrowD.second

{-# 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 = ArrowD.split

(***) = 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 = ArrowD.fanout

(&&&) = 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


-- loop :: a (b, d) (c, d) -> a b c
{-# INLINE loopVolume #-}
loopVolume ::
   (Field.C y, Module.C y yv, Dim.C v) =>
   DN.T v y ->
   T s (restAmpIn, Amp.Dimensional v y)
       (restAmpOut, Amp.Dimensional v y)
       (restSampIn, yv) (restSampOut, yv) ->
   T s restAmpIn restAmpOut restSampIn restSampOut
loopVolume ampIn f =
   ArrowD.loop (f >>> ArrowD.second (Map.forceDimensionalAmplitude ampIn))

-- loop2 :: a (b, (d,e)) (c, (d,e)) -> a b c

{-# INLINE loop2Volume #-}
loop2Volume ::
   (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
loop2Volume (amp0,amp1) p =
   loopVolume amp0 $
   loopVolume amp1 $
   (Map.balanceRight >>> p >>> Map.balanceLeft)
-- alternative implementation to ArrowD.loop2Volume