{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Synthesizer.Plain.Analysis (
   volumeMaximum,
   volumeEuclidean,
   volumeEuclideanSqr,
   volumeSum,
   volumeVectorMaximum,
   volumeVectorEuclidean,
   volumeVectorEuclideanSqr,
   volumeVectorSum,
   bounds,
   histogramDiscreteArray,
   histogramLinearArray,
   histogramDiscreteIntMap,
   histogramLinearIntMap,
   histogramIntMap,
   directCurrentOffset,
   scalarProduct,
   centroid,
   centroidAlt,
   firstMoment,
   average,
   rectify,
   zeros,

   BinaryLevel(Low, High),
   binaryLevelFromBool,
   binaryLevelToNumber,
   flipFlopHysteresis,
   flipFlopHysteresisStep,
   chirpTransform,
   binarySign,
   deltaSigmaModulation,
   deltaSigmaModulationPositive,

   -- for testing
   spread,
   ) where

import qualified Synthesizer.Plain.Signal as Sig
import qualified Synthesizer.Plain.Control as Ctrl
import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integration

import qualified Data.NonEmpty as NonEmpty
import qualified Data.Array as Array
import qualified Data.IntMap as IntMap
import Data.Tuple.HT (sortPair)
import Data.Array (accumArray)
import Data.List (foldl', )

import qualified Algebra.Algebraic             as Algebraic
import qualified Algebra.RealField             as RealField
import qualified Algebra.Field                 as Field
import qualified Algebra.RealRing              as RealRing
import qualified Algebra.Absolute              as Absolute
import qualified Algebra.Ring                  as Ring
import qualified Algebra.Additive              as Additive

import qualified Algebra.NormedSpace.Maximum   as NormedMax
import qualified Algebra.NormedSpace.Euclidean as NormedEuc
import qualified Algebra.NormedSpace.Sum       as NormedSum

import NumericPrelude.Numeric
import NumericPrelude.Base


{- * Notions of volume -}

{- |
Volume based on Manhattan norm.
-}
volumeMaximum :: (RealRing.C y) => Sig.T y -> y
volumeMaximum :: forall y. C y => T y -> y
volumeMaximum =
   forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a. Ord a => a -> a -> a
max forall a. C a => a
zero forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall y. C y => T y -> T y
rectify
--   maximum . rectify

{- |
Volume based on Energy norm.
-}
volumeEuclidean :: (Algebraic.C y) => Sig.T y -> y
volumeEuclidean :: forall y. C y => T y -> y
volumeEuclidean =
   forall a. C a => a -> a
Algebraic.sqrt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall y. C y => T y -> y
volumeEuclideanSqr

volumeEuclideanSqr :: (Field.C y) => Sig.T y -> y
volumeEuclideanSqr :: forall y. C y => T y -> y
volumeEuclideanSqr =
   forall y. C y => T y -> y
average forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. C a => a -> a
sqr

{- |
Volume based on Sum norm.
-}
volumeSum :: (Absolute.C y, Field.C y) => Sig.T y -> y
volumeSum :: forall y. (C y, C y) => T y -> y
volumeSum = forall y. C y => T y -> y
average forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall y. C y => T y -> T y
rectify



{- |
Volume based on Manhattan norm.
-}
volumeVectorMaximum :: (NormedMax.C y yv, Ord y) => Sig.T yv -> y
volumeVectorMaximum :: forall y yv. (C y yv, Ord y) => T yv -> y
volumeVectorMaximum =
   forall a v. C a v => v -> a
NormedMax.norm
--   maximum . map NormedMax.norm

{- |
Volume based on Energy norm.
-}
volumeVectorEuclidean :: (Algebraic.C y, NormedEuc.C y yv) => Sig.T yv -> y
volumeVectorEuclidean :: forall y yv. (C y, C y yv) => T yv -> y
volumeVectorEuclidean =
   forall a. C a => a -> a
Algebraic.sqrt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall y yv. (C y, Sqr y yv) => T yv -> y
volumeVectorEuclideanSqr

volumeVectorEuclideanSqr :: (Field.C y, NormedEuc.Sqr y yv) => Sig.T yv -> y
volumeVectorEuclideanSqr :: forall y yv. (C y, Sqr y yv) => T yv -> y
volumeVectorEuclideanSqr =
   forall y. C y => T y -> y
average forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a v. Sqr a v => v -> a
NormedEuc.normSqr

{- |
Volume based on Sum norm.
-}
volumeVectorSum :: (NormedSum.C y yv, Field.C y) => Sig.T yv -> y
volumeVectorSum :: forall y yv. (C y yv, C y) => T yv -> y
volumeVectorSum =
   forall y. C y => T y -> y
average forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a v. C a v => v -> a
NormedSum.norm




{- |
Compute minimum and maximum value of the stream the efficient way.
Input list must be non-empty and finite.
-}
bounds :: Ord y => NonEmpty.T Sig.T y -> (y,y)
bounds :: forall y. Ord y => T [] y -> (y, y)
bounds (NonEmpty.Cons y
x T y
xs) =
   forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(y
minX,y
maxX) y
y -> (forall a. Ord a => a -> a -> a
min y
y y
minX, forall a. Ord a => a -> a -> a
max y
y y
maxX)) (y
x,y
x) T y
xs




{- * Miscellaneous -}

{-
histogram:
    length x = sum (histogramDiscrete x)

    units:
    1) histogram (amplify k x) = timestretch k (amplify (1/k) (histogram x))
    2) histogram (timestretch k x) = amplify k (histogram x)
    timestretch: k -> (s -> V) -> (k*s -> V)
    amplify:     k -> (s -> V) -> (s -> k*V)
    histogram:   (a -> b) -> (a^ia*b^ib -> a^ja*b^jb)
    x:           (s -> V)
    1) => (s^ia*(k*V)^ib -> s^ja*(k*V)^jb)
              = (s^ia*V^ib*k -> s^ja*V^jb/k)
       => ib=1, jb=-1
    2) => ((k*s)^ia*V^ib -> (k*s)^ja*V^jb)
              = (s^ia*V^ib -> s^ja*V^jb*k)
       => ia=0, ja=1
    histogram:   (s -> V) -> (V -> s/V)
