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 Synthesizer.State.Filter.NonRecursive as FiltS
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 Control.Monad (mplus, )
import Data.Function.HT (nest, )
import Data.Tuple.HT (mapSnd, mapPair, )
import Data.Maybe.HT (toMaybe, )
import NumericPrelude.Base
import NumericPrelude.Numeric 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)
binomialMask ::
(Field.C a, SigG.Write sig a) =>
SigG.LazySize ->
Int -> sig a
binomialMask size n =
SigG.unfoldR size
(\(x, a, b) ->
toMaybe (b>=0)
(x, (x * fromInteger b / fromInteger (a+1), a+1, b1)))
(recip $ 2 ^ fromIntegral n, 0, fromIntegral n)
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)
downsample ::
(SigG.Write sig v) =>
SigG.LazySize -> Int -> sig v -> sig v
downsample cs n =
SigG.unfoldR cs
(\xs -> fmap (mapSnd (const (SigG.drop n xs))) $ SigG.viewL xs)
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.Transform sig v) =>
[sig v] -> (Int,Int) -> v
sumRangeFromPyramid =
Filt.sumRangePrepare $ \lr0 pyr0 ->
consumeRangeFromPyramid (\v k s -> k (s+v)) id pyr0 lr0 zero
sumRangeFromPyramidReverse ::
(Additive.C v, SigG.Transform sig v) =>
[sig v] -> (Int,Int) -> v
sumRangeFromPyramidReverse =
Filt.sumRangePrepare $ \lr0 pyr0 ->
consumeRangeFromPyramid (+) zero pyr0 lr0
sumRangeFromPyramidFoldr ::
(Additive.C v, SigG.Transform sig v) =>
[sig v] -> (Int,Int) -> v
sumRangeFromPyramidFoldr =
Filt.sumRangePrepare $ \lr0 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 lr0 ps0 zero
maybeAccumulateRangeFromPyramid ::
(SigG.Transform sig v) =>
(v -> v -> v) ->
[sig v] -> (Int,Int) -> Maybe v
maybeAccumulateRangeFromPyramid acc =
Filt.symmetricRangePrepare $ \lr0 pyr0 ->
consumeRangeFromPyramid
(\v k s -> k (fmap (acc v) s `mplus` Just v))
id pyr0 lr0 Nothing
consumeRangeFromPyramid ::
(SigG.Transform sig v) =>
(v -> a -> a) -> a ->
[sig v] -> (Int,Int) -> a
consumeRangeFromPyramid acc init0 pyr0 lr0 =
case pyr0 of
[] -> error "empty pyramid"
(ps0:pss) ->
foldr
(\psNext k (l,r) ps ->
case rl of
0 -> init0
1 -> acc (SigG.index ps l) init0
_ ->
let (lh,ll) = NP.negate $ divMod (NP.negate l) 2
(rh,rl) = divMod r 2
inc b x = if b==0 then id else acc x
in inc ll (SigG.index ps l) $
inc rl (SigG.index ps (r1)) $
k (lh,rh) psNext)
(\(l,r) ps ->
SigG.foldR acc init0 $
SigG.take (rl) $ SigG.drop l ps)
pss lr0 ps0
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
accumulatePosModulatedFromPyramid ::
(SigG.Transform sig (Int,Int), SigG.Write sig v) =>
([sig v] -> (Int,Int) -> v) ->
([Int], [sig v]) ->
sig (Int,Int) -> sig v
accumulatePosModulatedFromPyramid accumulate (sizes,pyr0) ctrl =
let 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 (accumulate pyr) .
SigS.zipWith (\d -> mapPair ((d+), (d+))) (SigS.iterate (1+) 0) .
SigG.toState)
pyrStarts ctrlBlocks
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 =
accumulatePosModulatedFromPyramid
sumRangeFromPyramid
(pyramid height xs) ctrl
withPaddedInput ::
(SigG2.Transform sig Int (Int, Int),
SigG.Write sig y) =>
y -> (sig (Int, Int) -> sig y -> v) ->
Int ->
sig Int ->
sig y -> v
withPaddedInput pad proc maxC ctrl xs =
proc
(SigG2.map (\c -> (maxC c, maxC + c + 1)) ctrl)
(delayPad pad maxC xs)
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 ctrl0 =
withPaddedInput zero
(\ctrl xs ->
SigG.zipWith (\c x -> (amp / fromIntegral (2*c+1)) *> x) ctrl0 $
sumsPosModulatedPyramid height ctrl xs)
maxC ctrl0
inverseFrequencyModulationFloor ::
(Ord t, Ring.C t,
SigG.Write sig v, SigG.Read sig t) =>
SigG.LazySize ->
sig t -> sig v -> sig v
inverseFrequencyModulationFloor chunkSize ctrl xs =
SigG.fromState chunkSize
(FiltS.inverseFrequencyModulationFloor
(SigG.toState ctrl) (SigG.toState 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