{-# 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 =
   forall v. C v => T v -> T v
Integration.run (T v
xs forall a. C a => a -> a -> a
- 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) = 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 a. Int -> T a -> a
Sig.index Int
fromInt T v
xs
          Ordering
LT ->
            forall a. C a => T a -> a
Sig.sum forall a b. (a -> b) -> a -> b
$
            forall a b c. (a -> b -> c) -> T a -> T b -> T c
Sig.zipWith forall a. a -> a
id
               (((a
1forall a. C a => a -> a -> a
-a
fromFrac) forall a v. C a v => a -> v -> v
*>) forall a. a -> T a -> T a
`Sig.cons`
                forall a. Int -> a -> T a
Sig.replicate (Int
toIntforall a. C a => a -> a -> a
-Int
fromIntforall a. C a => a -> a -> a
-Int
1) forall a. a -> a
id forall a. T a -> T a -> T a
`Sig.append`
                forall a. a -> T a
Sig.singleton (a
toFrac forall a v. C a v => a -> v -> v
*>)) forall a b. (a -> b) -> a -> b
$
            forall a. Int -> T a -> T a
Sig.drop Int
fromInt T v
xs
          Ordering
GT ->
            forall a. C a => a -> a
negate forall a b. (a -> b) -> a -> b
$ forall a. C a => T a -> a
Sig.sum forall a b. (a -> b) -> a -> b
$
            forall a b c. (a -> b -> c) -> T a -> T b -> T c
Sig.zipWith forall a. a -> a
id
               (((a
1forall a. C a => a -> a -> a
-a
toFrac) forall a v. C a v => a -> v -> v
*>) forall a. a -> T a -> T a
`Sig.cons`
                forall a. Int -> a -> T a
Sig.replicate (Int
fromIntforall a. C a => a -> a -> a
-Int
toIntforall a. C a => a -> a -> a
-Int
1) forall a. a -> a
id forall a. T a -> T a -> T a
`Sig.append`
                forall a. a -> T a
Sig.singleton (a
fromFrac forall a v. C a v => a -> v -> v
*>)) forall a b. (a -> b) -> a -> b
$
            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 =
   forall y. T y -> T y
Sig.init forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   -- prevent negative d's since 'drop' cannot restore past values
   forall y0 y1 y2. (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2
Sig.zipWithTails (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a v. (C a, C a v) => a -> a -> T v -> v
sumFromToFrac)
       (forall a b. T a -> T b -> T (a, b)
Sig.zip (forall a. a -> T a -> T a
Sig.cons (a
dforall a. C a => a -> a -> a
+a
1) T a
ds) (forall a b. (a -> b) -> T a -> T b
Sig.map (a
1forall a. C a => a -> a -> a
+) T a
ds)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a. a -> T a -> T a
Sig.cons 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  = 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 :: T v
delXs = forall v. C v => Int -> T v -> T v
Delay.staticPos Int
maxDInt T v
xs
       posXs :: T v
posXs = forall a v. (C a, C a v) => a -> T a -> T v -> T v
sumDiffsModulated a
d0 (forall a b. (a -> b) -> T a -> T b
Sig.map (a
d0forall a. C a => a -> a -> a
+) T a
ds) T v
delXs
       negXs :: T v
negXs = forall a v. (C a, C a v) => a -> T a -> T v -> T v
sumDiffsModulated a
d0 (forall a b. (a -> b) -> T a -> T b
Sig.map (a
d0forall a. C a => a -> a -> a
-) T a
ds) T v
delXs
   in  forall v. C v => T v -> T v
Integration.run (T v
posXs 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 =
   forall a b c. (a -> b -> c) -> T a -> T b -> T c
Sig.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) T a
ds forall a b. (a -> b) -> a -> b
$
   forall a v. (C a, C a v) => Int -> T a -> T v -> T v
sumsModulatedHalf Int
maxDInt T a
ds T v
xs