histogram':
    integral (histogram' x) = integral x
    histogram' (amplify k x) = timestretch k (histogram' x)
    histogram' (timestretch k x) = amplify k (histogram' x)
     -> this does only apply if we slice the area horizontally
        and sum the slice up at each level,
        we must also restrict to the positive values,
        this is not quite the usual histogram
-}

{- |
Input list must be finite.
List is scanned twice, but counting may be faster.
-}
histogramDiscreteArray :: NonEmpty.T Sig.T Int -> (Int, Sig.T Int)
histogramDiscreteArray :: T [] Int -> (Int, T Int)
histogramDiscreteArray T [] Int
x =
   let hist :: Array Int Int
hist =
          forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray forall a. C a => a -> a -> a
(+) forall a. C a => a
zero
             (forall y. Ord y => T [] y -> (y, y)
bounds T [] Int
x) (forall i. T i -> T (i, Int)
attachOne forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Cons f => T f a -> f a
NonEmpty.flatten T [] Int
x)
   in  (forall a b. (a, b) -> a
fst (forall i e. Array i e -> (i, i)
Array.bounds Array Int Int
hist), forall i e. Array i e -> [e]
Array.elems Array Int Int
hist)


{- |
Input list must be finite.
If the input signal is empty, the offset is @undefined@.
List is scanned twice, but counting may be faster.
The sum of all histogram values is one less than the length of the signal.
-}
histogramLinearArray :: RealField.C y => NonEmpty.T Sig.T y -> (Int, Sig.T y)
histogramLinearArray :: forall y. C y => T [] y -> (Int, T y)
histogramLinearArray (NonEmpty.Cons y
x []) = (forall a b. (C a, C b) => a -> b
floor y
x, [])
histogramLinearArray T [] y
x =
   let (y
xMin,y
xMax) = forall y. Ord y => T [] y -> (y, y)
bounds T [] y
x
       hist :: Array Int y
hist =
          forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray forall a. C a => a -> a -> a
