{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.FirstOrder ( Result(Result,lowpass_,highpass_), Parameter, parameter, causalP, lowpassCausalP, highpassCausalP, causalPackedP, lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP, -- for Allpass ) where import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder import Synthesizer.Plain.Filter.Recursive.FirstOrder (Parameter(Parameter), Result(Result)) import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Simple.Value as Value import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Class (Undefined, undefTuple, ) import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, phis, addPhis, ) import Control.Arrow (arr, (&&&), (<<<), ) import Control.Monad (liftM2, foldM, ) import NumericPrelude.Numeric import NumericPrelude.Base instance (Phi a) => Phi (Parameter a) where phis = Class.phisTraversable addPhis = Class.addPhisFoldable instance Undefined a => Undefined (Parameter a) where undefTuple = Class.undefTuplePointed instance (Memory.C a) => Memory.C (Parameter a) where type Struct (Parameter a) = Memory.Struct a load = Memory.loadNewtype Parameter store = Memory.storeNewtype (\(Parameter k) -> k) decompose = Memory.decomposeNewtype Parameter compose = Memory.composeNewtype (\(Parameter k) -> k) instance (Value.Flatten a) => Value.Flatten (Parameter a) where type Registers (Parameter a) = Parameter (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor {- instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where tupleDesc = Class.tupleDescFoldable -} instance (Class.MakeValueTuple a) => Class.MakeValueTuple (Parameter a) where type ValueTuple (Parameter a) = Parameter (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor parameter :: (A.Transcendental a, A.RationalConstant a) => a -> LLVM.CodeGenFunction r (Parameter a) parameter reson = Value.flatten $ FirstOrder.parameter (Value.constantValue reson) lowpassModifier, highpassModifier :: (A.PseudoModule a v, A.IntegerConstant a) => Modifier.Simple -- (FirstOrder.State (Value.T v)) (Value.T v) (Parameter (Value.T a)) (Value.T v) (Value.T v) lowpassModifier = FirstOrder.lowpassModifier highpassModifier = FirstOrder.highpassModifier causalP :: (A.IntegerConstant a, A.PseudoModule a v, Memory.C v) => CausalP.T p (Parameter a, v) (Result v) {- in contrast to CausalP.fromModifier this allows for sharing between lowpass and highpass channel -} causalP = CausalP.mapSimple (\(l,x) -> do h <- A.sub x l return (Result{FirstOrder.lowpass_ = l, FirstOrder.highpass_ = h})) <<< (lowpassCausalP &&& arr snd) lowpassCausalP, highpassCausalP :: (A.IntegerConstant a, A.PseudoModule a v, Memory.C v) => CausalP.T p (Parameter a, v) v lowpassCausalP = CausalP.fromModifier lowpassModifier highpassCausalP = CausalP.fromModifier highpassModifier lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP :: (Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant a, A.PseudoRing v, A.PseudoRing a) => CausalP.T p (Parameter a, v) v highpassCausalPackedP = arr snd - lowpassCausalPackedP lowpassCausalPackedP = causalRecursivePackedP <<< (arr fst &&& CausalP.mapSimple (\(FirstOrder.Parameter k, x) -> A.mul x =<< Serial.upsample =<< A.sub (A.fromInteger' 1) k)) {- x = [x0, x1, x2, x3] filter k y1 x = [x0 + k*y1, x1 + k*x0 + k^2*y1, x2 + k*x1 + k^2*x0 + k^3*y1, x3 + k*x2 + k^2*x1 + k^3*x0 + k^4*y1, ... ] f0x = insert 0 (k*y1) x f1x = f0x + k * f0x->1 f2x = f1x + k^2 * f1x->2 -} causalRecursivePackedP = CausalP.mapAccumSimple (\(FirstOrder.Parameter k, xk0) y1 -> do y1k <- A.mul k y1 xk1 <- Serial.modify (LLVM.valueOf 0) (A.add y1k) xk0 let size = Serial.size xk0 kv <- Serial.upsample k xk2 <- fmap fst $ foldM (\(y,k0) d -> liftM2 (,) (A.add y =<< Serial.shiftUpMultiZero d =<< A.mul y k0) (A.mul k0 k0)) (xk1,kv) (takeWhile (< size) $ iterate (2*) 1) {- do replicate in the loop xk2 <- fmap fst $ foldM (\(y,k0) d -> liftM2 (,) (A.add y =<< Serial.shiftUpMultiZero d =<< A.mul y =<< Serial.upsample k0) (A.mul k0 k0)) (xk1,k) (takeWhile (< size) $ iterate (2*) 1) -} y0 <- Serial.extract (LLVM.valueOf $ fromIntegral $ size - 1) xk2 return (xk2, y0)) (return A.zero) {- We can also optimize filtering with time-varying filter parameter. k = [k0, k1, k2, k3] x = [x0, x1, x2, x3] filter k y1 x = [x0 + k0*y1, x1 + k1*x0 + k1*k0*y1, x2 + k2*x1 + k2*k1*x0 + k2*k1*k0*y1, x3 + k3*x2 + k3*k2*x1 + k3*k2*k1*x0 + k3*k2*k1*k0*y1, ... ] f0x = insert 0 (k0*y1) x f1x = f0x + k * f0x->1 k' = k * k->1 f2x = f1x + k' * f1x->2 We can even interpret vectorised first order filtering as first order filtering with matrix coefficients. [x0 + k0*y1, x1 + k1*x0 + k1*k0*y1, x2 + k2*x1 + k2*k1*x0 + k2*k1*k0*y1, x3 + k3*x2 + k3*k2*x1 + k3*k2*k1*x0 + k3*k2*k1*k0*y1] = / 1 \ /x0\ / k0 0 0 0 \ /y1\ | k1 1 | . |x1| + | k1*k0 0 0 0 | . |y2| | k2*k1 k2 1 | |x2| | k2*k1*k0 0 0 0 | |y3| \ k3*k2*k1 k3*k2 k3 1 / \x3/ \ k3*k2*k1*k0 0 0 0 / \y4/ / 1 \ / 1 \ / 1 \ | k1 1 | = | 1 | . | k1 1 | | k2*k1 k2 1 | | k2*k1 1 | | k2 1 | \ k3*k2*k1 k3*k2 k3 1 / \ k3*k2 1 / \ k3 1 / -} causalPackedP :: (Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant a, A.PseudoRing v, A.PseudoRing a) => CausalP.T p (Parameter a, v) (Result v) causalPackedP = CausalP.mapSimple (\(l,x) -> do h <- A.sub x l return (Result{FirstOrder.lowpass_ = l, FirstOrder.highpass_ = h})) <<< (lowpassCausalPackedP &&& arr snd)