{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{- |
Copyright   :  (c) Henning Thielemann 2008
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes

Moog cascade lowpass with resonance.
-}
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
           {- ^ Feedback of the lowpass cascade -}
       ,forall a. Parameter a -> Parameter a
lowpassParam :: !(Filt1.Parameter a)
           {- ^ Feedback of each of the lowpasses of 1st order -} }
  deriving Int -> Parameter a -> ShowS
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
showList :: [Parameter a] -> ShowS
$cshowList :: forall a. Show a => [Parameter a] -> ShowS
show :: Parameter a -> String
$cshow :: forall a. Show a => Parameter a -> String
showsPrec :: Int -> Parameter a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> 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 = forall a. a -> Parameter a -> Parameter a
Parameter
      (a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
feedback Parameter a
p) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> Parameter a -> Parameter a
Parameter a
x (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 = forall a. a -> Parameter a -> Parameter a
Parameter
      (forall a. Parameter a -> a
feedback Parameter (a -> b)
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
feedback Parameter a
p) (forall a. Parameter a -> Parameter a
lowpassParam Parameter (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = 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 =
      forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. a -> Parameter a -> Parameter a
Parameter
         (forall a. Parameter a -> a
feedback Parameter (f a)
p) (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
Trav.sequenceA (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 = 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 forall a. a -> Parameter a -> Parameter a
Parameter forall a. Parameter a -> a
feedback forall a. Parameter a -> Parameter a
lowpassParam


{-
For small frequencies we get cancellations and division zero by zero.
-}
_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 forall a. C a => a -> a -> a
* a
2 forall a. C a => a -> a -> a
* forall a. C a => a
pi
        alpha :: a
alpha = (forall a. C a => a
piforall a. C a => a -> a -> a
-a
beta) forall a. C a => a -> a -> a
/ forall a b. (C a, C b) => a -> b
fromIntegral Int
order
        k :: a
k     = forall a. C a => a -> a
sin a
alpha forall a. C a => a -> a -> a
/ forall a. C a => a -> a
sin (a
alphaforall a. C a => a -> a -> a
+a
beta)

        q :: a
q = ((forall a. C a => a -> a
sin (a
alphaforall a. C a => a -> a -> a
+a
beta) forall a. C a => a -> a -> a
- forall a. C a => a -> a
sin a
alpha) forall a. C a => a -> a -> a
/ forall a. C a => a -> a
sin a
beta) forall a. C a => a -> Integer -> a
^ forall a b. (C a, C b) => a -> b
fromIntegral Int
order
        f :: a
f = (a
resonanceforall a. C a => a -> a -> a
-a
1) forall a. C a => a -> a -> a
/ (a
resonanceforall a. C a => a -> a -> a
*a
qforall a. C a => a -> a -> a
+a
1)
    in  forall a. a -> Parameter a -> Parameter a
Parameter a
f (forall a. a -> Parameter a
Filt1.Parameter a
k)

{-
sin (a+b)
 = sin a * cos b + cos a * sin b
 = (2*ta*(1-tb^2) + 2*tb*(1-ta^2)) / ((1+ta^2)*(1+tb^2)) where ta = tan(a/2); tb = tan(b/2)

sin (a+b) - sin a
 = 2*(ta*(1-tb^2) + tb*(1-ta^2) - ta*(1+tb^2)) / ((1+ta^2)*(1+tb^2))
 = 2*(tb*(1-ta^2) - 2*ta*tb^2) / ((1+ta^2)*(1+tb^2))
 = sin b * (1-ta^2 - 2*ta*tb) / (1+ta^2)
-}
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 forall a. C a => a -> a -> a
* forall a. C a => a
pi
        alpha2 :: a
alpha2 = (forall a. C a => a
piforall a. C a => a -> a -> a
/a
2forall a. C a => a -> a -> a
-a
beta2) forall a. C a => a -> a -> a
/ forall a b. (C a, C b) => a -> b
fromIntegral Int
order
        tanAlpha2 :: a
tanAlpha2 = forall a. C a => a -> a
tan a
alpha2
        tanBeta2 :: a
tanBeta2  = forall a. C a => a -> a
tan a
beta2
        k :: a
k =
           a
tanAlpha2forall a. C a => a -> a -> a
*(a
1forall a. C a => a -> a -> a
+a
tanBeta2forall a. C a => a -> Integer -> a
^Integer
2) forall a. C a => a -> a -> a
/
           (a
tanAlpha2forall a. C a => a -> a -> a
*(a
1forall a. C a => a -> a -> a
-a
tanBeta2forall a. C a => a -> Integer -> a
^Integer
2) forall a. C a => a -> a -> a
+ a
tanBeta2forall a. C a => a -> a -> a
*(a
1forall a. C a => a -> a -> a
-a
tanAlpha2forall a. C a => a -> Integer -> a
^Integer
2))

        d :: a
d = (a
1forall a. C a => a -> a -> a
-a
tanAlpha2forall a. C a => a -> Integer -> a
^Integer
2 forall a. C a => a -> a -> a
- a
2forall a. C a => a -> a -> a
*a
tanAlpha2forall a. C a => a -> a -> a
*a
tanBeta2) forall a. C a => a -> a -> a
/ (a
1forall a. C a => a -> a -> a
+a
tanAlpha2forall a. C a => a -> Integer -> a
^Integer
2)
        q :: a
q = a
d forall a. C a => a -> Integer -> a
^ forall a b. (C a, C b) => a -> b
fromIntegral Int
order
        f :: a
f = (a
resonanceforall a. C a => a -> a -> a
-a
1) forall a. C a => a -> a -> a
/ (a
resonanceforall a. C a => a -> a -> a
*a
qforall a. C a => a -> a -> a
+a
1)
    in  forall a. a -> Parameter a -> Parameter a
Parameter a
f (forall a. a -> Parameter a
Filt1.Parameter a
k)


type State = []

{-
Used for _lowpassState,
list of internal values may be processed by Applicative.traverse.
-}
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 <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
MS.gets forall a. [a] -> a
head
      v
y1 <- forall a s. (a -> State s a) -> a -> State [s] a
Modifier.stackStatesR (forall a v. (C a, C a v) => Parameter a -> v -> State v v
Filt1.lowpassStep Parameter a
k) (v
x forall a. C a => a -> a -> a
- a
f forall a v. C a v => a -> v -> v
*> v
y0)
      forall (m :: * -> *) a. Monad m => a -> m a
return ((a
1forall a. C a => a -> a -> a
+a
f) 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 = forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
MS.state forall a b. (a -> b) -> a -> b
$ \State v
s ->
    let news :: State v
news =
           forall a. [a] -> [a]
tail (forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl
              (forall s a. State s a -> s -> a
MS.evalState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a v. (C a, C a v) => Parameter a -> v -> State v v
Filt1.lowpassStep Parameter a
k)
              -- (\u0 y1 -> let Filt1.Parameter k0 = k in (1-k0) *> u0 + k0 *> y1)
              (v
x forall a. C a => a -> a -> a
- a
f forall a v. C a v => a -> v -> v
*> forall a. [a] -> a
last State v
s) State v
s)
    in  ((a
1forall a. C a => a -> a -> a
+a
f) forall a v. C a v => a -> v -> v
*> forall a. [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 =
   forall s ctrl a b.
s -> (ctrl -> a -> State s b) -> Simple s ctrl a b
Modifier.Simple (forall a. Int -> a -> [a]
replicate Int
order forall a. C a => a
zero) 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 = 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 =
   forall a b. (a -> b) -> T a b
Causal.map forall a b. (a, b) -> a
fst forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
   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 forall a. C a => a -> a -> a
- a
f forall a v. C a v => a -> v -> v
*> v
y0)) forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>>
       forall c x. Int -> T (c, x) x -> T (c, x) x
Causal.replicateControlled Int
order forall a v. (C a, C a v) => T (Parameter a, v) v
Filt1.lowpassCausal)
      (forall a b. (a, b) -> b
snd forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> forall x. x -> T x x
Causal.consInit forall a. C a => a
zero)
    forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ (\((Parameter a
f Parameter a
_k),v
y1) -> (a
1forall a. C a => a -> a -> a
+a
f) 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 =
   forall s ctrl a b. Simple s ctrl a b -> T (ctrl, a) b
Causal.fromSimpleModifier (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

{-| Choose one of the implementations below -}
lowpass :: forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
lowpass = forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
lowpassRecursive

{-| Simulate the Moog cascade by a list of states of the partial lowpasses -}
_lowpassState :: forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
_lowpassState Int
order =
   forall s ctrl a b. Modifier s ctrl a b -> T ctrl -> T a -> T b
Sig.modifyModulated (forall a v.
(C a, C a v) =>
Int -> Simple (State v) (Parameter a) v v
lowpassModifier Int
order)

{-| The elegant way of implementing the Moog cascade by recursion -}
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 = forall a b. (a -> b) -> [a] -> [b]
map forall a. Parameter a -> Parameter a
lowpassParam T (Parameter a)
c
       f :: [a]
f = forall a b. (a -> b) -> [a] -> [b]
map forall a. Parameter a -> a
feedback T (Parameter a)
c
       z :: T v
z = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. C a => a -> a -> a
subtract (forall a v. C a v => T a -> T v -> T v
envelopeVector [a]
f (forall a. C a => a
zeroforall a. a -> [a] -> [a]
:T v
y)) T v
x
       y :: T v
y = forall a. Int -> (a -> a) -> a -> a
nest Int
order (forall a v. (C a, C a v) => T (Parameter a) -> T v -> T v
Filt1.lowpass [Parameter a]
k) T v
z
   in  forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a v. C a v => a -> v -> v
(*>) (forall a b. (a -> b) -> [a] -> [b]
map (a
1forall a. C a => a -> a -> a
+) [a]
f) T v
y