(+) forall a. C a => a
zero
             (forall a b. (C a, C b) => a -> b
floor y
xMin, forall a b. (C a, C b) => a -> b
floor y
xMax)
             (forall y. C y => T [] y -> [(Int, y)]
meanValues T [] y
x)
   in  (forall a b. (a, b) -> a
fst (forall i e. Array i e -> (i, i)
Array.bounds Array Int y
hist), forall i e. Array i e -> [e]
Array.elems Array Int y
hist)


{- |
Input list must be finite.
If the input signal is empty, the offset is @undefined@.
List is scanned once, counting may be slower.
-}
histogramDiscreteIntMap :: NonEmpty.T Sig.T Int -> (Int, Sig.T Int)
histogramDiscreteIntMap :: T [] Int -> (Int, T Int)
histogramDiscreteIntMap T [] Int
x =
   let hist :: IntMap Int
hist = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith forall a. C a => a -> a -> a
(+) (forall i. T i -> T (i, Int)
attachOne forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Cons f => T f a -> f a
NonEmpty.flatten T [] Int
x)
   in  case forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap Int
hist of
          [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"histogramDiscreteIntMap: the list was non-empty before processing ..."
          fAll :: T (Int, Int)
fAll@((Int
fIndex,Int
fHead):T (Int, Int)
fs) -> (Int
fIndex, Int
fHead forall a. a -> [a] -> [a]
:
              forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                 (\(Int
i0,Int
_) (Int
i1,Int
f1) -> forall a. Int -> a -> [a]
replicate (Int
i1forall a. C a => a -> a -> a
-Int
i0forall a. C a => a -> a -> a
-Int
1) forall a. C a => a
zero forall a. [a] -> [a] -> [a]
++ [Int
f1])
                 T (Int, Int)
fAll T (Int, Int)
fs))

histogramLinearIntMap :: RealField.C y => NonEmpty.T Sig.T y -> (Int, Sig.T y)
histogramLinearIntMap :: forall y. C y => T [] y -> (Int, T y)
histogramLinearIntMap (NonEmpty.Cons y
x []) = (forall a b. (C a, C b) => a -> b
floor y
x, [])
histogramLinearIntMap T [] y
x =
   let hist :: IntMap y
hist = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith forall a. C a => a -> a -> a
(+) (forall y. C y => T [] y -> [(Int, y)]
meanValues T [] y
x)
   -- we can rely on the fact that the keys are contiguous
       (Int
startKey:T Int
_, [y]
elems) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap y
hist)
   in  (Int
startKey, [y]
elems)
   -- This doesn't work, due to a bug in IntMap of GHC-6.4.1
   -- in  (head (IntMap.keys hist), IntMap.elems hist)

{-
The bug in IntMap GHC-6.4.1 is:

*Synthesizer.Plain.Analysis> IntMap.keys $ IntMap.fromList $ [(0,0),(-1,-1::Int)]
[0,-1]
*Synthesizer.Plain.Analysis> IntMap.elems $ IntMap.fromList $ [(0,0),(-1,-1::Int)]
[0,-1]
*Synthesizer.Plain.Analysis> IntMap.assocs $ IntMap.fromList $ [(0,0),(-1,-1::Int)]
[(0,0),(-1,-1)]

The bug has gone in IntMap as shipped with GHC-6.6.
-}

histogramIntMap :: (RealField.C y) => y -> NonEmpty.T Sig.T y -> (Int, Sig.T Int)
histogramIntMap :: forall y. C y => y -> T [] y -> (Int, T Int)
histogramIntMap y
binsPerUnit =
   T [] Int -> (Int, T Int)
histogramDiscreteIntMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) y. (Functor f, C y) => y -> f y -> f Int
quantize y
binsPerUnit

quantize :: (Functor f, RealField.C y) => y -> f y -> f Int
quantize :: forall (f :: * -> *) y. (Functor f, C y) => y -> f y -> f Int
quantize y
binsPerUnit = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (C a, C b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. (y
binsPerUnitforall a. C a => a -> a -> a
*))

attachOne :: Sig.T i -> Sig.T (i,Int)
attachOne :: forall i. T i -> T (i, Int)
attachOne = forall a b. (a -> b) -> [a] -> [b]
map (\i
i -> (i
i,forall a. C a => a
one))

