{-# 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

All recursive filters with real coefficients
can be decomposed into first order and second order filters with real coefficients.
This follows from the Fundamental theorem of algebra.
-}
module Synthesizer.Plain.Filter.Recursive.SecondOrder (
   Parameter (Parameter, c0, c1, c2, d1, d2),
   State (State, u1, u2, y1, y2),
   adjustPassband,
   amplify,
   causal,
   modifier,
   modifierInit,
   run,
   runInit,
   step,
   zeroState,
   ) where

import qualified Synthesizer.Plain.Signal   as Sig
import qualified Synthesizer.Plain.Modifier as Modifier
import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass))

import qualified Synthesizer.Interpolation.Class as Interpol

import qualified Control.Applicative.HT as App
import Control.Applicative (Applicative, pure, (<*>), )

import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav

import qualified Synthesizer.Causal.Process as Causal

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

import Data.List (zipWith6)

import qualified Control.Monad.Trans.State as MS

import qualified Foreign.Storable.Record as Store
import Foreign.Storable (Storable(..))

import NumericPrelude.Numeric
import NumericPrelude.Base


{- | Parameters for a general recursive filter of 2nd order. -}
data Parameter a =
   Parameter {forall a. Parameter a -> a
c0, forall a. Parameter a -> a
c1, forall a. Parameter a -> a
c2, forall a. Parameter a -> a
d1, forall a. Parameter a -> a
d2 :: !a}
       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 -> a -> a -> a -> a -> Parameter a
Parameter
      (a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
c0 Parameter a
p) (a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
c1 Parameter a
p) (a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
c2 Parameter a
p) (a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
d1 Parameter a
p) (a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
d2 Parameter a
p)

