{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{- |
Copyright   :  (c) Henning Thielemann 2008-2009
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes
-}
module Synthesizer.Storable.Filter.NonRecursive (
   delay,
   delayPad,
   delayPos,
   delayNeg,

   downsample2,
   sumsDownsample2,
   convolveDownsample2,
   inverseFrequencyModulationFloor,
   sumsPosModulatedPyramid,
   accumulatePosModulatedPyramid,
   accumulateBinPosModulatedPyramid,
   movingAverageModulatedPyramid,
   movingAccumulateModulatedPyramid,

   -- for testing
   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 :: forall y. (C y, Storable y) => Int -> T y -> T y
delay = y -> Int -> T y -> T y
forall y. Storable y => y -> Int -> T y -> T y
delayPad y
forall a. C a => a
zero

{-# INLINE delayPad #-}
delayPad :: (Storable y) => y -> Int -> SigSt.T y -> SigSt.T y
delayPad :: forall y. Storable y => y -> Int -> T y -> T y
delayPad y
z Int
n =
   if Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
0
     then Int -> T y -> T y
forall y. Storable y => Int -> T y -> T y
delayNeg (Int -> Int
forall a. C a => a -> a
Additive.negate Int
n)
     else y -> Int -> T y -> T y
forall y. Storable y => y -> Int -> T y -> T y
delayPosPad y
z Int
n

{-# INLINE delayPos #-}
delayPos :: (Additive.C y, Storable y) => Int -> SigSt.T y -> SigSt.T y
delayPos :: forall y. (C y, Storable y) => Int -> T y -> T y
delayPos = y -> Int -> T y -> T y
forall y. Storable y => y -> Int -> T y -> T y
delayPosPad y
forall a. C a => a
zero

{-# INLINE delayPosPad #-}
delayPosPad :: (Storable v) => v -> Int -> SigSt.T v -> SigSt.T v
delayPosPad :: forall y. Storable y => y -> Int -> T y -> T y
delayPosPad v
z Int
n = Vector v -> Vector v -> Vector v
forall a. Storable a => Vector a -> Vector a -> Vector a
SigSt.append (ChunkSize -> Int -> v -> Vector v
forall a. Storable a => ChunkSize -> Int -> a -> Vector a
SigSt.replicate ChunkSize
SigSt.defaultChunkSize Int
n v
z)

{-# INLINE delayNeg #-}
delayNeg :: (Storable y) => Int -> SigSt.T y -> SigSt.T y
delayNeg :: forall y. Storable y => Int -> T y -> T y
delayNeg = Int -> Vector y -> Vector y
forall y. Storable y => Int -> T y -> T y
SigSt.drop


{- |
The Maybe type carries an unpaired value from one block to the next one.
-}
accumulateDownsample2Strict ::
   (Storable v) =>
   (v -> v -> v) ->
   Maybe v -> V.Vector v -> (Maybe v, V.Vector v)
accumulateDownsample2Strict :: forall v.
Storable v =>
(v -> v -> v) -> Maybe v -> Vector v -> (Maybe v, Vector v)
accumulateDownsample2Strict v -> v -> v
acc Maybe v
carry Vector v
ys =
   (Maybe (Maybe v, Vector v) -> Maybe v)
-> (Maybe (Maybe v, Vector v), Vector v) -> (Maybe v, Vector v)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (\Maybe (Maybe v, Vector v)
v -> ((v, Vector v) -> v) -> Maybe (v, Vector v) -> Maybe v
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v, Vector v) -> v
forall a b. (a, b) -> a
fst (Maybe (v, Vector v) -> Maybe v) -> Maybe (v, Vector v) -> Maybe v
forall a b. (a -> b) -> a -> b
$ Vector v -> Maybe (v, Vector v)
forall a. Storable a => Vector a -> Maybe (a, Vector a)
V.viewL (Vector v -> Maybe (v, Vector v))
-> ((Maybe v, Vector v) -> Vector v)
-> (Maybe v, Vector v)
-> Maybe (v, Vector v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe v, Vector v) -> Vector v
forall a b. (a, b) -> b
snd ((Maybe v, Vector v) -> Maybe (v, Vector v))
-> Maybe (Maybe v, Vector v) -> Maybe (v, Vector v)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Maybe v, Vector v)
v) ((Maybe (Maybe v, Vector v), Vector v) -> (Maybe v, Vector v))
-> (Maybe (Maybe v, Vector v), Vector v) -> (Maybe v, Vector v)
forall a b. (a -> b) -> a -> b
$ (Vector v, Maybe (Maybe v, Vector v))
-> (Maybe (Maybe v, Vector v), Vector v)
forall a b. (a, b) -> (b, a)
swap ((Vector v, Maybe (Maybe v, Vector v))
 -> (Maybe (Maybe v, Vector v), Vector v))
-> (Vector v, Maybe (Maybe v, Vector v))
-> (Maybe (Maybe v, Vector v), Vector v)
forall a b. (a -> b) -> a -> b
$
   Int
-> ((Maybe v, Vector v) -> Maybe (v, (Maybe v, Vector v)))
-> (Maybe v, Vector v)
-> (Vector v, Maybe (Maybe v, Vector v))
forall b a.
Storable b =>
Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)
V.unfoldrN (Int -> Int -> Int
forall a. C a => a -> a -> a
div (Vector v -> Int
forall a. Vector a -> Int
V.length Vector v
ys Int -> Int -> Int
forall a. C a => a -> a -> a
+ Int -> (v -> Int) -> Maybe v -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> v -> Int
forall a b. a -> b -> a
const Int
1) Maybe v
carry) Int
2) (\(Maybe v
carry0,Vector v
xs0) ->
      do (v
x0,Vector v
xs1) <- Maybe (v, Vector v) -> Maybe (v, Vector v) -> Maybe (v, Vector v)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus ((v -> (v, Vector v)) -> Maybe v -> Maybe (v, Vector v)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\v
c -> (v
c, Vector v
xs0)) Maybe v
carry0) (Vector v -> Maybe (v, Vector v)
forall a. Storable a => Vector a -> Maybe (a, Vector a)
V.viewL Vector v
xs0)
         (v
x1,Vector v
xs2) <- Vector v -> Maybe (v, Vector v)
forall a. Storable a => Vector a -> Maybe (a, Vector a)
V.viewL Vector v
xs1
         (v, (Maybe v, Vector v)) -> Maybe (v, (Maybe v, Vector v))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (v -> v -> v
acc v
x0 v
x1, (Maybe v
forall a. Maybe a
Nothing, Vector v
xs2)))
      (Maybe v
carry, Vector v
ys)

accumulateDownsample2 ::
   (Storable v) =>
   (v -> v -> v) ->
   SigSt.T v -> SigSt.T v
accumulateDownsample2 :: forall v. Storable v => (v -> v -> v) -> T v -> T v
accumulateDownsample2 v -> v -> v
acc =
   [Vector v] -> Vector v
forall a. Storable a => [Vector a] -> Vector a
SigSt.fromChunks ([Vector v] -> Vector v)
-> (Vector v -> [Vector v]) -> Vector v -> Vector v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (Vector v -> Bool) -> [Vector v] -> [Vector v]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Vector v -> Bool) -> Vector v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector v -> Bool
forall a. Vector a -> Bool
V.null) ([Vector v] -> [Vector v])
-> (Vector v -> [Vector v]) -> Vector v -> [Vector v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (\(Maybe v
carry, [Vector v]
chunks) ->
      [Vector v]
chunks [Vector v] -> [Vector v] -> [Vector v]
forall a. [a] -> [a] -> [a]
++ [Vector v] -> (v -> [Vector v]) -> Maybe v -> [Vector v]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\v
cr -> [v -> Vector v
forall a. Storable a => a -> Vector a
V.singleton v
cr]) Maybe v
carry) ((Maybe v, [Vector v]) -> [Vector v])
-> (Vector v -> (Maybe v, [Vector v])) -> Vector v -> [Vector v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (Maybe v -> Vector v -> (Maybe v, Vector v))
-> Maybe v -> [Vector v] -> (Maybe v, [Vector v])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL ((v -> v -> v) -> Maybe v -> Vector v -> (Maybe v, Vector v)
forall v.
Storable v =>
(v -> v -> v) -> Maybe v -> Vector v -> (Maybe v, Vector v)
accumulateDownsample2Strict v -> v -> v
acc) Maybe v
forall a. Maybe a
Nothing ([Vector v] -> (Maybe v, [Vector v]))
-> (Vector v -> [Vector v]) -> Vector v -> (Maybe v, [Vector v])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   Vector v -> [Vector v]
forall a. Vector a -> [Vector a]
SigSt.chunks

sumsDownsample2 ::
   (Additive.C v, Storable v) =>
   SigSt.T v -> SigSt.T v
sumsDownsample2 :: forall v. (C v, Storable v) => T v -> T v
sumsDownsample2 =
   (v -> v -> v) -> T v -> T v
forall v. Storable v => (v -> v -> v) -> T v -> T v
accumulateDownsample2 v -> v -> v
forall a. C a => a -> a -> a
(+)

sumsDownsample2Alt ::
   (Additive.C v, Storable v) =>
   SigSt.T v -> SigSt.T v
sumsDownsample2Alt :: forall v. (C v, Storable v) => T v -> T v
sumsDownsample2Alt T v
ys =
   (T v, Maybe (T v)) -> T v
forall a b. (a, b) -> a
fst ((T v, Maybe (T v)) -> T v)
-> (T v -> (T v, Maybe (T v))) -> T v -> T v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   LazySize -> (T v -> Maybe (v, T v)) -> T v -> (T v, Maybe (T v))
forall b a.
Storable b =>
LazySize -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)
VP.unfoldrN (LazySize -> LazySize
halfLazySize (LazySize -> LazySize) -> LazySize -> LazySize
forall a b. (a -> b) -> a -> b
$ T v -> LazySize
forall a. Vector a -> LazySize
VP.length T v
ys) (\T v
xs ->
      (((v, T v) -> (v, T v)) -> Maybe (v, T v) -> Maybe (v, T v))
-> Maybe (v, T v) -> ((v, T v) -> (v, T v)) -> Maybe (v, T v)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((v, T v) -> (v, T v)) -> Maybe (v, T v) -> Maybe (v, T v)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (T v -> Maybe (v, T v)
forall a. T a -> Maybe (a, T a)
SigS.viewL T v
xs) (((v, T v) -> (v, T v)) -> Maybe (v, T v))
-> ((v, T v) -> (v, T v)) -> Maybe (v, T v)
forall a b. (a -> b) -> a -> b
$ \xxs0 :: (v, T v)
xxs0@(v
x0,T v
xs0) ->
         (v, T v) -> (v -> T v -> (v, T v)) -> T v -> (v, T v)
forall b a. b -> (a -> T a -> b) -> T a -> b
SigS.switchL (v, T v)
xxs0 {- xs0 is empty -}
            (\ v
x1 T v
xs1 -> (v
x0v -> v -> v
forall a. C a => a -> a -> a
+v
x1, T v
xs1))
            T v
xs0)
    (T v -> (T v, Maybe (T v)))