meanValues :: RealField.C y => NonEmpty.T Sig.T y -> [(Int,y)]
meanValues :: forall y. C y => T [] y -> [(Int, y)]
meanValues = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall y. C y => (y, y) -> [(Int, y)]
spread forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
(a -> a -> b) -> T f a -> f b
NonEmpty.mapAdjacent (,)

spread :: RealField.C y => (y,y) -> [(Int,y)]
spread :: forall y. C y => (y, y) -> [(Int, y)]
spread (y, y)
lr0 =
   let (y
l,y
r) = forall a. Ord a => (a, a) -> (a, a)
sortPair (y, y)
lr0
       (Int
li,y
lf) = forall a b. (C a, C b) => a -> (b, a)
splitFraction y
l
       (Int
ri,y
rf) = forall a b. (C a, C b) => a -> (b, a)
splitFraction y
r
       k :: y
k = forall a. C a => a -> a
recip (y
rforall a. C a => a -> a -> a
-y
l)
       nodes :: [(Int, y)]
nodes =
          (Int
li,y
kforall a. C a => a -> a -> a
*(y
1forall a. C a => a -> a -> a
-y
lf)) forall a. a -> [a] -> [a]
:
          forall a b. [a] -> [b] -> [(a, b)]
zip [Int
liforall a. C a => a -> a -> a
+Int
1 ..] (forall a. Int -> a -> [a]
replicate (Int
riforall a. C a => a -> a -> a
-Int
liforall a. C a => a -> a -> a
-Int
1) y
k) forall a. [a] -> [a] -> [a]
++
          (Int
ri, y
kforall a. C a => a -> a -> a
*y
rf) forall a. a -> [a] -> [a]
:
          []
   in  if Int
liforall a. Eq a => a -> a -> Bool
==Int
ri
         then [(Int
li,forall a. C a => a
one)]
         else [(Int, y)]
nodes

{- |
Requires finite length.
This is identical to the arithmetic mean.
-}
directCurrentOffset :: Field.C y => Sig.T y -> y
directCurrentOffset :: forall y. C y => T y -> y
directCurrentOffset = forall y. C y => T y -> y
average


scalarProduct :: Ring.C y => Sig.T y -> Sig.T y -> y
scalarProduct :: forall y. C y => T y -> T y -> y
scalarProduct T y
xs T y
ys =
   forall a. C a => [a] -> a
sum (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. C a => a -> a -> a
(*) T y
xs T y
ys)

{- |
'directCurrentOffset' must be non-zero.
-}
centroid :: Field.C y => Sig.T y -> y
centroid :: forall y. C y => T y -> y
centroid T y
xs =
   forall y. C y => T y -> y
firstMoment T y
xs forall a. C a => a -> a -> a
/ forall a. C a => [a] -> a
sum T y
xs

centroidAlt :: Field.C y => Sig.T y -> y
centroidAlt :: forall y. C y => T y -> y
centroidAlt T y
xs =
   forall a. C a => [a] -> a
sum (forall a b. (a -> b -> b) -> b -> [a] -> [b]
scanr forall a. C a => a -> a -> a
(+) forall a. C a => a
zero (forall a. [a] -> [a]
tail T y
xs)) forall a. C a => a -> a -> a
/ forall a. C a => [a] -> a
sum T y
xs

firstMoment :: Ring.C y => Sig.T y -> y
firstMoment :: forall y. C y => T y -> y
firstMoment =
   forall y. C y => T y -> T y -> y
scalarProduct (forall a. (a -> a) -> a -> [a]
iterate (forall a. C a => a
oneforall a. C a => a -> a -> a
+) forall a. C a => a
zero)


average :: Field.C y => Sig.T y -> y
average :: forall y. C y => T y -> y
average T y
x =
   forall a. C a => [a] -> a
sum T y
x forall a. C a => a -> a -> a
/ forall a b. (C a, C b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length T y
x)

rectify :: Absolute.C y => Sig.T y -> Sig.T y
rectify :: forall y. C y => T y -> T y
rectify = forall a b. (a -> b) -> [a] -> [b]
map forall a. C a => a -> a
abs

