module Synthesizer.Plain.Filter.NonRecursive where
import qualified Synthesizer.Plain.Control as Ctrl
import qualified Synthesizer.Plain.Signal as Sig
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Module as Module
import qualified Algebra.RealField as RealField
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import Algebra.Module(linearComb, (*>))
import Data.Function.HT (nest, )
import Data.List (tails, )
import PreludeBase
import NumericPrelude
amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a
amplify v = map (v*)
amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v
amplifyVector = (*>)
envelope :: (Ring.C a) =>
Sig.T a
-> Sig.T a
-> Sig.T a
envelope = zipWith (*)
envelopeVector :: (Module.C a v) =>
Sig.T a
-> Sig.T v
-> Sig.T v
envelopeVector = zipWith (*>)
fadeInOut :: (Field.C a) => Int -> Int -> Int -> Sig.T a -> Sig.T a
fadeInOut tIn tHold tOut xs =
let leadIn = take tIn $ Ctrl.linearMultiscale ( recip (fromIntegral tIn)) 0
leadOut = take tOut $ Ctrl.linearMultiscale ( recip (fromIntegral tOut)) 1
(partIn, partHoldOut) = splitAt tIn xs
(partHold, partOut) = splitAt tHold partHoldOut
in envelope leadIn partIn ++
partHold ++
envelope leadOut partOut
fadeInOutAlt :: (Field.C a) => Int -> Int -> Int -> Sig.T a -> Sig.T a
fadeInOutAlt tIn tHold tOut =
zipWith id
((map (\x y -> y * fromIntegral x / fromIntegral tIn) [0..tIn1]) ++
(replicate tHold id) ++
(map (\x y -> y * fromIntegral x / fromIntegral tOut) [tOut1,tOut2..0]))
delay :: Additive.C y => Int -> Sig.T y -> Sig.T y
delay = delayPad zero
delayPad :: y -> Int -> Sig.T y -> Sig.T y
delayPad z n =
if n<0
then drop (negate n)
else (replicate n z ++)
generic :: Module.C a v =>
Sig.T a -> Sig.T v -> Sig.T v
generic m x =
let mr = reverse m
xp = delay (pred (length m)) x
in map (linearComb mr) (init (tails xp))
genericAlt :: Module.C a v =>
Sig.T a -> Sig.T v -> Sig.T v
genericAlt m x =
map (linearComb m)
(tail (scanl (flip (:)) [] x))
propGeneric :: (Module.C a v, Eq v) =>
Sig.T a -> Sig.T v -> Bool
propGeneric m x =
and $ zipWith (==) (generic m x) (genericAlt m x)
gaussian :: (Trans.C a, RealField.C a, Module.C a v) => a -> a -> a -> Sig.T v -> Sig.T v
gaussian eps ratio freq =
let var = ratioFreqToVariance ratio freq
area = var * sqrt (2*pi)
gau t = exp ((t/var)^2/2) / area
width = ceiling (var * sqrt (2 * log eps))
gauSmp = map (gau . fromIntegral) [width .. width]
in drop width . generic gauSmp
binomial :: (Trans.C a, RealField.C a, Module.C a v) => a -> a -> Sig.T v -> Sig.T v
binomial ratio freq =
let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2)
in drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1)
ratioFreqToVariance :: (Trans.C a) => a -> a -> a
ratioFreqToVariance ratio freq =
sqrt (2 * log ratio) / (2*pi*freq)
binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v
binomial1 xt@(x:xs) = x : (xs + xt)
binomial1 [] = []
sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v
sums n = map (sum . take n) . init . tails
sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v
sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs
sumsDownsample2 xs = xs
downsample2 :: Sig.T a -> Sig.T a
downsample2 (x0:_:xs) = x0 : downsample2 xs
downsample2 xs = xs
sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v
sumsUpsampleOdd n xs ss =
let xs2k = drop n xs
in (head ss + head xs2k) :
concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k])
(tail ss)
(downsample2 (tail xs))
(tail (downsample2 xs2k)))
sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v
sumsUpsampleEven n xs ss =
sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs)))
sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v
sumsPyramid =
let aux 1 ys = ys
aux 2 ys = ys + tail ys
aux m ys =
let ysd = sumsDownsample2 ys
in if even m
then sumsUpsampleEven (m2) ys (aux (div (m2) 2) ysd)
else sumsUpsampleOdd (m1) ys (aux (div (m1) 2) ysd)
in aux
differentiate :: Additive.C v => Sig.T v -> Sig.T v
differentiate x = zipWith subtract x (tail x)
differentiateCenter :: Field.C v => Sig.T v -> Sig.T v
differentiateCenter x =
map ((1/2)*) $
zipWith subtract x (tail (tail x))
differentiate2 :: Additive.C v => Sig.T v -> Sig.T v
differentiate2 xs0 =
let xs1 = tail xs0
xs2 = tail xs1
in zipWith3 (\x0 x1 x2 -> x0+x2(x1+x1)) xs0 xs1 xs2