{-# 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 =
   (y -> y -> y) -> y -> [y] -> y
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl y -> y -> y
forall a. Ord a => a -> a -> a
max y
forall a. C a => a
zero ([y] -> y) -> ([y] -> [y]) -> [y] -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [y] -> [y]
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 =
   y -> y
forall a. C a => a -> a
Algebraic.sqrt (y -> y) -> (T y -> y) -> T y -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T y -> y
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 =
   T y -> y
forall y. C y => T y -> y
average (T y -> y) -> (T y -> T y) -> T y -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (y -> y) -> T y -> T y
forall a b. (a -> b) -> [a] -> [b]
map y -> y
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 = T y -> y
forall y. C y => T y -> y
average (T y -> y) -> (T y -> T y) -> T y -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T y -> T y
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 =
   T yv -> y
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 =
   y -> y
forall a. C a => a -> a
Algebraic.sqrt (y -> y) -> (T yv -> y) -> T yv -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T yv -> y
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 =
   T y -> y
forall y. C y => T y -> y
average (T y -> y) -> (T yv -> T y) -> T yv -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (yv -> y) -> T yv -> T y
forall a b. (a -> b) -> [a] -> [b]
map yv -> y
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 =
   T y -> y
forall y. C y => T y -> y
average (T y -> y) -> (T yv -> T y) -> T yv -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (yv -> y) -> T yv -> T y
forall a b. (a -> b) -> [a] -> [b]
map yv -> y
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) =
   ((y, y) -> y -> (y, y)) -> (y, y) -> T y -> (y, y)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(y
minX,y
maxX) y
y -> (y -> y -> y
forall a. Ord a => a -> a -> a
min y
y y
minX, y -> y -> y
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 =
          (Int -> Int -> Int)
-> Int -> (Int, Int) -> [(Int, Int)] -> Array Int Int
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray Int -> Int -> Int
forall a. C a => a -> a -> a
(+) Int
forall a. C a => a
zero
             (T [] Int -> (Int, Int)
forall y. Ord y => T [] y -> (y, y)
bounds T [] Int
x) (T Int -> [(Int, Int)]
forall i. T i -> T (i, Int)
attachOne (T Int -> [(Int, Int)]) -> T Int -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ T [] Int -> T Int
forall (f :: * -> *) a. Cons f => T f a -> f a
NonEmpty.flatten T [] Int
x)
   in  ((Int, Int) -> Int
forall a b. (a, b) -> a
fst (Array Int Int -> (Int, Int)
forall i e. Array i e -> (i, i)
Array.bounds Array Int Int
hist), Array Int Int -> T Int
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 []) = (y -> Int
forall b. C b => y -> b
forall a b. (C a, C b) => a -> b
floor y
x, [])
histogramLinearArray T [] y
x =
   let (y
xMin,y
xMax) = T [] y -> (y, y)
forall y. Ord y => T [] y -> (y, y)
bounds T [] y
x
       hist :: Array Int y
hist =
          (y -> y -> y) -> y -> (Int, Int) -> [(Int, y)] -> Array Int y
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray y -> y -> y
forall a. C a => a -> a -> a
(+) y
forall a. C a => a
zero
             (y -> Int
forall b. C b => y -> b
forall a b. (C a, C b) => a -> b
floor y
xMin, y -> Int
forall b. C b => y -> b
forall a b. (C a, C b) => a -> b
floor y
xMax)
             (T [] y -> [(Int, y)]
forall y. C y => T [] y -> [(Int, y)]
meanValues T [] y
x)
   in  ((Int, Int) -> Int
forall a b. (a, b) -> a
fst (Array Int y -> (Int, Int)
forall i e. Array i e -> (i, i)
Array.bounds Array Int y
hist), Array Int y -> [y]
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 = (Int -> Int -> Int) -> [(Int, Int)] -> IntMap Int
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith Int -> Int -> Int
forall a. C a => a -> a -> a
(+) (T Int -> [(Int, Int)]
forall i. T i -> T (i, Int)
attachOne (T Int -> [(Int, Int)]) -> T Int -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ T [] Int -> T Int
forall (f :: * -> *) a. Cons f => T f a -> f a
NonEmpty.flatten T [] Int
x)
   in  case IntMap Int -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap Int
hist of
          [] -> [Char] -> (Int, T Int)
forall a. HasCallStack => [Char] -> a
error [Char]
"histogramDiscreteIntMap: the list was non-empty before processing ..."
          fAll :: [(Int, Int)]
fAll@((Int
fIndex,Int
fHead):[(Int, Int)]
fs) -> (Int
fIndex, Int
fHead Int -> T Int -> T Int
forall a. a -> [a] -> [a]
:
              [T Int] -> T Int
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((Int, Int) -> (Int, Int) -> T Int)
-> [(Int, Int)] -> [(Int, Int)] -> [T Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                 (\(Int
i0,Int
_) (Int
i1,Int
f1) -> Int -> Int -> T Int
forall a. Int -> a -> [a]
replicate (Int
i1Int -> Int -> Int
forall a. C a => a -> a -> a
-Int
i0Int -> Int -> Int
forall a. C a => a -> a -> a
-Int
1) Int
forall a. C a => a
zero T Int -> T Int -> T Int
forall a. [a] -> [a] -> [a]
++ [Int
f1])
                 [(Int, Int)]
fAll [(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 []) = (y -> Int
forall b. C b => y -> b
forall a b. (C a, C b) => a -> b
floor y
x, [])
histogramLinearIntMap T [] y
x =
   let hist :: IntMap y
hist = (y -> y -> y) -> [(Int, y)] -> IntMap y
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith y -> y -> y
forall a. C a => a -> a -> a
(+) (T [] y -> [(Int, y)]
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) = [(Int, y)] -> (T Int, [y])
forall a b. [(a, b)] -> ([a], [b])
unzip (IntMap y -> [(Int, y)]
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 (T [] Int -> (Int, T Int))
-> (T [] y -> T [] Int) -> T [] y -> (Int, T Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. y -> T [] y -> T [] Int
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 = (y -> Int) -> f y -> f Int
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (y -> Int
forall b. C b => y -> b
forall a b. (C a, C b) => a -> b
floor (y -> Int) -> (y -> y) -> y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (y
binsPerUnity -> y -> y
forall a. C a => a -> a -> a
*))

attachOne :: Sig.T i -> Sig.T (i,Int)
attachOne :: forall i. T i -> T (i, Int)
attachOne = (i -> (i, Int)) -> [i] -> [(i, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\i
i -> (i
i,Int
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 = ((y, y) -> [(Int, y)]) -> T (y, y) -> [(Int, y)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (y, y) -> [(Int, y)]
forall y. C y => (y, y) -> [(Int, y)]
spread (T (y, y) -> [(Int, y)])
-> (T [] y -> T (y, y)) -> T [] y -> [(Int, y)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (y -> y -> (y, y)) -> T [] y -> T (y, y)
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) = (y, y) -> (y, y)
forall a. Ord a => (a, a) -> (a, a)
sortPair (y, y)
lr0
       (Int
li,y
lf) = y -> (Int, y)
forall b. C b => y -> (b, y)
forall a b. (C a, C b) => a -> (b, a)
splitFraction y
l
       (Int
ri,y
rf) = y -> (Int, y)
forall b. C b => y -> (b, y)
forall a b. (C a, C b) => a -> (b, a)
splitFraction y
r
       k :: y
k = y -> y
forall a. C a => a -> a
recip (y
ry -> y -> y
forall a. C a => a -> a -> a
-y
l)
       nodes :: [(Int, y)]
nodes =
          (Int
li,y
ky -> y -> y
forall a. C a => a -> a -> a
*(y
1y -> y -> y
forall a. C a => a -> a -> a
-y
lf)) (Int, y) -> [(Int, y)] -> [(Int, y)]
forall a. a -> [a] -> [a]
:
          T Int -> [y] -> [(Int, y)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
liInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
1 ..] (Int -> y -> [y]
forall a. Int -> a -> [a]
replicate (Int
riInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
liInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
1) y
k) [(Int, y)] -> [(Int, y)] -> [(Int, y)]
forall a. [a] -> [a] -> [a]
++
          (Int
ri, y
ky -> y -> y
forall a. C a => a -> a -> a
*y
rf) (Int, y) -> [(Int, y)] -> [(Int, y)]
forall a. a -> [a] -> [a]
:
          []
   in  if Int
liInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
ri
         then [(Int
li,y
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 = T y -> y
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 =
   T y -> y
forall a. C a => [a] -> a
sum ((y -> y -> y) -> T y -> T y -> T y
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith y -> y -> y
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 =
   T y -> y
forall y. C y => T y -> y
firstMoment T y
xs y -> y -> y
forall a. C a => a -> a -> a
/ T y -> y
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 =
   T y -> y
forall a. C a => [a] -> a
sum ((y -> y -> y) -> y -> T y -> T y
forall a b. (a -> b -> b) -> b -> [a] -> [b]
scanr y -> y -> y
forall a. C a => a -> a -> a
(+) y
forall a. C a => a
zero (T y -> T y
forall a. HasCallStack => [a] -> [a]
tail T y
xs)) y -> y -> y
forall a. C a => a -> a -> a
/ T y -> y
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 =
   T y -> T y -> y
forall y. C y => T y -> T y -> y
scalarProduct ((y -> y) -> y -> T y
forall a. (a -> a) -> a -> [a]
iterate (y
forall a. C a => a
oney -> y -> y
forall a. C a => a -> a -> a
+) y
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 =
   T y -> y
forall a. C a => [a] -> a
sum T y
x y -> y -> y
forall a. C a => a -> a -> a
/ Int -> y
forall a b. (C a, C b) => a -> b
fromIntegral (T y -> Int
forall a. [a] -> Int
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 = (y -> y) -> [y] -> [y]
forall a b. (a -> b) -> [a] -> [b]
map y -> y
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 = (y -> Bool) -> T y -> T Bool
forall a b. (a -> b) -> [a] -> [b]
map (y -> y -> Bool
forall a. Ord a => a -> a -> Bool
>=y
forall a. C a => a
zero) T y
xs
   in  (Bool -> Bool -> Bool) -> T Bool -> T Bool -> T Bool
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(/=) T Bool
signs (T Bool -> T Bool
forall a. HasCallStack => [a] -> [a]
tail T Bool
signs)



data BinaryLevel = Low | High
   deriving (BinaryLevel -> BinaryLevel -> Bool
(BinaryLevel -> BinaryLevel -> Bool)
-> (BinaryLevel -> BinaryLevel -> Bool) -> Eq BinaryLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BinaryLevel -> BinaryLevel -> Bool
== :: BinaryLevel -> BinaryLevel -> Bool
$c/= :: BinaryLevel -> BinaryLevel -> Bool
/= :: BinaryLevel -> BinaryLevel -> Bool
Eq, Int -> BinaryLevel -> ShowS
[BinaryLevel] -> ShowS
BinaryLevel -> [Char]
(Int -> BinaryLevel -> ShowS)
-> (BinaryLevel -> [Char])
-> ([BinaryLevel] -> ShowS)
-> Show BinaryLevel
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BinaryLevel -> ShowS
showsPrec :: Int -> BinaryLevel -> ShowS
$cshow :: BinaryLevel -> [Char]
show :: BinaryLevel -> [Char]
$cshowList :: [BinaryLevel] -> ShowS
showList :: [BinaryLevel] -> ShowS
Show, Int -> BinaryLevel
BinaryLevel -> Int
BinaryLevel -> [BinaryLevel]
BinaryLevel -> BinaryLevel
BinaryLevel -> BinaryLevel -> [BinaryLevel]
BinaryLevel -> BinaryLevel -> BinaryLevel -> [BinaryLevel]
(BinaryLevel -> BinaryLevel)
-> (BinaryLevel -> BinaryLevel)
-> (Int -> BinaryLevel)
-> (BinaryLevel -> Int)
-> (BinaryLevel -> [BinaryLevel])
-> (BinaryLevel -> BinaryLevel -> [BinaryLevel])
-> (BinaryLevel -> BinaryLevel -> [BinaryLevel])
-> (BinaryLevel -> BinaryLevel -> BinaryLevel -> [BinaryLevel])
-> Enum 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
$csucc :: BinaryLevel -> BinaryLevel
succ :: BinaryLevel -> BinaryLevel
$cpred :: BinaryLevel -> BinaryLevel
pred :: BinaryLevel -> BinaryLevel
$ctoEnum :: Int -> BinaryLevel
toEnum :: Int -> BinaryLevel
$cfromEnum :: BinaryLevel -> Int
fromEnum :: BinaryLevel -> Int
$cenumFrom :: BinaryLevel -> [BinaryLevel]
enumFrom :: BinaryLevel -> [BinaryLevel]
$cenumFromThen :: BinaryLevel -> BinaryLevel -> [BinaryLevel]
enumFromThen :: BinaryLevel -> BinaryLevel -> [BinaryLevel]
$cenumFromTo :: BinaryLevel -> BinaryLevel -> [BinaryLevel]
enumFromTo :: BinaryLevel -> BinaryLevel -> [BinaryLevel]
$cenumFromThenTo :: BinaryLevel -> BinaryLevel -> BinaryLevel -> [BinaryLevel]
enumFromThenTo :: BinaryLevel -> BinaryLevel -> 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  = a -> a
forall a. C a => a -> a
negate a
forall a. C a => a
one
binaryLevelToNumber BinaryLevel
High =        a
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 = (BinaryLevel -> y -> BinaryLevel)
-> BinaryLevel -> [y] -> [BinaryLevel]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl ((y, y) -> BinaryLevel -> y -> BinaryLevel
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 (Bool -> BinaryLevel) -> Bool -> BinaryLevel
forall a b. (a -> b) -> a -> b
$
         case BinaryLevel
state of
            BinaryLevel
High -> Bool -> Bool
not(a
xa -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
lower)
            BinaryLevel
Low  -> a
xa -> a -> Bool
forall 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 =
   (T y -> y) -> [T y] -> T y
forall a b. (a -> b) -> [a] -> [b]
map (T y -> T y -> y
forall y. C y => T y -> T y -> y
scalarProduct T y
xs) ([T y] -> T y) -> [T y] -> T y
forall a b. (a -> b) -> a -> b
$
   (y -> T y) -> T y -> [T y]
forall a b. (a -> b) -> [a] -> [b]
map (\y
zn -> (y -> y -> y) -> y -> y -> T y
forall y. (y -> y -> y) -> y -> y -> T y
Ctrl.curveMultiscaleNeutral y -> y -> y
forall a. C a => a -> a -> a
(*) y
zn y
forall a. C a => a
one) (T y -> [T y]) -> T y -> [T y]
forall a b. (a -> b) -> a -> b
$
   (y -> y -> y) -> y -> y -> T y
forall y. (y -> y -> y) -> y -> y -> T y
Ctrl.curveMultiscaleNeutral y -> y -> y
forall a. C a => a -> a -> a
(*) y
z y
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 =
   (y -> BinaryLevel) -> [y] -> [BinaryLevel]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> BinaryLevel
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
<=))

{- |
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 = T y -> [BinaryLevel]
forall y. (Ord y, C y) => T y -> [BinaryLevel]
binarySign (T y -> T y
forall v. C v => T v -> T v
Integration.run (T y
x T y -> T y -> T y
forall a. C a => a -> a -> a
- (y
forall a. C a => a
zero y -> T y -> T y
forall a. a -> [a] -> [a]
: (BinaryLevel -> y) -> [BinaryLevel] -> T y
forall a b. (a -> b) -> [a] -> [b]
map BinaryLevel -> y
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 =
          (y -> y) -> T y -> T y
forall a b. (a -> b) -> [a] -> [b]
map (\y
xi -> if y
xiy -> y -> Bool
forall a. Ord a => a -> a -> Bool
>=y
threshold then y
threshold else y
forall a. C a => a
zero) (T y -> T y) -> T y -> T y
forall a b. (a -> b) -> a -> b
$
          T y -> T y
forall v. C v => T v -> T v
Integration.run (T y
x T y -> T y -> T y
forall a. C a => a -> a -> a
- (y
forall a. C a => a
zeroy -> T y -> T y
forall a. a -> [a] -> [a]
:T y
y))
   in  T y
y