{-# 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 =
   forall v (sig :: * -> *). (C v, Transform sig v) => sig v -> sig v
Integration.run (forall v (sig :: * -> *).
(C v, Transform sig v) =>
sig v -> sig v -> sig v
sub sig v
xs (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 =
   forall v (sig :: * -> *).
(C v, Transform sig v) =>
sig v -> sig v -> sig v
SigG.mix sig v
xs (forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map 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) = forall a b. (C a, C b) => a -> (b, a)
splitFraction a
from
       (Int
toInt,   a
toFrac)   = forall a b. (C a, C b) => a -> (b, a)
splitFraction a
to
   in  case forall a. Ord a => a -> a -> Ordering
compare Int
fromInt Int
toInt of
          Ordering
EQ -> (a
toforall a. C a => a -> a -> a
-a
from) forall a v. C a v => a -> v -> v
*> forall (sig :: * -> *) y. Transform sig y => y -> Int -> sig y -> y
index forall a. C a => a
zero Int
fromInt sig v
xs
          Ordering
LT ->
            (forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext ((a
1forall a. C a => a -> a -> a
-a
fromFrac) forall a v. C a v => a -> v -> v
*>) forall a b. (a -> b) -> a -> b
$
             forall a. Int -> (a -> a) -> a -> a
nest (Int
toIntforall a. C a => a -> a -> a
-Int
fromIntforall a. C a => a -> a -> a
-Int
1) (forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
             forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext (a
toFrac forall a v. C a v => a -> v -> v
*>) forall a b. (a -> b) -> a -> b
$
             forall a b. a -> b -> a
const)
            forall a. C a => a
zero (forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
fromInt sig v
xs)
          Ordering
GT ->
            (forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext ((a
1forall a. C a => a -> a -> a
-a
toFrac) forall a v. C a v => a -> v -> v
*>) forall a b. (a -> b) -> a -> b
$
             forall a. Int -> (a -> a) -> a -> a
nest (Int
fromIntforall a. C a => a -> a -> a
-Int
toIntforall a. C a => a -> a -> a
-Int
1) (forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
             forall v (sig :: * -> *) a.
(C v, Transform sig a) =>
(a -> v) -> (v -> sig a -> v) -> v -> sig a -> v
addNext (a
fromFrac forall a v. C a v => a -> v -> v
*>) forall a b. (a -> b) -> a -> b
$
             forall a b. a -> b -> a
const)
            forall a. C a => a
zero (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 =
   forall b a. b -> (a -> b) -> Maybe a -> b
maybe y
deflt forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
sig y -> Maybe (y, sig y)
SigG.viewL forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
   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 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 =
   forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => [Char] -> a
error [Char]
"MovingAverage: signal must be non-empty because we prepended a zero before") forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
sig y -> Maybe (sig y, y)
SigG.viewR forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   -- prevent negative d's since 'drop' cannot restore past values
   forall (sig :: * -> *) a v.
(Transform sig a, Transform sig v) =>
(a -> a -> sig v -> v) -> sig a -> sig a -> sig v -> sig v
zipRangesWithTails forall a v (sig :: * -> *).
(C a, C a v, Transform sig v) =>
a -> a -> sig v -> v
sumFromToFrac
      (forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
y -> sig y -> sig y
SigG.cons (a
dforall a. C a => a -> a -> a
+a
1) sig a
ds) (forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map (a
1forall a. C a => a -> a -> a
+) sig a
ds) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
y -> sig y -> sig y
SigG.cons 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 =
   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)
      (forall a b. T a -> T b -> T (a, b)
SigS.zip (forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> T y
SigG.toState sig a
tls) (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  = forall a b. (C a, C b) => a -> b
fromIntegral Int
maxDInt
       d0 :: a
d0    = a
maxDforall a. C a => a -> a -> a
+a
0.5
       delXs :: sig v
delXs = forall v (sig :: * -> *).
(C v, Write sig v) =>
Int -> sig v -> sig v
Delay.staticPos Int
maxDInt sig v
xs
       posXs :: sig v
posXs = 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 (forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map (a
d0forall a. C a => a -> a -> a
+) sig a
ds) sig v
delXs
       negXs :: sig v
negXs = 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 (forall (sig :: * -> *) y0 y1.
(Transform0 sig, Storage (sig y0), Storage (sig y1)) =>
(y0 -> y1) -> sig y0 -> sig y1
SigG.map (a
d0forall a. C a => a -> a -> a
-) sig a
ds) sig v
delXs
   in  forall v (sig :: * -> *). (C v, Transform sig v) => sig v -> sig v
Integration.run (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 =
   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 -> forall a. C a => a -> a
recip (a
2forall a. C a => a -> a -> a
*a
d) forall a v. C a v => a -> v -> v
*> v
y) sig a
ds forall a b. (a -> b) -> a -> b
$
   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