{- |
Detects zeros (sign changes) in a signal.
This can be used as a simple measure of the portion
of high frequencies or noise in the signal.
It ca be used as voiced\/unvoiced detector in a vocoder.

@zeros x !! n@ is @True@ if and only if
@(x !! n >= 0) \/= (x !! (n+1) >= 0)@.
The result will be one value shorter than the input.
-}
zeros :: (Ord y, Ring.C y) => Sig.T y -> Sig.T Bool
zeros :: forall y. (Ord y, C y) => T y -> T Bool
zeros T y
xs =
   let signs :: T Bool
signs = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => a -> a -> Bool
>=forall a. C a => a
zero) T y
xs
   in  forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Eq a => a -> a -> Bool
(/=) T Bool
signs (forall a. [a] -> [a]
tail T Bool
signs)



data BinaryLevel = Low | High
   deriving (BinaryLevel -> BinaryLevel -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BinaryLevel -> BinaryLevel -> Bool
$c/= :: BinaryLevel -> BinaryLevel -> Bool
== :: BinaryLevel -> BinaryLevel -> Bool
$c== :: BinaryLevel -> BinaryLevel -> Bool
Eq, Int -> BinaryLevel -> ShowS
[BinaryLevel] -> ShowS
BinaryLevel -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BinaryLevel] -> ShowS
$cshowList :: [BinaryLevel] -> ShowS
show :: BinaryLevel -> [Char]
$cshow :: BinaryLevel -> [Char]
showsPrec :: Int -> BinaryLevel -> ShowS
$cshowsPrec :: Int -> BinaryLevel -> ShowS
Show, Int -> BinaryLevel
BinaryLevel -> Int
BinaryLevel -> [BinaryLevel]
BinaryLevel -> BinaryLevel
BinaryLevel -> BinaryLevel -> [BinaryLevel]
BinaryLevel -> BinaryLevel -> BinaryLevel -> [BinaryLevel]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: BinaryLevel -> BinaryLevel -> BinaryLevel -> [BinaryLevel]
$cenumFromThenTo :: BinaryLevel -> BinaryLevel -> BinaryLevel -> [BinaryLevel]
enumFromTo :: BinaryLevel -> BinaryLevel -> [BinaryLevel]
$cenumFromTo :: BinaryLevel -> BinaryLevel -> [BinaryLevel]
enumFromThen :: BinaryLevel -> BinaryLevel -> [BinaryLevel]
$cenumFromThen :: BinaryLevel -> BinaryLevel -> [BinaryLevel]
enumFrom :: BinaryLevel -> [BinaryLevel]
$cenumFrom :: BinaryLevel -> [BinaryLevel]
fromEnum :: BinaryLevel -> Int
$cfromEnum :: BinaryLevel -> Int
toEnum :: Int -> BinaryLevel
$ctoEnum :: Int -> BinaryLevel
pred :: BinaryLevel -> BinaryLevel
$cpred :: BinaryLevel -> BinaryLevel
succ :: BinaryLevel -> BinaryLevel
$csucc :: BinaryLevel -> BinaryLevel
Enum)

binaryLevelFromBool :: Bool -> BinaryLevel
binaryLevelFromBool :: Bool -> BinaryLevel
binaryLevelFromBool Bool
False = BinaryLevel
Low
binaryLevelFromBool Bool
True  = BinaryLevel
High

binaryLevelToNumber :: Ring.C a => BinaryLevel -> a
binaryLevelToNumber :: forall a. C a => BinaryLevel -> a
binaryLevelToNumber BinaryLevel
Low  = forall a. C a => a -> a
negate forall a. C a => a
one
binaryLevelToNumber BinaryLevel
High =        forall a. C a => a
one


{- |
Detect thresholds with a hysteresis.
-}
flipFlopHysteresis :: (Ord y) =>
   (y,y) -> BinaryLevel -> Sig.T y -> Sig.T BinaryLevel
flipFlopHysteresis :: forall y. Ord y => (y, y) -> BinaryLevel -> T y -> [BinaryLevel]
flipFlopHysteresis (y, y)
bnds = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (forall a. Ord a => (a, a) -> BinaryLevel -> a -> BinaryLevel
flipFlopHysteresisStep (y, y)
bnds)

