Controlled.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{- |
This module provides a type class that automatically selects a filter
for a given parameter type.
We choose the dependency this way
because there may be different ways to specify the filter parameters
but there is only one implementation of the filter itself.
-}
module Synthesizer.LLVM.CausalParameterized.Controlled where

import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFiltPack
import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilt
import qualified Synthesizer.LLVM.Filter.Allpass as Allpass
import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1
import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2
import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade
import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P
import qualified Synthesizer.LLVM.Filter.Moog as Moog
import qualified Synthesizer.LLVM.Filter.Universal as UniFilter

import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Parameter as Param

import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Vector as Vector
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )

import qualified LLVM.Core as LLVM
import LLVM.Core
   (Value, IsFloating, IsConst, IsSized, )

import qualified Synthesizer.LLVM.Frame.Stereo as Stereo

import qualified Types.Data.Num as TypeNum
import Types.Data.Num.Ops ((:*:), )

import Foreign.Storable (Storable, )

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


{- |
A filter parameter type uniquely selects a filter function.
However it does not uniquely determine the input and output type,
since the same filter can run on mono and stereo signals.
-}
class (a ~ Input parameter b, b ~ Output parameter a) => C parameter a b where
   type Input  parameter b :: *
   type Output parameter a :: *
   process :: CausalP.T p (parameter, a) b


processCtrlRate ::
   (C parameter a b,
    Memory.C parameter,
    Memory.FirstClass r, IsSized r, IsSized (Memory.Stored r),
    Ring.C r, IsFloating r, Storable r, IsConst r,
    MakeValueTuple r, ValueTuple r ~ (Value r),
    LLVM.CmpRet r, LLVM.CmpResult r ~ Bool) =>
   Param.T p r ->
   (Param.T p r -> SigP.T p parameter) ->
   CausalP.T p a b
processCtrlRate reduct ctrlGen =
   CausalP.applyFst process
      (SigP.interpolateConstant reduct (ctrlGen reduct))


{-
Instances for the particular filters shall are defined here
in order to avoid orphan instances.
-}

instance
   (A.PseudoModule a v, A.IntegerConstant a,
    Memory.C a, Memory.C v) =>
      C (Filt1.Parameter a) v (Filt1.Result v) where
   type Input  (Filt1.Parameter a) (Filt1.Result v) = v
   type Output (Filt1.Parameter a) v = Filt1.Result v
   process = Filt1.causalP

instance
   (A.PseudoModule a v, A.RationalConstant a,
    Memory.C a, Memory.C v) =>
      C (Filt2.Parameter a) v v where
   type Input  (Filt2.Parameter a) v = v
   type Output (Filt2.Parameter a) v = v
   process = Filt2.causalP

instance
   (Vector.Arithmetic a, SoV.RationalConstant a,
    Memory.C (Value (Filt2P.State a)) {-,
    Memory.FirstClass a am, IsSized (Vector TypeNum.D4 a) as,
    IsSized am ams, LLVM.IsPrimitive am -}) =>
      C (Filt2P.Parameter a)
        (Value a) (Value a) where
   type Input  (Filt2P.Parameter a) (Value a) = Value a
   type Output (Filt2P.Parameter a) (Value a) = Value a
   process = Filt2P.causalP

instance
   (SoV.PseudoModule a v, SoV.IntegerConstant a,
    Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a),
    Memory.FirstClass v, IsSized v, IsSized (Memory.Stored v),
    TypeNum.NaturalT n,
    TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>
      C (Cascade.ParameterValue n a)
        (Value v) (Value v) where
   type Input  (Cascade.ParameterValue n a) (Value v) = Value v
   type Output (Cascade.ParameterValue n a) (Value v) = Value v
   process = Cascade.causalP


instance
   (A.PseudoModule a v, A.RationalConstant a,
    Memory.C a, Memory.C v) =>
      C (Allpass.Parameter a) v v where
   type Input  (Allpass.Parameter a) v = v
   type Output (Allpass.Parameter a) v = v
   process = Allpass.causalP

instance
   (A.PseudoModule a v, A.RationalConstant a,
    Memory.C a, Memory.C v,
    TypeNum.NaturalT n) =>
      C (Allpass.CascadeParameter n a) v v where
   type Input  (Allpass.CascadeParameter n a) v = v
   type Output (Allpass.CascadeParameter n a) v = v
   process = Allpass.cascadeP


instance
   (SoV.PseudoModule a v, SoV.IntegerConstant a,
    Additive.C v, IsConst v,
    Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a),
    Memory.FirstClass v, IsSized v, IsSized (Memory.Stored v),
    MakeValueTuple a, ValueTuple a ~ (Value a),
    MakeValueTuple v, ValueTuple v ~ (Value v),
    Storable v,
    TypeNum.NaturalT n) =>
      C (Moog.Parameter n (Value a))
        (Value v) (Value v) where
   type Input  (Moog.Parameter n (Value a)) (Value v) = Value v
   type Output (Moog.Parameter n (Value a)) (Value v) = Value v
   process = Moog.causalP

{-
instance
   (A.PseudoModule a v, A.RationalConstant a,
    Memory.C a, Memory.C v,
    TypeNum.NaturalT n) =>
      C (Moog.Parameter n a) v v where
   type Input  (Moog.Parameter n a) v = v
   type Output (Moog.Parameter n a) v = v
   process = Moog.causalP
-}

instance
   (A.PseudoModule a v, A.RationalConstant a,
    Memory.C a, Memory.C v) =>
      C (UniFilter.Parameter a) v (UniFilter.Result v) where
   type Input  (UniFilter.Parameter a) (UniFilter.Result v) = v
   type Output (UniFilter.Parameter a) v = UniFilter.Result v
   process = UniFilter.causalP

instance
   (A.PseudoRing a, A.RationalConstant a, Memory.C a) =>
      C (ComplexFilt.Parameter a) (Stereo.T a) (Stereo.T a) where
   type Input  (ComplexFilt.Parameter a) (Stereo.T a) = Stereo.T a
   type Output (ComplexFilt.Parameter a) (Stereo.T a) = Stereo.T a
   process = ComplexFilt.causalP

instance
   (Vector.Arithmetic a, IsConst a,
    Memory.C (Value (Filt2P.State a))) =>
{-
   (Memory.FirstClass a am, Vector.Arithmetic a, LLVM.IsPrimitive am,
    IsSized am ams,
    IsSized (Vector TypeNum.D4 a) as) =>
-}
      C (ComplexFiltPack.Parameter a)
        (Stereo.T (Value a)) (Stereo.T (Value a)) where
   type Input  (ComplexFiltPack.Parameter a) (Stereo.T (Value a)) = Stereo.T (Value a)
   type Output (ComplexFiltPack.Parameter a) (Stereo.T (Value a)) = Stereo.T (Value a)
   process = ComplexFiltPack.causalP