{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Synthesizer.Filter.Composition where
import qualified Synthesizer.Filter.Basic as FilterBasic
import Synthesizer.Filter.Basic (Filter, apply, )
import qualified Algebra.Module as Module
import qualified Algebra.Transcendental as Trans
import qualified Algebra.RealRing as RealRing
import qualified Algebra.Field as Field
import qualified Algebra.Additive as Additive
import qualified Number.Complex as Complex
import NumericPrelude.Base
import NumericPrelude.Numeric
{- ToDo:
- functions that build a FilterComposition for specific filters
(1st order, universal, allpass, butterworth, chebyshev)
- functions that turn physical filter parameters into
internal ones
- How can these function be combined?
A function like
[ FilterComposition v [m] ] -> FilterComposition v [[m]]
is not satisfying, since the conversion function cannot rely
that the structure of all FilterComposition v [m] is equal.
If the list is empty the structure can't even be reconstructed.
-}
{-|
This describes a generic filter with one input and one main output
that consists of non-recursive and recursive parts.
If you use Feedback, make sure that at least
one of the filters of a circle includes a delay,
otherwise the recursion will fail.
The main output is used to glue different parts together.
Additionally the functions 'apply' and 'transferFunction'
provide the signals at every node of the network.
-}
data T filter t a v =
Prim (filter t a v)
{-^ a filter primitve -}
| Serial [T filter t a v]
{-^ serial chain of filters -}
| Parallel [T filter t a v]
{-^ filters working parallel, there output is mixed together -}
| Feedback (T filter t a v) (T filter t a v)
{-^ filter the signal in the forward direction and
feed back the output signal filtered by the second filter -}
{-|
This is the data structure is used for the results
of 'apply' and 'transferFunction'.
Each constructor corresponds to one of 'Filter.Composition.T'.
By choosing only some of the outputs
the lazy evaluation will content
with applying the necessary filter steps, only.
-}
data Sockets s = Sockets {output :: s, socket :: SocketSpec s}
data SocketSpec s =
Output
| Multiplier [Sockets s]
| Adder [Sockets s]
| Loop (Sockets s) (Sockets s)
instance (Filter list filter) =>
Filter (list) (T filter) where
{-
apply :: (Module.C a v) =>
FilterComposition a v -> TwoWayList v -> TwoWayList v
-}
apply f x = output (applyMulti f x)
{-
transferFunction :: (Trans.C b, Module.C a (Complex.T b)) =>
T filter a v -> b -> (Complex.T b)
-}
transferFunction f w = output (transferFunctionMulti f w)
{-| Apply a filter network to a signal and keep the output of all nodes.
Generic function that is wrapped by 'apply'. -}
applyMulti :: (RealRing.C t, Trans.C t,
Module.C a v, Module.C a (list v), Filter list filter) =>
T filter t a v -> list v -> Sockets (list v)
applyMulti (Prim f) x =
Sockets (apply f x) Output
applyMulti (Serial fs) x =
let sq = scanl (\(Sockets y _) -> flip applyMulti y) (Sockets x Output) fs
in Sockets (output (last sq)) (Multiplier (tail sq))
applyMulti (Parallel fs) x =
let socks = map (flip applyMulti x) fs
y = foldr (Additive.+) zero (map output socks)
in Sockets y (Adder socks)
{- the distinction between 'feed' and 'back'
can be dropped in a more general net structure -}
applyMulti (Feedback feed back) x =
let sockY@(Sockets y _) = applyMulti feed ((Additive.+) x z)
sockZ@(Sockets z _) = applyMulti back y
in Sockets y (Loop sockY sockZ)
transferFunctionMulti ::
(Trans.C t, Module.C a t, Filter list filter) =>
T filter t a v -> t -> Sockets (Complex.T t)
transferFunctionMulti f w = tfAbsolutize 1 (tfRelative w f)
{-| Compute the transitivity for each part of the filter network.
We must do this in such a relative manner to be able
to compute feedback. -}
tfRelative ::
(Trans.C t, Module.C a t, Filter list filter) =>
t -> T filter t a v -> Sockets (Complex.T t)
tfRelative w (Prim f) =
Sockets (FilterBasic.transferFunction f w) Output
tfRelative w (Serial fs) =
let sq = map (tfRelative w) fs
in Sockets (product (map output sq)) (Multiplier sq)
tfRelative w (Parallel fs) =
let sq = map (tfRelative w) fs
in Sockets (sum (map output sq)) (Adder sq)
tfRelative w (Feedback feed back) =
let sockY = tfRelative w feed
sockZ = tfRelative w back
q = output sockY / (1 - output sockZ)
in Sockets q (Loop sockY sockZ)
{-| Make the results from 'tfRelative' absolute. -}
tfAbsolutize :: (Field.C a) => a -> Sockets a -> Sockets a
tfAbsolutize x (Sockets y spec) = Sockets (x*y)
(case spec of
(Multiplier socks) ->
let sq = scanl (\(Sockets z _) -> tfAbsolutize z)
(Sockets x Output) socks
in Multiplier (tail sq)
(Adder socks) ->
let sq = map (tfAbsolutize x) socks
in Adder sq
(Loop feed back) ->
let sockY = tfAbsolutize (x / (1 - output back)) feed
sockZ = tfAbsolutize (output sockY) back
-- it should be x*y == output sockY
in Loop sockY sockZ
Output -> spec)