module Synthesizer.Plain.Analysis 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 Algebra.Algebraic as Algebraic
import qualified Algebra.RealField as RealField
import qualified Algebra.Field as Field
import qualified Algebra.Real as Real
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 qualified Data.Array as Array
import qualified Data.IntMap as IntMap
import Data.Array (accumArray)
import Data.List (foldl', )
import qualified Prelude as P
import PreludeBase
import NumericPrelude
volumeMaximum :: (Real.C y) => Sig.T y -> y
volumeMaximum =
foldl max zero . rectify
volumeEuclidean :: (Algebraic.C y) => Sig.T y -> y
volumeEuclidean =
Algebraic.sqrt . volumeEuclideanSqr
volumeEuclideanSqr :: (Field.C y) => Sig.T y -> y
volumeEuclideanSqr =
average . map sqr
volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y
volumeSum = average . rectify
volumeVectorMaximum :: (NormedMax.C y yv, Ord y) => Sig.T yv -> y
volumeVectorMaximum =
NormedMax.norm
volumeVectorEuclidean :: (Algebraic.C y, NormedEuc.C y yv) => Sig.T yv -> y
volumeVectorEuclidean =
Algebraic.sqrt . volumeVectorEuclideanSqr
volumeVectorEuclideanSqr :: (Field.C y, NormedEuc.Sqr y yv) => Sig.T yv -> y
volumeVectorEuclideanSqr =
average . map NormedEuc.normSqr
volumeVectorSum :: (NormedSum.C y yv, Field.C y) => Sig.T yv -> y
volumeVectorSum =
average . map NormedSum.norm
bounds :: Ord y => Sig.T y -> (y,y)
bounds [] = error "Analysis.bounds: List must contain at least one element."
bounds (x:xs) =
foldl' (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs
histogramDiscreteArray :: Sig.T Int -> (Int, Sig.T Int)
histogramDiscreteArray [] =
(error "histogramDiscreteArray: no bounds found", [])
histogramDiscreteArray x =
let hist =
accumArray (+) zero
(bounds x) (attachOne x)
in (fst (Array.bounds hist), Array.elems hist)
histogramLinearArray :: RealField.C y => Sig.T y -> (Int, Sig.T y)
histogramLinearArray [] =
(error "histogramLinearArray: no bounds found", [])
histogramLinearArray [x] = (floor x, [])
histogramLinearArray x =
let (xMin,xMax) = bounds x
hist =
accumArray (+) zero
(floor xMin, floor xMax)
(meanValues x)
in (fst (Array.bounds hist), Array.elems hist)
histogramDiscreteIntMap :: Sig.T Int -> (Int, Sig.T Int)
histogramDiscreteIntMap [] =
(error "histogramDiscreteIntMap: no bounds found", [])
histogramDiscreteIntMap x =
let hist = IntMap.fromListWith (+) (attachOne x)
in case IntMap.toAscList hist of
[] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..."
fAll@((fIndex,fHead):fs) -> (fIndex, fHead :
concat (zipWith
(\(i0,_) (i1,f1) -> replicate (i1i01) zero ++ [f1])
fAll fs))
histogramLinearIntMap :: RealField.C y => Sig.T y -> (Int, Sig.T y)
histogramLinearIntMap [] =
(error "histogramLinearIntMap: no bounds found", [])
histogramLinearIntMap [x] = (floor x, [])
histogramLinearIntMap x =
let hist = IntMap.fromListWith (+) (meanValues x)
(startKey:_, elems) = unzip (IntMap.toAscList hist)
in (startKey, elems)
histogramIntMap :: (RealField.C y) => y -> Sig.T y -> (Int, Sig.T Int)
histogramIntMap binsPerUnit =
histogramDiscreteIntMap . quantize binsPerUnit
quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int
quantize binsPerUnit = map (floor . (binsPerUnit*))
attachOne :: Sig.T i -> Sig.T (i,Int)
attachOne = map (\i -> (i,one))
meanValues :: RealField.C y => Sig.T y -> [(Int,y)]
meanValues x = concatMap spread (zip x (tail x))
spread :: RealField.C y => (y,y) -> [(Int,y)]
spread (l0,r0) =
let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0)
(li,lf) = splitFraction l
(ri,rf) = splitFraction r
k = recip (rl)
nodes =
(li,k*(1lf)) :
zip [li+1 ..] (replicate (rili1) k) ++
(ri, k*rf) :
[]
in if li==ri
then [(li,one)]
else nodes
directCurrentOffset :: Field.C y => Sig.T y -> y
directCurrentOffset = average
scalarProduct :: Ring.C y => Sig.T y -> Sig.T y -> y
scalarProduct xs ys =
sum (zipWith (*) xs ys)
centroid :: Field.C y => Sig.T y -> y
centroid xs =
scalarProduct (iterate (one+) zero) xs / sum xs
centroidAlt :: Field.C y => Sig.T y -> y
centroidAlt xs =
sum (scanr (+) zero (tail xs)) / sum xs
average :: Field.C y => Sig.T y -> y
average x =
sum x / fromIntegral (length x)
rectify :: Real.C y => Sig.T y -> Sig.T y
rectify = map abs
zeros :: (Ord y, Ring.C y) => Sig.T y -> Sig.T Bool
zeros xs =
let signs = map (>=zero) xs
in zipWith (/=) signs (tail signs)
data BinaryLevel = Low | High
deriving (Eq, Show, Enum)
binaryLevelFromBool :: Bool -> BinaryLevel
binaryLevelFromBool False = Low
binaryLevelFromBool True = High
binaryLevelToNumber :: Ring.C a => BinaryLevel -> a
binaryLevelToNumber Low = negate one
binaryLevelToNumber High = one
flipFlopHysteresis :: (Ord y) =>
(y,y) -> BinaryLevel -> Sig.T y -> Sig.T BinaryLevel
flipFlopHysteresis (lower,upper) =
scanl
(\state x -> binaryLevelFromBool $
case state of
High -> not(x<lower)
Low -> x>upper)
chirpTransform :: Ring.C y =>
y -> Sig.T y -> Sig.T y
chirpTransform z xs =
let powers = Ctrl.curveMultiscaleNeutral (*) z one
powerPowers =
map (\zn -> Ctrl.curveMultiscaleNeutral (*) zn one) powers
in map (scalarProduct xs) powerPowers
binarySign :: Real.C y => Sig.T y -> Sig.T BinaryLevel
binarySign =
map (binaryLevelFromBool . (zero <=))
deltaSigmaModulation :: Real.C y => Sig.T y -> Sig.T BinaryLevel
deltaSigmaModulation x =
let y = binarySign (Integration.runInit zero (x map binaryLevelToNumber y))
in y