module Synthesizer.Generic.Filter.NonRecursive where
import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.Generic.Signal2 as SigG2
import qualified Synthesizer.Generic.Control as Ctrl
import qualified Synthesizer.State.Signal as SigS
import qualified Synthesizer.Plain.Filter.NonRecursive as Filt
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( (*>), )
import Data.Function.HT (nest, )
import Data.Tuple.HT (mapSnd, mapPair, )
import PreludeBase
import NumericPrelude as NP
negate ::
(Additive.C a, SigG.Transform sig a) =>
sig a -> sig a
negate = SigG.map Additive.negate
amplify ::
(Ring.C a, SigG.Transform sig a) =>
a -> sig a -> sig a
amplify v = SigG.map (v*)
amplifyVector ::
(Module.C a v, SigG.Transform sig v) =>
a -> sig v -> sig v
amplifyVector v = SigG.map (v*>)
envelope ::
(Ring.C a, SigG.Transform sig a) =>
sig a
-> sig a
-> sig a
envelope = SigG.zipWith (*)
envelopeVector ::
(Module.C a v, SigG.Read sig a, SigG.Transform sig v) =>
sig a
-> sig v
-> sig v
envelopeVector = SigG.zipWith (*>)
fadeInOut ::
(Field.C a, SigG.Write sig a) =>
Int -> Int -> Int -> sig a -> sig a
fadeInOut tIn tHold tOut xs =
let slopeIn = recip (fromIntegral tIn)
slopeOut = Additive.negate (recip (fromIntegral tOut))
leadIn = SigG.take tIn $ Ctrl.linear SigG.defaultLazySize slopeIn 0
leadOut = SigG.take tOut $ Ctrl.linear SigG.defaultLazySize slopeOut 1
(partIn, partHoldOut) = SigG.splitAt tIn xs
(partHold, partOut) = SigG.splitAt tHold partHoldOut
in envelope leadIn partIn `SigG.append`
partHold `SigG.append`
envelope leadOut partOut
delay :: (Additive.C y, SigG.Write sig y) =>
Int -> sig y -> sig y
delay =
delayPad zero
delayPad :: (SigG.Write sig y) =>
y -> Int -> sig y -> sig y
delayPad z n =
if n<0
then SigG.drop (Additive.negate n)
else SigG.append (SigG.replicate SigG.defaultLazySize n z)
delayPos :: (Additive.C y, SigG.Write sig y) =>
Int -> sig y -> sig y
delayPos n =
SigG.append (SigG.replicate SigG.defaultLazySize n zero)
delayNeg :: (SigG.Transform sig y) =>
Int -> sig y -> sig y
delayNeg = SigG.drop
delayLazySize :: (Additive.C y, SigG.Write sig y) =>
SigG.LazySize -> Int -> sig y -> sig y
delayLazySize size =
delayPadLazySize size zero
delayPadLazySize :: (SigG.Write sig y) =>
SigG.LazySize -> y -> Int -> sig y -> sig y
delayPadLazySize size z n =
if n<0
then SigG.drop (Additive.negate n)
else SigG.append (SigG.replicate size n z)
delayPosLazySize :: (Additive.C y, SigG.Write sig y) =>
SigG.LazySize -> Int -> sig y -> sig y
delayPosLazySize size n =
SigG.append (SigG.replicate size n zero)
generic ::
(Module.C a v, SigG.Transform sig a, SigG.Write sig v) =>
sig a -> sig v -> sig v
generic m x =
let mr = SigG.reverse m
xp = delayPos (pred (SigG.length m)) x
in SigG.mapTails (SigG.linearComb mr) xp
binomial ::
(Trans.C a, RealField.C a, Module.C a v, SigG.Transform sig v) =>
a -> a -> sig v -> sig v
binomial ratio freq =
let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2)
in SigG.drop width .
nest (2*width) (amplifyVector (asTypeOf 0.5 freq) . binomial1)
ratioFreqToVariance :: (Trans.C a) => a -> a -> a
ratioFreqToVariance ratio freq =
sqrt (Additive.negate (2 * log ratio)) / (2*pi*freq)
binomial1 ::
(Additive.C v, SigG.Transform sig v) => sig v -> sig v
binomial1 = SigG.mapAdjacent (+)
sums ::
(Additive.C v, SigG.Transform sig v) =>
Int -> sig v -> sig v
sums n = SigG.mapTails (SigG.sum . SigG.take n)
sumsDownsample2 ::
(Additive.C v, SigG.Write sig v) =>
SigG.LazySize -> sig v -> sig v
sumsDownsample2 cs =
SigG.unfoldR cs (\xs ->
flip fmap (SigG.viewL xs) $ \xxs0@(x0,xs0) ->
SigG.switchL xxs0
(\ x1 xs1 -> (x0+x1, xs1))
xs0)
downsample2 ::
(SigG.Write sig v) =>
SigG.LazySize -> sig v -> sig v
downsample2 cs =
SigG.unfoldR cs
(fmap (mapSnd SigG.laxTail) . SigG.viewL)
sumRange ::
(Additive.C v, SigG.Transform sig v) =>
sig v -> (Int,Int) -> v
sumRange =
Filt.sumRangePrepare $ \ (l,r) ->
SigG.sum . SigG.take (rl) . SigG.drop l
pyramid ::
(Additive.C v, SigG.Write sig v) =>
Int -> sig v -> ([Int], [sig v])
pyramid height sig =
let sizes =
reverse $ take (1+height) $ iterate (2*) 1
in (sizes,
scanl (flip sumsDownsample2) sig (map SigG.LazySize $ tail sizes))
sumRangeFromPyramid ::
(Additive.C v, SigG.Write sig v) =>
[sig v] -> (Int,Int) -> v
sumRangeFromPyramid =
Filt.sumRangePrepare $ \(l0,r0) pyr0 ->
case pyr0 of
[] -> error "empty pyramid"
(ps0:pss) ->
foldr
(\psNext k (l,r) ps s ->
case rl of
0 -> s
1 -> s + SigG.index ps l
_ ->
let (lh,ll) = NP.negate $ divMod (NP.negate l) 2
(rh,rl) = divMod r 2
inc b x = if b==0 then id else (x+)
in k (lh,rh) psNext $
inc ll (SigG.index ps l) $
inc rl (SigG.index ps (r1)) $
s)
(\(l,r) ps s ->
s + (SigG.sum $ SigG.take (rl) $ SigG.drop l ps))
pss (l0,r0) ps0 zero
sumsPosModulated ::
(Additive.C v, SigG2.Transform sig (Int,Int) v) =>
sig (Int,Int) -> sig v -> sig v
sumsPosModulated ctrl xs =
SigG2.zipWithTails (flip sumRange) ctrl xs
sumsPosModulatedPyramid ::
(Additive.C v, SigG.Transform sig (Int,Int), SigG.Write sig v) =>
Int -> sig (Int,Int) -> sig v -> sig v
sumsPosModulatedPyramid height ctrl xs =
let (sizes,pyr0) = pyramid height xs
blockSize = head sizes
pyrStarts =
iterate (zipWith SigG.drop sizes) pyr0
ctrlBlocks =
SigS.toList $
SigG.sliceVertical blockSize ctrl
in SigG.concat $
zipWith
(\pyr ->
SigG.fromState (SigG.LazySize blockSize) .
SigS.map (sumRangeFromPyramid pyr) .
SigS.zipWith (\d -> mapPair ((d+), (d+))) (SigS.iterate (1+) 0) .
SigG.toState)
pyrStarts ctrlBlocks
movingAverageModulatedPyramid ::
(Field.C a, Module.C a v,
SigG2.Transform sig Int (Int,Int), SigG.Write sig v) =>
a -> Int -> Int -> sig Int -> sig v -> sig v
movingAverageModulatedPyramid amp height maxC ctrl xs =
SigG.zipWith (\c x -> (amp / fromIntegral (2*c+1)) *> x) ctrl $
sumsPosModulatedPyramid height
(SigG2.map (\c -> (maxC c, maxC + c)) ctrl)
(delay maxC xs)
differentiate ::
(Additive.C v, SigG.Transform sig v) =>
sig v -> sig v
differentiate x = SigG.mapAdjacent subtract x
differentiateCenter ::
(Field.C v, SigG.Transform sig v) =>
sig v -> sig v
differentiateCenter =
SigG.drop 2 .
SigG.crochetL
(\x0 (x1,x2) -> Just ((x2x0)/2, (x0,x1)))
(zero,zero)
differentiate2 ::
(Additive.C v, SigG.Transform sig v) =>
sig v -> sig v
differentiate2 = differentiate . differentiate