{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Synthesizer.Plain.Filter.Recursive.Moog (
Parameter(Parameter, feedback, lowpassParam),
parameter,
State,
lowpass,
lowpassModifier,
lowpassCausal,
) where
import Synthesizer.Plain.Filter.Recursive (Pole(..))
import Synthesizer.Plain.Filter.NonRecursive (envelopeVector)
import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1
import qualified Synthesizer.Plain.Signal as Sig
import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Interpolation.Class as Interpol
import qualified Control.Monad.Trans.State as MS
import qualified Control.Applicative as App
import Control.Arrow ((&&&), (>>^), (^>>), )
import Control.Applicative (pure, liftA2, (<*>), )
import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav
import Data.Function.HT (nest, )
import qualified Algebra.Module as Module
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Ring as Ring
import NumericPrelude.Numeric
import NumericPrelude.Base
data Parameter a =
Parameter
{forall a. Parameter a -> a
feedback :: !a
,forall a. Parameter a -> Parameter a
lowpassParam :: !(Filt1.Parameter a)
}
deriving Int -> Parameter a -> ShowS
[Parameter a] -> ShowS
Parameter a -> String
(Int -> Parameter a -> ShowS)
-> (Parameter a -> String)
-> ([Parameter a] -> ShowS)
-> Show (Parameter a)
forall a. Show a => Int -> Parameter a -> ShowS
forall a. Show a => [Parameter a] -> ShowS
forall a. Show a => Parameter a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Parameter a -> ShowS
showsPrec :: Int -> Parameter a -> ShowS
$cshow :: forall a. Show a => Parameter a -> String
show :: Parameter a -> String
$cshowList :: forall a. Show a => [Parameter a] -> ShowS
showList :: [Parameter a] -> ShowS
Show
instance Functor Parameter where
{-# INLINE fmap #-}
fmap :: forall a b. (a -> b) -> Parameter a -> Parameter b
fmap a -> b
f Parameter a
p = b -> Parameter b -> Parameter b
forall a. a -> Parameter a -> Parameter a
Parameter
(a -> b
f (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ Parameter a -> a
forall a. Parameter a -> a
feedback Parameter a
p) ((a -> b) -> Parameter a -> Parameter b
forall a b. (a -> b) -> Parameter a -> Parameter b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Parameter a -> Parameter b) -> Parameter a -> Parameter b
forall a b. (a -> b) -> a -> b
$ Parameter a -> Parameter a
forall a. Parameter a -> Parameter a
lowpassParam Parameter a
p)
instance App.Applicative Parameter where
{-# INLINE pure #-}
pure :: forall a. a -> Parameter a
pure a
x = a -> Parameter a -> Parameter a
forall a. a -> Parameter a -> Parameter a
Parameter a
x (a -> Parameter a
forall a. a -> Parameter a
Filt1.Parameter a
x)
{-# INLINE (<*>) #-}
Parameter (a -> b)
f <*> :: forall a b. Parameter (a -> b) -> Parameter a -> Parameter b
<*> Parameter a
p = b -> Parameter b -> Parameter b
forall a. a -> Parameter a -> Parameter a
Parameter
(Parameter (a -> b) -> a -> b
forall a. Parameter a -> a
feedback Parameter (a -> b)
f (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ Parameter a -> a
forall a. Parameter a -> a
feedback Parameter a
p) (Parameter (a -> b) -> Parameter (a -> b)
forall a. Parameter a -> Parameter a
lowpassParam Parameter (a -> b)
f Parameter (a -> b) -> Parameter a -> Parameter b
forall a b. Parameter (a -> b) -> Parameter a -> Parameter b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parameter a -> Parameter a
forall a. Parameter a -> Parameter a
lowpassParam Parameter a
p)
instance Fold.Foldable Parameter where
{-# INLINE foldMap #-}
foldMap :: forall m a. Monoid m => (a -> m) -> Parameter a -> m
foldMap = (a -> m) -> Parameter a -> m
forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
Trav.foldMapDefault
instance Trav.Traversable Parameter where
{-# INLINE sequenceA #-}
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Parameter (f a) -> f (Parameter a)
sequenceA Parameter (f a)
p =
(a -> Parameter a -> Parameter a)
-> f a -> f (Parameter a) -> f (Parameter a)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> Parameter a -> Parameter a
forall a. a -> Parameter a -> Parameter a
Parameter
(Parameter (f a) -> f a
forall a. Parameter a -> a
feedback Parameter (f a)
p) (Parameter (f a) -> f (Parameter a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Parameter (f a) -> f (Parameter a)
Trav.sequenceA (Parameter (f a) -> Parameter (f a)
forall a. Parameter a -> Parameter a
lowpassParam Parameter (f a)
p))
instance Interpol.C a v => Interpol.C a (Parameter v) where
{-# INLINE scaleAndAccumulate #-}
scaleAndAccumulate :: (a, Parameter v) -> (Parameter v, Parameter v -> Parameter v)
scaleAndAccumulate = (v -> Parameter v -> Parameter v)
-> (Parameter v -> v)
-> (Parameter v -> Parameter v)
-> (a, Parameter v)
-> (Parameter v, Parameter v -> Parameter v)
forall a x y v.
(C a x, C a y) =>
(x -> y -> v) -> (v -> x) -> (v -> y) -> (a, v) -> (v, v -> v)
Interpol.makeMac2 v -> Parameter v -> Parameter v
forall a. a -> Parameter a -> Parameter a
Parameter Parameter v -> v
forall a. Parameter a -> a
feedback Parameter v -> Parameter v
forall a. Parameter a -> Parameter a
lowpassParam
_parameterInstable :: Trans.C a => Int -> Pole a -> Parameter a
_parameterInstable :: forall a. C a => Int -> Pole a -> Parameter a
_parameterInstable Int
order (Pole a
resonance a
frequency) =
let beta :: a
beta = a
frequency a -> a -> a
forall a. C a => a -> a -> a
* a
2 a -> a -> a
forall a. C a => a -> a -> a
* a
forall a. C a => a
pi
alpha :: a
alpha = (a
forall a. C a => a
pia -> a -> a
forall a. C a => a -> a -> a
-a
beta) a -> a -> a
forall a. C a => a -> a -> a
/ Int -> a
forall a b. (C a, C b) => a -> b
fromIntegral Int
order
k :: a
k = a -> a
forall a. C a => a -> a
sin a
alpha a -> a -> a
forall a. C a => a -> a -> a
/ a -> a
forall a. C a => a -> a
sin (a
alphaa -> a -> a
forall a. C a => a -> a -> a
+a
beta)
q :: a
q = ((a -> a
forall a. C a => a -> a
sin (a
alphaa -> a -> a
forall a. C a => a -> a -> a
+a
beta) a -> a -> a
forall a. C a => a -> a -> a
- a -> a
forall a. C a => a -> a
sin a
alpha) a -> a -> a
forall a. C a => a -> a -> a
/ a -> a
forall a. C a => a -> a
sin a
beta) a -> Integer -> a
forall a. C a => a -> Integer -> a
^ Int -> Integer
forall a b. (C a, C b) => a -> b
fromIntegral Int
order
f :: a
f = (a
resonancea -> a -> a
forall a. C a => a -> a -> a
-a
1) a -> a -> a
forall a. C a => a -> a -> a
/ (a
resonancea -> a -> a
forall a. C a => a -> a -> a
*a
qa -> a -> a
forall a. C a => a -> a -> a
+a
1)
in a -> Parameter a -> Parameter a
forall a. a -> Parameter a -> Parameter a
Parameter a
f (a -> Parameter a
forall a. a -> Parameter a
Filt1.Parameter a
k)
parameter :: Trans.C a => Int -> Pole a -> Parameter a
parameter :: forall a. C a => Int -> Pole a -> Parameter a
parameter Int
order (Pole a
resonance a
frequency) =
let beta2 :: a
beta2 = a
frequency a -> a -> a
forall a. C a => a -> a -> a
* a
forall a. C a => a
pi
alpha2 :: a
alpha2 = (a
forall a. C a => a
pia -> a -> a
forall a. C a => a -> a -> a
/a
2a -> a -> a
forall a. C a => a -> a -> a
-a
beta2) a -> a -> a
forall a. C a => a -> a -> a
/ Int -> a
forall a b. (C a, C b) => a -> b
fromIntegral Int
order
tanAlpha2 :: a
tanAlpha2 = a -> a
forall a. C a => a -> a
tan a
alpha2
tanBeta2 :: a
tanBeta2 = a -> a
forall a. C a => a -> a
tan a
beta2
k :: a
k =
a
tanAlpha2a -> a -> a
forall a. C a => a -> a -> a
*(a
1a -> a -> a
forall a. C a => a -> a -> a
+a
tanBeta2a -> Integer -> a
forall a. C a => a -> Integer -> a
^Integer
2) a -> a -> a
forall a. C a => a -> a -> a
/
(a
tanAlpha2a -> a -> a
forall a. C a => a -> a -> a
*(a
1a -> a -> a
forall a. C a => a -> a -> a
-a
tanBeta2a -> Integer -> a
forall a. C a => a -> Integer -> a
^Integer
2) a -> a -> a
forall a. C a => a -> a -> a
+ a
tanBeta2a -> a -> a
forall a. C a => a -> a -> a
*(a
1a -> a -> a
forall a. C a => a -> a -> a
-a
tanAlpha2a -> Integer -> a
forall a. C a => a -> Integer -> a
^Integer
2))
d :: a
d = (a
1a -> a -> a
forall a. C a => a -> a -> a
-a
tanAlpha2a -> Integer -> a
forall a. C a => a -> Integer -> a
^Integer
2 a -> a -> a
forall a. C a => a -> a -> a
- a
2a -> a -> a
forall a. C a => a -> a -> a
*a
tanAlpha2a -> a -> a
forall a. C a => a -> a -> a
*a
tanBeta2) a -> a -> a
forall a. C a => a -> a -> a
/ (a
1a -> a -> a
forall a. C a => a -> a -> a
+a
tanAlpha2a -> Integer -> a
forall a. C a => a -> Integer -> a
^Integer
2)
q :: a
q = a
d a -> Integer -> a
forall a. C a => a -> Integer -> a
^ Int -> Integer
forall a b. (C a, C b) => a -> b
fromIntegral Int
order
f :: a
f = (a
resonancea -> a -> a
forall a. C a => a -> a -> a
-a
1) a -> a -> a
forall a. C a => a -> a -> a
/ (a
resonancea -> a -> a
forall a. C a => a -> a -> a
*a
qa -> a -> a
forall a. C a => a -> a -> a
+a
1)
in a -> Parameter a -> Parameter a
forall a. a -> Parameter a -> Parameter a
Parameter a
f (a -> Parameter a
forall a. a -> Parameter a
Filt1.Parameter a
k)
type State = []
lowpassStepStack :: (Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State (State v) v
lowpassStepStack :: forall a v. (C a, C a v) => Parameter a -> v -> State (State v) v
lowpassStepStack (Parameter a
f Parameter a
k) v
x =
do v
y0 <- (State v -> v) -> State (State v) v
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
MS.gets State v -> v
forall a. HasCallStack => [a] -> a
head
v
y1 <- (v -> State v v) -> v -> State (State v) v
forall a s. (a -> State s a) -> a -> State [s] a
Modifier.stackStatesR (Parameter a -> v -> State v v
forall a v. (C a, C a v) => Parameter a -> v -> State v v
Filt1.lowpassStep Parameter a
k) (v
x v -> v -> v
forall a. C a => a -> a -> a
- a
f a -> v -> v
forall a v. C a v => a -> v -> v
*> v
y0)
v -> State (State v) v
forall a. a -> StateT (State v) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
1a -> a -> a
forall a. C a => a -> a -> a
+a
f) a -> v -> v
forall a v. C a v => a -> v -> v
*> v
y1)
_lowpassStepRev :: (Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State (State v) v
_lowpassStepRev :: forall a v. (C a, C a v) => Parameter a -> v -> State (State v) v
_lowpassStepRev (Parameter a
f Parameter a
k) v
x = (State v -> (v, State v)) -> StateT (State v) Identity v
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
MS.state ((State v -> (v, State v)) -> StateT (State v) Identity v)
-> (State v -> (v, State v)) -> StateT (State v) Identity v
forall a b. (a -> b) -> a -> b
$ \State v
s ->
let news :: State v
news =
State v -> State v
forall a. HasCallStack => [a] -> [a]
tail ((v -> v -> v) -> v -> State v -> State v
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl
(State v v -> v -> v
forall s a. State s a -> s -> a
MS.evalState (State v v -> v -> v) -> (v -> State v v) -> v -> v -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parameter a -> v -> State v v
forall a v. (C a, C a v) => Parameter a -> v -> State v v
Filt1.lowpassStep Parameter a
k)
(v
x v -> v -> v
forall a. C a => a -> a -> a
- a
f a -> v -> v
forall a v. C a v => a -> v -> v
*> State v -> v
forall a. HasCallStack => [a] -> a
last State v
s) State v
s)
in ((a
1a -> a -> a
forall a. C a => a -> a -> a
+a
f) a -> v -> v
forall a v. C a v => a -> v -> v
*> State v -> v
forall a. HasCallStack => [a] -> a
last State v
news, State v
news)
lowpassModifier :: (Ring.C a, Module.C a v) =>
Int -> Modifier.Simple (State v) (Parameter a) v v
lowpassModifier :: forall a v.
(C a, C a v) =>
Int -> Simple (State v) (Parameter a) v v
lowpassModifier Int
order =
State v
-> (Parameter a -> v -> State (State v) v)
-> Simple (State v) (Parameter a) v v
forall s ctrl a b.
s -> (ctrl -> a -> State s b) -> Simple s ctrl a b
Modifier.Simple (Int -> v -> State v
forall a. Int -> a -> [a]
replicate Int
order v
forall a. C a => a
zero) Parameter a -> v -> State (State v) v
forall a v. (C a, C a v) => Parameter a -> v -> State (State v) v
lowpassStepStack
{-# INLINE lowpassCausal #-}
{-# INLINE lowpassCausalStacked #-}
{-# INLINE _lowpassCausalModifier #-}
lowpassCausal, lowpassCausalStacked, _lowpassCausalModifier ::
(Ring.C a, Module.C a v) =>
Int -> Causal.T (Parameter a, v) v
lowpassCausal :: forall a v. (C a, C a v) => Int -> T (Parameter a, v) v
lowpassCausal = Int -> T (Parameter a, v) v
forall a v. (C a, C a v) => Int -> T (Parameter a, v) v
lowpassCausalStacked
lowpassCausalStacked :: forall a v. (C a, C a v) => Int -> T (Parameter a, v) v
lowpassCausalStacked Int
order =
((Parameter a, v) -> Parameter a)
-> T (Parameter a, v) (Parameter a)
forall a b. (a -> b) -> T a b
Causal.map (Parameter a, v) -> Parameter a
forall a b. (a, b) -> a
fst T (Parameter a, v) (Parameter a)
-> T (Parameter a, v) v -> T (Parameter a, v) (Parameter a, v)
forall b c c'. T b c -> T b c' -> T b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
T ((Parameter a, v), v) v
-> T (Parameter a, v) v -> T (Parameter a, v) v
forall ctrl a c b.
T ((ctrl, a), c) b -> T (ctrl, b) c -> T (ctrl, a) b
Causal.feedbackControlled
((\(((Parameter a
f Parameter a
k),v
x),v
y0) -> (Parameter a
k, v
x v -> v -> v
forall a. C a => a -> a -> a
- a
f a -> v -> v
forall a v. C a v => a -> v -> v
*> v
y0)) (((Parameter a, v), v) -> (Parameter a, v))
-> T (Parameter a, v) v -> T ((Parameter a, v), v) v
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>>
Int -> T (Parameter a, v) v -> T (Parameter a, v) v
forall c x. Int -> T (c, x) x -> T (c, x) x
Causal.replicateControlled Int
order T (Parameter a, v) v
forall a v. (C a, C a v) => T (Parameter a, v) v
Filt1.lowpassCausal)
((Parameter a, v) -> v
forall a b. (a, b) -> b
snd ((Parameter a, v) -> v) -> T v v -> T (Parameter a, v) v
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> v -> T v v
forall x. x -> T x x
Causal.consInit v
forall a. C a => a
zero)
T (Parameter a, v) (Parameter a, v)
-> ((Parameter a, v) -> v) -> T (Parameter a, v) v
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ (\((Parameter a
f Parameter a
_k),v
y1) -> (a
1a -> a -> a
forall a. C a => a -> a -> a
+a
f) a -> v -> v
forall a v. C a v => a -> v -> v
*> v
y1)
_lowpassCausalModifier :: forall a v. (C a, C a v) => Int -> T (Parameter a, v) v
_lowpassCausalModifier Int
order =
Simple (State v) (Parameter a) v v -> T (Parameter a, v) v
forall s ctrl a b. Simple s ctrl a b -> T (ctrl, a) b
Causal.fromSimpleModifier (Int -> Simple (State v) (Parameter a) v v
forall a v.
(C a, C a v) =>
Int -> Simple (State v) (Parameter a) v v
lowpassModifier Int
order)
lowpass, _lowpassState, lowpassRecursive ::
(Ring.C a, Module.C a v) =>
Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v
lowpass :: forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
lowpass = Int -> T (Parameter a) -> T v -> T v
forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
lowpassRecursive
_lowpassState :: forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
_lowpassState Int
order =
Modifier (State v) (Parameter a) v v
-> T (Parameter a) -> State v -> State v
forall s ctrl a b. Modifier s ctrl a b -> T ctrl -> T a -> T b
Sig.modifyModulated (Int -> Modifier (State v) (Parameter a) v v
forall a v.
(C a, C a v) =>
Int -> Simple (State v) (Parameter a) v v
lowpassModifier Int
order)
lowpassRecursive :: forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
lowpassRecursive Int
order T (Parameter a)
c T v
x =
let k :: [Parameter a]
k = (Parameter a -> Parameter a) -> T (Parameter a) -> [Parameter a]
forall a b. (a -> b) -> [a] -> [b]
map Parameter a -> Parameter a
forall a. Parameter a -> Parameter a
lowpassParam T (Parameter a)
c
f :: [a]
f = (Parameter a -> a) -> T (Parameter a) -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Parameter a -> a
forall a. Parameter a -> a
feedback T (Parameter a)
c
z :: T v
z = (v -> v -> v) -> T v -> T v -> T v
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith v -> v -> v
forall a. C a => a -> a -> a
subtract ([a] -> T v -> T v
forall a v. C a v => T a -> T v -> T v
envelopeVector [a]
f (v
forall a. C a => a
zerov -> T v -> T v
forall a. a -> [a] -> [a]
:T v
y)) T v
x
y :: T v
y = Int -> (T v -> T v) -> T v -> T v
forall a. Int -> (a -> a) -> a -> a
nest Int
order ([Parameter a] -> T v -> T v
forall a v. (C a, C a v) => T (Parameter a) -> T v -> T v
Filt1.lowpass [Parameter a]
k) T v
z
in (a -> v -> v) -> [a] -> T v -> T v
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> v -> v
forall a v. C a v => a -> v -> v
(*>) ((a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a
1a -> a -> a
forall a. C a => a -> a -> a
+) [a]
f) T v
y