{-# LANGUAGE RebindableSyntax #-} module Feature ( Class(..), lowRateSqrt, dictionaryMerged, HMM(..), readHMM, writeHMM, hmmHardwired, ) where import qualified HiddenMarkovModel.Hardwired as HMMHard import qualified HiddenMarkovModel as HMM import qualified Math.HiddenMarkovModel.Named as HMMNamed import qualified Evaluation import qualified LabelChain import qualified LabelChainShifted import qualified LabelTrack import qualified Label import qualified Signal import qualified Rate import qualified Named import qualified Class import qualified Parameters as Params import Parameters (Freq(Freq), formatFreq, Time(Time), timeCeil, ) import qualified SignalProcessingMethods as SPMethods import qualified SignalProcessingSpecific as SPS import SignalProcessingSpecific (bandEnvelopes, bandEnvelopesLowRate, dehum, ) import SignalProcessing (differentiate, differentiateMin3, differentiateMin3Init, bandpass, lowpassTwoPass, centroidVariance3, downSampleMax, downSampleMaxFrac, sliceOverlapping, ) import qualified Synthesizer.Generic.Signal as SigG import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.Basic.Binary as Bin import qualified Data.StorableVector.Lazy as SVL import qualified Control.Monad.Exception.Synchronous as ME import qualified Control.Functor.HT as FuncHT import Control.Arrow ((^<<), (<<^), ) import Control.Monad (liftM2, ) import Control.Applicative ((<$>), ) import qualified Data.List.Reverse.StrictElement as Rev import qualified Data.List.HT as ListHT import qualified Data.List as List import qualified Data.Char as Char import Data.Map (Map, ); import qualified Data.Map as Map import Data.Set (Set, ); import qualified Data.Set as Set import Data.Bool.HT (if', ) import Data.Maybe (isJust, ) import qualified System.Path.PartClass as PathClass import qualified System.Path.IO as PathIO import qualified System.Path as Path import qualified Text.CSV.Lazy.String as CSV import Text.Printf (printf, ) import NumericPrelude.Numeric import NumericPrelude.Base data Class = Class { name :: [String], signals :: SPMethods.T -> Signal.Sox -> Signal.T Rate.Feature [Named.Signal], scale :: [Float], fineSnappedFromCoarseIntervals :: Params.T -> Rate.Feature -> Signal.Sox -> LabelTrack.T Double Class.SoundParsed -> ME.Exceptional String (LabelChain.T Int String), evaluateFromIntervals :: SPMethods.T -> Params.T -> Signal.SoxLabelled String -> Evaluation.Result, admissibleTransitions :: Set (String, String) } bandName :: [String] bandName = ["band", "1200Hz", "2000Hz"] highRate :: Class highRate = Class { name = bandName ++ ["high rate"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = repeat 0.1, signals = \_methods sig@(Signal.Cons rate _) -> let (_volume, (relEnv12, relEnv20, _relEnv40)) = bandEnvelopes sig in Signal.Cons (Rate.featureFromSample rate) [relEnv12, relEnv20] } data HMM = HMM { hmmClass :: Class, hmmodel :: HMM.NamedGaussian } hmmHardwired :: HMM hmmHardwired = HMM { hmmClass = Class { name = ["band", "2000Hz"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = repeat 0.1, signals = \_methods sig@(Signal.Cons rate _) -> let (_volume, (_relEnv12, relEnv20, _relEnv40)) = bandEnvelopes sig in Signal.Cons (Rate.featureFromSample rate) [relEnv20] }, hmmodel = HMMHard.hmmNamed } reduceSampleRate :: Int -> Rate.Feature -> Rate.Feature reduceSampleRate k (Rate.Feature rate) = Rate.Feature $ rate / fromIntegral k formatRate :: Rate.Feature -> String formatRate = printf "%.0fHz" . Rate.unpack lowRate :: Rate.Feature -> Class lowRate rate = Class { name = bandName ++ ["low rate", formatRate rate], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = repeat 0.1, signals = \_methods sig -> let (_volume, (relEnv12, relEnv20, _relEnv40)) = bandEnvelopesLowRate rate sig in Signal.Cons rate [relEnv12, relEnv20] } {- | Computes the square root of all values in order to compress high values and expand low values. This way the emission clusters better fit to the normal distribution. -} lowRateSqrt :: Rate.Feature -> Class lowRateSqrt rate = Class { name = bandName ++ ["low rate", formatRate rate, "sqrt"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsEnv, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = repeat (1/3), signals = \_methods sig -> let (_volume, (relEnv12, relEnv20, _relEnv40)) = bandEnvelopesLowRate rate sig in Signal.Cons rate $ map (fmap (SVL.map sqrt)) [relEnv12, relEnv20] } attackSignal :: Rate.Feature -> Signal.Sox -> (Named.Signal, Named.Signal, Named.Signal, (Named.Signal, Named.Signal), (Named.Signal, Named.Signal)) attackSignal featRate sig = let rate = Signal.sampleRate sig dehummed = Causal.apply (dehum rate <<^ Bin.toCanonical) $ Signal.body sig envelope = downSampleMaxFrac (Rate.ratio rate featRate) $ SVL.map abs dehummed volFreq = Freq 20 volume = lowpassTwoPass featRate volFreq envelope relEnv = SVL.zipWith (/) envelope volume relEnvDiff = Causal.apply differentiate relEnv band bandFreq = lowpassTwoPass featRate volFreq $ downSampleMaxFrac (Rate.ratio rate featRate) $ Causal.apply (abs ^<< bandpass rate 10 bandFreq) dehummed relEnvBand f = Named.Cons ("band " ++ formatFreq f) $ SVL.zipWith (/) (band f) volume g0 = 1200; g1 = 2000 centroid = SVL.zipWith (\x0 x1 -> ((g0*x0 + g1*x1) / (x0+x1) * 2 - (g0+g1)) / (g1-g0)) (band (Freq g0)) (band (Freq g1)) f0 = 1000; f1 = 2500; f2 = 4000 spread = SVL.zipWith3 (\x0 x1 x2 -> snd (centroidVariance3 (f0,x0) (f1,x1) (f2,x2)) * (2 / (f2-f0))^2) (band (Freq f0)) (band (Freq f1)) (band (Freq f2)) in (Named.Cons "envelope" relEnv, Named.Cons "differentiated envelope" relEnvDiff, Named.Cons "variance of envelope" $ lowpassTwoPass featRate volFreq $ SVL.map abs relEnvDiff, (relEnvBand $ Freq 1200, relEnvBand $ Freq 2000), (Named.Cons "centroid" centroid, Named.Cons "spread" spread)) attacks :: Rate.Feature -> Class attacks rate = Class { name = ["attacks", formatRate rate], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsDiff, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [1/2, 1], signals = \_methods sig -> let (_relEnv, relEnvDiff, variance, _relVol, _spectral) = attackSignal rate sig in Signal.Cons rate [relEnvDiff, variance] } attacksClipped :: Rate.Feature -> Class attacksClipped rate = Class { name = ["attacks", formatRate rate, "clipped"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsDiff, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [1, 1], signals = \_methods sig -> let (_relEnv, relEnvDiff, variance, _relVol, _spectral) = attackSignal rate sig -- (limit (0,1)) would cause a singular matrix in unsupervised training softLimit x = if' (x<0) (x/10) $ if' (x>1) ((x+9)/10) $ x in Signal.Cons rate [fmap (SVL.map softLimit) relEnvDiff, variance] } attacksDelayed :: Rate.Feature -> Class attacksDelayed rate = Class { name = ["attacks", formatRate rate, "delayed"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsDiff, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [1/2, 1/2, 1], signals = \_methods sig -> let (relEnv, _relEnvDiff, variance, _relVol, _spectral) = attackSignal rate sig in Signal.Cons rate [relEnv, Named.apply "delayed" (Causal.apply (Causal.consInit zero)) relEnv, variance] } attacksFromEnv :: Named.Signal -> Named.Signal attacksFromEnv = Named.apply "attacks" (Causal.apply differentiateMin3) attackSignalMin3 :: Rate.Feature -> Signal.Sox -> (Named.Signal, Named.Signal, Named.Signal) attackSignalMin3 featRate sig = let (relEnv, _relEnvDiff, _variance, _relVol, (_centroid, spread)) = attackSignal featRate sig in (relEnv, attacksFromEnv relEnv, spread) attacksMin3Spread :: Rate.Feature -> Class attacksMin3Spread rate = Class { name = ["attacks", formatRate rate, "min3", "spread"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [1/2, 1], signals = \_methods sig -> let (_relEnv, relEnvDiff, spread) = attackSignalMin3 rate sig in Signal.Cons rate [relEnvDiff, spread] } attacksMin3SpreadSat :: Rate.Feature -> Class attacksMin3SpreadSat rate = Class { name = ["attacks", formatRate rate, "min3", "spread", "sat"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [1/2, 1], signals = \_methods sig -> let (_relEnv, relEnvDiff, spread) = attackSignalMin3 rate sig in Signal.Cons rate [fmap (SVL.map saturationRat) relEnvDiff, spread] } attacksMin3Band :: Rate.Feature -> Class attacksMin3Band rate = Class { name = ["attacks", formatRate rate, "min3", "band", "2000hz"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [1/2, 1/10], signals = \_methods sig -> let (relEnv, _relEnvDiff, _variance, (_relEnv12, relEnv20), _spectral) = attackSignal rate sig in Signal.Cons rate [attacksFromEnv relEnv, relEnv20] } attacksMin3BandSat :: Rate.Feature -> Class attacksMin3BandSat rate = Class { name = ["attacks", formatRate rate, "min3", "band", "2000hz", "sat"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [1/2, 1/10], signals = \_methods sig -> let (relEnv, _relEnvDiff, _variance, (_relEnv12, relEnv20), _spectral) = attackSignal rate sig in Signal.Cons rate [fmap (Causal.apply (saturationRat ^<< differentiateMin3)) relEnv, relEnv20] } attacksMin3Bands :: Rate.Feature -> Class attacksMin3Bands rate = Class { name = ["attacks", formatRate rate, "min3", "band", "1200hz", "2000hz"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [1/2, 1/10, 1/10], signals = \_methods sig -> let (relEnv, _relEnvDiff, _variance, (relEnv12, relEnv20), _spectral) = attackSignal rate sig in Signal.Cons rate [attacksFromEnv relEnv, relEnv12, relEnv20] } attacksMin3BandsSat :: Rate.Feature -> Class attacksMin3BandsSat rate = Class { name = ["attacks", formatRate rate, "min3", "band", "1200hz", "2000hz", "sat"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [1/2, 1/10, 1/10], signals = \_methods sig -> let (relEnv, _relEnvDiff, _variance, (relEnv12, relEnv20), _spectral) = attackSignal rate sig in Signal.Cons rate [fmap (Causal.apply (saturationRat ^<< differentiateMin3)) relEnv, relEnv12, relEnv20] } attackBandsSignal :: Rate.Feature -> Signal.Sox -> (Named.Signal, Named.Signal) attackBandsSignal featRate sig = let rate = Signal.sampleRate sig dehummed = Causal.apply (dehum rate <<^ Bin.toCanonical) $ Signal.body sig band f = downSampleMaxFrac (Rate.ratio rate featRate) $ Causal.apply (abs ^<< bandpass rate 10 f) dehummed volume = lowpassTwoPass featRate (Freq 20) $ downSampleMaxFrac (Rate.ratio rate featRate) $ SVL.map abs dehummed relEnv f = Named.Cons ("band " ++ formatFreq f) $ SVL.zipWith (/) (band f) volume in (relEnv $ Freq 1200, relEnv $ Freq 2000) attacksBandsMin3 :: Rate.Feature -> Class attacksBandsMin3 rate = Class { name = ["attacks", "1200Hz", "2000Hz", "low rate", formatRate rate, "min3"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [0.1, 0.1], signals = \_methods sig -> let (relEnv12, relEnv20) = attackBandsSignal rate sig in Signal.Cons rate [attacksFromEnv relEnv12, attacksFromEnv relEnv20] } attacksBandsMin3Sqrt :: Rate.Feature -> Class attacksBandsMin3Sqrt rate = Class { name = ["attacks", "1200Hz", "2000Hz", "low rate", formatRate rate, "min3", "sqrt"], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsMin3, evaluateFromIntervals = Evaluation.fromClicksFineIntervals, admissibleTransitions = HMM.admissibleTransitionSet, scale = [0.1, 0.1], signals = \_methods sig -> let (relEnv12, relEnv20) = attackBandsSignal rate sig in Signal.Cons rate [Named.apply "attacks" (Causal.apply (posSqrt ^<< differentiateMin3)) relEnv12, Named.apply "attacks" (Causal.apply (posSqrt ^<< differentiateMin3)) relEnv20] } posSqrt :: Float -> Float posSqrt x = if x>0 then sqrt x else x {- Saturation function helps to separate high and low values and concentrate the high values. Otherwise some negative values are associated with the broad cloud of high values. -} {- easier to write, but less efficient -} _saturationTanh :: Float -> Float _saturationTanh x = tanh (x-0.5) + 0.5 {- not as steep as tanh, but can be vectorised -} saturationRat :: Float -> Float saturationRat x = satRat (x-0.5) + 0.5 satRat :: Float -> Float satRat x = x/(1+abs x) globalBandsSignal :: SPMethods.T -> Rate.Feature -> Int -> Int -> Signal.Sox -> (Named.Signal, Named.Signal, Named.Signal) globalBandsSignal methods featRate blockSize preSize sig = let band f = SPMethods.bandpassDownSample methods (reduceSampleRate blockSize featRate) f sig (volume, relDehum) = SPMethods.dehummedEnvelopeLowRate methods featRate sig volumeDown = downSampleMax blockSize volume relEnv f = Named.Cons ("band " ++ formatFreq f) $ SVL.zipWith (/) (band f) volumeDown maxAttacks = Named.Cons "attack" $ SigG.fromList SigG.defaultLazySize $ fmap SVL.maximum $ sliceOverlapping blockSize (preSize, 0) $ Causal.apply (differentiateMin3Init $ SVL.switchL zero const relDehum) $ relDehum in (maxAttacks, relEnv $ Freq 1200, relEnv $ Freq 2000) globalBands :: Rate.Feature -> Int -> Int -> Class globalBands rate blockSize preSize = Class { name = ["global", "1200Hz", "2000Hz", "low rate", formatRate rate, "block size", show blockSize], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsGlobal, evaluateFromIntervals = Evaluation.fromGlobalRumbleDuo, admissibleTransitions = let states = [Label.pause, Label.rasping, Label.chirping, Label.growling] in Set.fromList $ liftM2 (,) states states, scale = [1/3, 0.1, 0.1], signals = \methods sig -> let (maxAttacks, relEnv12, relEnv20) = globalBandsSignal methods rate blockSize preSize sig in Signal.Cons (reduceSampleRate blockSize rate) [maxAttacks, relEnv12, relEnv20] } globalBandsSqrt :: Rate.Feature -> Int -> Int -> Class globalBandsSqrt rate blockSize preSize = let cls = globalBands rate blockSize preSize in cls { name = name cls ++ ["sqrt"], signals = \methods sig -> map (SVL.map sqrt <$>) <$> signals cls methods sig } {- | List must be non-empty, but we have no benefit from using NonEmpty.T. -} positiveOffset :: (Ord a) => [a] -> a positiveOffset xs = List.sort xs !! div (length xs) 32 removePositiveOffset :: SVL.Vector Float -> SVL.Vector Float removePositiveOffset xs = SVL.map (subtract $ positiveOffset $ SVL.unpack xs) xs globalBandsRumbleSignal :: SPMethods.T -> Rate.Feature -> Int -> Signal.Sox -> (Named.Signal, Named.Signal, Named.Signal, Named.Signal) globalBandsRumbleSignal methods featRate blockSize sig = let band f = SPMethods.bandpassDownSample methods (reduceSampleRate blockSize featRate) f sig (volume, relDehum) = SPMethods.dehummedEnvelopeLowRate methods featRate sig volumeDown = downSampleMax blockSize volume relEnv f = Named.Cons ("band " ++ formatFreq f) $ SVL.zipWith (/) (band f) volumeDown {- We do not normalize the rumbling track with the volume because we expect that rumble always occur directly at the microphone and thus should have similar amplitude. The rumbles might still differ in amplitude and microphones might be calibrated differently. We weaken this influence by taking square roots. Additionally we remove the influence of background noise by subtracting a low quantile of the rumble signal. -} rumblingEnv = Named.Cons "rumbling" $ removePositiveOffset $ SVL.map sqrt $ SPMethods.downSampleAbs methods (Rate.unpack featRate / fromIntegral blockSize) $ SPMethods.rumble methods sig maxAttacks = Named.Cons "attack" $ SigG.fromList SigG.defaultLazySize $ fmap SVL.maximum $ sliceOverlapping blockSize (blockSize, 0) $ Causal.apply (differentiateMin3Init $ SVL.switchL zero const relDehum) $ relDehum in (maxAttacks, rumblingEnv, relEnv $ Freq 1200, relEnv $ Freq 2000) globalBandsRumbleSolo :: Rate.Feature -> Int -> Class globalBandsRumbleSolo rate blockSize = Class { name = ["global", "rumble", "solo", "1200Hz", "2000Hz", "low rate", formatRate rate, "block size", show blockSize], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsGlobal, evaluateFromIntervals = Evaluation.fromGlobalRumbleSolo, admissibleTransitions = let states = [Label.pause, Label.rumble, Label.rasping, Label.chirping, Label.growling] in Set.fromList $ liftM2 (,) states states, scale = [1/3, 1, 0.1, 0.1], signals = \methods sig -> let (maxAttacks, relRumbleEnv, relEnv12, relEnv20) = globalBandsRumbleSignal methods rate blockSize sig in Signal.Cons (reduceSampleRate blockSize rate) [maxAttacks, relRumbleEnv, relEnv12, relEnv20] } globalBandsRumbleDuo :: Rate.Feature -> Int -> Class globalBandsRumbleDuo rate blockSize = Class { name = ["global", "rumble", "duo", "1200Hz", "2000Hz", "low rate", formatRate rate, "block size", show blockSize], fineSnappedFromCoarseIntervals = fineSnappedFromCoarseIntervalsGlobalRumble, evaluateFromIntervals = Evaluation.fromGlobalRumbleDuo, admissibleTransitions = let states = [Label.pause, Label.rasping, Label.chirping, Label.growling, Label.rumble, Label.raspingRumble, Label.chirpingRumble, Label.growlingRumble] in Set.fromList $ liftM2 (,) states states, scale = [1/3, 1, 0.1, 0.1], signals = \methods sig -> let (maxAttacks, relRumbleEnv, relEnv12, relEnv20) = globalBandsRumbleSignal methods rate blockSize sig in Signal.Cons (reduceSampleRate blockSize rate) [maxAttacks, relRumbleEnv, relEnv12, relEnv20] } tickingToRasping :: Class.Sound ticking chirping ticking growling -> Class.Sound ticking chirping ticking growling tickingToRasping cls = case cls of Class.Ticking x -> Class.Rasping x _ -> cls liftExc :: Rate.C rate => (rate -> signal -> LabelChain.T Int a -> b) -> rate -> signal -> LabelTrack.T Double a -> ME.Exceptional String b liftExc f rate sig = fmap (f rate sig . Signal.body) . LabelTrack.discretizeTrack rate fineSnappedFromCoarseIntervalsGlobal :: Params.T -> Rate.Feature -> Signal.Sox -> LabelTrack.T Double (Class.Sound rasping chirping rasping growling) -> ME.Exceptional String (LabelChain.T Int String) fineSnappedFromCoarseIntervalsGlobal _params = liftExc $ \ _rate _sig -> fmap (Class.toName . tickingToRasping) {- | Turn overlapping "+rumble" labels into combined labels like "rasping rumble". -} mergeRumble :: (Rate.C rate) => rate -> LabelTrack.T Double Class.SoundParsed -> ME.Exceptional String (LabelChain.T Int Class.SoundPurity) mergeRumble rate track = do let (rumble, labels) = FuncHT.unzip $ LabelTrack.partition ((Just Label.overlayedRumble ==) . Class.maybeOther) <$> LabelTrack.discretizeTimes rate (Class.checkPurity <$> track) sortedRumble <- LabelTrack.checkOverlap rumble fmap (\(maybeRumble, cls) -> Class.setRumble (isJust maybeRumble) cls) . LabelChainShifted.shiftToLabelChain . LabelChainShifted.subdivideTrack (Signal.body sortedRumble) . LabelChainShifted.fromLabelChain . Signal.body <$> LabelTrack.checkGaps labels fineSnappedFromCoarseIntervalsGlobalRumble :: Params.T -> Rate.Feature -> Signal.Sox -> LabelTrack.T Double Class.SoundParsed -> ME.Exceptional String (LabelChain.T Int String) fineSnappedFromCoarseIntervalsGlobalRumble _params rate _sig = fmap (fmap (Class.purityToName . tickingToRasping)) . mergeRumble rate _fineFromCoarseIntervalsBand20 :: Params.T -> Rate.Feature -> SVL.Vector Float -> LabelChain.T Int (Class.Sound rasping chirping ticking growling) -> LabelChain.T Int String _fineFromCoarseIntervalsBand20 _params rate = LabelChain.fineFromCoarseIntervalsInt (case fromInteger 3 :: Int of 0 -> LabelChain.detectClicksExtrema (timeCeil rate (Time 0.01), timeCeil rate (Time 0.03)) 1 -> LabelChain.detectClicksThreshold 2.5 2 -> LabelChain.detectClicksLaxMonotony (1.0,1.0) _ -> LabelChain.detectClicksWeakMonotony (3,3) 0.5) {- Threshold 0.5 gives a better separation of the emission clusters of r0 and r1, especially in the 1.2 kHz band, than a higher threshold like 0.7. However the low threshold risks to leave an empty click end phase. -} fineFromCoarseIntervalsEnv :: Params.T -> Rate.Feature -> SVL.Vector Float -> LabelChain.T Int (Class.Sound rasping chirping ticking growling) -> LabelChain.T Int String fineFromCoarseIntervalsEnv params _rate = LabelChain.fineFromCoarseIntervalsInt (LabelChain.detectClicksWeakMonotony (Params.weakCounterSlopeSizes params) 0.5) _fineSnappedFromCoarseIntervalsBand20 :: Params.T -> Rate.Feature -> Signal.Sox -> LabelChain.T Int (Class.Sound rasping chirping ticking growling) -> LabelChain.T Int String _fineSnappedFromCoarseIntervalsBand20 params rate sig = let (_volume, (_relEnv12, Named.Cons _ relEnv20, _relEnv40)) = bandEnvelopesLowRate rate sig in _fineFromCoarseIntervalsBand20 params rate relEnv20 . LabelChain.snapBoundaries relEnv20 {- | This should be prefered to '_fineSnappedFromCoarseIntervalsBand20' since it also works if the 2 kHz band is weak, e.g. in growling sounds. -} fineSnappedFromCoarseIntervalsEnv :: Params.T -> Rate.Feature -> Signal.Sox -> LabelTrack.T Double (Class.Sound rasping chirping ticking growling) -> ME.Exceptional String (LabelChain.T Int String) fineSnappedFromCoarseIntervalsEnv params = liftExc $ \ rate sig -> let (_volume, env) = SPMethods.dehummedEnvelopeLowRate SPS.methods rate sig in fineFromCoarseIntervalsEnv params rate env . LabelChain.snapBoundaries env fineSnappedFromCoarseIntervalsDiff :: Params.T -> Rate.Feature -> Signal.Sox -> LabelTrack.T Double (Class.Sound rasping chirping ticking growling) -> ME.Exceptional String (LabelChain.T Int String) fineSnappedFromCoarseIntervalsDiff _params = liftExc $ \ rate sig -> let (Named.Cons _ relEnv, Named.Cons _ relEnvDiff, _variance, _relVol, _spectral) = attackSignal rate sig in LabelChain.fineFromCoarseIntervalsInt2 (LabelChain.detectClicksDiff 0.2 0.8) relEnv relEnvDiff . LabelChain.snapBoundaries relEnv fineSnappedFromCoarseIntervalsMin3 :: Params.T -> Rate.Feature -> Signal.Sox -> LabelTrack.T Double (Class.Sound rasping chirping ticking growling) -> ME.Exceptional String (LabelChain.T Int String) fineSnappedFromCoarseIntervalsMin3 _params = liftExc $ \ rate sig -> let (Named.Cons _ relEnv, Named.Cons _ relEnvDiff, _variance) = attackSignalMin3 rate sig in LabelChain.fineFromCoarseIntervalsInt2 (LabelChain.detectClicksThreshold 0.5) relEnv relEnvDiff . LabelChain.snapBoundaries relEnv dictionary :: Map [String] Class dictionary = Map.fromList $ map (\cls -> (name cls, cls)) $ let featRate = Rate.Feature 200 in highRate : lowRate featRate : lowRateSqrt featRate : attacks featRate : attacksClipped featRate : attacksDelayed featRate : attacksMin3Spread featRate : attacksMin3SpreadSat featRate : attacksMin3Band featRate : attacksMin3BandSat featRate : attacksMin3Bands featRate : attacksMin3BandsSat featRate : attacksBandsMin3 featRate : attacksBandsMin3Sqrt featRate : globalBands featRate 5 5 : globalBands featRate 10 0 : globalBands featRate 20 0 : globalBandsSqrt featRate 5 5 : globalBandsRumbleSolo featRate 5 : globalBandsRumbleDuo featRate 5 : [] mergeName :: [String] -> String mergeName = let lower c = case c of ' ' -> '-' _ -> Char.toLower c in List.intercalate "-" . map (map lower) dictionaryMerged :: Map String Class dictionaryMerged = Map.mapKeys mergeName dictionary readHMM :: (PathClass.AbsRel ar) => Path.File ar -> IO HMM readHMM path = do content <- PathIO.readFile path case ListHT.breakAfter ('\n'==) content of (featureRow, model) -> ME.resolveT (ioError . userError) $ ME.ExceptionalT $ return $ do hmmNamed <- HMMNamed.fromCSV HMM.statesShape model featureDescr <- case CSV.parseCSV featureRow of [header] -> fmap (Rev.dropWhile null . map CSV.csvFieldContent) $ ME.mapException (unlines . ("when parsing header:" :) . map CSV.ppCSVError) $ ME.fromEither header _ -> error "CSV parsing of a row should produce exactly one row" let notFoundMsg = unlines $ ("unknown feature set: " ++ featureRow) : "known sets:" : (map show $ Map.keys dictionary) feature <- ME.fromMaybe notFoundMsg $ Map.lookup featureDescr dictionary return $ HMM { hmmClass = feature, hmmodel = hmmNamed } writeHMM :: (PathClass.AbsRel ar) => Path.File ar -> HMM -> IO () writeHMM path featureHMM = PathIO.writeFile path $ toCSV featureHMM toCSV :: HMM -> String toCSV featureHMM = (CSV.ppCSVTable $ snd $ CSV.toCSVTable [name $ hmmClass featureHMM]) ++ (HMMNamed.toCSV $ hmmodel featureHMM)