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

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

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

import qualified Synthesizer.State.Signal  as Sig
import qualified Synthesizer.State.Filter.Recursive.Integration as Integration

import qualified Synthesizer.State.Filter.Delay as Delay

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.State.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) => Int -> Sig.T v -> Sig.T v
sumsStaticInt :: forall v. C v => Int -> T v -> T v
sumsStaticInt Int
n T v
xs =
   T v -> T v
forall v. C v => T v -> T v
Integration.run (T v
xs T v -> T v -> T v
forall a. C a => a -> a -> a
- Int -> T v -> T v
forall v. C v => Int -> T v -> T v
Delay.staticPos Int
n T v
xs)

{-
staticInt :: (Module.C a v, Additive.C v) => Int -> Sig.T v -> Sig.T v
staticInt n xs =
-}


{-
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

sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T 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) => a -> a -> Sig.T v -> v
sumFromToFrac :: forall a v. (C a, C a v) => a -> a -> T v -> v
sumFromToFrac a
from a
to T 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
*> Int -> T v -> v
forall a. Int -> T a -> a
Sig.index Int
fromInt T v
xs
          Ordering
LT ->
            T v -> v
forall a. C a => T a -> a
Sig.sum (T v -> v) -> T v -> v
forall a b. (a -> b) -> a -> b
$
            ((v -> v) -> v -> v) -> T (v -> v) -> T v -> T v