flipFlopHysteresisStep :: Ord a => (a, a) -> BinaryLevel -> a -> BinaryLevel
flipFlopHysteresisStep :: forall a. Ord a => (a, a) -> BinaryLevel -> a -> BinaryLevel
flipFlopHysteresisStep (a
lower,a
upper) =
   \BinaryLevel
state a
x ->
      Bool -> BinaryLevel
binaryLevelFromBool forall a b. (a -> b) -> a -> b
$
         case BinaryLevel
state of
            BinaryLevel
High -> Bool -> Bool
not(a
xforall a. Ord a => a -> a -> Bool
<a
lower)
            BinaryLevel
Low  -> a
xforall a. Ord a => a -> a -> Bool
>a
upper

{- |
Almost naive implementation of the chirp transform,
a generalization of the Fourier transform.

More sophisticated algorithms like Rader, Cooley-Tukey, Winograd, Prime-Factor may follow.
-}
chirpTransform :: Ring.C y =>
   y -> Sig.T y -> Sig.T y
chirpTransform :: forall y. C y => y -> T y -> T y
chirpTransform y
z T y
xs =
   forall a b. (a -> b) -> [a] -> [b]
map (forall y. C y => T y -> T y -> y
scalarProduct T y
xs) forall a b. (a -> b) -> a -> b
$
   forall a b. (a -> b) -> [a] -> [b]
map (\y
zn -> forall y. (y -> y -> y) -> y -> y -> T y
Ctrl.curveMultiscaleNeutral forall a. C a => a -> a -> a
(*) y
zn forall a. C a => a
one) forall a b. (a -> b) -> a -> b
$
   forall y. (y -> y -> y) -> y -> y -> T y
Ctrl.curveMultiscaleNeutral forall a. C a => a -> a -> a
(*) y
z forall a. C a => a
one


binarySign ::
   (Ord y, Additive.C y) => Sig.T y -> Sig.T BinaryLevel
binarySign :: forall y. (Ord y, C y) => T y -> [BinaryLevel]
binarySign =
   forall a b. (a -> b) -> [a] -> [b]
map (Bool -> BinaryLevel
binaryLevelFromBool forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. C a => a
zero forall a. Ord a => a -> a -> Bool
<=))

{- |
A kind of discretization for signals with sample values between -1 and 1.
If you smooth the resulting signal
(after you transformed with 'map binaryLevelToNumber'),
you should obtain an approximation to the input signal.
-}
deltaSigmaModulation ::
   RealRing.C y => Sig.T y -> Sig.T BinaryLevel
deltaSigmaModulation :: forall y. C y => T y -> [BinaryLevel]
deltaSigmaModulation T y
x =
   let y :: [BinaryLevel]
y = forall y. (Ord y, C y) => T y -> [BinaryLevel]
binarySign (forall v. C v => T v -> T v
Integration.run (T y
x forall a. C a => a -> a -> a
- (forall a. C a => a
zero forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. C a => BinaryLevel -> a
binaryLevelToNumber [BinaryLevel]
y)))
   in  [BinaryLevel]
y
{-
   let y = binarySign (Integration.runInit zero (x - map binaryLevelToNumber y))
   in  y
-}

{- |
A kind of discretization for signals with sample values between 0 and a threshold.
We accumulate input values and emit a threshold value
whenever the accumulator exceeds the threshold.
This is intended for generating clicks from input noise.

See also 'deltaSigmaModulation'.
-}
deltaSigmaModulationPositive ::
   RealRing.C y => y -> Sig.T y -> Sig.T y
deltaSigmaModulationPositive :: forall y. C y => y -> T y -> T y
deltaSigmaModulationPositive y
threshold T y
x =
   let y :: T y
y =
          forall a b. (a -> b) -> [a] -> [b]
map (\y
xi -> if y
xiforall a. Ord a => a -> a -> Bool
>=y
threshold then y
threshold else forall a. C a => a
zero) forall a b. (a -> b) -> a -> b
$
          forall v. C v => T v -> T v
Integration.run (T y
x forall a. C a => a -> a -> a
- (forall a. C a => a
zeroforall a. a -> [a] -> [a]
:T y
y))
   in  T y
y