{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Synthesizer.Plain.Filter.Recursive.Allpass (
Parameter(Parameter, getParameter),
State,
cascade,
cascadeCausal,
cascadeModifier,
cascadeParameter,
cascadeStep,
cascadeDiverseStep,
firstOrder,
firstOrderCausal,
firstOrderModifier,
firstOrderStep,
flangerParameter,
flangerPhase,
makePhase,
parameter,
parameterApprox,
parameterAlt,
cascadeState,
cascadeIterative,
cascadeStepRec,
cascadeStepScanl,
cascadeStepStack,
cascadeCausalModifier,
cascadeCausalStacked,
) where
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 qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav
import Data.Tuple.HT (mapSnd, )
import Data.Function.HT (nest, )
import Data.List.HT (mapAdjacent, switchR, )
import qualified Foreign.Storable.Newtype as Store
import Foreign.Storable (Storable(sizeOf, alignment, peek, poke))
import qualified Algebra.Module as Module
import qualified Algebra.RealTranscendental as RealTrans
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.ZeroTestable as ZeroTestable
import qualified Number.Complex as Complex
import NumericPrelude.Numeric
import NumericPrelude.Base
newtype Parameter a =
Parameter {forall a. Parameter a -> a
getParameter :: 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
k) = forall a. a -> Parameter a
Parameter (a -> b
f a
k)
instance App.Applicative Parameter where
{-# INLINE pure #-}
pure :: forall a. a -> Parameter a
pure a
x = forall a. a -> Parameter a
Parameter a
x
{-# INLINE (<*>) #-}
Parameter a -> b
f <*> :: forall a b. Parameter (a -> b) -> Parameter a -> Parameter b
<*> Parameter a
k =
forall a. a -> Parameter a
Parameter (a -> b
f a
k)
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
k) =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Parameter a
Parameter f a
k
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 v.
C a x =>
(x -> v) -> (v -> x) -> (a, v) -> (v, v -> v)
Interpol.makeMac forall a. a -> Parameter a
Parameter forall a. Parameter a -> a
getParameter
instance Storable a => Storable (Parameter a) where
sizeOf :: Parameter a -> Int
sizeOf = forall core wrapper.
Storable core =>
(wrapper -> core) -> wrapper -> Int
Store.sizeOf forall a. Parameter a -> a
getParameter
alignment :: Parameter a -> Int
alignment = forall core wrapper.
Storable core =>
(wrapper -> core) -> wrapper -> Int
Store.alignment forall a. Parameter a -> a
getParameter
peek :: Ptr (Parameter a) -> IO (Parameter a)
peek = forall core wrapper.
Storable core =>
(core -> wrapper) -> Ptr wrapper -> IO wrapper
Store.peek forall a. a -> Parameter a
Parameter
poke :: Ptr (Parameter a) -> Parameter a -> IO ()
poke = forall core wrapper.
Storable core =>
(wrapper -> core) -> Ptr wrapper -> wrapper -> IO ()
Store.poke forall a. Parameter a -> a
getParameter
{-# INLINE parameter #-}
parameter :: Trans.C a =>
a
-> a
-> Parameter a
parameter :: forall a. C a => a -> a -> Parameter a
parameter a
phase a
frequency =
let s :: a
s = forall a. C a => a -> a
tan (forall a. C a => a
piforall a. C a => a -> a -> a
*a
frequency)
r :: a
r = forall a. C a => a -> a
tan (forall a. C a => a
piforall a. C a => a -> a -> a
*a
phase)
in forall a. a -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ (a
sforall a. C a => a -> a -> a
+a
r) forall a. C a => a -> a -> a
/ (a
sforall a. C a => a -> a -> a
-a
r)
{-# INLINE parameterAlt #-}
parameterAlt :: Trans.C a =>
a
-> a
-> Parameter a
parameterAlt :: forall a. C a => a -> a -> Parameter a
parameterAlt a
phase a
frequency =
let omega :: a
omega = a
2forall a. C a => a -> a -> a
*forall a. C a => a
pi forall a. C a => a -> a -> a
* a
frequency
phi :: a
phi = a
2forall a. C a => a -> a -> a
*forall a. C a => a
pi forall a. C a => a -> a -> a
* a
phase
k :: a
k = (forall a. C a => a -> a
cos a
phi forall a. C a => a -> a -> a
- forall a. C a => a -> a
cos a
omega) forall a. C a => a -> a -> a
/ (a
1 forall a. C a => a -> a -> a
- forall a. C a => a -> a
cos (a
phi forall a. C a => a -> a -> a
- a
omega))
in forall a. a -> Parameter a
Parameter a
k
{-# INLINE parameterApprox #-}
parameterApprox :: Trans.C a =>
a
-> a
-> Parameter a
parameterApprox :: forall a. C a => a -> a -> Parameter a
parameterApprox a
phase a
frequency =
forall a. a -> Parameter a
Parameter forall a b. (a -> b) -> a -> b
$ (a
frequency forall a. C a => a -> a -> a
+ a
phase) forall a. C a => a -> a -> a
/ (a
frequency forall a. C a => a -> a -> a
- a
phase)
type State v = (v,v)
{-# INLINE firstOrderStep #-}
firstOrderStep :: (Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State (State v) v
firstOrderStep :: forall a v. (C a, C a v) => Parameter a -> v -> State (State v) v
firstOrderStep (Parameter a
k) v
u0 =
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
MS.state (\(v
u1,v
y1) -> let y0 :: v
y0 = v
u1 forall a. C a => a -> a -> a
+ a
k forall a v. C a v => a -> v -> v
*> (v
u0forall a. C a => a -> a -> a
-v
y1) in (v
y0,(v
u0,v
y0)))
{-# INLINE firstOrderModifier #-}
firstOrderModifier :: (Ring.C a, Module.C a v) =>
Modifier.Simple (State v) (Parameter a) v v
firstOrderModifier :: forall a v. (C a, C a v) => Simple (State v) (Parameter a) v v
firstOrderModifier =
forall s ctrl a b.
s -> (ctrl -> a -> State s b) -> Simple s ctrl a b
Modifier.Simple (forall a. C a => a
zero,forall a. C a => a
zero) forall a v. (C a, C a v) => Parameter a -> v -> State (State v) v
firstOrderStep
{-# INLINE firstOrderCausal #-}
firstOrderCausal :: (Ring.C a, Module.C a v) =>
Causal.T (Parameter a, v) v
firstOrderCausal :: forall a v. (C a, C a v) => T (Parameter a, v) v
firstOrderCausal =
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
firstOrderModifier
{-# INLINE firstOrder #-}
firstOrder :: (Ring.C a, Module.C a v) =>
Sig.T (Parameter a) -> Sig.T v -> Sig.T v
firstOrder :: forall a v. (C a, C a v) => T (Parameter a) -> T v -> T v
firstOrder = 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) => Simple (State v) (Parameter a) v v
firstOrderModifier
{-# INLINE makePhase #-}
makePhase :: (RealTrans.C a, ZeroTestable.C a) => Parameter a -> a -> a
makePhase :: forall a. (C a, C a) => Parameter a -> a -> a
makePhase (Parameter a
k) a
frequency =
let cis :: T a
cis = forall a. C a => a -> T a
Complex.cis (- a
2forall a. C a => a -> a -> a
*forall a. C a => a
pi forall a. C a => a -> a -> a
* a
frequency)
in forall a. (C a, C a) => T a -> a
Complex.phase (forall a. C a => a -> T a
Complex.fromReal a
k forall a. C a => a -> a -> a
+ T a
cis) forall a. C a => a -> a -> a
/ forall a. C a => a
pi forall a. C a => a -> a -> a
+ a
frequency
{-# INLINE cascadeParameter #-}
cascadeParameter :: Trans.C a =>
Int
-> a
-> a
-> Parameter a
cascadeParameter :: forall a. C a => Int -> a -> a -> Parameter a
cascadeParameter Int
order a
phase =
forall a. C a => a -> a -> Parameter a
parameter (a
phase forall a. C a => a -> a -> a
/ forall a b. (C a, C b) => a -> b
fromIntegral Int
order)
{-# INLINE flangerPhase #-}
flangerPhase :: Field.C a => a
flangerPhase :: forall a. C a => a
flangerPhase = -a
1
{-# INLINE flangerParameter #-}
flangerParameter :: Trans.C a => Int -> a -> Parameter a
flangerParameter :: forall a. C a => Int -> a -> Parameter a
flangerParameter Int
order a
frequency =
forall a. C a => Int -> a -> a -> Parameter a
cascadeParameter Int
order forall a. C a => a
flangerPhase a
frequency
{-# INLINE cascadeStep #-}
cascadeStep :: (Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State [v] v
cascadeStep :: forall a v. (C a, C a v) => Parameter a -> v -> State [v] v
cascadeStep = forall a v. (C a, C a v) => Parameter a -> v -> State [v] v
cascadeStepRec
{-# INLINE cascadeStepStackPairs #-}
cascadeStepStackPairs :: (Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State [State v] v
cascadeStepStackPairs :: forall a v. (C a, C a v) => Parameter a -> v -> State [State v] v
cascadeStepStackPairs Parameter a
k =
forall a s. (a -> State s a) -> a -> State [s] a
Modifier.stackStatesL (forall a v. (C a, C a v) => Parameter a -> v -> State (State v) v
firstOrderStep Parameter a
k)
{-# INLINE cascadeStepStack #-}
{-# INLINE cascadeStepRec #-}
{-# INLINE cascadeStepScanl #-}
cascadeStepStack, cascadeStepRec, cascadeStepScanl ::
(Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State [v] v
cascadeStepStack :: forall a v. (C a, C a v) => Parameter a -> v -> State [v] v
cascadeStepStack 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
$
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd forall a. [(a, a)] -> [a]
fromPairs forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall s a. State s a -> s -> (a, s)
MS.runState (forall a v. (C a, C a v) => Parameter a -> v -> State [State v] v
cascadeStepStackPairs Parameter a
k v
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. [a] -> [(a, a)]
toPairs
{-# INLINE fromPairs #-}
fromPairs :: [(a,a)] -> [a]
fromPairs :: forall a. [(a, a)] -> [a]
fromPairs xs :: [(a, a)]
xs@((a, a)
x:[(a, a)]
_) = forall a b. (a, b) -> a
fst (a, a)
x forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, a)]
xs
fromPairs [] = forall a. HasCallStack => String -> a
error String
"Allpass.fromPairs: empty list"
{-# INLINE toPairs #-}
toPairs :: [a] -> [(a,a)]
toPairs :: forall a. [a] -> [(a, a)]
toPairs [a]
xs = forall a b. (a -> a -> b) -> [a] -> [b]
mapAdjacent (,) [a]
xs
cascadeStepRec :: forall a v. (C a, C a v) => Parameter a -> v -> State [v] v
cascadeStepRec (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
$ \[v]
s ->
let crawl :: a -> [a] -> [a]
crawl a
_ [] = forall a. HasCallStack => String -> a
error String
"Allpass.crawl needs at least one element in the list"
crawl a
u0 (a
_:[]) = a
u0forall a. a -> [a] -> [a]
:[]
crawl a
u0 (a
u1:a
y1:[a]
us) =
let y0 :: a
y0 = a
u1 forall a. C a => a -> a -> a
+ a
k forall a v. C a v => a -> v -> v
*> (a
u0forall a. C a => a -> a -> a
-a
y1)
in a
u0 forall a. a -> [a] -> [a]
: a -> [a] -> [a]
crawl a
y0 (a
y1forall a. a -> [a] -> [a]
:[a]
us)
news :: [v]
news = forall {a}. C a a => a -> [a] -> [a]
crawl v
x [v]
s
in (forall a. [a] -> a
last [v]
news, [v]
news)
cascadeStepScanl :: forall a v. (C a, C a v) => Parameter a -> v -> State [v] v
cascadeStepScanl 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
$ \[v]
s ->
let news :: [v]
news =
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 (State v) v
firstOrderStep Parameter a
k)
v
x (forall a b. (a -> a -> b) -> [a] -> [b]
mapAdjacent (,) [v]
s)
in (forall b a. b -> ([a] -> a -> b) -> [a] -> b
switchR
(forall a. HasCallStack => String -> a
error String
"Allpass.cascade needs at least one element in the state list")
(forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. a -> b -> a
const) [v]
news,
[v]
news)
{-# INLINE cascadeModifier #-}
cascadeModifier :: (Ring.C a, Module.C a v) =>
Int -> Modifier.Simple [v] (Parameter a) v v
cascadeModifier :: forall a v. (C a, C a v) => Int -> Simple [v] (Parameter a) v v
cascadeModifier 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 (forall a. Enum a => a -> a
succ Int
order) forall a. C a => a
zero) forall a v. (C a, C a v) => Parameter a -> v -> State [v] v
cascadeStep
{-# INLINE cascadeCausal #-}
{-# INLINE cascadeCausalStacked #-}
{-# INLINE cascadeCausalModifier #-}
cascadeCausal, cascadeCausalStacked, cascadeCausalModifier ::
(Ring.C a, Module.C a v) =>
Int -> Causal.T (Parameter a, v) v
cascadeCausal :: forall a v. (C a, C a v) => Int -> T (Parameter a, v) v
cascadeCausal = forall a v. (C a, C a v) => Int -> T (Parameter a, v) v
cascadeCausalModifier
cascadeCausalStacked :: forall a v. (C a, C a v) => Int -> T (Parameter a, v) v
cascadeCausalStacked Int
order =
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
firstOrderCausal
cascadeCausalModifier :: forall a v. (C a, C a v) => Int -> T (Parameter a, v) v
cascadeCausalModifier 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 [v] (Parameter a) v v
cascadeModifier Int
order)
{-# INLINE cascade #-}
{-# INLINE cascadeState #-}
{-# INLINE cascadeIterative #-}
cascade, cascadeState, cascadeIterative ::
(Ring.C a, Module.C a v) =>
Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v
cascade :: forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
cascade = forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
cascadeState
cascadeState :: forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
cascadeState 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 [v] (Parameter a) v v
cascadeModifier Int
order)
cascadeIterative :: forall a v. (C a, C a v) => Int -> T (Parameter a) -> T v -> T v
cascadeIterative Int
order T (Parameter a)
c =
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
firstOrder T (Parameter a)
c)
{-# INLINE cascadeDiverseStep #-}
{-# INLINE cascadeDiverseStepScanl #-}
cascadeDiverseStep, cascadeDiverseStepScanl :: (Ring.C a, Module.C a v) =>
[Parameter a] -> v -> MS.State [v] v
cascadeDiverseStep :: forall a v. (C a, C a v) => [Parameter a] -> v -> State [v] v
cascadeDiverseStep = forall a v. (C a, C a v) => [Parameter a] -> v -> State [v] v
cascadeDiverseStepScanl
cascadeDiverseStepScanl :: forall a v. (C a, C a v) => [Parameter a] -> v -> State [v] v
cascadeDiverseStepScanl [Parameter a]
ks v
x = forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
MS.state forall a b. (a -> b) -> a -> b
$ \[v]
s ->
let news :: [v]
news =
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl
(\v
u0 (Parameter a
k,State v
uy1) -> forall s a. State s a -> s -> a
MS.evalState (forall a v. (C a, C a v) => Parameter a -> v -> State (State v) v
firstOrderStep Parameter a
k v
u0) State v
uy1)
v
x (forall a b. [a] -> [b] -> [(a, b)]
zip [Parameter a]
ks forall a b. (a -> b) -> a -> b
$ forall a b. (a -> a -> b) -> [a] -> [b]
mapAdjacent (,) [v]
s)
in (forall b a. b -> ([a] -> a -> b) -> [a] -> b
switchR
(forall a. HasCallStack => String -> a
error String
"Allpass.cascadeDiverse needs at least one element in the state list")
(forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. a -> b -> a
const) [v]
news,
[v]
news)