forall a b c. (a -> b -> c) -> T a -> T b -> T c
Sig.zipWith (v -> v) -> v -> v
forall a. a -> a
id
               (((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 -> v) -> T (v -> v) -> T (v -> v)
forall a. a -> T a -> T a
`Sig.cons`
                Int -> (v -> v) -> T (v -> v)
forall a. Int -> a -> T a
Sig.replicate (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
forall a. a -> a
id T (v -> v) -> T (v -> v) -> T (v -> v)
forall a. T a -> T a -> T a
`Sig.append`
                (v -> v) -> T (v -> v)
forall a. a -> T a
Sig.singleton (a
toFrac a -> v -> v
forall a v. C a v => a -> v -> v
*>)) (T v -> T v) -> T v -> T v
forall a b. (a -> b) -> a -> b
$
            Int -> T v -> T v
forall a. Int -> T a -> T a
Sig.drop Int
fromInt T v
xs
          Ordering
GT ->
            v -> v
forall a. C a => a -> a
negate (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$ T v -> v
forall a. C a => T a -> a
Sig.sum (T v -> v) -> T v -> v
forall a b. (a -> b) -> a -> b
$
            ((v -> v) -> v -> v) -> T (v -> v) -> T v -> T v
forall a b c. (a -> b -> c) -> T a -> T b -> T c
Sig.zipWith (v -> v) -> v -> v
forall a. a -> a
id
               (((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 -> v) -> T (v -> v) -> T (v -> v)
forall a. a -> T a -> T a
`Sig.cons`
                Int -> (v -> v) -> T (v -> v)
forall a. Int -> a -> T a
Sig.replicate (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
forall a. a -> a
id T (v -> v) -> T (v -> v) -> T (v -> v)
forall a. T a -> T a -> T a
`Sig.append`
                (v -> v) -> T (v -> v)
forall a. a -> T a
Sig.singleton (a
fromFrac a -> v -> v
forall a v. C a v => a -> v -> v
*>)) (T v -> T v) -> T v -> T v
forall a b. (a -> b) -> a -> b
$
            Int -> T v -> T v
forall a. Int -> T a -> T a
Sig.drop Int
toInt T v
xs


{-
            run $
               addNextWeighted (1-toFrac) >>
               replicateM_ (fromInt-toInt-1) addNext >>
               addNextWeighted (fromFrac)

type Accumulator v a =
   WriterT (Dual (Endo v)) (StateT (Sig.T v) Maybe a)

getNext :: Accumulator v a
getNext =
   lift $ StateT $ ListHT.viewL

addAccum :: Additive.C v => v -> Accumulator v ()
addAccum x = tell ((x+) $!)

addNext :: Additive.C v => Accumulator v ()
addNext w =
   addAccum =<< getNext

addNextWeighted :: Module.C a v => a -> Accumulator v ()
addNextWeighted w =
   addAccum . (w *>) =<< getNext
-}

{-
newtype Accumulator v =
   Accumulator ((v, Sig.T v) -> v -> (Sig.T v, v))

addNext :: Additive.C v => Accumulator v
addNext =
   Accumulator $ \(x,xs) s -> (xs, x+s)

addNextWeighted :: Module.C a v => a -> Accumulator v
addNextWeighted a =
   Accumulator $ \(x,xs) s -> (xs, a*>x + s)

bindAccum :: Accumulator v -> Accumulator v -> Accumulator v
bindAccum (Accumulator f) (Accumulator g) =
   Accumulator $ \x s0 ->
      let (ys,s1) = f x s0
      in  maybe s1 () (ListHT.viewL ys)
-}


{- |
Sig.T a must contain only non-negative elements.
-}
{-# INLINE sumDiffsModulated #-}
sumDiffsModulated :: (RealField.C a, Module.C a v) =>
   a -> Sig.T a -> Sig.T v -> Sig.T v
sumDiffsModulated :: forall a v. (C a, C a v) => a -> T a -> T v -> T v
sumDiffsModulated a
d T a
ds =
   T v -> T v
forall y. T y -> T y
Sig.init (T v -> T v) -> (T v -> T v) -> T v -> T v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   -- prevent negative d's since 'drop' cannot restore past values
   ((a, a) -> T v -> v) -> T (a, a) -> T v -> T v
forall y0 y1 y2. (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2
Sig.zipWithTails ((a -> a -> T v -> v) -> (a, a) -> T v -> v
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> T v -> v
forall a v. (C a, C a v) => a -> a -> T v -> v
sumFromToFrac)
       (T a -> T a -> T (a, a)
forall a b. T a -> T b -> T (a, b)
Sig.zip (a -> T a -> T a
forall a. a -> T a -> T a
Sig.cons (a
da -> a -> a
forall a. C a => a -> a -> a
+a
1) T a
ds) ((a -> a) -> T a -> T a
forall a b. (a -> b) -> T a -> T b
Sig.map (a
1a -> a -> a
forall a. C a => a -> a -> a
+) T a
ds)) (T v -> T v) -> (T v -> T v) -> T v -> T v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   v -> T v -> T v
forall a. a -> T a -> T a
Sig.cons v
forall a. C a => a
zero
{-
   Sig.zipWithTails (uncurry sumFromToFrac)
      (Sig.zip (Sig.cons d (Sig.map (subtract 1) ds)) ds)
-}

{-
sumsModulated :: (RealField.C a, Module.C a v) =>
   Int -> Sig.T a -> Sig.T v -> Sig.T v
sumsModulated maxDInt ds xs =
   let maxD  = fromIntegral maxDInt
       posXs = sumDiffsModulated 0 ds xs
       negXs = sumDiffsModulated maxD (Sig.map (maxD-) ds) (Delay.static maxDInt xs)
   in  Integration.run (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) =>
   Int -> Sig.T a -> Sig.T v -> Sig.T v
sumsModulatedHalf :: forall a v. (C a, C a v) => Int -> T a -> T v -> T v
sumsModulatedHalf Int
maxDInt T a
ds T 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 :: T v
delXs = Int -> T v -> T v
forall v. C v => Int -> T v -> T v
Delay.staticPos Int
maxDInt T v
xs
       posXs :: T v
posXs = a -> T a -> T v -> T v
forall a v. (C a, C a v) => a -> T a -> T v -> T v
sumDiffsModulated a
d0 ((a -> a) -> T a -> T a
forall a b. (a -> b) -> T a -> T b
Sig.map (a
d0a -> a -> a
forall a. C a => a -> a -> a
+) T a
ds) T v
delXs
       negXs :: T v
negXs = a -> T a -> T v -> T v
forall a v. (C a, C a v) => a -> T a -> T v -> T v
sumDiffsModulated a
d0 ((a -> a) -> T a -> T a
forall a b. (a -> b) -> T a -> T b
Sig.map (a
d0a -> a -> a
forall a. C a => a -> a -> a
-) T a
ds) T v
delXs
   in  T v -> T v
forall v. C v => T v -> T v
Integration.run (T v
posXs T v -> T v -> T v
forall a. C a => a -> a -> a
- T v
negXs)

{-# INLINE modulatedFrac #-}
modulatedFrac :: (RealField.C a, Module.C a v) =>
   Int -> Sig.T a -> Sig.T v -> Sig.T v
modulatedFrac :: forall a v. (C a, C a v) => Int -> T a -> T v -> T v
modulatedFrac Int
maxDInt T a
ds T v
xs =
   (a -> v -> v) -> T a -> T v -> T v
forall a b c. (a -> b -> c) -> T a -> T b -> T c
Sig.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) T a
ds (T v -> T v) -> T v -> T v
forall a b. (a -> b) -> a -> b
$
   Int -> T a -> T v -> T v
forall a v. (C a, C a v) => Int -> T a -> T v -> T v
sumsModulatedHalf Int
maxDInt T a
ds T v
xs