instance Applicative Parameter where
   {-# INLINE pure #-}
   pure :: forall a. a -> Parameter a
pure a
x = forall a. a -> a -> a -> a -> a -> Parameter a
Parameter a
x a
x a
x a
x a
x
   {-# INLINE (<*>) #-}
   Parameter (a -> b)
f <*> :: forall a b. Parameter (a -> b) -> Parameter a -> Parameter b
<*> Parameter a
p = forall a. a -> a -> a -> a -> a -> Parameter a
Parameter
      (forall a. Parameter a -> a
c0 Parameter (a -> b)
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
c0 Parameter a
p) (forall a. Parameter a -> a
c1 Parameter (a -> b)
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
c1 Parameter a
p) (forall a. Parameter a -> a
c2 Parameter (a -> b)
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
c2 Parameter a
p) (forall a. Parameter a -> a
d1 Parameter (a -> b)
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
d1 Parameter a
p) (forall a. Parameter a -> a
d2 Parameter (a -> b)
f forall a b. (a -> b) -> a -> b
$ forall a. Parameter a -> a
d2 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 (m :: * -> *) a b c d e r.
Applicative m =>
(a -> b -> c -> d -> e -> r)
-> m a -> m b -> m c -> m d -> m e -> m r
App.lift5 forall a. a -> a -> a -> a -> a -> Parameter a
Parameter
         (forall a. Parameter a -> a
c0 Parameter (f a)
p) (forall a. Parameter a -> a
c1 Parameter (f a)
p) (forall a. Parameter a -> a
c2 Parameter (f a)
p) (forall a. Parameter a -> a
d1 Parameter (f a)
p) (forall a. Parameter a -> a
d2 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 v x. MAC a v x -> (a, v) -> (x, v -> x)
Interpol.runMac forall a b. (a -> b) -> a -> b
$
         forall (m :: * -> *) a b c d e r.
Applicative m =>
(a -> b -> c -> d -> e -> r)
-> m a -> m b -> m c -> m d -> m e -> m r
App.lift5 forall a. a -> a -> a -> a -> a -> Parameter a
Parameter
            (forall a x v. C a x => (v -> x) -> MAC a v x
Interpol.element forall a. Parameter a -> a
c0)
            (forall a x v. C a x => (v -> x) -> MAC a v x
Interpol.element forall a. Parameter a -> a
c1)
            (forall a x v. C a x => (v -> x) -> MAC a v x
Interpol.element forall a. Parameter a -> a
c2)
            (forall a x v. C a x => (v -> x) -> MAC a v x
Interpol.element forall a. Parameter a -> a
d1)
            (forall a x v. C a x => (v -> x) -> MAC a v x
Interpol.element forall a. Parameter a -> a
d2)



data State a =
   State {forall a. State a -> a
u1, forall a. State a -> a
u2, forall a. State a -> a
y1, forall a. State a -> a
y2 :: !a}
       deriving Int -> State a -> ShowS
forall a. Show a => Int -> State a -> ShowS
forall a. Show a => [State a] -> ShowS
forall a. Show a => State a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State a] -> ShowS
$cshowList :: forall a. Show a => [State a] -> ShowS
show :: State a -> String
$cshow :: forall a. Show a => State a -> String
showsPrec :: Int -> State a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> State a -> ShowS
Show

zeroState :: Additive.C a => State a
zeroState :: forall a. C a => State a
zeroState =
   State
      {u1 :: a
u1 = forall a. C a => a
zero, u2 :: a
u2 = forall a. C a => a
zero,
       y1 :: a
y1 = forall a. C a => a
zero, y2 :: a
y2 = forall a. C a => a
zero}


instance Functor State where
   {-# INLINE fmap #-}
   fmap :: forall a b. (a -> b) -> State a -> State b
fmap a -> b
f State a
p = forall a. a -> a -> a -> a -> State a
State
      (a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. State a -> a
u1 State a
p) (a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. State a -> a
u2 State a
p) (a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. State a -> a
y1 State a
p) (a -> b
f forall a b. (a -> b) -> a -> b
$ forall a. State a -> a
y2 State a
p)

instance Applicative State where
   {-# INLINE pure #-}
   pure :: forall a. a -> State a
pure a
x = forall a. a -> a -> a -> a -> State a
State a
x a
x a
x a
x
   {-# INLINE (<*>) #-}
   State (a -> b)
f <*> :: forall a b. State (a -> b) -> State a -> State b
<*> State a
p = forall a. a -> a -> a -> a -> State a
State
      (forall a. State a -> a
u1 State (a -> b)
f forall a b. (a -> b) -> a -> b
$ forall a. State a -> a
u1 State a
p) (forall a. State a -> a
u2 State (a -> b)
f forall a b. (a -> b) -> a -> b
$ forall a. State a -> a
u2 State a
p) (forall a. State a -> a
y1 State (a -> b)
f forall a b. (a -> b) -> a -> b
$ forall a. State a -> a
y1 State a
p) (forall a. State a -> a
y2 State (a -> b)
f forall a b. (a -> b) -> a -> b
$ forall a. State a -> a
y2 State a
p)

instance Fold.Foldable State where
   {-# INLINE foldMap #-}
   foldMap :: forall m a. Monoid m => (a -> m) -> State a -> m
foldMap = forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
Trav.foldMapDefault

instance Trav.Traversable State where
   {-# INLINE sequenceA #-}
   sequenceA :: forall (f :: * -> *) a. Applicative f => State (f a) -> f (State a)
sequenceA State (f a)
p =
      forall (m :: * -> *) a b c d r.
Applicative m =>
(a -> b -> c -> d -> r) -> m a -> m b -> m c -> m d -> m r
App.lift4 forall a. a -> a -> a -> a -> State a
State
         (forall a. State a -> a
u1 State (f a)
p) (forall a. State a -> a
u2 State (f a)
p) (forall a. State a -> a
y1 State (f a)
p) (forall a. State a -> a
y2 State (f a)
p)



instance Storable a => Storable (Parameter a) where
   sizeOf :: Parameter a -> Int
sizeOf    = forall r. Dictionary r -> r -> Int
Store.sizeOf forall a. Storable a => Dictionary (Parameter a)
storeParameter
   alignment :: Parameter a -> Int
alignment = forall r. Dictionary r -> r -> Int
Store.alignment forall a. Storable a => Dictionary (Parameter a)
storeParameter
   peek :: Ptr (Parameter a) -> IO (Parameter a)
peek      = forall r. Dictionary r -> Ptr r -> IO r
Store.peek forall a. Storable a => Dictionary (Parameter a)
storeParameter
   poke :: Ptr (Parameter a) -> Parameter a -> IO ()
poke      = forall r. Dictionary r -> Ptr r -> r -> IO ()
Store.poke forall a. Storable a => Dictionary (Parameter a)
storeParameter

storeParameter ::
   Storable a => Store.Dictionary (Parameter a)
storeParameter :: forall a. Storable a => Dictionary (Parameter a)
storeParameter =
   forall r. Access r r -> Dictionary r
Store.run forall a b. (a -> b) -> a -> b
$
   forall (m :: * -> *) a b c d e r.
Applicative m =>
(a -> b -> c -> d -> e -> r)
-> m a -> m b -> m c -> m d -> m e -> m r
App.lift5 forall a. a -> a -> a -> a -> a -> Parameter a
Parameter
      (forall a r. Storable a => (r -> a) -> Access r a
Store.element forall a. Parameter a -> a
c0)
      (forall a r. Storable a => (r -> a) -> Access r a
Store.element forall a. Parameter a -> a
c1)
      (forall a r. Storable a => (r -> a) -> Access r a
Store.element forall a. Parameter a -> a
c2)
      (forall a r. Storable a => (r -> a) -> Access r a
Store.element forall a. Parameter a -> a
d1)
      (forall a r. Storable a => (r -> a) -> Access r a
Store.element forall a. Parameter a -> a
d2)


instance Storable a => Storable (State a) where
   sizeOf :: State a -> Int
sizeOf    = forall r. Dictionary r -> r -> Int
Store.sizeOf forall a. Storable a => Dictionary (State a)
storeState
   alignment :: State a -> Int
alignment = forall r. Dictionary r -> r -> Int
Store.alignment forall a. Storable a => Dictionary (State a)
storeState
   peek :: Ptr (State a) -> IO (State a)
peek      = forall r. Dictionary r -> Ptr r -> IO r
Store.peek forall a. Storable a => Dictionary (State a)
storeState
   poke :: Ptr (State a) -> State a -> IO ()
poke      = forall r. Dictionary r -> Ptr r -> r -> IO ()
Store.poke forall a. Storable a => Dictionary (State a)
storeState

storeState ::
   Storable a => Store.Dictionary (State a)
storeState :: forall a. Storable a => Dictionary (State a)
storeState =
   forall r. Access r r -> Dictionary r
Store.run forall a b. (a -> b) -> a -> b
$
   forall (m :: * -> *) a b c d r.
Applicative m =>
(a -> b -> c -> d -> r) -> m a -> m b -> m c -> m d -> m r
App.lift4 forall a. a -> a -> a -> a -> State a
State
      (forall a r. Storable a => (r -> a) -> Access r a
Store.element forall a. State a -> a
u1)
      (forall a r. Storable a => (r -> a) -> Access r a
Store.element forall a. State a -> a
u2)
      (forall a r. Storable a => (r -> a) -> Access r a
Store.element forall a. State a -> a
y1)
      (forall a r. Storable a => (r -> a) -> Access r a
Store.element forall a. State a -> a
y2)


{- |
Given a function which computes the filter parameters of a lowpass filter
for a given frequency,
turn that into a function which generates highpass parameters,
if requested filter type is Highpass.
-}
{-# INLINE adjustPassband #-}
adjustPassband :: (Field.C a) =>
   Passband -> (a -> Parameter a) -> (a -> Parameter a)
adjustPassband :: forall a. C a => Passband -> (a -> Parameter a) -> a -> Parameter a
adjustPassband Passband
kind a -> Parameter a
comp a
f =
   case Passband
kind of
      Passband
Lowpass  -> a -> Parameter a
comp a
f
      Passband
Highpass ->
         let p :: Parameter a
p = a -> Parameter a
comp (a
0.5forall a. C a => a -> a -> a
-a
f)
         in  forall a. a -> a -> a -> a -> a -> Parameter a
Parameter (forall a. Parameter a -> a
c0 Parameter a
p) (- forall a. Parameter a -> a
c1 Parameter a
p) (forall a. Parameter a -> a
c2 Parameter a
p) (- forall a. Parameter a -> a
d1 Parameter a
p) (forall a. Parameter a -> a
d2 Parameter a
p)

{- |
Change filter parameter such that result is amplified by a given factor.
-}
{-# INLINE amplify #-}
amplify :: (Ring.C a) =>
   a -> Parameter a -> Parameter a
amplify :: forall a. C a => a -> Parameter a -> Parameter a
amplify a
a Parameter a
p =
   Parameter a
p{c0 :: a
c0 = a
a forall a. C a => a -> a -> a
* forall a. Parameter a -> a
c0 Parameter a
p,
     c1 :: a
c1 = a
a forall a. C a => a -> a -> a
* forall a. Parameter a -> a
c1 Parameter a
p,
     c2 :: a
c2 = a
a forall a. C a => a -> a -> a
* forall a. Parameter a -> a
c2 Parameter a
p}

{-# INLINE step #-}
step :: (Ring.C a, Module.C a v) =>
   Parameter a -> v -> MS.State (State v) v
step :: forall a v. (C a, C a v) => Parameter a -> v -> State (State v) v
step Parameter a
c v
u0 = 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 y0 :: v
y0 =
          forall a. Parameter a -> a
c0 Parameter a
c forall a v. C a v => a -> v -> v
*> v
u0   forall a. C a => a -> a -> a
+
          forall a. Parameter a -> a
c1 Parameter a
c forall a v. C a v => a -> v -> v
*> forall a. State a -> a
u1 State v
s forall a. C a => a -> a -> a
+ forall a. Parameter a -> a
d1 Parameter a
c forall a v. C a v => a -> v -> v
*> forall a. State a -> a
y1 State v
s forall a. C a => a -> a -> a
+
          forall a. Parameter a -> a
c2 Parameter a
c forall a v. C a v => a -> v -> v
*> forall a. State a -> a
u2 State v
s forall a. C a => a -> a -> a
+ forall a. Parameter a -> a
d2 Parameter a
c forall a v. C a v => a -> v -> v
*> forall a. State a -> a
y2 State v
s
   in  (v
y0, State
               {u1 :: v
u1 = v
u0, u2 :: v
u2 = forall a. State a -> a
u1 State v
s,
                y1 :: v
y1 = v
y0, y2 :: v
y2 = forall a. State a -> a
y1 State v
s})


{-# INLINE modifierInit #-}
modifierInit :: (Ring.C a, Module.C a v) =>
   Modifier.Initialized (State v) (State v) (Parameter a) v v
modifierInit :: forall a v.
(C a, C a v) =>
Initialized (State v) (State v) (Parameter a) v v
modifierInit =
   forall s init ctrl a b.
(init -> s)
-> (ctrl -> a -> State s b) -> Initialized s init ctrl a b
Modifier.Initialized forall a. a -> a
id forall a v. (C a, C a v) => Parameter a -> v -> State (State v) v
step

{-# INLINE modifier #-}
modifier :: (Ring.C a, Module.C a v) =>
   Modifier.Simple (State v) (Parameter a) v v
modifier :: forall a v. (C a, C a v) => Simple (State v) (Parameter a) v v
modifier =
   forall s init ctrl a b.
ModifierInit s init ctrl a b -> init -> Modifier s ctrl a b
Sig.modifierInitialize forall a v.
(C a, C a v) =>
Initialized (State v) (State v) (Parameter a) v v
modifierInit forall a. C a => State a
zeroState

{-# INLINE causal #-}
causal :: (Ring.C a, Module.C a v) =>
   Causal.T (Parameter a, v) v
causal :: forall a v. (C a, C a v) => T (Parameter a, v) v
causal =
   forall s ctrl a b. Simple s ctrl a b -> T (ctrl, a) b
Causal.fromSimpleModifier forall a v. (C a, C a v) => Simple (State v) (Parameter a) v v
modifier


{-# INLINE runInit #-}
runInit :: (Ring.C a, Module.C a v) =>
   State v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v
runInit :: forall a v.
(C a, C a v) =>
State v -> T (Parameter a) -> T v -> T v
runInit State v
sInit T (Parameter a)
control T v
input =
   let u0s :: T v
u0s = T v
input
       u1s :: T v
u1s = forall a. State a -> a
u1 State v
sInit forall a. a -> [a] -> [a]
: T v
u0s
       u2s :: T v
u2s = forall a. State a -> a
u2 State v
sInit forall a. a -> [a] -> [a]
: T v
u1s
       y1s :: T v
y1s = forall a. State a -> a
y1 State v
sInit forall a. a -> [a] -> [a]
: T v
y0s
       y2s :: T v
y2s = forall a. State a -> a
y2 State v
sInit forall a. a -> [a] -> [a]
: T v
y1s
       y0s :: T v
y0s = forall a b c d e f g.
(a -> b -> c -> d -> e -> f -> g)
-> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]
zipWith6
          (\Parameter a
c v
u0_ v
u1_ v
u2_ v
y1_ v
y2_ ->
              forall a. Parameter a -> a
c0 Parameter a
c forall a v. C a v => a -> v -> v
*> v
u0_ forall a. C a => a -> a -> a
+
              forall a. Parameter a -> a
c1 Parameter a
c forall a v. C a v => a -> v -> v
*> v
u1_ forall a. C a => a -> a -> a
+ forall a. Parameter a -> a
d1 Parameter a
c forall a v. C a v => a -> v -> v
*> v
y1_ forall a. C a => a -> a -> a
+
              forall a. Parameter a -> a
c2 Parameter a
c forall a v. C a v => a -> v -> v
*> v
u2_ forall a. C a => a -> a -> a
+ forall a. Parameter a -> a
d2 Parameter a
c forall a v. C a v => a -> v -> v
*> v
y2_)
          T (Parameter a)
control T v
u0s T v
u1s T v
u2s T v
y1s T v
y2s
   in  T v
y0s

{-# INLINE run #-}
run :: (Ring.C a, Module.C a v) =>
   Sig.T (Parameter a) -> Sig.T v -> Sig.T v
run :: forall a v. (C a, C a v) => T (Parameter a) -> T v -> T v
run =
   forall a v.
(C a, C a v) =>
State v -> T (Parameter a) -> T v -> T v
runInit forall a. C a => State a
zeroState