-> (T v -> T v) -> T v -> (T v, Maybe (T v))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T v -> T v
forall a. Storable a => T a -> T a
SigS.fromStorableSignal (T v -> T v) -> T v -> T v
forall a b. (a -> b) -> a -> b
$ T v
ys

{-
! - downsample

x ! 2
(y*x)    ! 2 = y    ! 2 * x ! 2  +  y->1 ! 2 * x<-1 ! 2
(y*x<-1) ! 2 = y<-1 ! 2 * x ! 2  +  y    ! 2 * x<-1 ! 2

(y^n*x) ! 2 can be implemented by matrix power and multiplication
where multiplication is convolution.
-}

convolveDownsample2 ::
   (Module.C a v, Storable a, Storable v) =>
   SigSt.T a -> SigSt.T v -> SigSt.T v
convolveDownsample2 :: forall a v. (C a v, Storable a, Storable v) => T a -> T v -> T v
convolveDownsample2 T a
ms T v
ys =
   let mac :: T v -> v
mac =
          T v -> v
forall a. C a => T a -> a
SigS.sum (T v -> v) -> (T v -> T v) -> T v -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> v -> v) -> T a -> T v -> T v
forall a b c. (a -> b -> c) -> T a -> T b -> T c
SigS.zipWith a -> v -> v
forall a v. C a v => a -> v -> v
(*>)
             (T a -> T a
forall a. Storable a => T a -> T a
SigS.fromStorableSignal T a
ms)
   in  (T v, Maybe (T v)) -> T v
