{-# 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,
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
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
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
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
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
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
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
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
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)
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)
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)
(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)
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
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)
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
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
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
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
<=))
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
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