{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.Causal.Analysis where

import qualified Synthesizer.Causal.Filter.Recursive.Integration as Integration

import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Plain.Analysis as Ana

import qualified Algebra.RealRing              as RealRing

import Control.Arrow (second, (^<<), (<<^), )

import qualified Data.Map as Map

import NumericPrelude.Numeric
import NumericPrelude.Base


flipFlopHysteresis ::
   (Ord y) => (y,y) -> Ana.BinaryLevel -> Causal.T y Ana.BinaryLevel
flipFlopHysteresis :: forall y. Ord y => (y, y) -> BinaryLevel -> T y BinaryLevel
flipFlopHysteresis (y, y)
bnds = (BinaryLevel -> y -> BinaryLevel) -> BinaryLevel -> T y BinaryLevel
forall acc x. (acc -> x -> acc) -> acc -> T x acc
Causal.scanL ((y, y) -> BinaryLevel -> y -> BinaryLevel
forall a. Ord a => (a, a) -> BinaryLevel -> a -> BinaryLevel
Ana.flipFlopHysteresisStep (y, y)
bnds)

deltaSigmaModulation ::
   RealRing.C y => Causal.T y Ana.BinaryLevel
deltaSigmaModulation :: forall y. C y => T y BinaryLevel
deltaSigmaModulation =
   T (y, y) BinaryLevel -> T BinaryLevel y -> T y BinaryLevel
forall a c b. T (a, c) b -> T b c -> T a b
Causal.feedback
      ((Bool -> BinaryLevel
Ana.binaryLevelFromBool (Bool -> BinaryLevel) -> (y -> Bool) -> y -> BinaryLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (y
forall a. C a => a
zero y -> y -> Bool
forall a. Ord a => a -> a -> Bool
<=)) (y -> BinaryLevel) -> T (y, y) y -> T (y, y) BinaryLevel
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
       T y y
forall v. C v => T v v
Integration.run T y y -> ((y, y) -> y) -> T (y, y) y
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^
       (y -> y -> y) -> (y, y) -> y
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (-))
      (y -> T y y
forall x. x -> T x x
Causal.consInit y
forall a. C a => a
zero T y y -> (BinaryLevel -> y) -> T BinaryLevel y
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^ BinaryLevel -> y
forall a. C a => BinaryLevel -> a
Ana.binaryLevelToNumber)

deltaSigmaModulationPositive ::
   RealRing.C y => Causal.T (y, y) y
deltaSigmaModulationPositive :: forall y. C y => T (y, y) y
deltaSigmaModulationPositive =
   T ((y, y), y) y -> T y y -> T (y, y) y
forall a c b. T (a, c) b -> T b c -> T a b
Causal.feedback
      ((\(y
threshold,y
xi) -> if y
thresholdy -> y -> Bool
forall a. Ord a => a -> a -> Bool
<=y
xi then y
threshold else y
forall a. C a => a
zero) ((y, y) -> y) -> T ((y, y), y) (y, y) -> T ((y, y), y) y
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
       T y y -> T (y, y) (y, y)
forall b c d. T b c -> T (d, b) (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second T y y
forall v. C v => T v v
Integration.run T (y, y) (y, y) -> (((y, y), y) -> (y, y)) -> T ((y, y), y) (y, y)
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^
       (\((y
threshold,y
xi),y
cum) -> (y
threshold,y
xiy -> y -> y
forall a. C a => a -> a -> a
-y
cum)))
      (y -> T y y
forall x. x -> T x x
Causal.consInit y
forall a. C a => a
zero)


{-
Abuse (Map a ()) as (Set a),
because in GHC-7.4.2 there is no Set.elemAt function.
-}
movingMedian :: (Ord a) => Int -> Causal.T a a
movingMedian :: forall a. Ord a => Int -> T a a
movingMedian Int
n =
   (a
 -> (Int, Map Int a, Map (a, Int) ())
 -> (a, (Int, Map Int a, Map (a, Int) ())))
-> (Int, Map Int a, Map (a, Int) ()) -> T a a
forall x acc y. (x -> acc -> (y, acc)) -> acc -> T x y
Causal.mapAccumL
      (\a
new (Int
k,Map Int a
queue,Map (a, Int) ()
oldSet) ->
         let set :: Map (a, Int) ()
set =
               (a, Int) -> () -> Map (a, Int) () -> Map (a, Int) ()
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (a
new,Int
k) () (Map (a, Int) () -> Map (a, Int) ())
-> Map (a, Int) () -> Map (a, Int) ()
forall a b. (a -> b) -> a -> b
$
               (Map (a, Int) () -> Map (a, Int) ())
-> (a -> Map (a, Int) () -> Map (a, Int) ())
-> Maybe a
-> Map (a, Int) ()
-> Map (a, Int) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map (a, Int) () -> Map (a, Int) ()
forall a. a -> a
id (\a
old -> (a, Int) -> Map (a, Int) () -> Map (a, Int) ()
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (a
old,Int
k)) (Int -> Map Int a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
k Map Int a
queue) Map (a, Int) ()
oldSet
         in  ((a, Int) -> a
forall a b. (a, b) -> a
fst ((a, Int) -> a) -> (a, Int) -> a
forall a b. (a -> b) -> a -> b
$ ((a, Int), ()) -> (a, Int)
forall a b. (a, b) -> a
fst (((a, Int), ()) -> (a, Int)) -> ((a, Int), ()) -> (a, Int)
forall a b. (a -> b) -> a -> b
$ Int -> Map (a, Int) () -> ((a, Int), ())
forall k a. Int -> Map k a -> (k, a)
Map.elemAt (Int -> Int -> Int
forall a. C a => a -> a -> a
div (Map (a, Int) () -> Int
forall k a. Map k a -> Int
Map.size Map (a, Int) ()
set) Int
2) Map (a, Int) ()
set,
              (Int -> Int -> Int
forall a. C a => a -> a -> a
mod (Int
kInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
1) Int
n, Int -> a -> Map Int a -> Map Int a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
k a
new Map Int a
queue, Map (a, Int) ()
set)))
      (Int
0, Map Int a
forall k a. Map k a
Map.empty, Map (a, Int) ()
forall k a. Map k a
Map.empty)