forall a b. (a, b) -> a
fst ((T v, Maybe (T v)) -> T v)
-> (T v -> (T v, Maybe (T v))) -> T v -> T v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
       LazySize -> (T v -> Maybe (v, T v)) -> T v -> (T v, Maybe (T v))
forall b a.
Storable b =>
LazySize -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)
VP.unfoldrN (LazySize -> LazySize
halfLazySize (LazySize -> LazySize) -> LazySize -> LazySize
forall a b. (a -> b) -> a -> b
$ T v -> LazySize
forall a. Vector a -> LazySize
VP.length T v
ys) (\T v
xs ->
          Bool -> (v, T v) -> Maybe (v, T v)
forall a. Bool -> a -> Maybe a
toMaybe (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ T v -> Bool
forall a. Storable a => Vector a -> Bool
SigSt.null T v
xs)
             (T v -> v
mac (T v -> T v
forall a. Storable a => T a -> T a
SigS.fromStorableSignal T v
xs),
              Int -> T v -> T v
forall y. Storable y => Int -> T y -> T y
SigSt.drop Int
2 T v
xs))
        (T v -> T v) -> T v -> T v
forall a b. (a -> b) -> a -> b
$ T v
ys


halfLazySize :: NonNegChunky.T VP.ChunkSize -> NonNegChunky.T VP.ChunkSize
halfLazySize :: LazySize -> LazySize
halfLazySize =
   [ChunkSize] -> LazySize
forall a. C a => [a] -> T a
NonNegChunky.fromChunks ([ChunkSize] -> LazySize)
-> (LazySize -> [ChunkSize]) -> LazySize -> LazySize
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (ChunkSize -> Bool) -> [ChunkSize] -> [ChunkSize]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> ChunkSize
VL.ChunkSize Int
forall a. C a => a
zero ChunkSize -> ChunkSize -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([ChunkSize] -> [ChunkSize])
-> (LazySize -> [ChunkSize]) -> LazySize -> [ChunkSize]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (\(Int
c,[ChunkSize]
ls) -> [ChunkSize]
ls [ChunkSize] -> [ChunkSize] -> [ChunkSize]
forall a. [a] -> [a] -> [a]
++ [Int -> ChunkSize
VL.ChunkSize Int
c]) ((Int, [ChunkSize]) -> [ChunkSize])
-> (LazySize -> (Int, [ChunkSize])) -> LazySize -> [ChunkSize]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (Int -> ChunkSize -> (Int, ChunkSize))
-> Int -> [ChunkSize] -> (Int, [ChunkSize])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL (\Int
c (VL.ChunkSize Int
l) ->
      (Int -> ChunkSize) -> (Int, Int) -> (Int, ChunkSize)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd Int -> ChunkSize
VL.ChunkSize ((Int, Int) -> (Int, ChunkSize)) -> (Int, Int) -> (Int, ChunkSize)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Int, Int)
forall a b. (a, b) -> (b, a)
swap ((Int, Int) -> (Int, Int)) -> (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> (Int, Int)
forall a. C a => a -> a -> (a, a)
divMod (Int
cInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
l) Int
2) Int
forall a. C a => a
zero ([ChunkSize] -> (Int, [ChunkSize]))
-> (LazySize -> [ChunkSize]) -> LazySize -> (Int, [ChunkSize])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   LazySize -> [ChunkSize]
forall a. T a -> [a]
NonNegChunky.toChunks


