module Synthesizer.Plain.Filter.Recursive.Universal (
Parameter(..),
Result(..),
State,
causal,
modifier,
modifierInit,
parameter,
parameterToSecondOrderLowpass,
run,
runInit,
step,
parameterAlt,
parameterOld,
) where
import Synthesizer.Plain.Filter.Recursive (Pole(..))
import qualified Synthesizer.Plain.Signal as Sig
import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as SecondOrder
import qualified Synthesizer.Interpolation.Class as Interpol
import qualified Control.Monad.Trans.State as MS
import qualified Control.Applicative as App
import Control.Applicative.HT (liftA4, liftA6, )
import Control.Applicative (pure, liftA2, )
import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav
import Foreign.Storable (Storable(..))
import qualified Foreign.Storable.Record as Store
import qualified Algebra.Module as Module
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import NumericPrelude.Numeric
import NumericPrelude.Base
data Parameter a =
Parameter {k1, k2, ampIn, ampI1, ampI2, ampLimit :: !a}
instance Functor Parameter where
fmap f p = Parameter
(f $ k1 p) (f $ k2 p) (f $ ampIn p) (f $ ampI1 p) (f $ ampI2 p) (f $ ampLimit p)
instance App.Applicative Parameter where
pure x = Parameter x x x x x x
f <*> p = Parameter
(k1 f $ k1 p) (k2 f $ k2 p) (ampIn f $ ampIn p) (ampI1 f $ ampI1 p) (ampI2 f $ ampI2 p) (ampLimit f $ ampLimit p)
instance Fold.Foldable Parameter where
foldMap = Trav.foldMapDefault
instance Trav.Traversable Parameter where
sequenceA p =
liftA6 Parameter
(k1 p) (k2 p) (ampIn p) (ampI1 p) (ampI2 p) (ampLimit p)
instance Interpol.C a v => Interpol.C a (Parameter v) where
scaleAndAccumulate =
Interpol.scaleAndAccumulateApplicative
instance Storable a => Storable (Parameter a) where
sizeOf = Store.sizeOf storeParameter
alignment = Store.alignment storeParameter
peek = Store.peek storeParameter
poke = Store.poke storeParameter
storeParameter ::
Storable a => Store.Dictionary (Parameter a)
storeParameter =
Store.run $
liftA6 Parameter
(Store.element k1)
(Store.element k2)
(Store.element ampIn)
(Store.element ampI1)
(Store.element ampI2)
(Store.element ampLimit)
data Result a =
Result {highpass, bandpass, lowpass, bandlimit :: !a}
instance Functor Result where
fmap f p = Result
(f $ highpass p) (f $ bandpass p) (f $ lowpass p) (f $ bandlimit p)
instance App.Applicative Result where
pure x = Result x x x x
f <*> p = Result
(highpass f $ highpass p) (bandpass f $ bandpass p) (lowpass f $ lowpass p) (bandlimit f $ bandlimit p)
instance Fold.Foldable Result where
foldMap = Trav.foldMapDefault
instance Trav.Traversable Result where
sequenceA p =
liftA4 Result
(highpass p) (bandpass p) (lowpass p) (bandlimit p)
instance Additive.C v => Additive.C (Result v) where
zero = pure zero
(+) = liftA2 (+)
() = liftA2 ()
negate = fmap negate
instance Module.C a v => Module.C a (Result v) where
s*>v = fmap (s*>) v
instance Storable a => Storable (Result a) where
sizeOf = Store.sizeOf storeResult
alignment = Store.alignment storeResult
peek = Store.peek storeResult
poke = Store.poke storeResult
storeResult ::
Storable a => Store.Dictionary (Result a)
storeResult =
Store.run $
liftA4 Result
(Store.element highpass)
(Store.element bandpass)
(Store.element lowpass)
(Store.element bandlimit)
parameter, parameterAlt, parameterOld :: Trans.C a => Pole a -> Parameter a
parameter (Pole resonance frequency) =
let w = sin (pi*frequency)
w2 = w^2
q2 = resonance^2
q21w2 = 4*q2*(1w2)
sqrtQZ = w * sqrt (q21w2 + w2)
pk1 = (w2+sqrtQZ) / (q2+w2+sqrtQZ)
d = (q21w2*w2 + w2^2 q2)
/ (q21w2 2*q2 w2 + (14*w2)*sqrtQZ)
volHP = (2pk1)/4 d
volRel = sqrt ((2pk1 + 4 * d) / volHP)
in Parameter
(pk1/volRel) volHP
volHP volRel volRel (recip resonance)
parameterAlt (Pole resonance frequency) =
let w = sin (pi*frequency)
w2 = w^2
q2 = resonance^2
sqrtQZ = w * sqrt (4*q2 + w2 4*q2*w2)
pk1 = (w2+sqrtQZ) / (q2+w2+sqrtQZ)
zr = 1 2 * w2
pk2 = 2pk1 +
4 * (w2^2q2*zr^2) / (2*q2*zrw2+(14*w2)*sqrtQZ)
volHP = (42*pk1pk2) / 4
volLP = pk2
volBP = sqrt (volHP*volLP)
in Parameter
(pk1*volHP/volBP) (pk2*volHP/volLP)
volHP (volBP/volHP) (volLP/volBP) (recip resonance)
parameterOld (Pole resonance frequency) =
let zr = cos (2*pi*frequency)
zr1 = zr1
q2 = resonance^2
sqrtQZ = sqrt (zr1*(8*q2+zr14*q2*zr1))
pk1 = (zr1+sqrtQZ) / (2*q2zr1+sqrtQZ)
q21zr = 4*q2*zr
a = 2 * (zr1*zr1q21zr*zr) / (zr1+q21zr+(1+2*zr1)*sqrtQZ)
pk2 = a+2pk1
volHP = (42*pk1pk2) / 4
volLP = pk2
volBP = sqrt (volHP*volLP)
in Parameter
(pk1*volHP/volBP) (pk2*volHP/volLP)
volHP (volBP/volHP) (volLP/volBP) (recip resonance)
parameterToSecondOrderLowpass ::
(Ring.C a) => Parameter a -> SecondOrder.Parameter a
parameterToSecondOrderLowpass p =
SecondOrder.Parameter {
SecondOrder.c0 = 1,
SecondOrder.c1 = 0,
SecondOrder.c2 = 0,
SecondOrder.d1 = k1 p k2 p,
SecondOrder.d2 = 1 k1 p
}
type State v = (v,v)
step :: (Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State (State v) (Result v)
step p u =
MS.state $ \(i1,i2) ->
let newsum = ampIn p *> u + k1 p *> i1 k2 p *> i2
newi1 = i1 ampI1 p *> newsum
newi2 = i2 ampI2 p *> newi1
out = Result newsum newi1 newi2 (u + ampLimit p *> newi1)
in (out, (newi1, newi2))
modifierInit :: (Ring.C a, Module.C a v) =>
Modifier.Initialized (State v) (v,v) (Parameter a) v (Result v)
modifierInit =
Modifier.Initialized id step
modifier :: (Ring.C a, Module.C a v) =>
Modifier.Simple (State v) (Parameter a) v (Result v)
modifier = Sig.modifierInitialize modifierInit (zero, zero)
causal ::
(Ring.C a, Module.C a v) =>
Causal.T (Parameter a, v) (Result v)
causal =
Causal.fromSimpleModifier modifier
runInit :: (Ring.C a, Module.C a v) =>
(v,v) -> Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v)
runInit = Sig.modifyModulatedInit modifierInit
run :: (Ring.C a, Module.C a v) =>
Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v)
run = runInit (zero, zero)