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

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes
-}
module Synthesizer.Generic.Filter.NonRecursive (
   negate,
   amplify,
   amplifyVector,
   normalize,
   envelope,
   envelopeVector,
   fadeInOut,
   delay,
   delayPad,
   delayPos,
   delayNeg,
   delayLazySize,
   delayPadLazySize,
   delayPosLazySize,
   binomialMask,
   binomial,
   binomial1,
   sums,
   sumsDownsample2,
   downsample2,
   downsample,
   sumRange,
   pyramid,
   sumRangeFromPyramid,
   sumsPosModulated,
   sumsPosModulatedPyramid,
   movingAverageModulatedPyramid,
   inverseFrequencyModulationFloor,

   differentiate,
   differentiateCenter,
   differentiate2,

   generic,
   karatsubaFinite,
   karatsubaFiniteInfinite,
   karatsubaInfinite,

   Pair,
   convolvePair,
   sumAndConvolvePair,
   Triple,
   convolvePairTriple,
   convolveTriple,
   sumAndConvolveTriple,
   sumAndConvolveTripleAlt,
   Quadruple,
   convolveQuadruple,
   sumAndConvolveQuadruple,
   sumAndConvolveQuadrupleAlt,

   -- for use in Storable.Filter.NonRecursive
   maybeAccumulateRangeFromPyramid,
   accumulatePosModulatedFromPyramid,
   withPaddedInput,
   -- for use in Generic.Fourier
   addShiftedSimple,

   -- for testing
   consumeRangeFromPyramid,
   sumRangeFromPyramidReverse,
   sumRangeFromPyramidFoldr,
   ) where

import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Generic.Control as Ctrl
import qualified Synthesizer.Generic.LengthSignal as SigL

import qualified Synthesizer.Basic.Filter.NonRecursive as Filt
import qualified Synthesizer.State.Filter.NonRecursive as FiltS
import qualified Synthesizer.State.Signal as SigS

import Control.Monad (mplus, )
import Data.Function.HT (nest, )
import Data.Tuple.HT (mapSnd, mapPair, )
import Data.Maybe.HT (toMaybe, )

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 qualified NumericPrelude.Numeric as NP
import NumericPrelude.Numeric hiding (negate, )
import NumericPrelude.Base


-- * Envelope application