{- |
offset must be zero or one.
-}
downsample2Strict ::
   (Storable v) =>
   Int -> V.Vector v -> V.Vector v
downsample2Strict :: forall v. Storable v => Int -> Vector v -> Vector v
downsample2Strict Int
offset Vector v
ys =
   (Vector v, Maybe (Vector v)) -> Vector v
forall a b. (a, b) -> a
fst ((Vector v, Maybe (Vector v)) -> Vector v)
-> (Vector v, Maybe (Vector v)) -> Vector v
forall a b. (a -> b) -> a -> b
$
   Int
-> (Vector v -> Maybe (v, Vector v))
-> Vector v
-> (Vector v, Maybe (Vector v))
forall b a.
Storable b =>
Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)
V.unfoldrN (- Int -> Int -> Int
forall a. C a => a -> a -> a
div (Int
offset Int -> Int -> Int
forall a. C a => a -> a -> a
- Vector v -> Int
forall a. Vector a -> Int
V.length Vector v
ys) Int
2)
      (((v, Vector v) -> (v, Vector v))
-> Maybe (v, Vector v) -> Maybe (v, Vector v)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Vector v -> Vector v) -> (v, Vector v) -> (v, Vector v)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd Vector v -> Vector v
forall v. Storable v => Vector v -> Vector v
laxTailStrict) (Maybe (v, Vector v) -> Maybe (v, Vector v))
-> (Vector v -> Maybe (v, Vector v))
-> Vector v
-> Maybe (v, Vector v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector v -> Maybe (v, Vector v)
forall a. Storable a => Vector a -> Maybe (a, Vector a)
V.viewL) (Vector v -> (Vector v, Maybe (Vector v)))
-> Vector v -> (Vector v, Maybe (Vector v))
forall a b. (a -> b) -> a -> b
$
   if Int
offset Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
     then Vector v
ys
     else Vector v -> Vector v
forall v. Storable v => Vector v -> Vector v
laxTailStrict Vector v
ys

laxTailStrict ::
   (Storable v) =>
   V.Vector v -> V.Vector v
laxTailStrict :: forall v. Storable v => Vector v -> Vector v
laxTailStrict Vector v
ys =
   Vector v -> (v -> Vector v -> Vector v) -> Vector v -> Vector v
forall a b.
Storable a =>
b -> (a -> Vector a -> b) -> Vector a -> b
V.switchL Vector v
ys ((Vector v -> v -> Vector v) -> v -> Vector v -> Vector v
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vector v -> v -> Vector v
forall a b. a -> b -> a
const) Vector v
ys

downsample2 ::
   (Storable v) =>
   SigSt.T v -> SigSt.T v
downsample2 :: forall v. Storable v => T v -> T v
downsample2 =
   [Vector v] -> Vector v
