ControlledPacked.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{- |
This is like "Synthesizer.LLVM.CausalParameterized.Controlled"
but for vectorised signals.
-}
module Synthesizer.LLVM.CausalParameterized.ControlledPacked (
   C(process), processCtrlRate,
   ) where

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.Moog as Moog
import qualified Synthesizer.LLVM.Filter.Universal as UniFilter

import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified LLVM.Extra.Representation as Rep
import qualified LLVM.Extra.Vector as Vector
import qualified Synthesizer.LLVM.Parameter as Param

import qualified LLVM.Core as LLVM
import LLVM.Core
   (Value, Vector, IsArithmetic, IsFloating, IsConst, IsSized,
    IsFirstClass, IsPrimitive, IsPowerOf2, )

import qualified Data.TypeLevel.Num      as TypeNum
import qualified Data.TypeLevel.Num.Sets as TypeSet

import Foreign.Storable (Storable, )

import Control.Arrow ((<<<), first, )

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

import NumericPrelude.Numeric
import NumericPrelude.Base


{- |
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 C parameter a b | parameter a -> b, parameter b -> a where
   process :: CausalP.T p (parameter, a) b

processCtrlRate ::
   (C parameter av bv,
    Vector.Access n a av,
    Vector.Access n b bv,
    Rep.Memory parameter struct, IsSized struct ss,
    Field.C r, IsFloating r, Storable r, IsConst r,
    LLVM.MakeValueTuple r (Value r),
    LLVM.CmpRet r Bool,
    IsSized r rs) =>
   Param.T p r ->
   (Param.T p r -> SigP.T p parameter) ->
   CausalP.T p av bv
processCtrlRate reduct ctrlGen = withSize $ \n ->
   CausalP.applyFst process
      (SigP.interpolateConstant
         (fmap (/ fromIntegral (TypeNum.toInt n)) reduct)
         (ctrlGen reduct))

withSize ::
   (Vector.Access n a av,
    Vector.Access n b bv) =>
   (n -> CausalP.T p av bv) ->
   CausalP.T p av bv
withSize f = f undefined


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

instance
   (Ring.C a, IsArithmetic a, IsPrimitive a,
    IsFirstClass a, IsConst a, IsSized a as,
    IsPowerOf2 n) =>
      C (Filt1.Parameter (Value a))
        (Value (Vector n a)) (Filt1.Result (Value (Vector n a))) where
   process = Filt1.causalPackedP

instance
   (Ring.C a, IsFirstClass a, IsArithmetic a, IsConst a,
    IsPowerOf2 n, IsPrimitive a, IsSized a as,
    TypeNum.Mul n as vas, TypeNum.Pos vas) =>
      C (Filt2.Parameter (Value a))
        (Value (Vector n a)) (Value (Vector n a)) where
   process = Filt2.causalPackedP

instance
   (Ring.C a, IsPrimitive a, IsSized a as, IsConst a,
    IsArithmetic a, TypeSet.Nat n,
    TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize,
    IsPowerOf2 d, TypeNum.Mul d as vas, TypeSet.Pos vas) =>
      C (Cascade.ParameterValue n a)
        (Value (Vector d a)) (Value (Vector d a)) where
   process = Cascade.causalPackedP


instance
   (Ring.C a, IsFirstClass a, IsArithmetic a, IsConst a,
    IsPowerOf2 n, IsPrimitive a, IsSized a as) =>
      C (Allpass.Parameter (Value a))
        (Value (Vector n a)) (Value (Vector n a)) where
   process = Allpass.causalPackedP

instance
   (Field.C a, IsFirstClass a, IsArithmetic a, IsConst a,
    IsPowerOf2 d, IsPrimitive a, IsSized a as,
    TypeNum.Nat n) =>
      C (Allpass.CascadeParameter n (Value a))
        (Value (Vector d a)) (Value (Vector d a)) where
   process = Allpass.cascadePackedP


instance
   (Module.C a a, IsFirstClass a, IsArithmetic a, IsConst a,
    LLVM.MakeValueTuple a (Value a), Storable a,
    IsPowerOf2 d, IsPrimitive a, IsSized a as,
    TypeNum.Nat n) =>
      C (Moog.Parameter n (Value a))
        (Value (Vector d a)) (Value (Vector d a)) where
   process =
      CausalPS.pack Moog.causalP <<<
      first (CausalP.mapSimple Vector.replicate)


instance
   (Field.C a, IsFirstClass a, IsArithmetic a, IsConst a,
    IsPowerOf2 d, IsPrimitive a, IsSized a as) =>
      C (UniFilter.Parameter (Value a))
        (Value (Vector d a)) (UniFilter.Result (Value (Vector d a))) where
   process =
      CausalPS.pack UniFilter.causalP <<<
      first (CausalP.mapSimple Vector.replicate)