{-# INLINE negate #-}
negate ::
   (Additive.C a, SigG.Transform sig a) =>
   sig a -> sig a
negate :: forall a (sig :: * -> *). (C a, Transform sig a) => sig a -> sig a
negate = (a -> a) -> sig a -> sig a
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map a -> a
forall a. C a => a -> a
Additive.negate

{-# INLINE amplify #-}
amplify ::
   (Ring.C a, SigG.Transform sig a) =>
   a -> sig a -> sig a
amplify :: forall a (sig :: * -> *).
(C a, Transform sig a) =>
a -> sig a -> sig a
amplify a
v = (a -> a) -> sig a -> sig a
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map (a
va -> a -> a
forall a. C a => a -> a -> a
*)

{-# INLINE amplifyVector #-}
amplifyVector ::
   (Module.C a v, SigG.Transform sig v) =>
   a -> sig v -> sig v
amplifyVector :: forall a v (sig :: * -> *).
(C a v, Transform sig v) =>
a -> sig v -> sig v
amplifyVector a
v = (v -> v) -> sig v -> sig v
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map (a
va -> v -> v
forall a v. C a v => a -> v -> v
*>)

{-# INLINE normalize #-}
normalize ::
   (Field.C a, SigG.Transform sig a) =>
   (sig a -> a) -> sig a -> sig a
normalize :: forall a (sig :: * -> *).
(C a, Transform sig a) =>
(sig a -> a) -> sig a -> sig a
normalize sig a -> a
volume sig a
xs =
   a -> sig a -> sig a
forall a (sig :: * -> *).
(C a, Transform sig a) =>
a -> sig a -> sig a
amplify (a -> a
forall a. C a => a -> a
recip (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ sig a -> a
volume sig a
xs) sig a
xs

{-# INLINE envelope #-}
envelope ::
   (Ring.C a, SigG.Transform sig a) =>
      sig a  {-^ the envelope -}
   -> sig a  {-^ the signal to be enveloped -}
   -> sig a
envelope :: forall a (sig :: * -> *).
(C a, Transform sig a) =>
sig a -> sig a -> sig a
envelope = (a -> a -> a) -> sig a -> sig a -> sig a
forall (sig :: * -> *) a b c.
(Read sig a, Transform sig b, Transform sig c) =>
(a -> b -> c) -> sig a -> sig b -> sig c
SigG.zipWith a -> a -> a
forall a. C a => a -> a -> a
(*)

{-# INLINE envelopeVector #-}
envelopeVector ::
   (Module.C a v, SigG.Read sig a, SigG.Transform sig v) =>
      sig a  {-^ the envelope -}
   -> sig v  {-^ the signal to be enveloped -}
   -> sig v
envelopeVector :: forall a v (sig :: * -> *).
(C a v, Read sig a, Transform sig v) =>
sig a -> sig v -> sig v
envelopeVector = (a -> v -> v) -> sig a -> sig v -> sig v
forall (sig :: * -> *) a b c.
(Read sig a, Transform sig b, Transform sig c) =>
(a -> b -> c) -> sig a -> sig b -> sig c
SigG.zipWith a -> v -> v
forall a v. C a v => a -> v -> v
(*>)



{-# INLINE fadeInOut #-}
fadeInOut ::
   (Field.C a, SigG.Write sig a) =>
   Int -> Int -> Int -> sig a -> sig a
fadeInOut :: forall a (sig :: * -> *).
(C a, Write sig a) =>
Int -> Int -> Int -> sig a -> sig a
fadeInOut Int
tIn Int
tHold Int
tOut sig a
xs =
   let slopeIn :: a
slopeIn  =                  a -> a
forall a. C a => a -> a
recip (Int -> a
forall a b. (C a, C b) => a -> b
fromIntegral Int
tIn)
       slopeOut :: a
slopeOut = a -> a
forall a. C a => a -> a
Additive.negate (a -> a
forall a. C a => a -> a
recip (Int -> a
forall a b. (C a, C b) => a -> b
fromIntegral Int
tOut))
       {-
       Since we use the size only for the internal envelope
       no laziness effect can be observed outside the function.
       We could also create the envelope as State.Signal.
       But I assume that concatenating chunks of an envelope
       is more efficient than concatenating generator loops.
       However, our intermediate envelope is still observable,
       because we have to use SigG.Write class.
       -}
       leadIn :: sig a
leadIn  = Int -> sig a -> sig a
forall sig. Transform sig => Int -> sig -> sig
SigG.take Int
tIn  (sig a -> sig a) -> sig a -> sig a
forall a b. (a -> b) -> a -> b
$ LazySize -> a -> a -> sig a
forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
Ctrl.linear LazySize
SigG.defaultLazySize a
slopeIn  a
0
       leadOut :: sig a
leadOut = Int -> sig a -> sig a
forall sig. Transform sig => Int -> sig -> sig
SigG.take Int
tOut (sig a -> sig a) -> sig a -> sig a
forall a b. (a -> b) -> a -> b
$ LazySize -> a -> a -> sig a
forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> y -> y -> sig y
Ctrl.linear LazySize
SigG.defaultLazySize a
slopeOut a
1
       (sig a
partIn, sig a
partHoldOut) = Int -> sig a -> (sig a, sig a)
forall sig. Transform sig => Int -> sig -> (sig, sig)
SigG.splitAt Int
tIn sig a
xs
       (sig a
partHold, sig a
partOut)   = Int -> sig a -> (sig a, sig a)
forall sig. Transform sig => Int -> sig -> (sig, sig)
SigG.splitAt Int
tHold sig a
partHoldOut
   in  sig a -> sig a -> sig a
forall a (sig :: * -> *).
(C a, Transform sig a) =>
sig a -> sig a -> sig a
envelope sig a
leadIn sig a
partIn sig a -> sig a -> sig a
forall sig. Monoid sig => sig -> sig -> sig
`SigG.append`
       sig a
partHold sig a -> sig a -> sig a
forall sig. Monoid sig => sig -> sig -> sig
`SigG.append`
       sig a -> sig a -> sig a
forall a (sig :: * -> *).
(C a, Transform sig a) =>
sig a -> sig a -> sig a
envelope sig a
leadOut sig a
partOut


-- * Delay

{-# INLINE delay #-}
delay :: (Additive.C y, SigG.Write sig y) =>
   Int -> sig y -> sig y
delay :: forall y (sig :: * -> *).
(C y, Write sig y) =>
Int -> sig y -> sig y
delay =
   y -> Int -> sig y -> sig y
forall (sig :: * -> *) y. Write sig y => y -> Int -> sig y -> sig y
delayPad y
forall a. C a => a
zero

{-# INLINE delayPad #-}
delayPad :: (SigG.Write sig y) =>
   y -> Int -> sig y -> sig y
delayPad :: forall (sig :: * -> *) y. Write sig y => y -> Int -> sig y -> sig y
delayPad y
z Int
n =
   if Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
0
     then Int -> sig y -> sig y
forall sig. Transform sig => Int -> sig -> sig
SigG.drop (Int -> Int
forall a. C a => a -> a
Additive.negate Int
n)
     else sig y -> sig y -> sig y
forall sig. Monoid sig => sig -> sig -> sig
SigG.append (LazySize -> Int -> y -> sig y
forall y. Storage (sig y) => LazySize -> Int -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> Int -> y -> sig y
SigG.replicate LazySize
SigG.defaultLazySize Int
n y
z)

{-# INLINE delayPos #-}
delayPos :: (Additive.C y, SigG.Write sig y) =>
   Int -> sig y -> sig y
delayPos :: forall y (sig :: * -> *).
(C y, Write sig y) =>
Int -> sig y -> sig y
delayPos Int
n =
   sig y -> sig y -> sig y
forall sig. Monoid sig => sig -> sig -> sig
SigG.append (LazySize -> Int -> y -> sig y
forall y. Storage (sig y) => LazySize -> Int -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> Int -> y -> sig y
SigG.replicate LazySize
SigG.defaultLazySize Int
n y
forall a. C a => a
zero)

{-# INLINE delayNeg #-}
delayNeg :: (SigG.Transform sig y) =>
   Int -> sig y -> sig y
delayNeg :: forall (sig :: * -> *) y. Transform sig y => Int -> sig y -> sig y
delayNeg = Int -> sig y -> sig y
forall sig. Transform sig => Int -> sig -> sig
SigG.drop



{-# INLINE delayLazySize #-}
delayLazySize :: (Additive.C y, SigG.Write sig y) =>
   SigG.LazySize -> Int -> sig y -> sig y
delayLazySize :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> Int -> sig y -> sig y
delayLazySize LazySize
size =
   LazySize -> y -> Int -> sig y -> sig y
forall (sig :: * -> *) y.
Write sig y =>
LazySize -> y -> Int -> sig y -> sig y
delayPadLazySize LazySize
size y
forall a. C a => a
zero

{- |
The pad value @y@ must be defined,
otherwise the chunk size of the padding can be observed.
-}
{-# INLINE delayPadLazySize #-}
delayPadLazySize :: (SigG.Write sig y) =>
   SigG.LazySize -> y -> Int -> sig y -> sig y
delayPadLazySize :: forall (sig :: * -> *) y.
Write sig y =>
LazySize -> y -> Int -> sig y -> sig y
delayPadLazySize LazySize
size y
z Int
n =
   if Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
0
     then Int -> sig y -> sig y
forall sig. Transform sig => Int -> sig -> sig
SigG.drop (Int -> Int
forall a. C a => a -> a
Additive.negate Int
n)
     else sig y -> sig y -> sig y
forall sig. Monoid sig => sig -> sig -> sig
SigG.append (LazySize -> Int -> y -> sig y
forall y. Storage (sig y) => LazySize -> Int -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> Int -> y -> sig y
SigG.replicate LazySize
size Int
n y
z)

{-# INLINE delayPosLazySize #-}
delayPosLazySize :: (Additive.C y, SigG.Write sig y) =>
   SigG.LazySize -> Int -> sig y -> sig y
delayPosLazySize :: forall y (sig :: * -> *).
(C y, Write sig y) =>
LazySize -> Int -> sig y -> sig y
delayPosLazySize LazySize
size Int
n =
   sig y -> sig y -> sig y
forall sig. Monoid sig => sig -> sig -> sig
SigG.append (LazySize -> Int -> y -> sig y
forall y. Storage (sig y) => LazySize -> Int -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> Int -> y -> sig y
SigG.replicate LazySize
size Int
n y
forall a. C a => a
zero)


-- * smoothing

binomialMask ::
   (Field.C a, SigG.Write sig a) =>
   SigG.LazySize ->
   Int -> sig a
binomialMask :: forall a (sig :: * -> *).
(C a, Write sig a) =>
LazySize -> Int -> sig a
binomialMask LazySize
size Int
n =
   LazySize
-> ((a, Integer, Integer) -> Maybe (a, (a, Integer, Integer)))
-> (a, Integer, Integer)
-> sig a
forall y s.
Storage (sig y) =>
LazySize -> (s -> Maybe (y, s)) -> s -> sig y
forall (sig :: * -> *) y s.
(Write0 sig, Storage (sig y)) =>
LazySize -> (s -> Maybe (y, s)) -> s -> sig y
SigG.unfoldR LazySize
size
      (\(a
x, Integer
a, Integer
b) ->
          Bool
-> (a, (a, Integer, Integer)) -> Maybe (a, (a, Integer, Integer))
forall a. Bool -> a -> Maybe a
toMaybe (Integer
bInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>=Integer
0)
             (a
x, (a
x a -> a -> a
forall a. C a => a -> a -> a
* Integer -> a
forall a. C a => Integer -> a
fromInteger Integer
b a -> a -> a
forall a. C a => a -> a -> a
/ Integer -> a
forall a. C a => Integer -> a
fromInteger (Integer
aInteger -> Integer -> Integer
forall a. C a => a -> a -> a
+Integer
1), Integer
aInteger -> Integer -> Integer
forall a. C a => a -> a -> a
+Integer
1, Integer
bInteger -> Integer -> Integer
forall a. C a => a -> a -> a
-Integer
1)))
      (a -> a
forall a. C a => a -> a
recip (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
2 a -> Integer -> a
forall a. C a => a -> Integer -> a
^ Int -> Integer
forall a b. (C a, C b) => a -> b
fromIntegral Int
n, Integer
0, Int -> Integer
forall a b. (C a, C b) => a -> b
fromIntegral Int
n)

{-
property: must sum up to 1
-}

{-
{- |
@eps@ is the threshold relatively to the maximum.
That is, if the gaussian falls below @eps * gaussian 0@,
then the function truncated.
-}
gaussian ::
   (Trans.C a, RealField.C a, Module.C a v) =>
   a -> a -> a -> sig v -> sig v
gaussian eps ratio freq =
   let var    = Filt.ratioFreqToVariance ratio freq
       area   = var * sqrt (2*pi)
       gau t  = exp (-(t/var)^2/2) / area
       width  = ceiling (var * sqrt (-2 * log eps))  -- inverse gau
       gauSmp = map (gau . fromIntegral) [-width .. width]
   in  drop width . generic gauSmp
-}

{-
GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double])

The filtered chirp must have amplitude 0.5 at 400 (0.04*10000).
-}

{-
  We want to approximate a Gaussian by a binomial filter.
  The latter one can be implemented by a convolutional power.
  However we still require a number of operations per sample
  which is proportional to the variance.
-}
{-# INLINE binomial #-}
binomial ::
   (Trans.C a, RealField.C a, Module.C a v, SigG.Transform sig v) =>
   a -> a -> sig v -> sig v
binomial :: forall a v (sig :: * -> *).
(C a, C a, C a v, Transform sig v) =>
a -> a -> sig v -> sig v
binomial a
ratio a
freq =
   let width :: Int
width = a -> Int
forall b. C b => a -> b
forall a b. (C a, C b) => a -> b
ceiling (a
2 a -> a -> a
forall a. C a => a -> a -> a
* a -> a -> a
forall a. C a => a -> a -> a
Filt.ratioFreqToVariance a
ratio a
freq a -> Integer -> a
forall a. C a => a -> Integer -> a
^ Integer
2)
   in  Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
width (sig v -> sig v) -> (sig v -> sig v) -> sig v -> sig v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
       Int -> (sig v -> sig v) -> sig v -> sig v
forall a. Int -> (a -> a) -> a -> a
nest (Int
2Int -> Int -> Int
forall a. C a => a -> a -> a
*Int
width) (a -> sig v -> sig v
forall a v (sig :: * -> *).
(C a v, Transform sig v) =>
a -> sig v -> sig v
amplifyVector (a -> a -> a
forall a. a -> a -> a
asTypeOf a
0.5 a
freq) (sig v -> sig v) -> (sig v -> sig v) -> sig v -> sig v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig v -> sig v
forall a (sig :: * -> *). (C a, Transform sig a) => sig a -> sig a
binomial1)

{-# INLINE binomial1 #-}
binomial1 ::
   (Additive.C v, SigG.Transform sig v) => sig v -> sig v
binomial1 :: forall a (sig :: * -> *). (C a, Transform sig a) => sig a -> sig a
binomial1 = (v -> v -> v) -> sig v -> sig v
forall (sig :: * -> *) a.
(Read sig a, Transform sig a) =>
(a -> a -> a) -> sig a -> sig a
SigG.mapAdjacent v -> v -> v
forall a. C a => a -> a -> a
(+)





{- |
Moving (uniformly weighted) average in the most trivial form.
This is very slow and needs about @n * length x@ operations.
-}
{-# INLINE sums #-}
sums ::
   (Additive.C v, SigG.Transform sig v) =>
   Int -> sig v -> sig v
sums :: forall v (sig :: * -> *).
(C v, Transform sig v) =>
Int -> sig v -> sig v
sums Int
n = (sig v -> v) -> sig v -> sig v
forall (sig :: * -> *) a.
Transform sig a =>
(sig a -> a) -> sig a -> sig a
SigG.mapTails (sig v -> v
forall a (sig :: * -> *). (C a, Read sig a) => sig a -> a
SigG.sum (sig v -> v) -> (sig v -> sig v) -> sig v -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.take Int
n)


sumsDownsample2 ::
   (Additive.C v, SigG.Write sig v) =>
   SigG.LazySize -> sig v -> sig v
sumsDownsample2 :: forall v (sig :: * -> *).
(C v, Write sig v) =>
LazySize -> sig v -> sig v
sumsDownsample2 LazySize
cs =
   LazySize -> (sig v -> Maybe (v, sig v)) -> sig v -> sig v
forall y s.
Storage (sig y) =>
LazySize -> (s -> Maybe (y, s)) -> s -> sig y
forall (sig :: * -> *) y s.
(Write0 sig, Storage (sig y)) =>
LazySize -> (s -> Maybe (y, s)) -> s -> sig y
SigG.unfoldR LazySize
cs (\sig v
xs ->
      (((v, sig v) -> (v, sig v))
 -> Maybe (v, sig v) -> Maybe (v, sig v))
-> Maybe (v, sig v)
-> ((v, sig v) -> (v, sig v))
-> Maybe (v, sig v)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((v, sig v) -> (v, sig v)) -> Maybe (v, sig v) -> Maybe (v, sig v)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (sig v -> Maybe (v, sig v)
forall y. Storage (sig y) => sig y -> Maybe (y, sig y)
forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
sig y -> Maybe (y, sig y)
SigG.viewL sig v
xs) (((v, sig v) -> (v, sig v)) -> Maybe (v, sig v))
-> ((v, sig v) -> (v, sig v)) -> Maybe (v, sig v)
forall a b. (a -> b) -> a -> b
$ \xxs0 :: (v, sig v)
xxs0@(v
x0,sig v
xs0) ->
         (v, sig v) -> (v -> sig v -> (v, sig v)) -> sig v -> (v, sig v)
forall (sig :: * -> *) y a.
Transform sig y =>
a -> (y -> sig y -> a) -> sig y -> a
SigG.switchL (v, sig v)
xxs0 {- xs0 is empty -}
            (\ v
x1 sig v
xs1 -> (v
x0v -> v -> v
forall a. C a => a -> a -> a
+v
x1, sig v
xs1))
            sig v
xs0)

downsample2 ::
   (SigG.Write sig v) =>
   SigG.LazySize -> sig v -> sig v
downsample2 :: forall (sig :: * -> *) v. Write sig v => LazySize -> sig v -> sig v
downsample2 LazySize
cs =
   LazySize -> (sig v -> Maybe (v, sig v)) -> sig v -> sig v
forall y s.
Storage (sig y) =>
LazySize -> (s -> Maybe (y, s)) -> s -> sig y
forall (sig :: * -> *) y s.
(Write0 sig, Storage (sig y)) =>
LazySize -> (s -> Maybe (y, s)) -> s -> sig y
SigG.unfoldR LazySize
cs
      (((v, sig v) -> (v, sig v)) -> Maybe (v, sig v) -> Maybe (v, sig v)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((sig v -> sig v) -> (v, sig v) -> (v, sig v)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd sig v -> sig v
forall (sig :: * -> *) y. Transform sig y => sig y -> sig y
SigG.laxTail) (Maybe (v, sig v) -> Maybe (v, sig v))
-> (sig v -> Maybe (v, sig v)) -> sig v -> Maybe (v, sig v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig v -> Maybe (v, sig v)
forall y. Storage (sig y) => sig y -> Maybe (y, sig y)
forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
sig y -> Maybe (y, sig y)
SigG.viewL)

downsample ::
   (SigG.Write sig v) =>
   SigG.LazySize -> Int -> sig v -> sig v
downsample :: forall (sig :: * -> *) v.
Write sig v =>
LazySize -> Int -> sig v -> sig v
downsample LazySize
cs Int
n =
   LazySize -> (sig v -> Maybe (v, sig v)) -> sig v -> sig v
forall y s.
Storage (sig y) =>
LazySize -> (s -> Maybe (y, s)) -> s -> sig y
forall (sig :: * -> *) y s.
(Write0 sig, Storage (sig y)) =>
LazySize -> (s -> Maybe (y, s)) -> s -> sig y
SigG.unfoldR LazySize
cs
      (\sig v
xs -> ((v, sig v) -> (v, sig v)) -> Maybe (v, sig v) -> Maybe (v, sig v)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((sig v -> sig v) -> (v, sig v) -> (v, sig v)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (sig v -> sig v -> sig v
forall a b. a -> b -> a
const (Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
n sig v
xs))) (Maybe (v, sig v) -> Maybe (v, sig v))
-> Maybe (v, sig v) -> Maybe (v, sig v)
forall a b. (a -> b) -> a -> b
$ sig v -> Maybe (v, sig v)
forall y. Storage (sig y) => sig y -> Maybe (y, sig y)
forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
sig y -> Maybe (y, sig y)
SigG.viewL sig v
xs)


{-
{- |
Given a list of numbers
and a list of sums of (2*k) of successive summands,
compute a list of the sums of (2*k+1) or (2*k+2) summands.

Eample for 2*k+1

@
 [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->
    [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...]
@

Example for 2*k+2

@
 [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->
    [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...]
@
-}
sumsUpsampleOdd :: (Additive.C v) => Int -> sig v -> sig v -> sig v
sumsUpsampleOdd n {- 2*k -} 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 v -> sig v -> sig v
sumsUpsampleEven n {- 2*k -} xs ss =
   sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs)))

sumsPyramid :: (Additive.C v) => Int -> sig v -> sig v
sumsPyramid n xs =
   let aux 1 ys = ys
       aux 2 ys = ys + tail ys
       aux m ys =
          let ysd = sumsDownsample2 ys
          in  if even m
                then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd)
                else sumsUpsampleOdd  (m-1) ys (aux (div (m-1) 2) ysd)
   in  aux n xs


propSums :: Bool
propSums =
   let n  = 1000
       xs = [0::Double ..]
       naive   =              sums        n xs
       rec     = drop (n-1) $ sumsRec     n xs
       pyramid =              sumsPyramid n xs
   in  and $ take 1000 $
         zipWith3 (\x y z -> x==y && y==z) naive rec pyramid

-}

sumRange ::
   (Additive.C v, SigG.Transform sig v) =>
   sig v -> (Int,Int) -> v
sumRange :: forall v (sig :: * -> *).
(C v, Transform sig v) =>
sig v -> (Int, Int) -> v
sumRange =
   ((Int, Int) -> sig v -> v) -> sig v -> (Int, Int) -> v
forall v source.
C v =>
((Int, Int) -> source -> v) -> source -> (Int, Int) -> v
Filt.sumRangePrepare (((Int, Int) -> sig v -> v) -> sig v -> (Int, Int) -> v)
-> ((Int, Int) -> sig v -> v) -> sig v -> (Int, Int) -> v
forall a b. (a -> b) -> a -> b
$ \ (Int
l,Int
r) ->
   sig v -> v
forall a (sig :: * -> *). (C a, Read sig a) => sig a -> a
SigG.sum (sig v -> v) -> (sig v -> sig v) -> sig v -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.take (Int
rInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
l) (sig v -> sig v) -> (sig v -> sig v) -> sig v -> sig v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
l

pyramid ::
   (Additive.C v, SigG.Write sig v) =>
   Int -> sig v -> ([Int], [sig v])
pyramid :: forall v (sig :: * -> *).
(C v, Write sig v) =>
Int -> sig v -> ([Int], [sig v])
pyramid Int
height sig v
sig =
   let sizes :: [Int]
sizes = [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (Int
1Int -> Int -> Int
forall a. C a => a -> a -> a
+Int
height) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int
2Int -> Int -> Int
forall a. C a => a -> a -> a
*) Int
1
   in  ([Int]
sizes,
        (sig v -> LazySize -> sig v) -> sig v -> [LazySize] -> [sig v]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl ((LazySize -> sig v -> sig v) -> sig v -> LazySize -> sig v
forall a b c. (a -> b -> c) -> b -> a -> c
flip LazySize -> sig v -> sig v
forall v (sig :: * -> *).
(C v, Write sig v) =>
LazySize -> sig v -> sig v
sumsDownsample2) sig v
sig ((Int -> LazySize) -> [Int] -> [LazySize]
forall a b. (a -> b) -> [a] -> [b]
map Int -> LazySize
SigG.LazySize ([Int] -> [LazySize]) -> [Int] -> [LazySize]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
tail [Int]
sizes))

{-# INLINE sumRangeFromPyramid #-}
sumRangeFromPyramid ::
   (Additive.C v, SigG.Transform sig v) =>
   [sig v] -> (Int,Int) -> v
sumRangeFromPyramid :: forall v (sig :: * -> *).
(C v, Transform sig v) =>
[sig v] -> (Int, Int) -> v
sumRangeFromPyramid =
   ((Int, Int) -> [sig v] -> v) -> [sig v] -> (Int, Int) -> v
forall v source.
C v =>
((Int, Int) -> source -> v) -> source -> (Int, Int) -> v
Filt.sumRangePrepare (((Int, Int) -> [sig v] -> v) -> [sig v] -> (Int, Int) -> v)
-> ((Int, Int) -> [sig v] -> v) -> [sig v] -> (Int, Int) -> v
forall a b. (a -> b) -> a -> b
$ \(Int, Int)
lr0 [sig v]
pyr0 ->
   (v -> (v -> v) -> v -> v)
-> (v -> v) -> [sig v] -> (Int, Int) -> v -> v
forall (sig :: * -> *) v a.
Transform sig v =>
(v -> a -> a) -> a -> [sig v] -> (Int, Int) -> a
consumeRangeFromPyramid (\v
v v -> v
k v
s -> v -> v
k (v
sv -> v -> v
forall a. C a => a -> a -> a
+v
v)) v -> v
forall a. a -> a
id [sig v]
pyr0 (Int, Int)
lr0 v
forall a. C a => a
zero

-- add from right to left, which is inefficient
sumRangeFromPyramidReverse ::
   (Additive.C v, SigG.Transform sig v) =>
   [sig v] -> (Int,Int) -> v
sumRangeFromPyramidReverse :: forall v (sig :: * -> *).
(C v, Transform sig v) =>
[sig v] -> (Int, Int) -> v
sumRangeFromPyramidReverse =
   ((Int, Int) -> [sig v] -> v) -> [sig v] -> (Int, Int) -> v
forall v source.
C v =>
((Int, Int) -> source -> v) -> source -> (Int, Int) -> v
Filt.sumRangePrepare (((Int, Int) -> [sig v] -> v) -> [sig v] -> (Int, Int) -> v)
-> ((Int, Int) -> [sig v] -> v) -> [sig v] -> (Int, Int) -> v
forall a b. (a -> b) -> a -> b
$ \(Int, Int)
lr0 [sig v]
pyr0 ->
   (v -> v -> v) -> v -> [sig v] -> (Int, Int) -> v
forall (sig :: * -> *) v a.
Transform sig v =>
(v -> a -> a) -> a -> [sig v] -> (Int, Int) -> a
consumeRangeFromPyramid v -> v -> v
forall a. C a => a -> a -> a
(+) v
forall a. C a => a
zero [sig v]
pyr0 (Int, Int)
lr0

-- for speed benchmarks
sumRangeFromPyramidFoldr ::
   (Additive.C v, SigG.Transform sig v) =>
   [sig v] -> (Int,Int) -> v
sumRangeFromPyramidFoldr :: forall v (sig :: * -> *).
(C v, Transform sig v) =>
[sig v] -> (Int, Int) -> v
sumRangeFromPyramidFoldr =
   ((Int, Int) -> [sig v] -> v) -> [sig v] -> (Int, Int) -> v
forall v source.
C v =>
((Int, Int) -> source -> v) -> source -> (Int, Int) -> v
Filt.sumRangePrepare (((Int, Int) -> [sig v] -> v) -> [sig v] -> (Int, Int) -> v)
-> ((Int, Int) -> [sig v] -> v) -> [sig v] -> (Int, Int) -> v
forall a b. (a -> b) -> a -> b
$ \(Int, Int)
lr0 [sig v]
pyr0 ->
   case [sig v]
pyr0 of
      [] -> [Char] -> v
forall a. HasCallStack => [Char] -> a
error [Char]
"empty pyramid"
      (sig v
ps0:[sig v]
pss) ->
         (sig v
 -> ((Int, Int) -> sig v -> v -> v)
 -> (Int, Int)
 -> sig v
 -> v
 -> v)
-> ((Int, Int) -> sig v -> v -> v)
-> [sig v]
-> (Int, Int)
-> sig v
-> v
-> v
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
            (\sig v
psNext (Int, Int) -> sig v -> v -> v
k (Int
l,Int
r) sig v
ps v
s ->
               case Int
rInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
l of
                  Int
0 -> v
s
                  Int
1 -> v
s v -> v -> v
forall a. C a => a -> a -> a
+ sig v -> Int -> v
forall y. Storage (sig y) => sig y -> Int -> y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> Int -> y
SigG.index sig v
ps Int
l
                  Int
_ ->
                     let (Int
lh,Int
ll) = (Int, Int) -> (Int, Int)
forall a. C a => a -> a
NP.negate ((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 -> Int
forall a. C a => a -> a
NP.negate Int
l) Int
2
                         (Int
rh,Int
rl) = Int -> Int -> (Int, Int)
forall a. C a => a -> a -> (a, a)
divMod Int
r Int
2
                         {-# INLINE inc #-}
                         inc :: a -> a -> a -> a
inc a
b a
x = if a
ba -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
0 then a -> a
forall a. a -> a
id else (a
xa -> a -> a
forall a. C a => a -> a -> a
+)
                     in  (Int, Int) -> sig v -> v -> v
k (Int
lh,Int
rh) sig v
psNext (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$
                         Int -> v -> v -> v
forall {a} {a}. (Eq a, C a, C a) => a -> a -> a -> a
inc Int
ll (sig v -> Int -> v
forall y. Storage (sig y) => sig y -> Int -> y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> Int -> y
SigG.index sig v
ps Int
l) (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$
                         Int -> v -> v -> v
forall {a} {a}. (Eq a, C a, C a) => a -> a -> a -> a
inc Int
rl (sig v -> Int -> v
forall y. Storage (sig y) => sig y -> Int -> y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> Int -> y
SigG.index sig v
ps (Int
rInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
1)) (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$
                         v
s)
            (\(Int
l,Int
r) sig v
ps v
s ->
               v
s v -> v -> v
forall a. C a => a -> a -> a
+ (sig v -> v
forall a (sig :: * -> *). (C a, Read sig a) => sig a -> a
SigG.sum (sig v -> v) -> sig v -> v
forall a b. (a -> b) -> a -> b
$ Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.take (Int
rInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
l) (sig v -> sig v) -> sig v -> sig v
forall a b. (a -> b) -> a -> b
$ Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
l sig v
ps))
            [sig v]
pss (Int, Int)
lr0 sig v
ps0 v
forall a. C a => a
zero

{-# INLINE maybeAccumulateRangeFromPyramid #-}
maybeAccumulateRangeFromPyramid ::
   (SigG.Transform sig v) =>
   (v -> v -> v) ->
   [sig v] -> (Int,Int) -> Maybe v
maybeAccumulateRangeFromPyramid :: forall (sig :: * -> *) v.
Transform sig v =>
(v -> v -> v) -> [sig v] -> (Int, Int) -> Maybe v
maybeAccumulateRangeFromPyramid v -> v -> v
acc =
   ((Int, Int) -> [sig v] -> Maybe v)
-> [sig v] -> (Int, Int) -> Maybe v
forall source v.
((Int, Int) -> source -> v) -> source -> (Int, Int) -> v
Filt.symmetricRangePrepare (((Int, Int) -> [sig v] -> Maybe v)
 -> [sig v] -> (Int, Int) -> Maybe v)
-> ((Int, Int) -> [sig v] -> Maybe v)
-> [sig v]
-> (Int, Int)
-> Maybe v
forall a b. (a -> b) -> a -> b
$ \(Int, Int)
lr0 [sig v]
pyr0 ->
   (v -> (Maybe v -> Maybe v) -> Maybe v -> Maybe v)
-> (Maybe v -> Maybe v)
-> [sig v]
-> (Int, Int)
-> Maybe v
-> Maybe v
forall (sig :: * -> *) v a.
Transform sig v =>
(v -> a -> a) -> a -> [sig v] -> (Int, Int) -> a
consumeRangeFromPyramid
      (\v
v Maybe v -> Maybe v
k Maybe v
s -> Maybe v -> Maybe v
k ((v -> v) -> Maybe 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 -> v -> v
acc v
v) Maybe v
s Maybe v -> Maybe v -> Maybe v
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` v -> Maybe v
forall a. a -> Maybe a
Just v
v))
      Maybe v -> Maybe v
forall a. a -> a
id [sig v]
pyr0 (Int, Int)
lr0 Maybe v
forall a. Maybe a
Nothing

{-
This would also be a useful signature,
but that's not easy to implement
and I don't know whether it can be computed efficiently.

getRangeFromPyramid ::
   (Additive.C v, SigG.Transform sig v) =>
   [sig v] -> (Int,Int) -> SigS.T v
-}

{-# INLINE consumeRangeFromPyramid #-}
consumeRangeFromPyramid ::
   (SigG.Transform sig v) =>
   (v -> a -> a) -> a ->
   [sig v] -> (Int,Int) -> a
consumeRangeFromPyramid :: forall (sig :: * -> *) v a.
Transform sig v =>
(v -> a -> a) -> a -> [sig v] -> (Int, Int) -> a
consumeRangeFromPyramid v -> a -> a
acc a
init0 [sig v]
pyr0 (Int, Int)
lr0 =
   case [sig v]
pyr0 of
      [] -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"empty pyramid"
      (sig v
ps0:[sig v]
pss) ->
         (sig v -> ((Int, Int) -> sig v -> a) -> (Int, Int) -> sig v -> a)
-> ((Int, Int) -> sig v -> a)
-> [sig v]
-> (Int, Int)
-> sig v
-> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
            (\sig v
psNext (Int, Int) -> sig v -> a
k (Int
l,Int
r) sig v
ps ->
               case Int
rInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
l of
                  Int
0 -> a
init0
                  Int
1 -> v -> a -> a
acc (sig v -> Int -> v
forall y. Storage (sig y) => sig y -> Int -> y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> Int -> y
SigG.index sig v
ps Int
l) a
init0
                  Int
_ ->
                     let (Int
lh,Int
ll) = (Int, Int) -> (Int, Int)
forall a. C a => a -> a
NP.negate ((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 -> Int
forall a. C a => a -> a
NP.negate Int
l) Int
2
                         (Int
rh,Int
rl) = Int -> Int -> (Int, Int)
forall a. C a => a -> a -> (a, a)
divMod Int
r Int
2
                         {-# INLINE inc #-}
                         inc :: a -> v -> a -> a
inc a
b v
x = if a
ba -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
0 then a -> a
forall a. a -> a
id else v -> a -> a
acc v
x
                     in  Int -> v -> a -> a
forall {a}. (Eq a, C a) => a -> v -> a -> a
inc Int
ll (sig v -> Int -> v
forall y. Storage (sig y) => sig y -> Int -> y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> Int -> y
SigG.index sig v
ps Int
l) (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$
                         Int -> v -> a -> a
forall {a}. (Eq a, C a) => a -> v -> a -> a
inc Int
rl (sig v -> Int -> v
forall y. Storage (sig y) => sig y -> Int -> y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> Int -> y
SigG.index sig v
ps (Int
rInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
1)) (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$
                         (Int, Int) -> sig v -> a
k (Int
lh,Int
rh) sig v
psNext)
            (\(Int
l,Int
r) sig v
ps ->
               (v -> a -> a) -> a -> sig v -> a
forall y s. Storage (sig y) => (y -> s -> s) -> s -> sig y -> s
forall (sig :: * -> *) y s.
(Read0 sig, Storage (sig y)) =>
(y -> s -> s) -> s -> sig y -> s
SigG.foldR v -> a -> a
acc a
init0 (sig v -> a) -> sig v -> a
forall a b. (a -> b) -> a -> b
$
               Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.take (Int
rInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
l) (sig v -> sig v) -> sig v -> sig v
forall a b. (a -> b) -> a -> b
$ Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
l sig v
ps)
            [sig v]
pss (Int, Int)
lr0 sig v
ps0

sumsPosModulated ::
   (Additive.C v, SigG.Transform sig (Int,Int), SigG.Transform sig v) =>
   sig (Int,Int) -> sig v -> sig v
sumsPosModulated :: forall v (sig :: * -> *).
(C v, Transform sig (Int, Int), Transform sig v) =>
sig (Int, Int) -> sig v -> sig v
sumsPosModulated sig (Int, Int)
ctrl sig v
xs =
   ((Int, Int) -> sig v -> v) -> sig (Int, Int) -> sig v -> sig v
forall (sig :: * -> *) a b c.
(Transform sig a, Transform sig b, Transform sig c) =>
(a -> sig b -> c) -> sig a -> sig b -> sig c
SigG.zipWithTails ((sig v -> (Int, Int) -> v) -> (Int, Int) -> sig v -> v
forall a b c. (a -> b -> c) -> b -> a -> c
flip sig v -> (Int, Int) -> v
forall v (sig :: * -> *).
(C v, Transform sig v) =>
sig v -> (Int, Int) -> v
sumRange) sig (Int, Int)
ctrl sig v
xs


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

The laziness granularity is @2^height@.
-}
{-# INLINE accumulatePosModulatedFromPyramid #-}
accumulatePosModulatedFromPyramid ::
   (SigG.Transform sig (Int,Int), SigG.Write sig v) =>
   ([sig v] -> (Int,Int) -> v) ->
   ([Int], [sig v]) ->
   sig (Int,Int) -> sig v
accumulatePosModulatedFromPyramid :: forall (sig :: * -> *) v.
(Transform sig (Int, Int), Write sig v) =>
([sig v] -> (Int, Int) -> v)
-> ([Int], [sig v]) -> sig (Int, Int) -> sig v
accumulatePosModulatedFromPyramid [sig v] -> (Int, Int) -> v
accumulate ([Int]
sizes,[sig v]
pyr0) sig (Int, Int)
ctrl =
   let blockSize :: Int
blockSize = [Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
sizes
       pyrStarts :: [[sig v]]
pyrStarts = ([sig v] -> [sig v]) -> [sig v] -> [[sig v]]
forall a. (a -> a) -> a -> [a]
iterate ((Int -> sig v -> sig v) -> [Int] -> [sig v] -> [sig v]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop [Int]
sizes) [sig v]
pyr0
       ctrlBlocks :: [sig (Int, Int)]
ctrlBlocks = T (sig (Int, Int)) -> [sig (Int, Int)]
forall y. T y -> [y]
SigS.toList (T (sig (Int, Int)) -> [sig (Int, Int)])
-> T (sig (Int, Int)) -> [sig (Int, Int)]
forall a b. (a -> b) -> a -> b
$ Int -> sig (Int, Int) -> T (sig (Int, Int))
forall sig. Transform sig => Int -> sig -> T sig
SigG.sliceVertical Int
blockSize sig (Int, Int)
ctrl
   in  [sig v] -> sig v
forall sig. Monoid sig => [sig] -> sig
SigG.concat ([sig v] -> sig v) -> [sig v] -> sig v
forall a b. (a -> b) -> a -> b
$
       ([sig v] -> sig (Int, Int) -> sig v)
-> [[sig v]] -> [sig (Int, Int)] -> [sig v]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
          (\[sig v]
pyr ->
              LazySize -> T v -> sig v
forall (sig :: * -> *) y. Write sig y => LazySize -> T y -> sig y
SigG.fromState (Int -> LazySize
SigG.LazySize Int
blockSize) (T v -> sig v)
-> (sig (Int, Int) -> T v) -> sig (Int, Int) -> sig 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 ([sig v] -> (Int, Int) -> v
accumulate [sig v]
pyr) (T (Int, Int) -> T v)
-> (sig (Int, Int) -> T (Int, Int)) -> sig (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))
-> (sig (Int, Int) -> T (Int, Int))
-> sig (Int, Int)
-> T (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              sig (Int, Int) -> T (Int, Int)
forall y. Storage (sig y) => sig y -> T y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> T y
SigG.toState)
          [[sig v]]
pyrStarts [sig (Int, Int)]
ctrlBlocks

sumsPosModulatedPyramid ::
   (Additive.C v, SigG.Transform sig (Int,Int), SigG.Write sig v) =>
   Int -> sig (Int,Int) -> sig v -> sig v
sumsPosModulatedPyramid :: forall v (sig :: * -> *).
(C v, Transform sig (Int, Int), Write sig v) =>
Int -> sig (Int, Int) -> sig v -> sig v
sumsPosModulatedPyramid Int
height sig (Int, Int)
ctrl sig v
xs =
   ([sig v] -> (Int, Int) -> v)
-> ([Int], [sig v]) -> sig (Int, Int) -> sig v
forall (sig :: * -> *) v.
(Transform sig (Int, Int), Write sig v) =>
([sig v] -> (Int, Int) -> v)
-> ([Int], [sig v]) -> sig (Int, Int) -> sig v
accumulatePosModulatedFromPyramid
      [sig v] -> (Int, Int) -> v
forall v (sig :: * -> *).
(C v, Transform sig v) =>
[sig v] -> (Int, Int) -> v
sumRangeFromPyramid
      (Int -> sig v -> ([Int], [sig v])
forall v (sig :: * -> *).
(C v, Write sig v) =>
Int -> sig v -> ([Int], [sig v])
pyramid Int
height sig v
xs) sig (Int, Int)
ctrl

withPaddedInput ::
   (SigG.Transform sig Int, SigG.Transform sig (Int, Int),
    SigG.Write sig y) =>
   y -> (sig (Int, Int) -> sig y -> v) ->
   Int ->
   sig Int ->
   sig y -> v
withPaddedInput :: forall (sig :: * -> *) y v.
(Transform sig Int, Transform sig (Int, Int), Write sig y) =>
y -> (sig (Int, Int) -> sig y -> v) -> Int -> sig Int -> sig y -> v
withPaddedInput y
pad sig (Int, Int) -> sig y -> v
proc Int
maxC sig Int
ctrl sig y
xs =
   sig (Int, Int) -> sig y -> v
proc
      ((Int -> (Int, Int)) -> sig Int -> sig (Int, Int)
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.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)) sig Int
ctrl)
      (y -> Int -> sig y -> sig y
forall (sig :: * -> *) y. Write sig y => y -> Int -> sig y -> sig y
delayPad y
pad Int
maxC sig y
xs)

{- |
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,
    SigG.Transform sig Int, SigG.Transform sig (Int,Int), SigG.Write sig v) =>
   a -> Int -> Int -> sig Int -> sig v -> sig v
movingAverageModulatedPyramid :: forall a v (sig :: * -> *).
(C a, C a v, Transform sig Int, Transform sig (Int, Int),
 Write sig v) =>
a -> Int -> Int -> sig Int -> sig v -> sig v
movingAverageModulatedPyramid a
amp Int
height Int
maxC sig Int
ctrl0 =
   v
-> (sig (Int, Int) -> sig v -> sig v)
-> Int
-> sig Int
-> sig v
-> sig v
forall (sig :: * -> *) y v.
(Transform sig Int, Transform sig (Int, Int), Write sig y) =>
y -> (sig (Int, Int) -> sig y -> v) -> Int -> sig Int -> sig y -> v
withPaddedInput v
forall a. C a => a
zero
      (\sig (Int, Int)
ctrl sig v
xs ->
         (Int -> v -> v) -> sig Int -> sig v -> sig v
forall (sig :: * -> *) a b c.
(Read sig a, Transform sig b, Transform sig c) =>
(a -> b -> c) -> sig a -> sig b -> sig c
SigG.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) sig Int
ctrl0 (sig v -> sig v) -> sig v -> sig v
forall a b. (a -> b) -> a -> b
$
         Int -> sig (Int, Int) -> sig v -> sig v
forall v (sig :: * -> *).
(C v, Transform sig (Int, Int), Write sig v) =>
Int -> sig (Int, Int) -> sig v -> sig v
sumsPosModulatedPyramid Int
height sig (Int, Int)
ctrl sig v
xs)
      Int
maxC sig Int
ctrl0


inverseFrequencyModulationFloor ::
   (Ord t, Ring.C t, SigG.Write sig v, SigG.Read sig t) =>
   SigG.LazySize ->
   sig t -> sig v -> sig v
inverseFrequencyModulationFloor :: forall t (sig :: * -> *) v.
(Ord t, C t, Write sig v, Read sig t) =>
LazySize -> sig t -> sig v -> sig v
inverseFrequencyModulationFloor LazySize
chunkSize sig t
ctrl sig v
xs =
   LazySize -> T v -> sig v
forall (sig :: * -> *) y. Write sig y => LazySize -> T y -> sig y
SigG.fromState LazySize
chunkSize
      (T t -> T v -> T v
forall t v. (Ord t, C t) => T t -> T v -> T v
FiltS.inverseFrequencyModulationFloor
         (sig t -> T t
forall y. Storage (sig y) => sig y -> T y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> T y
SigG.toState sig t
ctrl) (sig v -> T v
forall y. Storage (sig y) => sig y -> T y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> T y
SigG.toState sig v
xs))



{- * Filter operators from calculus -}

{- |
Forward difference quotient.
Shortens the signal by one.
Inverts 'Synthesizer.Generic.Filter.Recursive.Integration.run' in the sense that
@differentiate (zero : integrate x) == x@.
The signal is shifted by a half time unit.
-}
{-# INLINE differentiate #-}
differentiate ::
   (Additive.C v, SigG.Transform sig v) =>
   sig v -> sig v
differentiate :: forall a (sig :: * -> *). (C a, Transform sig a) => sig a -> sig a
differentiate sig v
x = (v -> v -> v) -> sig v -> sig v
forall (sig :: * -> *) a.
(Read sig a, Transform sig a) =>
(a -> a -> a) -> sig a -> sig a
SigG.mapAdjacent v -> v -> v
forall a. C a => a -> a -> a
subtract sig v
x

{- |
Central difference quotient.
Shortens the signal by two elements,
and shifts the signal by one element.
(Which can be fixed by prepending an appropriate value.)
For linear functions this will yield
essentially the same result as 'differentiate'.
You obtain the result of 'differentiateCenter'
if you smooth the one of 'differentiate'
by averaging pairs of adjacent values.

ToDo: Vector variant
-}
{-
This implementation is a bit cumbersome,
but it fits both StorableVector and State.Signal
(since it avoids recomputation).
-}
{-# INLINE differentiateCenter #-}
differentiateCenter ::
   (Field.C v, SigG.Transform sig v) =>
   sig v -> sig v
differentiateCenter :: forall v (sig :: * -> *). (C v, Transform sig v) => sig v -> sig v
differentiateCenter =
   Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
2 (sig v -> sig v) -> (sig v -> sig v) -> sig v -> sig v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (v -> (v, v) -> Maybe (v, (v, v))) -> (v, v) -> sig v -> sig v
forall y0 y1 s.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> s -> Maybe (y1, s)) -> s -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1 s.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> s -> Maybe (y1, s)) -> s -> sig y0 -> sig y1
SigG.crochetL
      (\v
x0 (v
x1,v
x2) -> (v, (v, v)) -> Maybe (v, (v, v))
forall a. a -> Maybe a
Just ((v
x2v -> v -> v
forall a. C a => a -> a -> a
-v
x0)v -> v -> v
forall a. C a => a -> a -> a
/v
2, (v
x0,v
x1)))
      (v
forall a. C a => a
zero,v
forall a. C a => a
zero)

{- |
Second derivative.
It is @differentiate2 == differentiate . differentiate@
but 'differentiate2' should be faster.
-}
{-# INLINE differentiate2 #-}
differentiate2 ::
   (Additive.C v, SigG.Transform sig v) =>
   sig v -> sig v
differentiate2 :: forall a (sig :: * -> *). (C a, Transform sig a) => sig a -> sig a
differentiate2 = sig v -> sig v
forall a (sig :: * -> *). (C a, Transform sig a) => sig a -> sig a
differentiate (sig v -> sig v) -> (sig v -> sig v) -> sig v -> sig v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig v -> sig v
forall a (sig :: * -> *). (C a, Transform sig a) => sig a -> sig a
differentiate


-- * general non-recursive filters

{-|
Unmodulated non-recursive filter (convolution)

Brute force implementation.
-}
{-# INLINE generic #-}
generic ::
   (Module.C a v, SigG.Transform sig a, SigG.Write sig v) =>
   sig a -> sig v -> sig v
generic :: forall a v (sig :: * -> *).
(C a v, Transform sig a, Write sig v) =>
sig a -> sig v -> sig v
generic sig a
m sig v
x =
   if sig a -> Bool
forall sig. Read sig => sig -> Bool
SigG.null sig a
m Bool -> Bool -> Bool
|| sig v -> Bool
forall sig. Read sig => sig -> Bool
SigG.null sig v
x
     then sig v
forall sig. Monoid sig => sig
CutG.empty
     else
       let mr :: sig a
mr = sig a -> sig a
forall sig. Transform sig => sig -> sig
SigG.reverse sig a
m
           xp :: sig v
xp = Int -> sig v -> sig v
forall y (sig :: * -> *).
(C y, Write sig y) =>
Int -> sig y -> sig y
delayPos (Int -> Int
forall a. Enum a => a -> a
pred (sig a -> Int
forall sig. Read sig => sig -> Int
SigG.length sig a
m)) sig v
x
       in  (sig v -> v) -> sig v -> sig v
forall (sig :: * -> *) a.
Transform sig a =>
(sig a -> a) -> sig a -> sig a
SigG.mapTails (sig a -> sig v -> v
forall t y (sig :: * -> *).
(C t y, Read sig t, Read sig y) =>
sig t -> sig y -> y
SigG.linearComb sig a
mr) sig v
xp


{- |
Both should signals should have similar length.
If they have considerably different length,
then better use 'karatsubaFiniteInfinite'.

Implementation using Karatsuba trick and split-and-overlap-add.
This way we stay in a ring, are faster than quadratic runtime
but do not reach log-linear runtime.
-}
karatsubaFinite ::
   (Additive.C a, Additive.C b, Additive.C c,
    SigG.Transform sig a, SigG.Transform sig b, SigG.Transform sig c) =>
   (a -> b -> c) ->
   sig a -> sig b -> sig c
karatsubaFinite :: forall a b c (sig :: * -> *).
(C a, C b, C c, Transform sig a, Transform sig b,
 Transform sig c) =>
(a -> b -> c) -> sig a -> sig b -> sig c
karatsubaFinite a -> b -> c
mul sig a
a sig b
b =
   T (sig c) -> sig c
forall sig. T sig -> sig
SigL.toSignal (T (sig c) -> sig c) -> T (sig c) -> sig c
forall a b. (a -> b) -> a -> b
$
   (a -> b -> c) -> T (sig a) -> T (sig b) -> T (sig c)
forall a b c (sig :: * -> *).
(C a, C b, C c, Transform sig a, Transform sig b,
 Transform sig c) =>
(a -> b -> c) -> T (sig a) -> T (sig b) -> T (sig c)
karatsubaBounded a -> b -> c
mul
      (sig a -> T (sig a)
forall sig. Read sig => sig -> T sig
SigL.fromSignal sig a
a) (sig b -> T (sig b)
forall sig. Read sig => sig -> T sig
SigL.fromSignal sig b
b)

{-# INLINE karatsubaBounded #-}
karatsubaBounded ::
   (Additive.C a, Additive.C b, Additive.C c,
    SigG.Transform sig a, SigG.Transform sig b, SigG.Transform sig c) =>
   (a -> b -> c) ->
   SigL.T (sig a) -> SigL.T (sig b) -> SigL.T (sig c)
karatsubaBounded :: forall a b c (sig :: * -> *).
(C a, C b, C c, Transform sig a, Transform sig b,
 Transform sig c) =>
(a -> b -> c) -> T (sig a) -> T (sig b) -> T (sig c)
karatsubaBounded a -> b -> c
mul T (sig a)
a T (sig b)
b =
   case (T (sig a) -> Int
forall sig. T sig -> Int
SigL.length T (sig a)
a, T (sig b) -> Int
forall sig. T sig -> Int
SigL.length T (sig b)
b) of
      (Int
0,Int
_) -> T (sig c)
forall sig. Monoid sig => sig
CutG.empty
      (Int
_,Int
0) -> T (sig c)
forall sig. Monoid sig => sig
CutG.empty
      (Int
1,Int
_) ->
         T (sig c) -> (a -> sig a -> T (sig c)) -> sig a -> T (sig c)
forall (sig :: * -> *) y a.
Transform sig y =>
a -> (y -> sig y -> a) -> sig y -> a
SigG.switchL
            ([Char] -> T (sig c)
forall a. HasCallStack => [Char] -> a
error [Char]
"karatsubaBounded: empty signal")
            (\a
y sig a
_ -> (sig b -> sig c) -> T (sig b) -> T (sig c)
forall a b. (a -> b) -> T a -> T b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> c) -> sig b -> sig c
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map (a -> b -> c
mul a
y)) T (sig b)
b) (sig a -> T (sig c)) -> sig a -> T (sig c)
forall a b. (a -> b) -> a -> b
$
         T (sig a) -> sig a
forall sig. T sig -> sig
SigL.body T (sig a)
a
      (Int
_,Int
1) ->
         T (sig c) -> (b -> sig b -> T (sig c)) -> sig b -> T (sig c)
forall (sig :: * -> *) y a.
Transform sig y =>
a -> (y -> sig y -> a) -> sig y -> a
SigG.switchL
            ([Char] -> T (sig c)
forall a. HasCallStack => [Char] -> a
error [Char]
"karatsubaBounded: empty signal")
            (\b
y sig b
_ -> (sig a -> sig c) -> T (sig a) -> T (sig c)
forall a b. (a -> b) -> T a -> T b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> c) -> sig a -> sig c
forall y0 y1.
(Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map ((a -> b -> c) -> b -> a -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> c
mul b
y)) T (sig a)
a) (sig b -> T (sig c)) -> sig b -> T (sig c)
forall a b. (a -> b) -> a -> b
$
         T (sig b) -> sig b
forall sig. T sig -> sig
SigL.body T (sig b)
b
      (Int
2,Int
2) ->
         let [a
a0,a
a1] = sig a -> [a]
forall y. Storage (sig y) => sig y -> [y]
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> [y]
SigG.toList (T (sig a) -> sig a
forall sig. T sig -> sig
SigL.toSignal T (sig a)
a)
             [b
b0,b
b1] = sig b -> [b]
forall y. Storage (sig y) => sig y -> [y]
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> [y]
SigG.toList (T (sig b) -> sig b
forall sig. T sig -> sig
SigL.toSignal T (sig b)
b)
             (c
c0,c
c1,c
c2) = (a -> b -> c) -> Pair a -> Pair b -> (c, c, c)
forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Pair a -> Pair b -> Triple c
convolvePair a -> b -> c
mul (a
a0,a
a1) (b
b0,b
b1)
         in  Int -> sig c -> T (sig c)
forall sig. Int -> sig -> T sig
SigL.Cons Int
3 (sig c -> T (sig c)) -> sig c -> T (sig c)
forall a b. (a -> b) -> a -> b
$ T (sig a) -> T (sig b) -> [c] -> sig c
forall (sig1 :: * -> *) a b c (sig0 :: * -> *).
(Transform sig1 a, Transform sig1 b, Transform sig1 c,
 Transform sig0 c) =>
T (sig1 a) -> T (sig1 b) -> sig0 c -> sig1 c
rechunk T (sig a)
a T (sig b)
b ([c] -> sig c) -> [c] -> sig c
forall a b. (a -> b) -> a -> b
$
             c
c0 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c1 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c2 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: []
      (Int
2,Int
3) ->
         let [a
a0,a
a1]    = sig a -> [a]
forall y. Storage (sig y) => sig y -> [y]
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> [y]
SigG.toList (T (sig a) -> sig a
forall sig. T sig -> sig
SigL.toSignal T (sig a)
a)
             [b
b0,b
b1,b
b2] = sig b -> [b]
forall y. Storage (sig y) => sig y -> [y]
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> [y]
SigG.toList (T (sig b) -> sig b
forall sig. T sig -> sig
SigL.toSignal T (sig b)
b)
             (c
c0,c
c1,c
c2,c
c3) =
                (a -> b -> c) -> Pair a -> Triple b -> (c, c, c, c)
forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Pair a -> Triple b -> (c, c, c, c)
convolvePairTriple a -> b -> c
mul (a
a0,a
a1) (b
b0,b
b1,b
b2)
         in  Int -> sig c -> T (sig c)
forall sig. Int -> sig -> T sig
SigL.Cons Int
4 (sig c -> T (sig c)) -> sig c -> T (sig c)
forall a b. (a -> b) -> a -> b
$ T (sig a) -> T (sig b) -> [c] -> sig c
forall (sig1 :: * -> *) a b c (sig0 :: * -> *).
(Transform sig1 a, Transform sig1 b, Transform sig1 c,
 Transform sig0 c) =>
T (sig1 a) -> T (sig1 b) -> sig0 c -> sig1 c
rechunk T (sig a)
a T (sig b)
b ([c] -> sig c) -> [c] -> sig c
forall a b. (a -> b) -> a -> b
$
             c
c0 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c1 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c2 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c3 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: []
      (Int
3,Int
2) ->
         let [a
a0,a
a1,a
a2] = sig a -> [a]
forall y. Storage (sig y) => sig y -> [y]
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> [y]
SigG.toList (T (sig a) -> sig a
forall sig. T sig -> sig
SigL.toSignal T (sig a)
a)
             [b
b0,b
b1]    = sig b -> [b]
forall y. Storage (sig y) => sig y -> [y]
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> [y]
SigG.toList (T (sig b) -> sig b
forall sig. T sig -> sig
SigL.toSignal T (sig b)
b)
             (c
c0,c
c1,c
c2,c
c3) =
                (b -> a -> c) -> Pair b -> Triple a -> (c, c, c, c)
forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Pair a -> Triple b -> (c, c, c, c)
convolvePairTriple ((a -> b -> c) -> b -> a -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> c
mul) (b
b0,b
b1) (a
a0,a
a1,a
a2)
         in  Int -> sig c -> T (sig c)
forall sig. Int -> sig -> T sig
SigL.Cons Int
4 (sig c -> T (sig c)) -> sig c -> T (sig c)
forall a b. (a -> b) -> a -> b
$ T (sig a) -> T (sig b) -> [c] -> sig c
forall (sig1 :: * -> *) a b c (sig0 :: * -> *).
(Transform sig1 a, Transform sig1 b, Transform sig1 c,
 Transform sig0 c) =>
T (sig1 a) -> T (sig1 b) -> sig0 c -> sig1 c
rechunk T (sig a)
a T (sig b)
b ([c] -> sig c) -> [c] -> sig c
forall a b. (a -> b) -> a -> b
$
             c
c0 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c1 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c2 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c3 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: []
      (Int
3,Int
3) ->
         let [a
a0,a
a1,a
a2] = sig a -> [a]
forall y. Storage (sig y) => sig y -> [y]
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> [y]
SigG.toList (T (sig a) -> sig a
forall sig. T sig -> sig
SigL.toSignal T (sig a)
a)
             [b
b0,b
b1,b
b2] = sig b -> [b]
forall y. Storage (sig y) => sig y -> [y]
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> [y]
SigG.toList (T (sig b) -> sig b
forall sig. T sig -> sig
SigL.toSignal T (sig b)
b)
             (c
c0,c
c1,c
c2,c
c3,c
c4) =
                (a -> b -> c) -> Triple a -> Triple b -> (c, c, c, c, c)
forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Triple a -> Triple b -> (c, c, c, c, c)
convolveTriple a -> b -> c
mul (a
a0,a
a1,a
a2) (b
b0,b
b1,b
b2)
         in  Int -> sig c -> T (sig c)
forall sig. Int -> sig -> T sig
SigL.Cons Int
5 (sig c -> T (sig c)) -> sig c -> T (sig c)
forall a b. (a -> b) -> a -> b
$ T (sig a) -> T (sig b) -> [c] -> sig c
forall (sig1 :: * -> *) a b c (sig0 :: * -> *).
(Transform sig1 a, Transform sig1 b, Transform sig1 c,
 Transform sig0 c) =>
T (sig1 a) -> T (sig1 b) -> sig0 c -> sig1 c
rechunk T (sig a)
a T (sig b)
b ([c] -> sig c) -> [c] -> sig c
forall a b. (a -> b) -> a -> b
$
             c
c0 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c1 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c2 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c3 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c4 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: []
      (Int
4,Int
4) ->
         let [a
a0,a
a1,a
a2,a
a3] = sig a -> [a]
forall y. Storage (sig y) => sig y -> [y]
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> [y]
SigG.toList (T (sig a) -> sig a
forall sig. T sig -> sig
SigL.toSignal T (sig a)
a)
             [b
b0,b
b1,b
b2,b
b3] = sig b -> [b]
forall y. Storage (sig y) => sig y -> [y]
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> [y]
SigG.toList (T (sig b) -> sig b
forall sig. T sig -> sig
SigL.toSignal T (sig b)
b)
             (c
c0,c
c1,c
c2,c
c3,c
c4,c
c5,c
c6) =
                (a -> b -> c)
-> Quadruple a -> Quadruple b -> (c, c, c, c, c, c, c)
forall a b c.
(C a, C b, C c) =>
(a -> b -> c)
-> Quadruple a -> Quadruple b -> (c, c, c, c, c, c, c)
convolveQuadruple a -> b -> c
mul (a
a0,a
a1,a
a2,a
a3) (b
b0,b
b1,b
b2,b
b3)
         in  Int -> sig c -> T (sig c)
forall sig. Int -> sig -> T sig
SigL.Cons Int
7 (sig c -> T (sig c)) -> sig c -> T (sig c)
forall a b. (a -> b) -> a -> b
$ T (sig a) -> T (sig b) -> [c] -> sig c
forall (sig1 :: * -> *) a b c (sig0 :: * -> *).
(Transform sig1 a, Transform sig1 b, Transform sig1 c,
 Transform sig0 c) =>
T (sig1 a) -> T (sig1 b) -> sig0 c -> sig1 c
rechunk T (sig a)
a T (sig b)
b ([c] -> sig c) -> [c] -> sig c
forall a b. (a -> b) -> a -> b
$
             c
c0 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c1 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c2 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c3 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c4 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c5 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: c
c6 c -> [c] -> [c]
forall a. a -> [a] -> [a]
: []
      (Int
lenA,Int
lenB) ->
         let n2 :: Int
n2 = Int -> Int -> Int
forall a. C a => a -> a -> a
div (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
lenA Int
lenB) Int
2
             (T (sig a)
a0,T (sig a)
a1) = Int -> T (sig a) -> (T (sig a), T (sig a))
forall sig. Transform sig => Int -> T sig -> (T sig, T sig)
SigL.splitAt Int
n2 T (sig a)
a
             (T (sig b)
b0,T (sig b)
b1) = Int -> T (sig b) -> (T (sig b), T (sig b))
forall sig. Transform sig => Int -> T sig -> (T sig, T sig)
SigL.splitAt Int
n2 T (sig b)
b
             (T (sig c)
c0,T (sig c)
c1,T (sig c)
c2) =
                (T (sig a) -> T (sig b) -> T (sig c))
-> (T (sig a), T (sig a))
-> (T (sig b), T (sig b))
-> (T (sig c), T (sig c), T (sig c))
forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Pair a -> Pair b -> Triple c
convolvePair
                   ((a -> b -> c) -> T (sig a) -> T (sig b) -> T (sig c)
forall a b c (sig :: * -> *).
(C a, C b, C c, Transform sig a, Transform sig b,
 Transform sig c) =>
(a -> b -> c) -> T (sig a) -> T (sig b) -> T (sig c)
karatsubaBounded a -> b -> c
mul)
                   (T (sig a)
a0,T (sig a)
a1) (T (sig b)
b0,T (sig b)
b1)
         in  (sig c -> sig c) -> T (sig c) -> T (sig c)
forall a b. (a -> b) -> T a -> T b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (T (sig a) -> T (sig b) -> sig c -> sig c
forall (sig1 :: * -> *) a b c (sig0 :: * -> *).
(Transform sig1 a, Transform sig1 b, Transform sig1 c,
 Transform sig0 c) =>
T (sig1 a) -> T (sig1 b) -> sig0 c -> sig1 c
rechunk T (sig a)
a T (sig b)
b) (T (sig c) -> T (sig c)) -> T (sig c) -> T (sig c)
forall a b. (a -> b) -> a -> b
$
             Int -> T (sig c) -> T (sig c) -> T (sig c)
forall a (sig :: * -> *).
(C a, Transform sig a) =>
Int -> T (sig a) -> T (sig a) -> T (sig a)
SigL.addShiftedSimple Int
n2 T (sig c)
c0 (T (sig c) -> T (sig c)) -> T (sig c) -> T (sig c)
forall a b. (a -> b) -> a -> b
$
             Int -> T (sig c) -> T (sig c) -> T (sig c)
forall a (sig :: * -> *).
(C a, Transform sig a) =>
Int -> T (sig a) -> T (sig a) -> T (sig a)
SigL.addShiftedSimple Int
n2 T (sig c)
c1 T (sig c)
c2

{-# INLINE rechunk #-}
rechunk ::
   (SigG.Transform sig1 a, SigG.Transform sig1 b, SigG.Transform sig1 c,
    SigG.Transform sig0 c) =>
   SigL.T (sig1 a) -> SigL.T (sig1 b) -> sig0 c -> sig1 c
rechunk :: forall (sig1 :: * -> *) a b c (sig0 :: * -> *).
(Transform sig1 a, Transform sig1 b, Transform sig1 c,
 Transform sig0 c) =>
T (sig1 a) -> T (sig1 b) -> sig0 c -> sig1 c
rechunk T (sig1 a)
a T (sig1 b)
b sig0 c
c =
   let (sig0 c
ac,sig0 c
bc) = Int -> sig0 c -> (sig0 c, sig0 c)
forall sig. Transform sig => Int -> sig -> (sig, sig)
CutG.splitAt (T (sig1 a) -> Int
forall sig. T sig -> Int
SigL.length T (sig1 a)
a) sig0 c
c
   in  sig1 a -> T c -> sig1 c
forall (sig :: * -> *) a b.
(Transform sig a, Transform sig b) =>
sig a -> T b -> sig b
SigG.takeStateMatch (T (sig1 a) -> sig1 a
forall sig. T sig -> sig
SigL.body T (sig1 a)
a) (sig0 c -> T c
forall y. Storage (sig0 y) => sig0 y -> T y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> T y
SigG.toState sig0 c
ac)
       sig1 c -> sig1 c -> sig1 c
forall sig. Monoid sig => sig -> sig -> sig
`SigG.append`
       sig1 b -> T c -> sig1 c
forall (sig :: * -> *) a b.
(Transform sig a, Transform sig b) =>
sig a -> T b -> sig b
SigG.takeStateMatch (T (sig1 b) -> sig1 b
forall sig. T sig -> sig
SigL.body T (sig1 b)
b) (sig0 c -> T c
forall y. Storage (sig0 y) => sig0 y -> T y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> T y
SigG.toState sig0 c
bc)


{- |
The first operand must be finite and
the second one can be infinite.
For efficient operation we expect that the second signal
is longer than the first one.
-}
{-
Implemented by overlap-add of pieces that are convolved by Karatsuba trick.
Is it more efficient to round the chunk size up to the next power of two?
Can we make use of the fact,
that the first operand is always split in the same way?
-}
karatsubaFiniteInfinite ::
   (Additive.C a, Additive.C b, Additive.C c,
    SigG.Transform sig a, SigG.Transform sig b, SigG.Transform sig c) =>
   (a -> b -> c) ->
   sig a -> sig b -> sig c
karatsubaFiniteInfinite :: forall a b c (sig :: * -> *).
(C a, C b, C c, Transform sig a, Transform sig b,
 Transform sig c) =>
(a -> b -> c) -> sig a -> sig b -> sig c
karatsubaFiniteInfinite a -> b -> c
mul sig a
a sig b
b =
   let al :: T (sig a)
al = sig a -> T (sig a)
forall sig. Read sig => sig -> T sig
SigL.fromSignal sig a
a
   in  case T (sig a) -> Int
forall sig. T sig -> Int
SigL.length T (sig a)
al of
          Int
0 -> sig c
forall sig. Monoid sig => sig
CutG.empty
          Int
alen ->
             (sig c -> sig c -> sig c) -> sig c -> T (sig c) -> sig c
forall x acc. (x -> acc -> acc) -> acc -> T x -> acc
SigS.foldR (Int -> sig c -> sig c -> sig c
forall a (sig :: * -> *).
(C a, Transform sig a) =>
Int -> sig a -> sig a -> sig a
addShiftedSimple Int
alen) sig c
forall sig. Monoid sig => sig
CutG.empty (T (sig c) -> sig c) -> T (sig c) -> sig c
forall a b. (a -> b) -> a -> b
$
             (T (sig c) -> sig c) -> T (T (sig c)) -> T (sig c)
forall a b. (a -> b) -> T a -> T b
SigS.map T (sig c) -> sig c
forall sig. T sig -> sig
SigL.toSignal (T (T (sig c)) -> T (sig c)) -> T (T (sig c)) -> T (sig c)
forall a b. (a -> b) -> a -> b
$
             (sig b -> T (sig c)) -> T (sig b) -> T (T (sig c))
forall a b. (a -> b) -> T a -> T b
SigS.map ((a -> b -> c) -> T (sig a) -> T (sig b) -> T (sig c)
forall a b c (sig :: * -> *).
(C a, C b, C c, Transform sig a, Transform sig b,
 Transform sig c) =>
(a -> b -> c) -> T (sig a) -> T (sig b) -> T (sig c)
karatsubaBounded a -> b -> c
mul T (sig a)
al (T (sig b) -> T (sig c))
-> (sig b -> T (sig b)) -> sig b -> T (sig c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig b -> T (sig b)
forall sig. Read sig => sig -> T sig
SigL.fromSignal) (T (sig b) -> T (T (sig c))) -> T (sig b) -> T (T (sig c))
forall a b. (a -> b) -> a -> b
$
             Int -> sig b -> T (sig b)
forall sig. Transform sig => Int -> sig -> T sig
SigG.sliceVertical Int
alen sig b
b


karatsubaInfinite ::
   (Additive.C a, Additive.C b, Additive.C c,
    SigG.Transform sig a, SigG.Transform sig c, SigG.Transform sig b) =>
   (a -> b -> c) ->
   sig a -> sig b -> sig c
karatsubaInfinite :: forall a b c (sig :: * -> *).
(C a, C b, C c, Transform sig a, Transform sig c,
 Transform sig b) =>
(a -> b -> c) -> sig a -> sig b -> sig c
karatsubaInfinite a -> b -> c
mul =
   let recourse :: Int -> sig a -> sig b -> sig c
recourse Int
n sig a
a sig b
b =
          let (sig a
a0,sig a
a1) = Int -> sig a -> (sig a, sig a)
forall sig. Transform sig => Int -> sig -> (sig, sig)
SigG.splitAt Int
n sig a
a
              (sig b
b0,sig b
b1) = Int -> sig b -> (sig b, sig b)
forall sig. Transform sig => Int -> sig -> (sig, sig)
SigG.splitAt Int
n sig b
b
              {-
              We could also apply Karatsuba's trick to these pairs.
              But this requires Additive (sig a) constraint
              and I do not know whether this is actually an optimization.
              -}
              ab00 :: sig c
ab00 =
                 T (sig c) -> sig c
forall sig. T sig -> sig
SigL.toSignal (T (sig c) -> sig c) -> T (sig c) -> sig c
forall a b. (a -> b) -> a -> b
$
                 (a -> b -> c) -> T (sig a) -> T (sig b) -> T (sig c)
forall a b c (sig :: * -> *).
(C a, C b, C c, Transform sig a, Transform sig b,
 Transform sig c) =>
(a -> b -> c) -> T (sig a) -> T (sig b) -> T (sig c)
karatsubaBounded a -> b -> c
mul
                    (sig a -> T (sig a)
forall sig. Read sig => sig -> T sig
SigL.fromSignal sig a
a0) (sig b -> T (sig b)
forall sig. Read sig => sig -> T sig
SigL.fromSignal sig b
b0)
              ab01 :: sig c
ab01 = (a -> b -> c) -> sig a -> sig b -> sig c
forall a b c (sig :: * -> *).
(C a, C b, C c, Transform sig a, Transform sig b,
 Transform sig c) =>
(a -> b -> c) -> sig a -> sig b -> sig c
karatsubaFiniteInfinite a -> b -> c
mul sig a
a0 sig b
b1
              ab10 :: sig c
ab10 = (b -> a -> c) -> sig b -> sig a -> sig c
forall a b c (sig :: * -> *).
(C a, C b, C c, Transform sig a, Transform sig b,
 Transform sig c) =>
(a -> b -> c) -> sig a -> sig b -> sig c
karatsubaFiniteInfinite ((a -> b -> c) -> b -> a -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> c
mul) sig b
b0 sig a
a1
              ab11 :: sig c
ab11 = Int -> sig a -> sig b -> sig c
recourse (Int
2Int -> Int -> Int
forall a. C a => a -> a -> a
*Int
n) sig a
a1 sig b
b1
          in  if sig a -> Bool
forall sig. Read sig => sig -> Bool
SigG.null sig a
a Bool -> Bool -> Bool
|| sig b -> Bool
forall sig. Read sig => sig -> Bool
SigG.null sig b
b
                then sig c
forall sig. Monoid sig => sig
CutG.empty
                else
                  Int -> sig c -> sig c -> sig c
forall a (sig :: * -> *).
(C a, Transform sig a) =>
Int -> sig a -> sig a -> sig a
addShiftedSimple Int
n sig c
ab00 (sig c -> sig c) -> sig c -> sig c
forall a b. (a -> b) -> a -> b
$
                  Int -> sig c -> sig c -> sig c
forall a (sig :: * -> *).
(C a, Transform sig a) =>
Int -> sig a -> sig a -> sig a
addShiftedSimple Int
n (sig c -> sig c -> sig c
forall y (sig :: * -> *).
(C y, Transform sig y) =>
sig y -> sig y -> sig y
SigG.mix sig c
ab01 sig c
ab10) sig c
ab11
   in  Int -> sig a -> sig b -> sig c
forall {sig :: * -> *}.
(Transform sig b, Transform sig a, Transform sig c) =>
Int -> sig a -> sig b -> sig c
recourse Int
1


{- |
It must hold @delay <= length a@.
-}
{-
It is crucial that 'mix' uses the chunk size structure of the second operand.
This way we avoid unnecessary and even infinite look-ahead.
-}
{-# INLINE addShiftedSimple #-}
addShiftedSimple ::
   (Additive.C a, SigG.Transform sig a) =>
   Int -> sig a -> sig a -> sig a
addShiftedSimple :: forall a (sig :: * -> *).
(C a, Transform sig a) =>
Int -> sig a -> sig a -> sig a
addShiftedSimple Int
del sig a
a sig a
b =
   (sig a -> sig a -> sig a) -> (sig a, sig a) -> sig a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry sig a -> sig a -> sig a
forall sig. Monoid sig => sig -> sig -> sig
CutG.append ((sig a, sig a) -> sig a) -> (sig a, sig a) -> sig a
forall a b. (a -> b) -> a -> b
$
   (sig a -> sig a) -> (sig a, sig a) -> (sig a, sig a)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd ((sig a -> sig a -> sig a) -> sig a -> sig a -> sig a
forall a b c. (a -> b -> c) -> b -> a -> c
flip sig a -> sig a -> sig a
forall y (sig :: * -> *).
(C y, Transform sig y) =>
sig y -> sig y -> sig y
SigG.mix sig a
b) ((sig a, sig a) -> (sig a, sig a))
-> (sig a, sig a) -> (sig a, sig a)
forall a b. (a -> b) -> a -> b
$
   Int -> sig a -> (sig a, sig a)
forall sig. Transform sig => Int -> sig -> (sig, sig)
CutG.splitAt Int
del sig a
a


-- ** hard-wired convolutions for small sizes

{-
Some small size convolutions using the Karatsuba trick.
We do not use Toom-3 multiplication,
because this requires division by 2 and 6.
With Karatsuba we can stay in a ring.
-}

type Pair a = (a,a)

{- |
Reasonable choices for the multiplication operation are '(*)', '(*>)', 'convolve'.
-}
{-# INLINE convolvePair #-}
convolvePair ::
   (Additive.C a, Additive.C b, Additive.C c) =>
   (a -> b -> c) ->
   Pair a -> Pair b -> Triple c
convolvePair :: forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Pair a -> Pair b -> Triple c
convolvePair a -> b -> c
mul Pair a
a Pair b
b =
   ((a, b), Triple c) -> Triple c
forall a b. (a, b) -> b
snd (((a, b), Triple c) -> Triple c) -> ((a, b), Triple c) -> Triple c
forall a b. (a -> b) -> a -> b
$ (a -> b -> c) -> Pair a -> Pair b -> ((a, b), Triple c)
forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Pair a -> Pair b -> ((a, b), Triple c)
sumAndConvolvePair a -> b -> c
mul Pair a
a Pair b
b

{-# INLINE sumAndConvolvePair #-}
sumAndConvolvePair ::
   (Additive.C a, Additive.C b, Additive.C c) =>
   (a -> b -> c) ->
   Pair a -> Pair b -> ((a,b), Triple c)
sumAndConvolvePair :: forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Pair a -> Pair b -> ((a, b), Triple c)
sumAndConvolvePair a -> b -> c
(!*!) (a
a0,a
a1) (b
b0,b
b1) =
   let sa01 :: a
sa01 = a
a0a -> a -> a
forall a. C a => a -> a -> a
+a
a1
       sb01 :: b
sb01 = b
b0b -> b -> b
forall a. C a => a -> a -> a
+b
b1
       ab0 :: c
ab0 = a
a0a -> b -> c
!*!b
b0
       ab1 :: c
ab1 = a
a1a -> b -> c
!*!b
b1
   in  ((a
sa01, b
sb01), (c
ab0, a
sa01a -> b -> c
!*!b
sb01c -> c -> c
forall a. C a => a -> a -> a
-(c
ab0c -> c -> c
forall a. C a => a -> a -> a
+c
ab1), c
ab1))

type Triple a = (a,a,a)

{-# INLINE convolvePairTriple #-}
convolvePairTriple ::
   (Additive.C a, Additive.C b, Additive.C c) =>
   (a -> b -> c) ->
   Pair a -> Triple b -> (c,c,c,c)
convolvePairTriple :: forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Pair a -> Triple b -> (c, c, c, c)
convolvePairTriple a -> b -> c
(!*!) (a
a0,a
a1) (b
b0,b
b1,b
b2) =
   let ab0 :: c
ab0 = a
a0a -> b -> c
!*!b
b0
       ab1 :: c
ab1 = a
a1a -> b -> c
!*!b
b1
       sa01 :: a
sa01 = a
a0a -> a -> a
forall a. C a => a -> a -> a
+a
a1; sb01 :: b
sb01 = b
b0b -> b -> b
forall a. C a => a -> a -> a
+b
b1; ab01 :: c
ab01 = a
sa01a -> b -> c
!*!b
sb01
   in  (c
ab0, c
ab01 c -> c -> c
forall a. C a => a -> a -> a
- (c
ab0c -> c -> c
forall a. C a => a -> a -> a
+c
ab1),
        a
a0a -> b -> c
!*!b
b2 c -> c -> c
forall a. C a => a -> a -> a
+ c
ab1, a
a1a -> b -> c
!*!b
b2)


{-# INLINE convolveTriple #-}
convolveTriple ::
   (Additive.C a, Additive.C b, Additive.C c) =>
   (a -> b -> c) ->
   Triple a -> Triple b -> (c,c,c,c,c)
convolveTriple :: forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Triple a -> Triple b -> (c, c, c, c, c)
convolveTriple a -> b -> c
mul Triple a
a Triple b
b =
   ((a, b), (c, c, c, c, c)) -> (c, c, c, c, c)
forall a b. (a, b) -> b
snd (((a, b), (c, c, c, c, c)) -> (c, c, c, c, c))
-> ((a, b), (c, c, c, c, c)) -> (c, c, c, c, c)
forall a b. (a -> b) -> a -> b
$ (a -> b -> c) -> Triple a -> Triple b -> ((a, b), (c, c, c, c, c))
forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Triple a -> Triple b -> ((a, b), (c, c, c, c, c))
sumAndConvolveTriple a -> b -> c
mul Triple a
a Triple b
b

{-# INLINE sumAndConvolveTriple #-}
sumAndConvolveTriple ::
   (Additive.C a, Additive.C b, Additive.C c) =>
   (a -> b -> c) ->
   Triple a -> Triple b -> ((a,b), (c,c,c,c,c))
sumAndConvolveTriple :: forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Triple a -> Triple b -> ((a, b), (c, c, c, c, c))
sumAndConvolveTriple a -> b -> c
(!*!) (a
a0,a
a1,a
a2) (b
b0,b
b1,b
b2) =
   let ab0 :: c
ab0 = a
a0a -> b -> c
!*!b
b0
       ab1 :: c
ab1 = a
a1a -> b -> c
!*!b
b1
       ab2 :: c
ab2 = a
a2a -> b -> c
!*!b
b2
       sa01 :: a
sa01 = a
a0a -> a -> a
forall a. C a => a -> a -> a
+a
a1; sb01 :: b
sb01 = b
b0b -> b -> b
forall a. C a => a -> a -> a
+b
b1; ab01 :: c
ab01 = a
sa01a -> b -> c
!*!b
sb01
       sa02 :: a
sa02 = a
a0a -> a -> a
forall a. C a => a -> a -> a
+a
a2; sb02 :: b
sb02 = b
b0b -> b -> b
forall a. C a => a -> a -> a
+b
b2; ab02 :: c
ab02 = a
sa02a -> b -> c
!*!b
sb02
       sa012 :: a
sa012 = a
sa01a -> a -> a
forall a. C a => a -> a -> a
+a
a2
       sb012 :: b
sb012 = b
sb01b -> b -> b
forall a. C a => a -> a -> a
+b
b2
   in  ((a
sa012, b
sb012),
        (c
ab0, c
ab01 c -> c -> c
forall a. C a => a -> a -> a
- (c
ab0c -> c -> c
forall a. C a => a -> a -> a
+c
ab1),
         c
ab02 c -> c -> c
forall a. C a => a -> a -> a
+ c
ab1 c -> c -> c
forall a. C a => a -> a -> a
- (c
ab0c -> c -> c
forall a. C a => a -> a -> a
+c
ab2),
         a
sa012a -> b -> c
!*!b
sb012 c -> c -> c
forall a. C a => a -> a -> a
- c
ab02 c -> c -> c
forall a. C a => a -> a -> a
- c
ab01 c -> c -> c
forall a. C a => a -> a -> a
+ c
ab0, c
ab2))

{-# INLINE sumAndConvolveTripleAlt #-}
sumAndConvolveTripleAlt ::
   (Additive.C a, Additive.C b, Additive.C c) =>
   (a -> b -> c) ->
   Triple a -> Triple b -> ((a,b), (c,c,c,c,c))
sumAndConvolveTripleAlt :: forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Triple a -> Triple b -> ((a, b), (c, c, c, c, c))
sumAndConvolveTripleAlt a -> b -> c
(!*!) (a
a0,a
a1,a
a2) (b
b0,b
b1,b
b2) =
   let ab0 :: c
ab0 = a
a0a -> b -> c
!*!b
b0
       ab1 :: c
ab1 = a
a1a -> b -> c
!*!b
b1
       ab2 :: c
ab2 = a
a2a -> b -> c
!*!b
b2
       sa01 :: a
sa01 = a
a0a -> a -> a
forall a. C a => a -> a -> a
+a
a1; sb01 :: b
sb01 = b
b0b -> b -> b
forall a. C a => a -> a -> a
+b
b1
       ab01 :: c
ab01 = a
sa01a -> b -> c
!*!b
sb01 c -> c -> c
forall a. C a => a -> a -> a
- (c
ab0c -> c -> c
forall a. C a => a -> a -> a
+c
ab1)
       sa02 :: a
sa02 = a
a0a -> a -> a
forall a. C a => a -> a -> a
+a
a2; sb02 :: b
sb02 = b
b0b -> b -> b
forall a. C a => a -> a -> a
+b
b2
       ab02 :: c
ab02 = a
sa02a -> b -> c
!*!b
sb02 c -> c -> c
forall a. C a => a -> a -> a
- (c
ab0c -> c -> c
forall a. C a => a -> a -> a
+c
ab2)
       sa12 :: a
sa12 = a
a1a -> a -> a
forall a. C a => a -> a -> a
+a
a2; sb12 :: b
sb12 = b
b1b -> b -> b
forall a. C a => a -> a -> a
+b
b2
       ab12 :: c
ab12 = a
sa12a -> b -> c
!*!b
sb12 c -> c -> c
forall a. C a => a -> a -> a
- (c
ab1c -> c -> c
forall a. C a => a -> a -> a
+c
ab2)
   in  ((a
sa01a -> a -> a
forall a. C a => a -> a -> a
+a
a2, b
sb01b -> b -> b
forall a. C a => a -> a -> a
+b
b2),
        (c
ab0, c
ab01, c
ab1c -> c -> c
forall a. C a => a -> a -> a
+c
ab02, c
ab12, c
ab2))

type Quadruple a = (a,a,a,a)

{-# INLINE convolveQuadruple #-}
convolveQuadruple ::
   (Additive.C a, Additive.C b, Additive.C c) =>
   (a -> b -> c) ->
   Quadruple a -> Quadruple b -> (c,c,c,c,c,c,c)
convolveQuadruple :: forall a b c.
(C a, C b, C c) =>
(a -> b -> c)
-> Quadruple a -> Quadruple b -> (c, c, c, c, c, c, c)
convolveQuadruple a -> b -> c
mul Quadruple a
a Quadruple b
b =
   ((a, b), (c, c, c, c, c, c, c)) -> (c, c, c, c, c, c, c)
forall a b. (a, b) -> b
snd (((a, b), (c, c, c, c, c, c, c)) -> (c, c, c, c, c, c, c))
-> ((a, b), (c, c, c, c, c, c, c)) -> (c, c, c, c, c, c, c)
forall a b. (a -> b) -> a -> b
$ (a -> b -> c)
-> Quadruple a -> Quadruple b -> ((a, b), (c, c, c, c, c, c, c))
forall a b c.
(C a, C b, C c) =>
(a -> b -> c)
-> Quadruple a -> Quadruple b -> ((a, b), (c, c, c, c, c, c, c))
sumAndConvolveQuadruple a -> b -> c
mul Quadruple a
a Quadruple b
b

{-# INLINE sumAndConvolveQuadruple #-}
sumAndConvolveQuadruple ::
   (Additive.C a, Additive.C b, Additive.C c) =>
   (a -> b -> c) ->
   Quadruple a -> Quadruple b -> ((a,b), (c,c,c,c,c,c,c))
sumAndConvolveQuadruple :: forall a b c.
(C a, C b, C c) =>
(a -> b -> c)
-> Quadruple a -> Quadruple b -> ((a, b), (c, c, c, c, c, c, c))
sumAndConvolveQuadruple a -> b -> c
(!*!) (a
a0,a
a1,a
a2,a
a3) (b
b0,b
b1,b
b2,b
b3) =
   let ab0 :: c
ab0 = a
a0a -> b -> c
!*!b
b0
       ab1 :: c
ab1 = a
a1a -> b -> c
!*!b
b1
       sa01 :: a
sa01 = a
a0a -> a -> a
forall a. C a => a -> a -> a
+a
a1; sb01 :: b
sb01 = b
b0b -> b -> b
forall a. C a => a -> a -> a
+b
b1
       ab01 :: c
ab01 = a
sa01a -> b -> c
!*!b
sb01 c -> c -> c
forall a. C a => a -> a -> a
- (c
ab0c -> c -> c
forall a. C a => a -> a -> a
+c
ab1)
       ab2 :: c
ab2 = a
a2a -> b -> c
!*!b
b2
       ab3 :: c
ab3 = a
a3a -> b -> c
!*!b
b3
       sa23 :: a
sa23 = a
a2a -> a -> a
forall a. C a => a -> a -> a
+a
a3; sb23 :: b
sb23 = b
b2b -> b -> b
forall a. C a => a -> a -> a
+b
b3
       ab23 :: c
ab23 = a
sa23a -> b -> c
!*!b
sb23 c -> c -> c
forall a. C a => a -> a -> a
- (c
ab2c -> c -> c
forall a. C a => a -> a -> a
+c
ab3)
       ab02 :: c
ab02 = (a
a0a -> a -> a
forall a. C a => a -> a -> a
+a
a2)a -> b -> c
!*!(b
b0b -> b -> b
forall a. C a => a -> a -> a
+b
b2)
       ab13 :: c
ab13 = (a
a1a -> a -> a
forall a. C a => a -> a -> a
+a
a3)a -> b -> c
!*!(b
b1b -> b -> b
forall a. C a => a -> a -> a
+b
b3)
       sa0123 :: a
sa0123 = a
sa01a -> a -> a
forall a. C a => a -> a -> a
+a
sa23
       sb0123 :: b
sb0123 = b
sb01b -> b -> b
forall a. C a => a -> a -> a
+b
sb23
       ab0123 :: c
ab0123 = a
sa0123a -> b -> c
!*!b
sb0123 c -> c -> c
forall a. C a => a -> a -> a
- (c
ab02c -> c -> c
forall a. C a => a -> a -> a
+c
ab13)
   in  ((a
sa0123, b
sb0123),
        (c
ab0, c
ab01, c
ab1c -> c -> c
forall a. C a => a -> a -> a
+c
ab02c -> c -> c
forall a. C a => a -> a -> a
-(c
ab0c -> c -> c
forall a. C a => a -> a -> a
+c
ab2),
         c
ab0123 c -> c -> c
forall a. C a => a -> a -> a
- (c
ab01c -> c -> c
forall a. C a => a -> a -> a
+c
ab23),
         c
ab2c -> c -> c
forall a. C a => a -> a -> a
+c
ab13c -> c -> c
forall a. C a => a -> a -> a
-(c
ab1c -> c -> c
forall a. C a => a -> a -> a
+c
ab3), c
ab23, c
ab3))

{-# INLINE sumAndConvolveQuadrupleAlt #-}
sumAndConvolveQuadrupleAlt ::
   (Additive.C a, Additive.C b, Additive.C c) =>
   (a -> b -> c) ->
   Quadruple a -> Quadruple b -> ((a,b), (c,c,c,c,c,c,c))
sumAndConvolveQuadrupleAlt :: forall a b c.
(C a, C b, C c) =>
(a -> b -> c)
-> Quadruple a -> Quadruple b -> ((a, b), (c, c, c, c, c, c, c))
sumAndConvolveQuadrupleAlt a -> b -> c
mul (a
a0,a
a1,a
a2,a
a3) (b
b0,b
b1,b
b2,b
b3) =
   let (((a
sa02,a
sa13), (b
sb02,b
sb13)),
        ((c
c00,c
c01,c
c02), (c
c10,c
c11,c
c12), (c
c20,c
c21,c
c22))) =
          (Pair a -> Pair b -> Triple c)
-> Pair (Pair a)
-> Pair (Pair b)
-> ((Pair a, Pair b), Triple (Triple c))
forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Pair a -> Pair b -> ((a, b), Triple c)
sumAndConvolvePair ((a -> b -> c) -> Pair a -> Pair b -> Triple c
forall a b c.
(C a, C b, C c) =>
(a -> b -> c) -> Pair a -> Pair b -> Triple c
convolvePair a -> b -> c
mul)
             ((a
a0,a
a1),(a
a2,a
a3)) ((b
b0,b
b1),(b
b2,b
b3))
   in  ((a
sa02a -> a -> a
forall a. C a => a -> a -> a
+a
sa13, b
sb02b -> b -> b
forall a. C a => a -> a -> a
+b
sb13),
        (c
c00,c
c01,c
c02c -> c -> c
forall a. C a => a -> a -> a
+c
c10,c
c11,c
c12c -> c -> c
forall a. C a => a -> a -> a
+c
c20,c
c21,c
c22))