{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
module Synthesizer.Storable.Filter.NonRecursive (
delay,
delayPad,
delayPos,
delayNeg,
downsample2,
sumsDownsample2,
convolveDownsample2,
inverseFrequencyModulationFloor,
sumsPosModulatedPyramid,
accumulatePosModulatedPyramid,
accumulateBinPosModulatedPyramid,
movingAverageModulatedPyramid,
movingAccumulateModulatedPyramid,
sumsDownsample2Alt,
pyramid,
) where
import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector as V
import qualified Data.StorableVector.Pointer as VPtr
import qualified Data.StorableVector.Lazy as VL
import qualified Data.StorableVector.Lazy.Pattern as VP
import qualified Synthesizer.Basic.Filter.NonRecursive as Filt
import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG
import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.State.Signal as SigS
import qualified Synthesizer.Plain.Signal as Sig
import qualified Algebra.Module as Module
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import Foreign.Storable (Storable, )
import Foreign.Storable.Tuple ()
import Control.Monad (mplus, )
import qualified Data.List as List
import Data.Tuple.HT (mapFst, mapSnd, mapPair, swap, )
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (fromMaybe, )
import qualified Numeric.NonNegative.Chunky as NonNegChunky
import NumericPrelude.Numeric
import NumericPrelude.Base as NP
{-# INLINE delay #-}
delay :: (Additive.C y, Storable y) => Int -> SigSt.T y -> SigSt.T y
delay = delayPad zero
{-# INLINE delayPad #-}
delayPad :: (Storable y) => y -> Int -> SigSt.T y -> SigSt.T y
delayPad z n =
if n<0
then delayNeg (Additive.negate n)
else delayPosPad z n
{-# INLINE delayPos #-}
delayPos :: (Additive.C y, Storable y) => Int -> SigSt.T y -> SigSt.T y
delayPos = delayPosPad zero
{-# INLINE delayPosPad #-}
delayPosPad :: (Storable v) => v -> Int -> SigSt.T v -> SigSt.T v
delayPosPad z n = SigSt.append (SigSt.replicate SigSt.defaultChunkSize n z)
{-# INLINE delayNeg #-}
delayNeg :: (Storable y) => Int -> SigSt.T y -> SigSt.T y
delayNeg = SigSt.drop
accumulateDownsample2Strict ::
(Storable v) =>
(v -> v -> v) ->
Maybe v -> V.Vector v -> (Maybe v, V.Vector v)
accumulateDownsample2Strict acc carry ys =
mapFst (\v -> fmap fst $ V.viewL . snd =<< v) $ swap $
V.unfoldrN (div (V.length ys + maybe 0 (const 1) carry) 2) (\(carry0,xs0) ->
do (x0,xs1) <- mplus (fmap (\c -> (c, xs0)) carry0) (V.viewL xs0)
(x1,xs2) <- V.viewL xs1
return (acc x0 x1, (Nothing, xs2)))
(carry, ys)
accumulateDownsample2 ::
(Storable v) =>
(v -> v -> v) ->
SigSt.T v -> SigSt.T v
accumulateDownsample2 acc =
SigSt.fromChunks .
filter (not . V.null) .
(\(carry, chunks) ->
chunks ++ maybe [] (\cr -> [V.singleton cr]) carry) .
List.mapAccumL (accumulateDownsample2Strict acc) Nothing .
SigSt.chunks
sumsDownsample2 ::
(Additive.C v, Storable v) =>
SigSt.T v -> SigSt.T v
sumsDownsample2 =
accumulateDownsample2 (+)
sumsDownsample2Alt ::
(Additive.C v, Storable v) =>
SigSt.T v -> SigSt.T v
sumsDownsample2Alt ys =
fst .
VP.unfoldrN (halfLazySize $ VP.length ys) (\xs ->
flip fmap (SigS.viewL xs) $ \xxs0@(x0,xs0) ->
SigS.switchL xxs0
(\ x1 xs1 -> (x0+x1, xs1))
xs0)
. SigS.fromStorableSignal $ ys
convolveDownsample2 ::
(Module.C a v, Storable a, Storable v) =>
SigSt.T a -> SigSt.T v -> SigSt.T v
convolveDownsample2 ms ys =
let mac =
SigS.sum . SigS.zipWith (*>)
(SigS.fromStorableSignal ms)
in fst .
VP.unfoldrN (halfLazySize $ VP.length ys) (\xs ->
toMaybe (not $ SigSt.null xs)
(mac (SigS.fromStorableSignal xs),
SigSt.drop 2 xs))
$ ys
halfLazySize :: NonNegChunky.T VP.ChunkSize -> NonNegChunky.T VP.ChunkSize
halfLazySize =
NonNegChunky.fromChunks .
filter (VL.ChunkSize zero /=) .
(\(c,ls) -> ls ++ [VL.ChunkSize c]) .
List.mapAccumL (\c (VL.ChunkSize l) ->
mapSnd VL.ChunkSize $ swap $ divMod (c+l) 2) zero .
NonNegChunky.toChunks
downsample2Strict ::
(Storable v) =>
Int -> V.Vector v -> V.Vector v
downsample2Strict offset ys =
fst $
V.unfoldrN (- div (offset - V.length ys) 2)
(fmap (mapSnd laxTailStrict) . V.viewL) $
if offset == 0
then ys
else laxTailStrict ys
laxTailStrict ::
(Storable v) =>
V.Vector v -> V.Vector v
laxTailStrict ys =
V.switchL ys (flip const) ys
downsample2 ::
(Storable v) =>
SigSt.T v -> SigSt.T v
downsample2 =
SigSt.fromChunks .
filter (not . V.null) .
snd .
List.mapAccumL
(\k c ->
(mod (k + V.length c) 2, downsample2Strict k c)) zero .
SigSt.chunks
pyramid ::
(Storable v) =>
(v -> v -> v) ->
Int -> SigSt.T v -> [SigSt.T v]
pyramid acc height =
take (1+height) . iterate (accumulateDownsample2 acc)
accumulatePosModulatedPyramid ::
(Storable v) =>
([SigSt.T v] -> (Int,Int) -> v) ->
([Int], [SigSt.T v]) ->
SigSt.T (Int,Int) -> SigSt.T v
accumulatePosModulatedPyramid accumulate (sizes,pyr0) ctrl =
let blockSize = head sizes
pyrStarts = iterate (zipWith SigSt.drop sizes) pyr0
ctrlBlocks = SigS.toList $ SigG.sliceVertical blockSize ctrl
in SigSt.fromChunks $
zipWith
(\pyr ->
SigS.toStrictStorableSignal blockSize .
SigS.map (accumulate pyr) .
SigS.zipWith (\d -> mapPair ((d+), (d+))) (SigS.iterate (1+) 0) .
SigS.fromStorableSignal)
pyrStarts ctrlBlocks
sumsPosModulatedPyramid ::
(Additive.C v, Storable v) =>
Int -> SigSt.T (Int,Int) -> SigSt.T v -> SigSt.T v
sumsPosModulatedPyramid height ctrl xs =
accumulatePosModulatedPyramid
FiltG.sumRangeFromPyramid
(addSizes $ pyramid (+) height xs)
ctrl
accumulateBinPosModulatedPyramid ::
(Storable v) =>
(v -> v -> v) ->
Int -> SigSt.T (Int,Int) -> SigSt.T v -> SigSt.T v
accumulateBinPosModulatedPyramid acc height ctrl xs =
accumulatePosModulatedPyramid
(\pyr ->
fromMaybe (error "accumulateBinPosModulatedPyramid: empty window") .
FiltG.maybeAccumulateRangeFromPyramid acc pyr)
(addSizes $ pyramid acc height xs)
ctrl
addSizes :: [signal] -> ([Int], [signal])
addSizes pyr = (Filt.unitSizesFromPyramid pyr, pyr)
movingAverageModulatedPyramid ::
(Field.C a, Module.C a v, Storable Int, Storable v) =>
a -> Int -> Int -> SigSt.T Int -> SigSt.T v -> SigSt.T v
movingAverageModulatedPyramid amp height maxC ctrl0 =
withPaddedInput zero
(\ctrl xs ->
SigSt.zipWith (\c x -> (amp / fromIntegral (2*c+1)) *> x) ctrl0 $
sumsPosModulatedPyramid height ctrl xs)
maxC ctrl0
movingAccumulateModulatedPyramid ::
(Storable v) =>
(v -> v -> v) ->
v -> Int -> Int -> SigSt.T Int -> SigSt.T v -> SigSt.T v
movingAccumulateModulatedPyramid acc pad height =
withPaddedInput pad $
accumulateBinPosModulatedPyramid acc height
withPaddedInput ::
(Storable y) =>
y -> (SigSt.T (Int, Int) -> SigSt.T y -> v) ->
Int -> SigSt.T Int -> SigSt.T y -> v
withPaddedInput pad proc maxC ctrl xs =
proc
(SigSt.map (\c -> (maxC - c, maxC + c + 1)) ctrl)
(delayPad pad maxC xs)
{-# INLINE inverseFrequencyModulationFloor #-}
inverseFrequencyModulationFloor ::
(Storable v, SigG.Read sig t, Ring.C t, Ord t) =>
SigSt.ChunkSize ->
sig t -> SigSt.T v -> SigSt.T v
inverseFrequencyModulationFloor chunkSize ctrl =
SigG.runViewL ctrl (\nextC cst0 ->
SigSt.concat .
Sig.crochetL
(\chunk ms -> flip fmap ms $ \ts ->
inverseFrequencyModulationChunk chunkSize
nextC ts chunk)
(Just (0,cst0)) .
SigSt.chunks)
{-# INLINE inverseFrequencyModulationChunk #-}
inverseFrequencyModulationChunk ::
(Storable v, Ring.C t, Ord t) =>
SigSt.ChunkSize ->
(s -> Maybe (t,s)) -> (t,s) -> V.Vector v -> (SigSt.T v, Maybe (t,s))
inverseFrequencyModulationChunk chunkSize nextC (phase,cst0) chunk =
let {-# INLINE switch #-}
switch l r t (cp0,xp0) =
maybe
(l Nothing)
(\(c1,cp1) ->
VPtr.switchL
(l (Just (t,cp0)))
(\x1 xp1 -> r (t+c1,x1) (cp1,xp1))
xp0)
(nextC cp0)
{-# INLINE go #-}
go (c,x) cxp =
if c<1
then switch Left go c cxp
else Right (x, ((c-1,x),cxp))
in switch ((,) SigSt.empty)
(curry $ VL.unfoldrResult chunkSize (uncurry go))
phase (cst0, VPtr.cons chunk)