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

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes

-}
module Synthesizer.Generic.Filter.Recursive.MovingAverage (
   sumsStaticInt,
   modulatedFrac,
   ) where

import qualified Synthesizer.Generic.Signal  as SigG

import qualified Synthesizer.Generic.Filter.Recursive.Integration as Integration
import qualified Synthesizer.Generic.Filter.Delay as Delay

import qualified Synthesizer.State.Signal as SigS

import Data.Function.HT (nest, )

import qualified Algebra.Module                as Module
import qualified Algebra.RealField             as RealField
import qualified Algebra.Additive              as Additive

import NumericPrelude.Numeric
import NumericPrelude.Base



{- |
Like 'Synthesizer.Generic.Filter.NonRecursive.sums' but in a recursive form.
This needs only linear time (independent of the window size)
but may accumulate rounding errors.

@
ys = xs * (1,0,0,0,-1) \/ (1,-1)
ys * (1,-1) = xs * (1,0,0,0,-1)
ys = xs * (1,0,0,0,-1) + ys * (0,1)
@
-}
{-# INLINE sumsStaticInt #-}
sumsStaticInt :: (Additive.C v, SigG.Write sig v) =>
   Int -> sig v -> sig v
sumsStaticInt :: forall v (sig :: * -> *).
(C v, Write sig v) =>
Int -> sig v -> sig v
sumsStaticInt Int
n sig v
xs =
   sig v -> sig v
forall v (sig :: * -> *). (C v, Transform sig v) => sig v -> sig v
Integration.run (sig v -> sig v -> sig v
forall v (sig :: * -> *).
(C v, Transform sig v) =>
sig v -> sig v -> sig v
sub sig v
xs (Int -> sig v -> sig v
forall v (sig :: * -> *).
(C v, Write sig v) =>
Int -> sig v -> sig v
Delay.staticPos Int
n sig v
xs))


{-# INLINE sub #-}
sub :: (Additive.C v, SigG.Transform sig v) =>
   sig v -> sig v -> sig v
sub :: forall v (sig :: * -> *).
(C v, Transform sig v) =>
sig v -> sig v -> sig v
sub sig v
xs sig v
ys =
   sig v -> sig v -> sig v
forall v (sig :: * -> *).
(C v, Transform sig v) =>
sig v -> sig v -> sig v
SigG.mix sig v
xs ((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 v -> v
forall a. C a => a -> a
Additive.negate sig v
ys)


{-
Sum of a part of a vector with negative sign for reverse order.
It adds from @from@ (inclusively) to @to@ (exclusively),
that is, it sums up @abs (to-from)@ values

{-# INLINE sumFromTo #-}
sumFromTo :: (Additive.C v) => Int -> Int -> sig v -> v
sumFromTo from to =
   if from <= to
     then          Sig.sum . Sig.take (to-from) . Sig.drop from
     else negate . Sig.sum . Sig.take (from-to) . Sig.drop to
-}

{-# INLINE sumFromToFrac #-}
sumFromToFrac ::
   (RealField.C a, Module.C a v, SigG.Transform sig v) =>
   a -> a -> sig v -> v
sumFromToFrac :: forall a v (sig :: * -> *).
(C a, C a v, Transform sig v) =>
a -> a -> sig v -> v
sumFromToFrac a
from a
to sig v
xs =
   let (Int
fromInt, a
fromFrac) = a -> (Int, a)
forall b. C b => a -> (b, a)
forall a b. (C a, C b) => a -> (b, a)
splitFraction a
from
       (Int
toInt,   a
toFrac)   = a -> (Int, a)
forall b. C b => a -> (b, a)
forall a b. (C a, C b) => a -> (b, a)
splitFraction a
to
   in  case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
fromInt Int
toInt of
          Ordering
EQ -> (a
toa -> a -> a
forall a. C a => a -> a -> a
-a
from) a -> v -> v
forall a v. C a v => a -> v -> v
*> v -> Int -> sig v -> v
forall (sig :: * -> *) y. Transform sig y => y -> Int -> sig y -> y
index v
forall a. C a => a
zero Int
fromInt sig v
xs
          Ordering
LT ->
            ((v -> v) -> (v -> sig v -> v) -> v -> sig v -> v
forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext ((a
1a -> a -> a
forall a. C a => a -> a -> a
-a
fromFrac) a -> v -> v
forall a v. C a v => a -> v -> v
*>) ((v -> sig v -> v) -> v -> sig v -> v)
-> (v -> sig v -> v) -> v -> sig v -> v
forall a b. (a -> b) -> a -> b
$
             Int
-> ((v -> sig v -> v) -> v -> sig v -> v)
-> (v -> sig v -> v)
-> v
-> sig v
-> v
forall a. Int -> (a -> a) -> a -> a
nest (Int
toIntInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
fromIntInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
1) ((v -> v) -> (v -> sig v -> v) -> v -> sig v -> v
forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext v -> v
forall a. a -> a
id) ((v -> sig v -> v) -> v -> sig v -> v)
-> (v -> sig v -> v) -> v -> sig v -> v
forall a b. (a -> b) -> a -> b
$
             (v -> v) -> (v -> sig v -> v) -> v -> sig v -> v
forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext (a
toFrac a -> v -> v
forall a v. C a v => a -> v -> v
*>) ((v -> sig v -> v) -> v -> sig v -> v)
-> (v -> sig v -> v) -> v -> sig v -> v
forall a b. (a -> b) -> a -> b
$
             v -> sig v -> v
forall a b. a -> b -> a
const)
            v
forall a. C a => a
zero (Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
fromInt sig v
xs)
          Ordering
GT ->
            ((v -> v) -> (v -> sig v -> v) -> v -> sig v -> v
forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext ((a
1a -> a -> a
forall a. C a => a -> a -> a
-a
toFrac) a -> v -> v
forall a v. C a v => a -> v -> v
*>) ((v -> sig v -> v) -> v -> sig v -> v)
-> (v -> sig v -> v) -> v -> sig v -> v
forall a b. (a -> b) -> a -> b
$
             Int
-> ((v -> sig v -> v) -> v -> sig v -> v)
-> (v -> sig v -> v)
-> v
-> sig v
-> v
forall a. Int -> (a -> a) -> a -> a
nest (Int
fromIntInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
toIntInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
1) ((v -> v) -> (v -> sig v -> v) -> v -> sig v -> v
forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext v -> v
forall a. a -> a
id) ((v -> sig v -> v) -> v -> sig v -> v)
-> (v -> sig v -> v) -> v -> sig v -> v
forall a b. (a -> b) -> a -> b
$
             (v -> v) -> (v -> sig v -> v) -> v -> sig v -> v
forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext (a
fromFrac a -> v -> v
forall a v. C a v => a -> v -> v
*>) ((v -> sig v -> v) -> v -> sig v -> v)
-> (v -> sig v -> v) -> v -> sig v -> v
forall a b. (a -> b) -> a -> b
$
             v -> sig v -> v
forall a b. a -> b -> a
const)
            v
forall a. C a => a
zero (Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
toInt sig v
xs)


{-# INLINE index #-}
index ::
   (SigG.Transform sig y) =>
   y -> Int -> sig y -> y
index :: forall (sig :: * -> *) y. Transform sig y => y -> Int -> sig y -> y
index y
deflt Int
n =
   y -> ((y, sig y) -> y) -> Maybe (y, sig y) -> y
forall b a. b -> (a -> b) -> Maybe a -> b
maybe y
deflt (y, sig y) -> y
forall a b. (a, b) -> a
fst (Maybe (y, sig y) -> y)
-> (sig y -> Maybe (y, sig y)) -> sig y -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig y -> Maybe (y, sig y)
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 y -> Maybe (y, sig y))
-> (sig y -> sig y) -> sig y -> Maybe (y, sig y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> sig y -> sig y
forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
n


{-# INLINE addNext #-}
addNext ::
   (Additive.C v, SigG.Transform sig a) =>
   (a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext :: forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext a -> v
f v -> sig a -> v
next v
s =
   v -> (a -> sig a -> v) -> sig a -> v
forall (sig :: * -> *) y a.
Transform sig y =>
a -> (y -> sig y -> a) -> sig y -> a
SigG.switchL v
s
      (\a
y sig a
ys -> v -> sig a -> v
next (v
s v -> v -> v
forall a. C a => a -> a -> a
+ a -> v
f a
y) sig a
ys)


{- |
@sig a@ must contain only non-negative elements.
-}
{-# INLINE sumDiffsModulated #-}
sumDiffsModulated ::
   (RealField.C a, Module.C a v, SigG.Transform sig a, SigG.Transform sig v) =>
   a -> sig a -> sig v -> sig v
sumDiffsModulated :: forall a v (sig :: * -> *).
(C a, C a v, Transform sig a, Transform sig v) =>
a -> sig a -> sig v -> sig v
sumDiffsModulated a
d sig a
ds =
   sig v -> ((sig v, v) -> sig v) -> Maybe (sig v, v) -> sig v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> sig v
forall a. HasCallStack => [Char] -> a
error [Char]
"MovingAverage: signal must be non-empty because we prepended a zero before") (sig v, v) -> sig v
forall a b. (a, b) -> a
fst (Maybe (sig v, v) -> sig v)
-> (sig v -> Maybe (sig v, v)) -> sig v -> sig v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   sig v -> Maybe (sig v, v)
forall y. Storage (sig y) => sig y -> Maybe (sig y, y)
forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
sig y -> Maybe (sig y, y)
SigG.viewR (sig v -> Maybe (sig v, v))
-> (sig v -> sig v) -> sig v -> Maybe (sig v, v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   -- prevent negative d's since 'drop' cannot restore past values
   (a -> a -> sig v -> v) -> sig a -> sig a -> sig v -> sig v
forall (sig :: * -> *) a v.
(Transform sig a, Transform sig v) =>
(a -> a -> sig v -> v) -> sig a -> sig a -> sig v -> sig v
zipRangesWithTails a -> a -> sig v -> v
forall a v (sig :: * -> *).
(C a, C a v, Transform sig v) =>
a -> a -> sig v -> v
sumFromToFrac
      (a -> sig a -> sig a
forall y. Storage (sig y) => y -> sig y -> sig y
forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
y -> sig y -> sig y
SigG.cons (a
da -> a -> a
forall a. C a => a -> a -> a
+a
1) sig a
ds) ((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
1a -> a -> a
forall a. C a => a -> a -> a
+) sig a
ds) (sig v -> sig v) -> (sig v -> sig v) -> sig v -> sig v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   v -> sig v -> sig v
forall y. Storage (sig y) => y -> sig y -> sig y
forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
y -> sig y -> sig y
SigG.cons v
forall a. C a => a
zero

{-
   zipRangesWithTails sumFromToFrac
      (SigG.cons d (SigG.map (subtract 1) ds)) ds
-}

zipRangesWithTails ::
   (SigG.Transform sig a, SigG.Transform sig v) =>
   (a -> a -> sig v -> v) -> sig a -> sig a -> sig v -> sig v
zipRangesWithTails :: forall (sig :: * -> *) a v.
(Transform sig a, Transform sig v) =>
(a -> a -> sig v -> v) -> sig a -> sig a -> sig v -> sig v
zipRangesWithTails a -> a -> sig v -> v
f sig a
tls sig a
tus sig v
xs =
   ((a, sig v) -> a -> v) -> T (a, sig v) -> sig a -> sig v
forall (sig :: * -> *) b c a.
(Transform sig b, Transform sig c) =>
(a -> b -> c) -> T a -> sig b -> sig c
SigG.zipWithState
      (\(a
tl,sig v
suffix) a
tu -> a -> a -> sig v -> v
f a
tl a
tu sig v
suffix)
      (T a -> T (sig v) -> T (a, sig v)
forall a b. T a -> T b -> T (a, b)
SigS.zip (sig a -> T a
forall y. Storage (sig y) => sig y -> T y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> T y
SigG.toState sig a
tls) (sig v -> T (sig v)
forall (sig :: * -> *) y. Transform sig y => sig y -> T (sig y)
SigG.tails sig v
xs))
      sig a
tus

{-
{-# INLINE sumsModulated #-}
sumsModulated :: (RealField.C a, Module.C a v) =>
   Int -> sig a -> sig v -> sig v
sumsModulated maxDInt ds xs =
   let maxD  = fromIntegral maxDInt
       posXs = sumDiffsModulated 0 ds xs
       negXs = sumDiffsModulated maxD (SigG.map (maxD-) ds) (Delay.static maxDInt xs)
   in  Integration.run (sub posXs negXs)
-}

{- |
Shift sampling points by a half sample period
in order to preserve signals for window widths below 1.
-}
{-# INLINE sumsModulatedHalf #-}
sumsModulatedHalf ::
   (RealField.C a, Module.C a v, SigG.Transform sig a, SigG.Write sig v) =>
   Int -> sig a -> sig v -> sig v
sumsModulatedHalf :: forall a v (sig :: * -> *).
(C a, C a v, Transform sig a, Write sig v) =>
Int -> sig a -> sig v -> sig v
sumsModulatedHalf Int
maxDInt sig a
ds sig v
xs =
   let maxD :: a
maxD  = Int -> a
forall a b. (C a, C b) => a -> b
fromIntegral Int
maxDInt
       d0 :: a
d0    = a
maxDa -> a -> a
forall a. C a => a -> a -> a
+a
0.5
       delXs :: sig v
delXs = Int -> sig v -> sig v
forall v (sig :: * -> *).
(C v, Write sig v) =>
Int -> sig v -> sig v
Delay.staticPos Int
maxDInt sig v
xs
       posXs :: sig v
posXs = a -> sig a -> sig v -> sig v
forall a v (sig :: * -> *).
(C a, C a v, Transform sig a, Transform sig v) =>
a -> sig a -> sig v -> sig v
sumDiffsModulated a
d0 ((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
d0a -> a -> a
forall a. C a => a -> a -> a
+) sig a
ds) sig v
delXs
       negXs :: sig v
negXs = a -> sig a -> sig v -> sig v
forall a v (sig :: * -> *).
(C a, C a v, Transform sig a, Transform sig v) =>
a -> sig a -> sig v -> sig v
sumDiffsModulated a
d0 ((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
d0a -> a -> a
forall a. C a => a -> a -> a
-) sig a
ds) sig v
delXs
   in  sig v -> sig v
forall v (sig :: * -> *). (C v, Transform sig v) => sig v -> sig v
Integration.run (sig v -> sig v -> sig v
forall v (sig :: * -> *).
(C v, Transform sig v) =>
sig v -> sig v -> sig v
sub sig v
posXs sig v
negXs)

{-# INLINE modulatedFrac #-}
modulatedFrac ::
   (RealField.C a, Module.C a v, SigG.Transform sig a, SigG.Write sig v) =>
   Int -> sig a -> sig v -> sig v
modulatedFrac :: forall a v (sig :: * -> *).
(C a, C a v, Transform sig a, Write sig v) =>
Int -> sig a -> sig v -> sig v
modulatedFrac Int
maxDInt sig a
ds sig v
xs =
   (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
d v
y -> a -> a
forall a. C a => a -> a
recip (a
2a -> a -> a
forall a. C a => a -> a -> a
*a
d) a -> v -> v
forall a v. C a v => a -> v -> v
*> v
y) sig a
ds (sig v -> sig v) -> sig v -> sig v
forall a b. (a -> b) -> a -> b
$
   Int -> sig a -> sig v -> sig v
forall a v (sig :: * -> *).
(C a, C a v, Transform sig a, Write sig v) =>
Int -> sig a -> sig v -> sig v
sumsModulatedHalf Int
maxDInt sig a
ds sig v
xs