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 {getParameter :: a}
deriving Show
instance Functor Parameter where
fmap f (Parameter k) = Parameter (f k)
instance App.Applicative Parameter where
pure x = Parameter x
Parameter f <*> Parameter k =
Parameter (f k)
instance Fold.Foldable Parameter where
foldMap = Trav.foldMapDefault
instance Trav.Traversable Parameter where
sequenceA (Parameter k) =
fmap Parameter k
instance Interpol.C a v => Interpol.C a (Parameter v) where
scaleAndAccumulate = Interpol.makeMac Parameter getParameter
instance Storable a => Storable (Parameter a) where
sizeOf = Store.sizeOf getParameter
alignment = Store.alignment getParameter
peek = Store.peek Parameter
poke = Store.poke getParameter
parameter :: Trans.C a =>
a
-> a
-> Parameter a
parameter phase frequency =
let s = tan (pi*frequency)
r = tan (pi*phase)
in Parameter $ (s+r) / (sr)
parameterAlt :: Trans.C a =>
a
-> a
-> Parameter a
parameterAlt phase frequency =
let omega = 2*pi * frequency
phi = 2*pi * phase
k = (cos phi cos omega) / (1 cos (phi omega))
in Parameter k
parameterApprox :: Trans.C a =>
a
-> a
-> Parameter a
parameterApprox phase frequency =
Parameter $ (frequency + phase) / (frequency phase)
type State v = (v,v)
firstOrderStep :: (Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State (State v) v
firstOrderStep (Parameter k) u0 =
MS.state (\(u1,y1) -> let y0 = u1 + k *> (u0y1) in (y0,(u0,y0)))
firstOrderModifier :: (Ring.C a, Module.C a v) =>
Modifier.Simple (State v) (Parameter a) v v
firstOrderModifier =
Modifier.Simple (zero,zero) firstOrderStep
firstOrderCausal :: (Ring.C a, Module.C a v) =>
Causal.T (Parameter a, v) v
firstOrderCausal =
Causal.fromSimpleModifier firstOrderModifier
firstOrder :: (Ring.C a, Module.C a v) =>
Sig.T (Parameter a) -> Sig.T v -> Sig.T v
firstOrder = Sig.modifyModulated firstOrderModifier
makePhase :: (RealTrans.C a, ZeroTestable.C a) => Parameter a -> a -> a
makePhase (Parameter k) frequency =
let cis = Complex.cis ( 2*pi * frequency)
in Complex.phase (Complex.fromReal k + cis) / pi + frequency
cascadeParameter :: Trans.C a =>
Int
-> a
-> a
-> Parameter a
cascadeParameter order phase =
parameter (phase / fromIntegral order)
flangerPhase :: Field.C a => a
flangerPhase = 1
flangerParameter :: Trans.C a => Int -> a -> Parameter a
flangerParameter order frequency =
cascadeParameter order flangerPhase frequency
cascadeStep :: (Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State [v] v
cascadeStep = cascadeStepRec
cascadeStepStackPairs :: (Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State [State v] v
cascadeStepStackPairs k =
Modifier.stackStatesL (firstOrderStep k)
cascadeStepStack, cascadeStepRec, cascadeStepScanl ::
(Ring.C a, Module.C a v) =>
Parameter a -> v -> MS.State [v] v
cascadeStepStack k x =
MS.state $
mapSnd fromPairs .
MS.runState (cascadeStepStackPairs k x) .
toPairs
fromPairs :: [(a,a)] -> [a]
fromPairs xs@(x:_) = fst x : map snd xs
fromPairs [] = error "Allpass.fromPairs: empty list"
toPairs :: [a] -> [(a,a)]
toPairs xs = mapAdjacent (,) xs
cascadeStepRec (Parameter k) x = MS.state $ \s ->
let crawl _ [] = error "Allpass.crawl needs at least one element in the list"
crawl u0 (_:[]) = u0:[]
crawl u0 (u1:y1:us) =
let y0 = u1 + k *> (u0y1)
in u0 : crawl y0 (y1:us)
news = crawl x s
in (last news, news)
cascadeStepScanl k x = MS.state $ \s ->
let news =
scanl
(MS.evalState . firstOrderStep k)
x (mapAdjacent (,) s)
in (switchR
(error "Allpass.cascade needs at least one element in the state list")
(flip const) news,
news)
cascadeModifier :: (Ring.C a, Module.C a v) =>
Int -> Modifier.Simple [v] (Parameter a) v v
cascadeModifier order =
Modifier.Simple (replicate (succ order) zero) cascadeStep
cascadeCausal, cascadeCausalStacked, cascadeCausalModifier ::
(Ring.C a, Module.C a v) =>
Int -> Causal.T (Parameter a, v) v
cascadeCausal = cascadeCausalModifier
cascadeCausalStacked order =
Causal.replicateControlled order firstOrderCausal
cascadeCausalModifier order =
Causal.fromSimpleModifier (cascadeModifier order)
cascade, cascadeState, cascadeIterative ::
(Ring.C a, Module.C a v) =>
Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v
cascade = cascadeState
cascadeState order =
Sig.modifyModulated (cascadeModifier order)
cascadeIterative order c =
nest order (firstOrder c)
cascadeDiverseStep, cascadeDiverseStepScanl :: (Ring.C a, Module.C a v) =>
[Parameter a] -> v -> MS.State [v] v
cascadeDiverseStep = cascadeDiverseStepScanl
cascadeDiverseStepScanl ks x = MS.state $ \s ->
let news =
scanl
(\u0 (k,uy1) -> MS.evalState (firstOrderStep k u0) uy1)
x (zip ks $ mapAdjacent (,) s)
in (switchR
(error "Allpass.cascadeDiverse needs at least one element in the state list")
(flip const) news,
news)