forall a. Storable a => [Vector a] -> Vector a
SigSt.fromChunks ([Vector v] -> Vector v)
-> (Vector v -> [Vector v]) -> Vector v -> Vector v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (Vector v -> Bool) -> [Vector v] -> [Vector v]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Vector v -> Bool) -> Vector v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector v -> Bool
forall a. Vector a -> Bool
V.null) ([Vector v] -> [Vector v])
-> (Vector v -> [Vector v]) -> Vector v -> [Vector v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (Int, [Vector v]) -> [Vector v]
forall a b. (a, b) -> b
snd ((Int, [Vector v]) -> [Vector v])
-> (Vector v -> (Int, [Vector v])) -> Vector v -> [Vector v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (Int -> Vector v -> (Int, Vector v))
-> Int -> [Vector v] -> (Int, [Vector v])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL
      (\Int
k Vector v
c ->
         (Int -> Int -> Int
forall a. C a => a -> a -> a
mod (Int
k Int -> Int -> Int
forall a. C a => a -> a -> a
+ Vector v -> Int
forall a. Vector a -> Int
V.length Vector v
c) Int
2, Int -> Vector v -> Vector v
forall v. Storable v => Int -> Vector v -> Vector v
downsample2Strict Int
k Vector v
c)) Int
forall a. C a => a
zero ([Vector v] -> (Int, [Vector v]))
-> (Vector v -> [Vector v]) -> Vector v -> (Int, [Vector v])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   Vector v -> [Vector v]
forall a. Vector a -> [Vector a]
SigSt.chunks


{-
The laziness granularity of the input signal is maintained.
-}
pyramid ::
   (Storable v) =>
   (v -> v -> v) ->
   Int -> SigSt.T v -> [SigSt.T v]
pyramid :: forall v. Storable v => (v -> v -> v) -> Int -> T v -> [T v]
pyramid v -> v -> v
acc Int
height =
   Int -> [T v] -> [T v]
forall a. Int -> [a] -> [a]
take (Int
1Int -> Int -> Int
forall a. C a => a -> a -> a
+Int
height) ([T v] -> [T v]) -> (T v -> [T v]) -> T v -> [T v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T v -> T v) -> T v -> [T v]
forall a. (a -> a) -> a -> [a]
iterate ((v -> v -> v) -> T v -> T v
forall v. Storable v => (v -> v -> v) -> T v -> T v
accumulateDownsample2 v -> v -> v
acc)



{- |
Moving average, where window bounds must be always non-negative.

The laziness granularity is @2^height@.

This function is only slightly more efficient
than its counterpart from Generic.Filter,
since it generates strict blocks
and not one-block chunky signals.
-}
accumulatePosModulatedPyramid ::
   (Storable v) =>
   ([SigSt.T v] -> (Int,Int) -> v) ->
   ([Int], [SigSt.T v]) ->
   SigSt.T (Int,Int) -> SigSt.T v
accumulatePosModulatedPyramid :: forall v.
Storable v =>
([T v] -> (Int, Int) -> v) -> ([Int], [T v]) -> T (Int, Int) -> T v
accumulatePosModulatedPyramid [T v] -> (Int, Int) -> v
accumulate ([Int]
sizes,[T v]
pyr0) T (Int, Int)
ctrl =
   let blockSize :: Int
blockSize = [Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
sizes
       pyrStarts :: [[T v]]
pyrStarts = ([T v] -> [T v]) -> [T v] -> [[T v]]
forall a. (a -> a) -> a -> [a]
iterate ((Int -> T v -> T v) -> [Int] -> [T v] -> [T v]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> T v -> T v
forall y. Storable y => Int -> T y -> T y
SigSt.drop [Int]
sizes) [T v]
pyr0
       ctrlBlocks :: [T (Int, Int)]
ctrlBlocks = T (T (Int, Int)) -> [T (Int, Int)]
forall y. T y -> [y]
SigS.toList (T (T (Int, Int)) -> [T (Int, Int)])
-> T (T (Int, Int)) -> [T (Int, Int)]
forall a b. (a -> b) -> a -> b
$ Int -> T (Int, Int) -> T (T (Int, Int))
forall sig. Transform sig => Int -> sig -> T sig
SigG.sliceVertical Int
blockSize T (Int, Int)
ctrl
   in  [Vector v] -> T v
forall a. Storable a => [Vector a] -> Vector a
SigSt.fromChunks ([Vector v] -> T v) -> [Vector v] -> T v
forall a b. (a -> b) -> a -> b
$
       ([T v] -> T (Int, Int) -> Vector v)
-> [[T v]] -> [T (Int, Int)] -> [Vector v]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
          (\[T v]
pyr ->
              Int -> T v -> Vector v
forall a. Storable a => Int -> T a -> Vector a
SigS.toStrictStorableSignal Int
blockSize (T v -> Vector v)
-> (T (Int, Int) -> T v) -> T (Int, Int) -> Vector v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              ((Int, Int) -> v) -> T (Int, Int) -> T v
forall a b. (a -> b) -> T a -> T b
SigS.map ([T v] -> (Int, Int) -> v
accumulate [T v]
pyr) (T (Int, Int) -> T v)
-> (T (Int, Int) -> T (Int, Int)) -> T (Int, Int) -> T v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              (Int -> (Int, Int) -> (Int, Int))
-> T Int -> T (Int, Int) -> T (Int, Int)
forall a b c. (a -> b -> c) -> T a -> T b -> T c
SigS.zipWith (\Int
d -> (Int -> Int, Int -> Int) -> (Int, Int) -> (Int, Int)
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair ((Int
dInt -> Int -> Int
forall a. C a => a -> a -> a
+), (Int
dInt -> Int -> Int
forall a. C a => a -> a -> a
+))) ((Int -> Int) -> Int -> T Int
forall a. (a -> a) -> a -> T a
SigS.iterate (Int
1Int -> Int -> Int
forall a. C a => a -> a -> a
+) Int
0) (T (Int, Int) -> T (Int, Int))
-> (T (Int, Int) -> T (Int, Int)) -> T (Int, Int) -> T (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              T (Int, Int) -> T (Int, Int)
forall a. Storable a => T a -> T a
SigS.fromStorableSignal)
          [[T v]]
pyrStarts [T (Int, Int)]
ctrlBlocks

sumsPosModulatedPyramid ::
   (Additive.C v, Storable v) =>
   Int -> SigSt.T (Int,Int) -> SigSt.T v -> SigSt.T v
sumsPosModulatedPyramid :: forall v. (C v, Storable v) => Int -> T (Int, Int) -> T v -> T v
sumsPosModulatedPyramid Int
height T (Int, Int)
ctrl T v
xs =
   ([T v] -> (Int, Int) -> v) -> ([Int], [T v]) -> T (Int, Int) -> T v
forall v.
Storable v =>
([T v] -> (Int, Int) -> v) -> ([Int], [T v]) -> T (Int, Int) -> T v
accumulatePosModulatedPyramid
      [T v] -> (Int, Int) -> v
forall v (sig :: * -> *).
(C v, Transform sig v) =>
[sig v] -> (Int, Int) -> v
FiltG.sumRangeFromPyramid
      ([T v] -> ([Int], [T v])
forall signal. [signal] -> ([Int], [signal])
addSizes ([T v] -> ([Int], [T v])) -> [T v] -> ([Int], [T v])
forall a b. (a -> b) -> a -> b
$ (v -> v -> v) -> Int -> T v -> [T v]
forall v. Storable v => (v -> v -> v) -> Int -> T v -> [T v]
pyramid v -> v -> v
forall a. C a => a -> a -> a
(+) Int
height T v
xs)
      T (Int, Int)
ctrl

accumulateBinPosModulatedPyramid ::
   (Storable v) =>
   (v -> v -> v) ->
   Int -> SigSt.T (Int,Int) -> SigSt.T v -> SigSt.T v
accumulateBinPosModulatedPyramid :: forall v.
Storable v =>
(v -> v -> v) -> Int -> T (Int, Int) -> T v -> T v
accumulateBinPosModulatedPyramid v -> v -> v
acc Int
height T (Int, Int)
ctrl T v
xs =
   ([T v] -> (Int, Int) -> v) -> ([Int], [T v]) -> T (Int, Int) -> T v
forall v.
Storable v =>
([T v] -> (Int, Int) -> v) -> ([Int], [T v]) -> T (Int, Int) -> T v
accumulatePosModulatedPyramid
      (\[T v]
pyr ->
         v -> Maybe v -> v
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> v
forall a. HasCallStack => [Char] -> a
error [Char]
"accumulateBinPosModulatedPyramid: empty window") (Maybe v -> v) -> ((Int, Int) -> Maybe v) -> (Int, Int) -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         (v -> v -> v) -> [T v] -> (Int, Int) -> Maybe v
forall (sig :: * -> *) v.
Transform sig v =>
(v -> v -> v) -> [sig v] -> (Int, Int) -> Maybe v
FiltG.maybeAccumulateRangeFromPyramid v -> v -> v
acc [T v]
pyr)
      ([T v] -> ([Int], [T v])
forall signal. [signal] -> ([Int], [signal])
addSizes ([T v] -> ([Int], [T v])) -> [T v] -> ([Int], [T v])
forall a b. (a -> b) -> a -> b
$ (v -> v -> v) -> Int -> T v -> [T v]
forall v. Storable v => (v -> v -> v) -> Int -> T v -> [T v]
pyramid v -> v -> v
acc Int
height T v
xs)
      T (Int, Int)
ctrl

addSizes :: [signal] -> ([Int], [signal])
addSizes :: forall signal. [signal] -> ([Int], [signal])
addSizes [signal]
pyr = ([signal] -> [Int]
forall signal. [signal] -> [Int]
Filt.unitSizesFromPyramid [signal]
pyr, [signal]
pyr)


{- |
The first argument is the amplification.
The main reason to introduce it,
was to have only a Module constraint instead of Field.
This way we can also filter stereo signals.
-}
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 :: forall a v.
(C a, C a v, Storable Int, Storable v) =>
a -> Int -> Int -> T Int -> T v -> T v
movingAverageModulatedPyramid a
amp Int
height Int
maxC T Int
ctrl0 =
   v -> (T (Int, Int) -> T v -> T v) -> Int -> T Int -> T v -> T v
forall y v.
Storable y =>
y -> (T (Int, Int) -> T y -> v) -> Int -> T Int -> T y -> v
withPaddedInput v
forall a. C a => a
zero
      (\T (Int, Int)
ctrl T v
xs ->
         (Int -> v -> v) -> T Int -> T v -> T v
forall a b c.
(Storable a, Storable b, Storable c) =>
(a -> b -> c) -> Vector a -> Vector b -> Vector c
SigSt.zipWith (\Int
c v
x -> (a
amp a -> a -> a
forall a. C a => a -> a -> a
/ Int -> a
forall a b. (C a, C b) => a -> b
fromIntegral (Int
2Int -> Int -> Int
forall a. C a => a -> a -> a
*Int
cInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
1)) a -> v -> v
forall a v. C a v => a -> v -> v
*> v
x) T Int
ctrl0 (T v -> T v) -> T v -> T v
forall a b. (a -> b) -> a -> b
$
         Int -> T (Int, Int) -> T v -> T v
forall v. (C v, Storable v) => Int -> T (Int, Int) -> T v -> T v
sumsPosModulatedPyramid Int
height T (Int, Int)
ctrl T v
xs)
      Int
maxC T Int
ctrl0


movingAccumulateModulatedPyramid ::
   (Storable v) =>
   (v -> v -> v) ->
   v -> Int -> Int -> SigSt.T Int -> SigSt.T v -> SigSt.T v
movingAccumulateModulatedPyramid :: forall v.
Storable v =>
(v -> v -> v) -> v -> Int -> Int -> T Int -> T v -> T v
movingAccumulateModulatedPyramid v -> v -> v
acc v
pad Int
height =
   v -> (T (Int, Int) -> T v -> T v) -> Int -> T Int -> T v -> T v
forall y v.
Storable y =>
y -> (T (Int, Int) -> T y -> v) -> Int -> T Int -> T y -> v
withPaddedInput v
pad ((T (Int, Int) -> T v -> T v) -> Int -> T Int -> T v -> T v)
-> (T (Int, Int) -> T v -> T v) -> Int -> T Int -> T v -> T v
forall a b. (a -> b) -> a -> b
$
   (v -> v -> v) -> Int -> T (Int, Int) -> T v -> T v
forall v.
Storable v =>
(v -> v -> v) -> Int -> T (Int, Int) -> T v -> T v
accumulateBinPosModulatedPyramid v -> v -> v
acc Int
height


withPaddedInput ::
   (Storable y) =>
   y -> (SigSt.T (Int, Int) -> SigSt.T y -> v) ->
   Int -> SigSt.T Int -> SigSt.T y -> v
withPaddedInput :: forall y v.
Storable y =>
y -> (T (Int, Int) -> T y -> v) -> Int -> T Int -> T y -> v
withPaddedInput y
pad T (Int, Int) -> T y -> v
proc Int
maxC T Int
ctrl T y
xs =
   T (Int, Int) -> T y -> v
proc
      ((Int -> (Int, Int)) -> T Int -> T (Int, Int)
forall x y.
(Storable x, Storable y) =>
(x -> y) -> Vector x -> Vector y
SigSt.map (\Int
c -> (Int
maxC Int -> Int -> Int
forall a. C a => a -> a -> a
- Int
c, Int
maxC Int -> Int -> Int
forall a. C a => a -> a -> a
+ Int
c Int -> Int -> Int
forall a. C a => a -> a -> a
+ Int
1)) T Int
ctrl)
      (y -> Int -> T y -> T y
forall y. Storable y => y -> Int -> T y -> T y
delayPad y
pad Int
maxC T y
xs)


{- |
The function is like that of
'Synthesizer.State.Filter.NonRecursive.inverseFrequencyModulationFloor',
but this function preserves in a sense the chunk structure.

The result will have laziness breaks at least
at the chunk boundaries that correspond to the breaks in the input signal.
However we insert more breaks,
such that a maximum chunk size can be warrented.
(Since control and input signal are aligned in time,
we might as well use the control chunk structure.
Currently I do not know what is better.
For the above example it doesn't matter.
We might implement a variant in Causal.Filter.NonRecursive.)

This function cannot be written using generic functions,
since we have to inspect the chunks individually.
-}
{-# 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 :: forall v (sig :: * -> *) t.
(Storable v, Read sig t, C t, Ord t) =>
ChunkSize -> sig t -> T v -> T v
inverseFrequencyModulationFloor ChunkSize
chunkSize sig t
ctrl =
   sig t
-> (forall s. (s -> Maybe (t, s)) -> s -> T v -> T v) -> T v -> T v
forall (sig :: * -> *) y x.
Read sig y =>
sig y -> (forall s. (s -> Maybe (y, s)) -> s -> x) -> x
SigG.runViewL sig t
ctrl (\s -> Maybe (t, s)
nextC s
cst0 ->
      [T v] -> T v
forall a. Storable a => [Vector a] -> Vector a
SigSt.concat ([T v] -> T v) -> (T v -> [T v]) -> T v -> T v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (Vector v -> Maybe (t, s) -> Maybe (T v, Maybe (t, s)))
-> Maybe (t, s) -> T (Vector v) -> [T v]
forall x acc y. (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y
Sig.crochetL
         (\Vector v
chunk Maybe (t, s)
ms -> (((t, s) -> (T v, Maybe (t, s)))
 -> Maybe (t, s) -> Maybe (T v, Maybe (t, s)))
-> Maybe (t, s)
-> ((t, s) -> (T v, Maybe (t, s)))
-> Maybe (T v, Maybe (t, s))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((t, s) -> (T v, Maybe (t, s)))
-> Maybe (t, s) -> Maybe (T v, Maybe (t, s))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (t, s)
ms (((t, s) -> (T v, Maybe (t, s))) -> Maybe (T v, Maybe (t, s)))
-> ((t, s) -> (T v, Maybe (t, s))) -> Maybe (T v, Maybe (t, s))
forall a b. (a -> b) -> a -> b
$ \(t, s)
ts ->
            ChunkSize
-> (s -> Maybe (t, s)) -> (t, s) -> Vector v -> (T v, Maybe (t, s))
forall v t s.
(Storable v, C t, Ord t) =>
ChunkSize
-> (s -> Maybe (t, s)) -> (t, s) -> Vector v -> (T v, Maybe (t, s))
inverseFrequencyModulationChunk ChunkSize
chunkSize
               s -> Maybe (t, s)
nextC (t, s)
ts Vector v
chunk)
         ((t, s) -> Maybe (t, s)
forall a. a -> Maybe a
Just (t
0,s
cst0)) (T (Vector v) -> [T v]) -> (T v -> T (Vector v)) -> T v -> [T v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      T v -> T (Vector v)
forall a. Vector a -> [Vector a]
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 :: forall v t s.
(Storable v, C t, Ord t) =>
ChunkSize
-> (s -> Maybe (t, s)) -> (t, s) -> Vector v -> (T v, Maybe (t, s))
inverseFrequencyModulationChunk ChunkSize
chunkSize s -> Maybe (t, s)
nextC (t
phase,s
cst0) Vector v
chunk =
   let {-# INLINE switch #-}
       {-
       switch ::
          (Maybe (t, s) -> r) ->
          ((t, v) -> (s, VPtr.Pointer v) -> r) ->
          t ->
          (s, VPtr.Pointer v) -> r
       -}
       {-
       This is a combination of two switches,
       that simulate a switch on (zip ctrl xs).
       -}
       switch :: (Maybe (t, s) -> b)
-> ((t, b) -> (s, Pointer b) -> b) -> t -> (s, Pointer b) -> b
switch Maybe (t, s) -> b
l (t, b) -> (s, Pointer b) -> b
r t
t (s
cp0,Pointer b
xp0) =
          b -> ((t, s) -> b) -> Maybe (t, s) -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
             (Maybe (t, s) -> b
l Maybe (t, s)
forall a. Maybe a
Nothing)
             (\(t
c1,s
cp1) ->
                b -> (b -> Pointer b -> b) -> Pointer b -> b
forall a b.
Storable a =>
b -> (a -> Pointer a -> b) -> Pointer a -> b
VPtr.switchL
                   (Maybe (t, s) -> b
l ((t, s) -> Maybe (t, s)
forall a. a -> Maybe a
Just (t
t,s
cp0)))
                   (\b
x1 Pointer b
xp1 -> (t, b) -> (s, Pointer b) -> b
r (t
tt -> t -> t
forall a. C a => a -> a -> a
+t
c1,b
x1) (s
cp1,Pointer b
xp1))
                   Pointer b
xp0)
             (s -> Maybe (t, s)
nextC s
cp0)

       {-# INLINE go #-}
       {-
       go ::
          (t,v) -> (s, VPtr.Pointer v) ->
          Either (Maybe (t,s)) (v, ((t,v), (s, VPtr.Pointer v)))
       -}
       go :: (t, b)
-> (s, Pointer b)
-> Either (Maybe (t, s)) (b, ((t, b), (s, Pointer b)))
go (t
c,b
x) (s, Pointer b)
cxp =
          if t
ct -> t -> Bool
forall a. Ord a => a -> a -> Bool
<t
1
            then (Maybe (t, s)
 -> Either (Maybe (t, s)) (b, ((t, b), (s, Pointer b))))
-> ((t, b)
    -> (s, Pointer b)
    -> Either (Maybe (t, s)) (b, ((t, b), (s, Pointer b))))
-> t
-> (s, Pointer b)
-> Either (Maybe (t, s)) (b, ((t, b), (s, Pointer b)))
forall {b} {b}.
Storable b =>
(Maybe (t, s) -> b)
-> ((t, b) -> (s, Pointer b) -> b) -> t -> (s, Pointer b) -> b
switch Maybe (t, s) -> Either (Maybe (t, s)) (b, ((t, b), (s, Pointer b)))
forall a b. a -> Either a b
Left (t, b)
-> (s, Pointer b)
-> Either (Maybe (t, s)) (b, ((t, b), (s, Pointer b)))
go t
c (s, Pointer b)
cxp
            else (b, ((t, b), (s, Pointer b)))
-> Either (Maybe (t, s)) (b, ((t, b), (s, Pointer b)))
forall a b. b -> Either a b
Right (b
x, ((t
ct -> t -> t
forall a. C a => a -> a -> a
-t
1,b
x),(s, Pointer b)
cxp))

   in  (Maybe (t, s) -> (T v, Maybe (t, s)))
-> ((t, v) -> (s, Pointer v) -> (T v, Maybe (t, s)))
-> t
-> (s, Pointer v)
-> (T v, Maybe (t, s))
forall {b} {b}.
Storable b =>
(Maybe (t, s) -> b)
-> ((t, b) -> (s, Pointer b) -> b) -> t -> (s, Pointer b) -> b
switch ((,) T v
forall a. Storable a => Vector a
SigSt.empty)
          ((((t, v), (s, Pointer v)) -> (T v, Maybe (t, s)))
-> (t, v) -> (s, Pointer v) -> (T v, Maybe (t, s))
forall a b c. ((a, b) -> c) -> a -> b -> c
curry ((((t, v), (s, Pointer v)) -> (T v, Maybe (t, s)))
 -> (t, v) -> (s, Pointer v) -> (T v, Maybe (t, s)))
-> (((t, v), (s, Pointer v)) -> (T v, Maybe (t, s)))
-> (t, v)
-> (s, Pointer v)
-> (T v, Maybe (t, s))
forall a b. (a -> b) -> a -> b
$ ChunkSize
-> (((t, v), (s, Pointer v))
    -> Either (Maybe (t, s)) (v, ((t, v), (s, Pointer v))))
-> ((t, v), (s, Pointer v))
-> (T v, Maybe (t, s))
forall b a c.
Storable b =>
ChunkSize -> (a -> Either c (b, a)) -> a -> (Vector b, c)
VL.unfoldrResult ChunkSize
chunkSize (((t, v)
 -> (s, Pointer v)
 -> Either (Maybe (t, s)) (v, ((t, v), (s, Pointer v))))
-> ((t, v), (s, Pointer v))
-> Either (Maybe (t, s)) (v, ((t, v), (s, Pointer v)))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (t, v)
-> (s, Pointer v)
-> Either (Maybe (t, s)) (v, ((t, v), (s, Pointer v)))
forall {b}.
Storable b =>
(t, b)
-> (s, Pointer b)
-> Either (Maybe (t, s)) (b, ((t, b), (s, Pointer b)))
go))
          t
phase (s
cst0, Vector v -> Pointer v
forall a. Storable a => Vector a -> Pointer a
VPtr.cons Vector v
chunk)