packages feed

classify-frog (empty) → 0.2.3

raw patch · 50 files changed

+10297/−0 lines, 50 filesdep +Cabaldep +arraydep +audacitysetup-changed

Dependencies added: Cabal, array, audacity, base, bifunctors, carray, concurrent-split, containers, deepseq, explicit-exception, fft, filemanip, gnuplot, hmatrix, hmm-hmatrix, lazy-csv, llvm-extra, llvm-tf, non-empty, numeric-prelude, optparse-applicative, parallel, pathtype, pooled-io, semigroups, soxlib, storable-record, storablevector, storablevector-carray, synthesizer-core, synthesizer-llvm, tagchup, text, time, transformers, utility-ht, xml-basic

Files

+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2015, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The names of contributors may not be used to endorse or promote+      products derived from this software without specific prior+      written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ classify-frog.cabal view
@@ -0,0 +1,177 @@+Name:           classify-frog+Version:        0.2.3+License:        BSD3+License-File:   LICENSE+Author:         Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:     Henning Thielemann <haskell@henning-thielemann.de>+Homepage:       http://code.haskell.org/~thielema/classify-frog/+Category:       Bioinformatics+Synopsis:       Classify sounds produced by Xenopus laevis+Description:+  This program is part of the Xenocall project.+  Researchers observed that the amount and duration of calls+  of the African clawed frog (Xenopus laevis) change+  when exposed to hormonal effective substances.+  The Xenocall project checks whether this effect+  can be used as an endpoint in animal tests+  instead of dissecting animals after the experiments.+  .+  An experiment for one substance+  may produce about 100 hours of audio recordings.+  It is a very tedious and error-prone work+  to examine this amount of data visually or by listening.+  The purpose of this program is to examine the recordings automatically+  and generate tables with basic statistical parameters.+  .+  Read the full report at+  <http://code.henning-thielemann.de/classify-frog-doc/report.pdf>.+Tested-With:    GHC==7.4.2, GHC==7.8.4+Cabal-Version:  >=1.6+Build-Type:     Simple++Extra-Source-Files:+  data/directory-order.txt+  data/advertisement.gp+  data/advertisement.sh+  data/advertisement-hourly.gp++Data-Files:+  model/diclo/hmm-global-supervised.csv+  model/diclo/hmm-global-unsupervised.csv+  model/diclo/hmm-growling-supervised.csv+  model/diclo/hmm-supervised.csv++Source-Repository this+  Tag:         0.2.3+  Type:        darcs+  Location:    http://hub.darcs.net/thielema/classify-frog++Source-Repository head+  Type:        darcs+  Location:    http://hub.darcs.net/thielema/classify-frog++Flag buildSketch+  Description: Enable some sketch programs+  Default:     False++Flag llvm+  Description: Enable efficient signal processing using LLVM+  Default:     True++Executable classify-frog+  Main-Is: Main.hs+  Other-Modules:+    HiddenMarkovModel+    HiddenMarkovModel.Hardwired+    Label+    Class+    ClassRecord+    Durations+    Evaluation+    Measurement+    SpectralDistribution+    SignalProcessingSpecific+    SignalProcessing+    SignalProcessingMethods+    SignalProcessingOption+    Sox+    Audacity+    Audacity.TrackName+    Spreadsheet.Formula+    Spreadsheet.Row+    Spreadsheet.Palisade+    Spreadsheet.Format+    Quantile+    Time+    Fourier+    Arithmetic+    LabelTrack+    LabelChain+    LabelChainShifted+    LabelPattern+    Signal+    Rate+    Named+    Parameters+    Feature+    Option+  Hs-Source-Dirs: src++  Build-Depends:+    hmm-hmatrix >=0.0 && <0.1,+    hmatrix >=0.16 && <0.17,+    text >=1.1 && <1.3,+    lazy-csv >=0.5 && <0.6,+    tagchup >=0.4 && <0.5,+    xml-basic >=0.1.1 && <0.2,+    synthesizer-core >=0.7.1 && <0.9,+    audacity >=0.0.1 && <0.1,+    soxlib >=0.0 && <0.1,+    gnuplot >=0.5 && <0.6,+    parallel >=3.2 && <3.3,+    pooled-io >=0.0.2 && <0.1,+    concurrent-split >=0.0 && <0.1,+    fft >=0.1.8 && <0.2,+    carray >=0.1.5 && <0.2,+    storablevector-carray >=0.0 && <0.1,+    -- for NFData instance+    storablevector >=0.2.11 && <0.3,+    storable-record >=0.0 && <0.1,+    array >=0.4 && <0.6,+    time >=1.5 && <1.9,+    Cabal >=1.14 && <3,+    optparse-applicative >=0.11 && <0.15,+    filemanip >=0.3.6 && <0.4,+    pathtype >=0.8 && <0.9,+    non-empty >=0.3 && <0.4,+    semigroups >=0.1 && <1.0,+    containers >=0.4 && <0.6,+    explicit-exception >=0.1.8 && <0.2,+    transformers >=0.2 && <0.6,+    bifunctors >=5 && <6,+    semigroups >=0.8.4.1 && <0.19,+    utility-ht >=0.0.12 && <0.1,+    numeric-prelude >=0.4 && <0.5,+    deepseq >=1.3 && <1.5,+    base >=4 && <5++  If flag(llvm)+    Hs-Source-Dirs: llvm/yes+    Other-Modules:+      SignalProcessingSpecificLLVM+      SignalProcessingLLVM+    Build-Depends:+      synthesizer-llvm >=0.8 && <0.9,+      llvm-extra >=0.6 && <0.8,+      llvm-tf >=3.0 && <3.2+  Else+    Hs-Source-Dirs: llvm/no++  GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates+  GHC-Options: -rtsopts -threaded+  GHC-Prof-Options: -fprof-auto -rtsopts++  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP++Executable spectral-distribution+  Main-Is: SpectralDistributionTest.hs+  Other-Modules:+    SpectralDistribution+  Hs-Source-Dirs: src+  If flag(buildSketch)+    Build-Depends:+      synthesizer-core,+      storablevector >=0.2.10 && <0.3,+      utility-ht,+      numeric-prelude >=0.4 && <0.5,+      base >=4 && <5+  Else+    Buildable: False++  GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -rtsopts++  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind
+ data/advertisement-hourly.gp view
@@ -0,0 +1,16 @@+set terminal pdf+set xdata time+set timefmt "%Y-%m-%d %H"+set format x "%m-%d\n%H:00"+set ylabel "% advertisement calling"+set key below+set offset graph 0.10, 0.10+plot "/tmp/meto/Nacht 1 ohne hCG/advertisement-hourly-MetoKo.ssv" \+        using (timecolumn(1)-500):($5*100):($4*100):($6*100) \+        title "Ko" with errorlines, \+     "/tmp/meto/Nacht 1 ohne hCG/advertisement-hourly-Meto10-8M.ssv" \+        using 1:($5*100):($4*100):($6*100) \+        title "10-8M" with errorlines, \+     "/tmp/meto/Nacht 1 ohne hCG/advertisement-hourly-Meto10-10M.ssv" \+        using (timecolumn(1)+500):($5*100):($4*100):($6*100) \+        title "10-10M" with errorlines
+ data/advertisement.gp view
@@ -0,0 +1,15 @@+set macro+set ylabel "% advertisement calling"+set key below+set offset graph 0.10, 0.10+plot "/tmp/meto/advertisement-MetoKo.ssv" \+        every @rng using 0:(NaN):xticlabels(1) notitle with points, \+     "/tmp/meto/advertisement-MetoKo.ssv" \+        every @rng using ($0-0.1):($4*100):($3*100):($5*100) \+        title "Ko" with errorlines, \+     "/tmp/meto/advertisement-Meto10-8M.ssv" \+        every @rng using 0:($4*100):($3*100):($5*100) \+        title "10-8M" with errorlines, \+     "/tmp/meto/advertisement-Meto10-10M.ssv" \+        every @rng using ($0+0.1):($4*100):($3*100):($5*100) \+        title "10-10M" with errorlines
+ data/advertisement.sh view
@@ -0,0 +1,4 @@+gnuplot -e "set terminal pdf color; rng='::0::2'" advertisement.gp >/tmp/advertisement-ohne-hcg-color.pdf+gnuplot -e "set terminal pdf monochrome; rng='::0::2'" advertisement.gp >/tmp/advertisement-ohne-hcg-monochrome.pdf+gnuplot -e "set terminal pdf color; rng='::3::6'" advertisement.gp >/tmp/advertisement-mit-hcg-color.pdf+gnuplot -e "set terminal pdf monochrome; rng='::3::6'" advertisement.gp >/tmp/advertisement-mit-hcg-monochrome.pdf
+ data/directory-order.txt view
@@ -0,0 +1,31 @@+Ko 1+MetoKo1+MetoKo-2+MetoKo-3+MetoKo4+MetoKo-5+MetoKo-6+MetoKo-7+MetoKo-8+MetoKo9+MetoKo-10+Meto10-8M-1+Meto10-8M-2+Meto10-8M-3+Meto10-8M-4+Meto10-8M-5+Meto10-8M-6+Meto10-8M-7+Meto10-8M-8+Meto10-8M-9+Meto10-8M-10+Meto10-10M-1+Meto10-10M-2+Meto10-10M-3+Meto10-10M-4+Meto10-10M-5+Meto10-10M-6+Meto10-10M-7+Meto10-10M-8+Meto10-10M-9+Meto10-10M-10
+ llvm/no/SignalProcessingOption.hs view
@@ -0,0 +1,10 @@+module SignalProcessingOption where++import qualified Options.Applicative as OP++import qualified SignalProcessingMethods as SPMethods+import qualified SignalProcessingSpecific as SPS+++opt :: OP.Parser SPMethods.T+opt = OP.pure SPS.methods
+ llvm/yes/SignalProcessingLLVM.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RebindableSyntax #-}+module SignalProcessingLLVM where++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameter as Param++import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Memory as Memory+import LLVM.Core (Value, )++import Foreign.Storable (Storable, )++import qualified Control.Category as Cat+import Control.Arrow (arr, (<<<), (^<<), (&&&), )+import Control.Applicative (pure, )++import Data.Tuple.HT (fst3, snd3, thd3, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++zerothMoment :: CausalP.T p (Value Float) (Value Float)+zerothMoment = CausalP.delay1Zero++firstMoment :: CausalP.T p (Value Float) (Value Float)+firstMoment =+   ((arr thd3 - arr fst3) / 2) <<< lag2++secondMoment :: CausalP.T p (Value Float) (Value Float)+secondMoment =+   (arr thd3 - 2 * arr snd3 + arr fst3) <<< lag2++lag2 :: CausalP.T p (Value Float) (Value Float, Value Float, Value Float)+lag2 = lag2Init $ pure (zero :: Float)++lag2Init ::+   (Storable a, Class.MakeValueTuple a, Memory.C al, Class.ValueTuple a ~ al) =>+   Param.T p a -> CausalP.T p al (al,al,al)+lag2Init x =+   (\((x0,x1),x2) -> (x0,x1,x2))+   ^<<+   (CausalP.delay1 x &&& Cat.id <<< CausalP.delay1 x) &&& Cat.id
+ llvm/yes/SignalProcessingOption.hs view
@@ -0,0 +1,16 @@+module SignalProcessingOption where++import Option (switch, )+import qualified Options.Applicative as OP++import qualified SignalProcessingMethods as SPMethods+import qualified SignalProcessingSpecific as SPS+import qualified SignalProcessingSpecificLLVM as SPSLLVM++import Control.Applicative ((<$>), )+++opt :: OP.Parser SPMethods.T+opt =+   (\b -> if b then SPSLLVM.methods else SPS.methods) <$>+   switch True "llvm" "use LLVM to accelerate signal processing"
+ llvm/yes/SignalProcessingSpecificLLVM.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE RebindableSyntax #-}+module SignalProcessingSpecificLLVM where++import qualified Parameters as Params+import Parameters (Freq(Freq), )++import qualified SpectralDistribution as SD+import qualified SignalProcessingMethods as Methods+import qualified SignalProcessingLLVM as SPLLVM+import qualified SignalProcessing as SP+import qualified Signal+import qualified Rate+import SignalProcessingMethods (Triple, )+import SignalProcessing (fanout3, )++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Filter.Universal as UniFilter+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Fold as Fold+import qualified Synthesizer.LLVM.Frame.Binary as Bin+import qualified Synthesizer.LLVM.Parameter as Param+import Synthesizer.LLVM.Causal.Process (($*), ($<), )++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilt+import Synthesizer.Plain.Filter.Recursive (Pole(Pole), )++import qualified Sound.SoxLib as SoxLib+import qualified Data.StorableVector.Lazy as SVL++import qualified LLVM.Extra.Arithmetic as A+import LLVM.Core (Value, )++import Control.Arrow (arr, (&&&), (<<<), (^<<), )+import Control.Applicative (pure, liftA2, (<$>), )+import Data.Tuple.HT (mapSnd, fst3, snd3, thd3, uncurry3, )++import NumericPrelude.Numeric hiding (sum1)+import NumericPrelude.Base++import Data.Word (Word32, )+++type Causal p = CausalP.T (SoxLib.Rate, p)+type Param p = Param.T (SoxLib.Rate, p)++dehum :: Causal p (Value Float) (Value Float)+dehum =+   UniFilter.highpass+   ^<<+   UniFilter.causal+      $< SigP.constant (UniFilt.parameter . Pole 1 <$> freq (pure (Freq 800)))++rumble :: Causal p (Value Float) (Value Float)+rumble =+   UniFilter.lowpass+   ^<<+   UniFilter.causal+      $< SigP.constant (UniFilt.parameter . Pole 5 <$> freq (pure (Freq 220)))++bandpass ::+   Param p Float -> Param p Freq -> Causal p (Value Float) (Value Float)+bandpass q f =+   UniFilter.bandpass+   ^<<+   UniFilter.causal+      $< SigP.constant (UniFilt.parameter <$> liftA2 Pole q (freq f))++freq :: Param p Freq -> Param p Float+freq f = liftA2 Params.freq (arr (Rate.Sample . fst)) f+++_downSampleMaxAbsFrac ::+   Param.T p Double -> SigP.T p (Value Float) -> SigP.T p (Value Float)+_downSampleMaxAbsFrac sizeFrac xs =+   Causal.foldChunksPartial Fold.maxAbs xs $*+   SigP.fromStorableVectorLazy (downSampleChunkSizes <$> sizeFrac)++downSampleMaxAbsFrac ::+   SigP.T p (Value Float) -> Double -> p -> SVL.Vector Float+downSampleMaxAbsFrac xs =+   let folds =+         CausalP.applyStorableChunky (Causal.foldChunksPartial Fold.maxAbs xs)+   in  \sizeFrac p -> folds p (downSampleChunkSizes sizeFrac)++downSampleChunkSizes :: Double -> SVL.Vector Word32+downSampleChunkSizes =+   SigG.fromState SigG.defaultLazySize .+   fmap fromIntegral . SP.downSampleChunkSizes++bandsDerivativesProc ::+   Param.T (SoxLib.Rate, p) (Triple Freq) ->+   CausalP.T+      (SoxLib.Rate, p)+      (Value Float)+      (Triple (Value Float), Triple (Value Float))+bandsDerivativesProc bandFreqs =+   let band f = bandpass 10 (f <$> bandFreqs)+   in  fanout3 (band fst3) (band snd3) (band thd3)+   &&&+   fanout3 SPLLVM.zerothMoment SPLLVM.firstMoment SPLLVM.secondMoment++bandsDerivatives ::+   Triple Freq -> Signal.Sampled Float ->+   SVL.Vector (Triple Float, Triple Float)+bandsDerivatives bandFreqs =+   let proc = CausalP.applyStorableChunky $ bandsDerivativesProc $ arr snd+   in  \(Signal.Cons rate sig) -> proc (Rate.unpack rate, bandFreqs) sig++intervalSizes :: [Int] -> SVL.Vector Word32+intervalSizes =+   SigG.fromList SigG.defaultLazySize . map fromIntegral++allSums ::+   SigP.T p (Triple (Value Float), Triple (Value Float)) ->+   [Int] -> p -> [(Triple Float, Triple Float)]+allSums xs =+   let foldSumAbs = Fold.premap A.abs Fold.sum+       foldSumAbs3 = Fold.triple foldSumAbs foldSumAbs foldSumAbs+       folds =+         CausalP.applyStorableChunky+            (Causal.foldChunksPartial (Fold.pair foldSumAbs3 foldSumAbs3) xs)+   in  \sizes p -> SVL.unpack $ folds p $ intervalSizes sizes+++spectralBandDistr :: Triple Freq -> Triple Float -> (Float, Float)+spectralBandDistr+      (Freq bandFreq0, Freq bandFreq1, Freq bandFreq2) (sum0, sum1, sum2) =+   mapSnd sqrt $+   SP.centroidVariance3+      (bandFreq0, sum0)+      (bandFreq1, sum1)+      (bandFreq2, sum2)++bandParameters ::+   Triple Freq -> (Triple Float, Triple Float) -> ((Float, Float), SD.T Float)+bandParameters bandFreqs (bandSums, diffSums) =+   (spectralBandDistr bandFreqs bandSums,+    uncurry3 SD.spectralDistribution1 diffSums)+++methods :: Methods.T+methods =+   Methods.Cons {+      Methods.dehum =+         let run =+               CausalP.applyStorableChunky+                  (dehum <<< Causal.map Bin.toCanonical)+         in  \(Signal.Cons rate xs) ->+               Signal.Cons rate $ run (Rate.unpack rate, ()) xs,++      Methods.rumble =+         let run =+               CausalP.applyStorableChunky+                  (rumble <<< Causal.map Bin.toCanonical)+         in  \(Signal.Cons rate xs) ->+               Signal.Cons rate $ run (Rate.unpack rate, ()) xs,++      Methods.downSampleAbs =+         let run =+               downSampleMaxAbsFrac $+               SigP.fromStorableVectorLazy (arr snd)+         in  \featRate (Signal.Cons rate xs) ->+               run (Rate.unpack rate / featRate) (Rate.unpack rate, xs),++      Methods.bandpassDownSample =+         let run =+               downSampleMaxAbsFrac $+               CausalP.apply+                  (bandpass 10 (arr (fst.snd)) <<< Causal.map Bin.toCanonical)+                  (SigP.fromStorableVectorLazy (arr (snd.snd)))+         in  \featRate f (Signal.Cons rate xs) ->+               run (Rate.ratio rate featRate) (Rate.unpack rate, (f, xs)),++      Methods.bandParameters =+         let run =+               allSums $+               CausalP.apply+                  (bandsDerivativesProc (arr (fst.snd)))+                  (SigP.fromStorableVectorLazy (arr (snd.snd)))+         in  \bandFreqs (Signal.Cons rate xs) sizes ->+               map (bandParameters bandFreqs) $+               run sizes (Rate.unpack rate, (bandFreqs, xs))+   }
+ model/diclo/hmm-global-supervised.csv view
@@ -0,0 +1,27 @@+global,1200Hz,2000Hz,low rate,200Hz,block size,5+chirping,growling,p,rasping+0.1,0.2,0.5,0.2+0.9092827004219408,1.7985611510791366e-2,5.928853754940711e-3,3.601440576230492e-2+1.6877637130801686e-2,0.960431654676259,2.569169960474308e-2,1.2004801920768306e-3+2.109704641350211e-3,1.9784172661870505e-2,0.9367588932806323,2.4009603841536612e-2+7.172995780590717e-2,1.7985611510791368e-3,3.162055335968379e-2,0.9387755102040816+,,,+0.8587364400992413,1.4232983619351929,7.338302583634098,+0.37618100020750006,0.3303891388355467,-0.15695059129166744,+0.0,0.761113627386951,-0.2383077009820257,+0.0,0.0,1.7976586946549482,+,,,+1.915046286593648,6.615332768250197,4.3444321736078075,+0.3033090089584653,0.628862584638055,0.1789626247534727,+0.0,1.32531418386663,-0.3086778219708213,+0.0,0.0,1.0813382222444057,+,,,+0.5016917140462778,2.3917899698106853,2.9387258145014052,+0.2750444201238891,0.5153981440298611,0.2557314768917813,+0.0,0.9551385194413451,5.2061246425613404e-2,+0.0,0.0,0.8888464803100031,+,,,+1.5758024277232532,3.473913098500072,6.813986195434483,+0.404957679895657,-0.12314488883509744,0.5884665034934281,+0.0,1.3085334794619674,-0.6429168763903721,+0.0,0.0,1.766639995775783,
+ model/diclo/hmm-global-unsupervised.csv view
@@ -0,0 +1,27 @@+global,1200Hz,2000Hz,low rate,200Hz,block size,5+chirping,growling,p,rasping+0.0,2.5182677828407726e-39,0.7516877496065736,0.24831225039342655+0.8832105323287546,1.5693732128492243e-2,1.7667043248381836e-2,6.46767390259016e-2+2.5492490550710352e-2,0.9401954364242668,1.7302502685456498e-2,2.8628504778003622e-2+2.659956972233448e-3,8.718281414902813e-3,0.9401446952247045,1.1719482873687945e-2+8.863702014830155e-2,3.539255003233807e-2,2.488575884145718e-2,0.894975273322407+,,,+0.7488273464777045,1.24079995162256,6.9523340312012465,+0.2809788531413077,0.16405312861622548,0.4447958307183242,+0.0,0.2551609464157609,0.1881060460055203,+0.0,0.0,2.003608882341692,+,,,+1.7820889138469223,6.149753597789371,4.945415046755182,+0.2746470467280688,0.2252428295722046,0.20079381238569424,+0.0,1.1608041672048595,-0.35421223059056617,+0.0,0.0,1.0949321088890642,+,,,+0.44822689311988695,2.2597933074377385,2.933059975538248,+0.1271168079500722,-4.4273581861703264e-2,-6.048436965402269e-2,+0.0,0.4461413271415143,1.9323992704078315e-2,+0.0,0.0,0.5860114444501294,+,,,+1.4743993393293948,3.219060810449654,6.501203215444358,+0.3639275159883088,-6.800455306372202e-2,0.8292696304547397,+0.0,0.9507450274051655,-0.12749508318037758,+0.0,0.0,1.706880611979072,
+ model/diclo/hmm-growling-supervised.csv view
@@ -0,0 +1,38 @@+band,1200Hz,2000Hz,low rate,200Hz,sqrt+ch,cp,g0,g1,p,r0,r1+0.0,0.0,0.0,0.2,0.6000000000000001,0.0,0.2+0.9802661771454796,0.0,0.0,5.120327700972862e-3,1.1682242990654205e-3,0.0,1.2583892617449664e-2+1.973382285452042e-2,0.7971698113207547,0.0,0.0,0.0,0.0,0.0+0.0,3.773584905660377e-2,0.3711843711843712,0.2529441884280594,5.0623052959501555e-3,0.0,4.1946308724832214e-4+0.0,0.0,0.6288156288156288,0.7357910906298003,0.0,0.0,0.0+0.0,4.7169811320754715e-3,0.0,5.6323604710701485e-3,0.9875389408099688,0.0,8.389261744966443e-3+0.0,0.16037735849056603,0.0,5.120327700972862e-4,6.230529595015576e-3,0.5799086757990868,0.2873322147651007+0.0,0.0,0.0,0.0,0.0,0.4200913242009132,0.6912751677852349+,,,,,,+0.9550183803567979,2.2859005687323224,,,,,+0.19524390507481648,-1.2393091495619494e-2,,,,,+0.0,0.45341351961456355,,,,,+,,,,,,+0.7067445279714071,1.6467289224548158,,,,,+0.25036045720184585,0.2220873541185848,,,,,+0.0,0.6692064476280676,,,,,+,,,,,,+2.11645829459516,1.803474807521192,,,,,+0.4505252618934032,3.8883740752153895e-2,,,,,+0.0,0.3049370489689819,,,,,+,,,,,,+1.583775902162194,1.301590493251224,,,,,+0.5562444931501922,0.1991733399386165,,,,,+0.0,0.25284096017155894,,,,,+,,,,,,+1.2816906989269894,1.4535234969490374,,,,,+0.22928568193736565,8.090579770808067e-2,,,,,+0.0,0.2457968791040043,,,,,+,,,,,,+1.5335102065649207,2.2115089248984914,,,,,+0.3426988228331401,-5.483041894071192e-2,,,,,+0.0,0.42960665641503176,,,,,+,,,,,,+0.9782469885904084,1.4426482854649205,,,,,+0.3509634221742646,0.1288353892318251,,,,,+0.0,0.4786606234655372,,,,,
+ model/diclo/hmm-supervised.csv view
@@ -0,0 +1,28 @@+band,1200Hz,2000Hz,low rate,200Hz,sqrt+ch,cp,p,r0,r1+0.0,0.0,0.75,0.0,0.25+0.9819474835886214,0.0,1.5045135406218657e-3,0.0,1.4211274277593557e-2+1.8052516411378554e-2,0.7870967741935484,0.0,0.0,0.0+0.0,1.2903225806451613e-2,0.9909729187562688,0.0,7.579346281383231e-3+0.0,0.2,7.522567703109328e-3,0.661904761904762,0.280909521553766+0.0,0.0,0.0,0.3380952380952381,0.6972998578872572+,,,,+0.9368601738428392,2.270088559623881,,,+0.17760211937277373,-3.0445023371788348e-2,,,+0.0,0.4616682895546417,,,+,,,,+0.8478956213881893,1.4212917872013584,,,+0.500306885072571,3.3980997724841415e-2,,,+0.0,0.5445140035569593,,,+,,,,+1.2955354219624322,1.4758575685214088,,,+0.21800316741240738,3.5504609649847065e-2,,,+0.0,0.2332111684329513,,,+,,,,+1.3925725036197238,2.2883030459994362,,,+0.35474193945399723,4.772943733071615e-2,,,+0.0,0.3354287181232641,,,+,,,,+1.0404438883715281,1.3178025116918213,,,+0.43411299248183316,0.1432972470646394,,,+0.0,0.3546874178976907,,,
+ src/Arithmetic.hs view
@@ -0,0 +1,28 @@+module Arithmetic where++import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import NumericPrelude.Numeric+import NumericPrelude.Base hiding (id)++import Prelude ()+++det2 :: (Ring.C a) => ((a, a), (a, a)) -> a+det2 ((a00,a01), (a10,a11)) = a00*a11 - a10*a01++solve2 ::+   (Field.C a) =>+   ((a, a), (a, a)) -> (a, a) -> (a, a)+solve2 a@(a0,a1) b =+   let d = det2 a+   in  (det2 (b,a1) / d, det2 (a0,b) / d)++linearRegression :: (Field.C a) => [(a,a)] -> (a, a)+linearRegression xys =+   let (xs,ys) = unzip xys+       s = sum xs+       s2 = sum $ map (^2) xs+   in  solve2+          ((fromIntegral $ length xs, s), (s, s2))+          (sum ys, sum $ zipWith (*) xs ys)
+ src/Audacity.hs view
@@ -0,0 +1,362 @@+module Audacity where++import qualified Audacity.TrackName as TrackName+import qualified LabelTrack+import qualified LabelChain+import qualified Named+import qualified Parameters as Params+import qualified Signal+import qualified Rate++import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Basic.Binary as Bin++import qualified Sound.Audacity.Project.Track.Label as ProjectLabelTrack+import qualified Sound.Audacity.Project.Track.Wave.Summary as ProjectWaveSummary+import qualified Sound.Audacity.Project.Track.Wave as ProjectWaveTrack+import qualified Sound.Audacity.Project as Audacity+import qualified Sound.SoxLib as SoxLib+import Sox (writeFeatures)++import qualified Data.StorableVector.Lazy as SVL++import qualified Text.HTML.Tagchup.Parser as TagParser+import qualified Text.HTML.Tagchup.Tag as Tag+import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name.MixedCase as Name++import Spreadsheet.Format ((<->), )++import qualified Control.Monad.Exception.Synchronous as ME+import Control.Monad.IO.Class (MonadIO, liftIO, )+import Control.Monad.HT ((<=<), )+import Control.Monad (guard, liftM, )+import Control.Applicative ((<$>), )++import qualified Data.Traversable as Trav+import qualified Data.List.HT as ListHT+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.Map as Map+import Data.Zip (transposeClip, )+import Data.Traversable (forM, )+import Data.Monoid (mconcat, )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (mapMaybe, listToMaybe, isJust, )++import qualified System.Path.PartClass as PathClass+import qualified System.Path.IO as PathIO+import qualified System.Path as Path+import qualified System.FilePath.Find as Find+import System.FilePath.Find ((~~?), (==?), (<?), (&&?), (||?), )+import System.Path ((<.>), (<++>), )+import Text.Read.HT (maybeRead, )+import Text.Printf (printf, )++++zoomWidth :: Double+zoomWidth = 850++zoomFullSignal ::+   (Rate.C rate,  CutG.Read signal) => Signal.T rate signal -> Double+zoomFullSignal sig  =  zoomWidth / Signal.duration sig++createProject :: Double -> [Audacity.Track] -> Audacity.T+createProject zoom tracks =+   Audacity.deflt {+      Audacity.zoom_ = zoom,+      Audacity.tracks_ = tracks+   }+++projectLabelTrack :: String -> LabelTrack.T Double String -> Audacity.Track+projectLabelTrack name labels =+   Audacity.LabelTrack+      (ProjectLabelTrack.deflt {+         ProjectLabelTrack.name_ = name,+         ProjectLabelTrack.track_ = labels+      })++projectLabelChain :: String -> LabelChain.T Double String -> Audacity.Track+projectLabelChain name = projectLabelTrack name . LabelTrack.fromLabelChain+++summary :: SVL.Vector Float -> [ProjectWaveSummary.T]+summary = ProjectWaveSummary.sequenceFromStorableVector 262144++summaryDuration ::+   (Rate.C rate) => Signal.T rate [ProjectWaveSummary.T] -> Double+summaryDuration (Signal.Cons rate xs) =+   Params.toTime rate $ sum $ map ProjectWaveSummary.length_ xs+++pcmAliasSequenceFromSummary ::+   (PathClass.AbsRel ar, MonadIO m) =>+   Path.FilePath ar -> Int ->+   [ProjectWaveSummary.T] ->+   ProjectWaveSummary.Monad m ProjectWaveTrack.Sequence+pcmAliasSequenceFromSummary aliasFile channel sig = do+   aliasFileAbs <- liftIO $ Path.genericMakeAbsoluteFromCwd aliasFile+   ProjectWaveTrack.pcmAliasSequenceFromSummary+      (Path.toString aliasFileAbs) channel sig++projectWaveTrack ::+   (Rate.C rate, PathClass.AbsRel ar, MonadIO m) =>+   Int -> Bool ->+   (Signal.T rate (Named.T [ProjectWaveSummary.T]), Path.FilePath ar) ->+   ProjectWaveSummary.Monad m Audacity.Track+projectWaveTrack channel active+      (Signal.Cons rate (Named.Cons name sig), aliasFile) = do+   sequ <- pcmAliasSequenceFromSummary aliasFile channel sig+   return $+      Audacity.WaveTrack $+         ProjectWaveTrack.deflt {+            ProjectWaveTrack.name_ = name,+            ProjectWaveTrack.rate_ = round $ Rate.unpack rate,+            ProjectWaveTrack.mute_ = not active,+            ProjectWaveTrack.clips_ =+               [ProjectWaveTrack.Clip {+                  ProjectWaveTrack.offset_ = 0,+                  ProjectWaveTrack.sequence_ = sequ+               }]+         }++projectWaveTrackFeatures ::+   (Rate.C rate, PathClass.AbsRel ar, MonadIO m) =>+   (([Float], Signal.T rate [Named.Signal]), Path.FilePath ar) ->+   ProjectWaveSummary.Monad m [Audacity.Track]+projectWaveTrackFeatures ((scales, featSigs), output) =+   forM (zip3 [0..] scales $ Trav.sequenceA featSigs) $ \(n, scale, featSig) ->+      projectWaveTrack n False+         (Signal.map (summary . SVL.map (scale*) <$>) featSig, output)++projectWaveTrackInputSummary ::+   (Rate.C rate, PathClass.AbsRel ar, MonadIO m) =>+   (Signal.T rate [ProjectWaveSummary.T], Path.FilePath ar) ->+   ProjectWaveSummary.Monad m Audacity.Track+projectWaveTrackInputSummary (sig, input) =+   projectWaveTrack 0 True+      (Signal.map (Named.Cons TrackName.recording) sig, input)++projectWaveTrackInput ::+   (PathClass.AbsRel ar, MonadIO m) =>+   (Signal.Sox, Path.FilePath ar) ->+   ProjectWaveSummary.Monad m Audacity.Track+projectWaveTrackInput (sig, input) =+   projectWaveTrackInputSummary+      (Signal.map (summary . SVL.map Bin.toCanonical) sig, input)++projectWaveTrackConcat ::+   (Rate.C rate, PathClass.AbsRel ar,+    MonadIO m, NonEmptyC.Zip f, NonEmptyC.Repeat f) =>+   f String ->+   [(Path.FilePath ar,+     (Signal.T rate [ProjectWaveSummary.T], f (LabelTrack.T Double String)))] ->+   ProjectWaveSummary.Monad m+      (Double, Audacity.Track, f (Audacity.Track), Audacity.Track)+projectWaveTrackConcat labelNames sigs = do+   sequs <-+      forM sigs $ \(aliasFile, (Signal.Cons _ sig, _)) ->+         pcmAliasSequenceFromSummary aliasFile 0 sig+   let durs = map (summaryDuration . fst . snd) sigs+   let starts = scanl (+) 0 durs+   setRate <-+      case map (Rate.unpack . Signal.sampleRate . fst . snd) sigs of+         [] -> return id+         rt@(r:rs) ->+            if all (r==) rs+              then return $ \track -> track {ProjectWaveTrack.rate_ = round r}+              else liftIO $ ioError $ userError $ unlines $+                   ["differing sample rates", show rt]+   return+      (sum durs+       ,+       Audacity.WaveTrack $ setRate $+         ProjectWaveTrack.deflt {+            ProjectWaveTrack.name_ = TrackName.recording,+            ProjectWaveTrack.clips_ = zipWith ProjectWaveTrack.Clip starts sequs+         }+       ,+       NonEmptyC.zipWith projectLabelTrack labelNames $+       fmap mconcat $ transposeClip $+       zipWith+         (\start (_,(_,labv)) -> LabelTrack.shift start <$> labv) starts sigs+{-+       zipWith+         (\dur (_,(_,labv)) -> LabelTrack.trim (0,dur) <$> labv) durs sigs+-}+       ,+       projectLabelChain TrackName.origin $+       LabelChain.fromAdjacentChunks $+       zip durs $ map (Path.toString . Path.takeBaseName . fst) sigs)+++writeLabelTrackInt ::+   (Rate.C rate, PathClass.AbsRel ar) =>+   rate -> Path.FilePath ar -> String ->+   LabelChain.T Int String -> IO Audacity.Track+writeLabelTrackInt rate stem part trackInt = do+   let track = LabelChain.realTimes rate trackInt+   LabelChain.writeFile (stem <-> "hmm-labels" <-> part <.> "txt") track+   return $ projectLabelChain part track++writeFeatureTracks ::+   (PathClass.AbsRel ar, MonadIO m) =>+   SoxLib.Format mode -> Path.FilePath ar ->+   [Float] -> Signal.T Rate.Feature [Named.Signal] ->+   IO (ProjectWaveSummary.Monad m [Audacity.Track])+writeFeatureTracks fmtIn output scales featSigs = do+   writeFeatures fmtIn output scales featSigs+   return $ projectWaveTrackFeatures ((scales, featSigs), output)++waveSummaryEval ::+   (PathClass.AbsRel ar, Monad m) =>+   Path.FilePath ar -> ProjectWaveSummary.Monad m a ->+   m ((Path.FilePath ar, Audacity.T -> String), a)+waveSummaryEval outputStem summ = do+   let outputSumDir = outputStem <++> "_data"+   liftM+      ((,) (outputStem <.> "aup",+            \audProj ->+               Audacity.format+                  (audProj {Audacity.name_ =+                     Path.toString (Path.takeFileName outputSumDir)}) "")) $+      ProjectWaveSummary.eval (Path.toString outputSumDir) summ+++++type OriginPaths ar = (Path.RelFile, Path.FilePath ar)++maybePCMAliasTag ::+   (PathClass.AbsRel ar) =>+   Tag.T Name.T String -> Maybe (OriginPaths ar)+maybePCMAliasTag tag = do+   (name, attrs) <- Tag.maybeOpen tag+   guard $ name == Tag.Name (Name.Cons "pcmaliasblockfile")+   path <- Path.maybe =<< Attr.lookupLit "aliasfile" attrs+   return (Path.takeFileName path, path)++originsFromOriginTrack ::+   (PathClass.AbsRel ar) =>+   [Tag.T Name.T String] ->+   (String -> IO (LabelTrack.T time String)) ->+   IO [ME.Exceptional String (LabelTrack.Interval time (OriginPaths ar))]+originsFromOriginTrack tagsoup lookupTrack = do+   let fileMap =+         Map.fromList $ map (\pair -> (Path.toString $ fst pair, pair)) $+         mapMaybe maybePCMAliasTag tagsoup+   origins <- lookupTrack TrackName.origin+   return $+      flip map (LabelTrack.decons origins) $ \(bnds, origin) ->+         case Map.lookup origin fileMap of+            Just pair -> ME.Success (bnds, pair)+            Nothing -> ME.Exception $ printf "missing origin '%s'" origin++++waveTrackName :: Tag.Name Name.T+waveTrackName = Tag.Name (Name.Cons "wavetrack")++maybeWaveTrackTag :: Tag.T Name.T String -> Maybe SoxLib.Rate+maybeWaveTrackTag tag = do+   (name, attrs) <- Tag.maybeOpen tag+   guard $ name == waveTrackName+   trackName <- Attr.lookupLit "name" attrs+   guard $ trackName == TrackName.recording+   maybeRead =<< Attr.lookupLit "rate" attrs++maybeWaveTrackCloseTag :: Tag.T Name.T String -> Maybe ()+maybeWaveTrackCloseTag tag = do+   name <- Tag.maybeClose tag+   guard $ name == waveTrackName++maybeWaveClipTag :: Tag.T Name.T String -> Maybe Double+maybeWaveClipTag tag = do+   (name, attrs) <- Tag.maybeOpen tag+   guard $ name == Tag.Name (Name.Cons "waveclip")+   maybeRead =<< Attr.lookupLit "offset" attrs++maybeSequenceTag :: Tag.T Name.T String -> Maybe Integer+maybeSequenceTag tag = do+   (name, attrs) <- Tag.maybeOpen tag+   guard $ name == Tag.Name (Name.Cons "sequence")+   maybeRead =<< Attr.lookupLit "numsamples" attrs++intervalFromWaveClip ::+   (PathClass.AbsRel ar) =>+   SoxLib.Rate -> Double -> [Tag.T Name.T String] ->+   Maybe (LabelTrack.Interval Double (OriginPaths ar))+intervalFromWaveClip rate from tagsoup = do+   len <- listToMaybe $ mapMaybe maybeSequenceTag tagsoup+   origin <- listToMaybe $ mapMaybe maybePCMAliasTag tagsoup+   return ((from, from + fromInteger len / rate), origin)++originsFromRecordingTrack ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Path.FilePath ar0 -> [Tag.T Name.T String] ->+   IO [ME.Exceptional String+         (LabelTrack.Interval Double (OriginPaths ar1))]+originsFromRecordingTrack path tagsoup = do+   (rate, waveTrackStart) <-+      case ListHT.segmentBeforeMaybe maybeWaveTrackTag tagsoup of+         (_, firstTrack : _) -> return firstTrack+         _ ->+            ioError $ userError $+            printf "%s: no 'recording' wave track found" $ Path.toString path++   let intervalFromClip (from, clip) =+         ME.fromMaybe+            (printf+               "missing length or origin info for clip starting from %f" from) $+         intervalFromWaveClip rate from clip++   return $ map intervalFromClip $+      snd $ ListHT.segmentBeforeMaybe maybeWaveClipTag $+      takeWhile (not . isJust . maybeWaveTrackCloseTag) waveTrackStart++++audacityExt :: String+audacityExt = ".aup"++dirFromAudPath ::+   (PathClass.AbsRel ar) =>+   Path.FilePath ar -> Maybe (Path.DirPath ar)+dirFromAudPath =+   (\(base, ext) -> toMaybe (ext==audacityExt) $ Path.dirFromFile base) .+   Path.splitExtension+++findAudacityProject ::+   (PathClass.AbsRel ar) => Path.DirPath ar -> IO [Path.FilePath ar]+findAudacityProject =+   let isAup =+         Find.fileName ~~? ("*"++audacityExt) &&?+         Find.depth ==? 2 &&?+         (Find.fileType ==? Find.RegularFile ||?+          Find.fileType ==? Find.SymbolicLink)+   in  fmap (map Path.path) . Find.find (Find.depth <? 2) isAup . Path.toString++getOriginRoot ::+   (PathClass.AbsRel ar) => Path.DirPath ar -> IO Path.AbsDir+getOriginRoot input = do+   let msg = "When searching for root directory of original recordings: "+   let loop [] =+         ioError $ userError $+         msg ++ "no Audacity project with pointers to original recordings found"+       loop (aup:aups) = do+         origs <-+            originsFromRecordingTrack aup . TagParser.runSoup =<<+            PathIO.readFile aup+         case mapMaybe ME.toMaybe origs of+            [] -> loop aups+            (_, (_, orig)):_ ->+               case Path.takeSuperDirectory <=< Path.takeSuperDirectory $+                    Path.takeDirectory orig of+                  Nothing ->+                     ioError $ userError $+                     printf "In %s found %s which has no second super directory"+                        (Path.toString aup) (Path.toString orig)+                  Just root -> return root+   loop =<< findAudacityProject input
+ src/Audacity/TrackName.hs view
@@ -0,0 +1,26 @@+module Audacity.TrackName where+++recording :: String+recording = "recording"++classes :: String+classes = "classes"++coarse :: String+coarse = "coarse"++abstract :: String+abstract = "abstract"++warnings :: String+warnings = "warnings"++time :: String+time = "absolute times"++hour :: String+hour = "hours"++origin :: String+origin = "origin"
+ src/Class.hs view
@@ -0,0 +1,233 @@+module Class where++import qualified Label++import Control.DeepSeq (NFData, rnf)+import Control.Monad (mplus, mfilter)++import qualified Data.Foldable as Fold+import qualified Data.List.HT as ListHT+import qualified Data.Map as Map; import Data.Map (Map)+import Data.String.HT (trim)+import Data.Maybe (fromMaybe)+import Data.Maybe.HT (toMaybe)+import Data.Char (isDigit)+++data Sound rasping chirping ticking growling =+     Other String+   | Rasping rasping+   | Chirping chirping+   | Ticking ticking+   | Growling growling++instance+   (NFData rasping, NFData chirping, NFData ticking, NFData growling) =>+      NFData (Sound rasping chirping ticking growling) where+   rnf (Other str) = rnf str+   rnf (Rasping dat) = rnf dat+   rnf (Chirping dat) = rnf dat+   rnf (Ticking dat) = rnf dat+   rnf (Growling dat) = rnf dat+++isPause :: Sound rasping chirping ticking growling -> Bool+isPause (Other str) = str == Label.pause+isPause _ = False+++toName :: Sound rasping chirping ticking growling -> String+toName cl =+   case cl of+      Other str -> str+      Rasping _ -> Label.rasping+      Chirping _ -> Label.chirping+      Ticking _ -> Label.ticking+      Growling _ -> Label.growling++toLabel :: Sound Int chirping Int Int -> String+toLabel cl =+   case cl of+      Other str -> str+      Rasping numClicks -> Label.rasping ++ ' ' : show numClicks+      Chirping _ -> Label.chirping+      Ticking numClicks -> Label.ticking ++ ' ' : show numClicks+      Growling numClicks -> Label.growling ++ ' ' : show numClicks+++type SoundParsed = Sound String String String String++fromLabel :: String -> SoundParsed+fromLabel lab =+   fromMaybe (Other lab) $+   fmap (Rasping . trim) (ListHT.maybePrefixOf Label.rasping lab)+   `mplus`+   fmap (Chirping . trim) (ListHT.maybePrefixOf Label.chirping lab)+   `mplus`+   fmap (Ticking . trim) (ListHT.maybePrefixOf Label.ticking lab)+   `mplus`+   fmap (Growling . trim) (ListHT.maybePrefixOf Label.growling lab)++strToLabel :: SoundParsed -> String+strToLabel cl =+   let add ext str = if null ext then str else str ++ ' ' : ext+   in case cl of+         Other str -> str+         Rasping str -> add Label.rasping str+         Chirping str -> add Label.chirping str+         Ticking str -> add Label.ticking str+         Growling str -> add Label.growling str+++data Purity = Pure | Rumble+   deriving (Eq)++type SoundPurity = Sound Purity Purity Purity Purity++purityToName :: SoundPurity -> String+purityToName cl =+   let ext p =+         case p of+            Pure -> ""+            Rumble -> " rumble"+   in case cl of+         Other str -> str+         Rasping p -> Label.rasping ++ ext p+         Chirping p -> Label.chirping ++ ext p+         Ticking p -> Label.ticking ++ ext p+         Growling p -> Label.growling ++ ext p++checkPurity :: SoundParsed -> SoundPurity+checkPurity cl =+   fromMaybe (Other $ strToLabel cl) $+   let check cons p str =+         toMaybe (str==Label.rumble) (cons Rumble)+         `mplus`+         toMaybe (p str) (cons Pure)+   in case cl of+         Other str -> Just $ Other str+         Rasping str -> check Rasping (all isDigit) str+         Chirping str -> check Chirping null str+         Ticking str -> check Ticking (all isDigit) str+         Growling str -> check Growling (all isDigit) str++setRumble :: Bool -> SoundPurity -> SoundPurity+setRumble b cl =+   let add r = if b then Rumble else r+   in  case cl of+         Other str ->+            Other $+            if b+              then+                if str == Label.pause+                  then Label.rumble+                  else str ++ ' ' : Label.rumble+              else str+         Rasping r -> Rasping $ add r+         Chirping r -> Chirping $ add r+         Ticking r -> Ticking $ add r+         Growling r -> Growling $ add r+++mapChirping ::+   (chirping0 -> chirping1) ->+   Sound rasping chirping0 ticking growling ->+   Sound rasping chirping1 ticking growling+mapChirping f cl =+   case cl of+      Other str -> Other str+      Rasping r -> Rasping r+      Chirping ch -> Chirping $ f ch+      Ticking t -> Ticking t+      Growling g -> Growling g++mapRasping ::+   (rasping0 -> rasping1) ->+   Sound rasping0 chirping ticking growling ->+   Sound rasping1 chirping ticking growling+mapRasping f cl =+   case cl of+      Other str -> Other str+      Rasping r -> Rasping $ f r+      Chirping ch -> Chirping ch+      Ticking t -> Ticking t+      Growling g -> Growling g++mapTicking ::+   (ticking0 -> ticking1) ->+   Sound rasping chirping ticking0 growling ->+   Sound rasping chirping ticking1 growling+mapTicking f cl =+   case cl of+      Other str -> Other str+      Rasping r -> Rasping r+      Chirping ch -> Chirping ch+      Ticking t -> Ticking $ f t+      Growling g -> Growling g++mapGrowling ::+   (growling0 -> growling1) ->+   Sound rasping chirping ticking growling0 ->+   Sound rasping chirping ticking growling1+mapGrowling f cl =+   case cl of+      Other str -> Other str+      Rasping r -> Rasping r+      Chirping ch -> Chirping ch+      Ticking t -> Ticking t+      Growling g -> Growling $ f g+++maybeRasping :: Sound rasping chirping ticking growling -> Maybe rasping+maybeRasping cl =+   case cl of+      Rasping r -> Just r+      _ -> Nothing++maybeChirping :: Sound rasping chirping ticking growling -> Maybe chirping+maybeChirping cl =+   case cl of+      Chirping c -> Just c+      _ -> Nothing++maybeTicking :: Sound rasping chirping ticking growling -> Maybe ticking+maybeTicking cl =+   case cl of+      Ticking r -> Just r+      _ -> Nothing++maybeGrowling :: Sound rasping chirping ticking growling -> Maybe growling+maybeGrowling cl =+   case cl of+      Growling r -> Just r+      _ -> Nothing++maybeOther :: Sound rasping chirping ticking growling -> Maybe String+maybeOther cl =+   case cl of+      Other s -> Just s+      _ -> Nothing+++countOthers ::+   (Fold.Foldable f) =>+   f (Sound rasping chirping ticking growling) -> Map String Int+countOthers =+   Map.unionsWith (+) .+   map (maybe Map.empty (flip Map.singleton 1) .+        mfilter (flip notElem [Label.pause, Label.rumble]) . maybeOther) .+   Fold.toList+++data Abstract advert rasping chirping ticking growling =+     NoAdvertisement (Sound rasping chirping ticking growling)+   | Advertisement advert rasping (Maybe chirping)+++abstractToLabel :: Abstract time Int chirping Int Int -> String+abstractToLabel cl =+   case cl of+      NoAdvertisement x -> toLabel x+      Advertisement _ numClicks chirp ->+         Label.advertisement ++ ' ' : show numClicks +++         maybe " end" (const "") chirp
+ src/ClassRecord.hs view
@@ -0,0 +1,45 @@+module ClassRecord where++import Control.DeepSeq (NFData, rnf)+import Control.Applicative (Applicative, pure, (<*>))++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import Data.Traversable (Traversable, traverse)+import Data.Foldable (Foldable, foldMap)+++{- |+Columns in the generated spreadsheet tables+are sorted according to the order of the record fields.+-}+data T a =+   Cons {+      advertisement, rasping, chirping, ticking, growling :: a+   }++names :: T String+names = Cons "Advertisement" "Rasping" "Chirping" "Ticking" "Growling"+++instance NFData a => NFData (T a) where+   rnf = rnf . Fold.toList++instance Functor T where+   fmap = Trav.fmapDefault++instance Foldable T where+   foldMap = Trav.foldMapDefault++instance Traversable T where+   traverse f (Cons xAdvertisement xRasping xChirping xTicking xGrowling) =+      pure Cons <*> f xAdvertisement+         <*> f xRasping <*> f xChirping <*> f xTicking <*> f xGrowling++instance Applicative T where+   pure a = Cons a a a a a+   Cons fAdvertisement fRasping fChirping fTicking fGrowling <*>+         Cons xAdvertisement xRasping xChirping xTicking xGrowling =+      Cons+         (fAdvertisement xAdvertisement) (fRasping xRasping)+         (fChirping xChirping) (fTicking xTicking) (fGrowling xGrowling)
+ src/Durations.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE RebindableSyntax #-}+module Durations where++import qualified ClassRecord+import qualified Class++import qualified Sound.Audacity.LabelTrack as LabelTrack++import Control.DeepSeq (NFData, rnf, force)+import Control.Applicative (Applicative, liftA2, pure, (<*>))++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import Data.Traversable (Traversable, traverse)+import Data.Foldable (Foldable, foldMap)++import qualified Algebra.Additive as Additive+import NumericPrelude.Numeric hiding (sum)+import NumericPrelude.Base hiding (readFile, writeFile)+++data T a =+   Cons {+      total :: a,+      classes :: ClassRecord.T a+   }++names :: T String+names = Cons "Total" ClassRecord.names++instance NFData a => NFData (T a) where+   rnf (Cons totalDur classDurs) = rnf (totalDur, classDurs)++instance Functor T where+   fmap = Trav.fmapDefault++instance Foldable T where+   foldMap = Trav.foldMapDefault++instance Traversable T where+   traverse f (Cons totalDur classDurs) =+      liftA2 Cons (f totalDur) (traverse f classDurs)++instance Applicative T where+   pure a = Cons a $ pure a+   Cons fTotal fClasses <*> Cons totalDur classDurs =+      Cons (fTotal totalDur) (fClasses <*> classDurs)+++class Track f where+   intervalSizes :: (Additive.C t) => f t a -> f t (t, a)++-- ToDo: move to audacity+instance Track LabelTrack.T where+   intervalSizes =+      LabelTrack.mapWithTime (\bnds lab -> (uncurry subtract bnds, lab))+++sum ::+   (Track f, Foldable (f Double)) =>+   f Double (Class.Abstract advert rasping chirping ticking growling) ->+   T Double+sum =+   Fold.foldl'+      (\(Cons totalDur acc) (dur,cls) ->+         let add r select set = set r $ select r + dur+         in  force $ Cons (totalDur+dur) $+             case cls of+                Class.Advertisement _ _ _ ->+                   add acc ClassRecord.advertisement+                      (\r d -> r{ClassRecord.advertisement = d})+                Class.NoAdvertisement (Class.Rasping _) ->+                   add acc ClassRecord.rasping+                      (\r d -> r{ClassRecord.rasping = d})+                Class.NoAdvertisement (Class.Chirping _) ->+                   add acc ClassRecord.chirping+                      (\r d -> r{ClassRecord.chirping = d})+                Class.NoAdvertisement (Class.Ticking _) ->+                   add acc ClassRecord.ticking+                      (\r d -> r{ClassRecord.ticking = d})+                Class.NoAdvertisement (Class.Growling _) ->+                   add acc ClassRecord.growling+                      (\r d -> r{ClassRecord.growling = d})+                Class.NoAdvertisement (Class.Other _) -> acc)+      (pure 0) .+   intervalSizes
+ src/Evaluation.hs view
@@ -0,0 +1,304 @@+module Evaluation (+   Result,+   fromClicksFineIntervals,+   fromGlobalRumbleSolo,+   fromGlobalRumbleDuo,+   ) where++import qualified LabelTrack+import qualified LabelChain+import qualified SignalProcessingMethods as SPMethods+import qualified SignalProcessing as SP+import qualified Signal+import qualified Rate+import qualified Named+import qualified Class+import qualified Parameters as Params+import LabelChain (BreakRel(BreakRel), )+import Parameters (Time(Time), getTime, )+import Measurement+          (ClassFeatures, ChunkFeatures, SpectralParameters, measureSignal, )++import qualified Control.Functor.HT as FuncHT+import Control.Monad (join, )+import Control.Applicative ((<$>), )+import Control.Functor.HT (void)++import qualified Data.NonEmpty as NonEmpty+import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapSnd, )++import Text.Printf (printf, )++import Algebra.ToRational (realToField)++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()++++type SoundMeasure t = Class.Sound Int (BreakRel t) Int Int+++doubleFromTime :: Time -> Double+doubleFromTime = realToField . Params.getTime++_classFromClicksFloat ::+   Params.T ->+   LabelChain.T Double String ->+   LabelChain.T Double (SoundMeasure Double)+_classFromClicksFloat params =+   let skip :: (a -> a) -> (a -> a)+       skip _ = id+   in  fmap+          (Class.mapTicking SP.foldLength .+           Class.mapRasping SP.foldLength .+           Class.mapGrowling SP.foldLength) .+       LabelChain.classRelativeFromAbsolute .+       LabelChain.fuseTickingBouts join .+       LabelChain.tickingsFromRaspings+          (ListHT.lengthAtLeast (Params.raspingMinNumClicks params) .+           NonEmpty.flatten) .+       skip+          (LabelChain.breakLongClicks+             (realToField (Params.raspingMaxRelativeClickDistance params) *)) .+       LabelChain.mergeRaspingGrowling+          join (void . concatMap NonEmpty.flatten) .+       LabelChain.classFromFineIntervals .+       LabelChain.correctShortChirping+          (doubleFromTime $ Params.chirpingHackDur params) .+       skip+          (LabelChain.mergeRaspingShortPause+             (doubleFromTime $ Params.hardHighDist params))++classFromClicksInt ::+   Params.T -> Rate.Sample ->+   LabelChain.T Int String ->+   LabelChain.T Int (SoundMeasure Int)+classFromClicksInt params rate =+   let skip :: (a -> a) -> (a -> a)+       skip _ = id+   in  fmap+          (Class.mapTicking SP.foldLength .+           Class.mapRasping SP.foldLength .+           Class.mapGrowling SP.foldLength) .+       LabelChain.classRelativeFromAbsolute .+       LabelChain.fuseTickingBouts join .+       LabelChain.tickingsFromRaspings+          (ListHT.lengthAtLeast (Params.raspingMinNumClicks params) .+           NonEmpty.flatten) .+       skip+          (LabelChain.breakLongClicks+             (\median ->+                ceiling $+                Params.raspingMaxRelativeClickDistance params+                   * fromIntegral median)) .+       LabelChain.mergeRaspingGrowling+          join (void . concatMap NonEmpty.flatten) .+       LabelChain.classFromFineIntervals .+       LabelChain.correctShortChirping+          (Params.time rate $ Params.chirpingHackDur params) .+       skip+          (LabelChain.mergeRaspingShortPause+             (Params.time rate $ Params.hardHighDist params))+++classLabelsFromChunkFeatures ::+   ChunkFeatures ->+   Class.Sound rasping chirping ticking growling -> SoundMeasure Int+classLabelsFromChunkFeatures+      ((numClicks, _sumHalfLifes, _numEmphasized), chirpMain) cls =++   case cls of+      Class.Rasping _ -> Class.Rasping numClicks+      Class.Chirping _ -> Class.Chirping $ BreakRel chirpMain+      Class.Ticking _ -> Class.Ticking numClicks+      Class.Growling _ -> Class.Growling numClicks+      Class.Other str -> Class.Other str+++checkWarn :: Bool -> a -> [a]+checkWarn cond msg = if cond then [] else [msg]++checkChirping :: Params.T -> (Double, Double) -> [String]+checkChirping params bnd =+   let dur = Time $ realToFrac $ uncurry subtract bnd+       minDur = Params.chirpingMinDur params+       maxDur = Params.chirpingMaxDur params+   in  (checkWarn (dur >= minDur) $+        printf "duration must be at least %f" $ getTime minDur)+       +++       (checkWarn (dur <= maxDur) $+        printf "duration must be at most %f" $ getTime maxDur)++checkTicking :: Int -> [String]+checkTicking numClicks =+   checkWarn (numClicks > 0) "zero ticks"++suspiciousIntervalsFromClicks ::+   Params.T -> Rate.Sample ->+   LabelTrack.T Double (ChunkFeatures, SoundMeasure Int) ->+   LabelTrack.T Double String+suspiciousIntervalsFromClicks params highRate =+   let measRate = Params.measureSampleRate params+   in  LabelTrack.concat .+       LabelTrack.mapWithTime+          (\bnd (((numClicks, _sumHalfLifes, _numEmphasized), chirpMain), cls) ->+             case cls of+                Class.Rasping n ->+                   let minNumClicks = Params.raspingMinNumClicks params+                   in  (checkWarn (n == numClicks) $+                        printf "deviating alternative click count: %d" n)+                       +++                       (checkWarn (numClicks >= minNumClicks) $+                        printf "expected at least %d clicks" minNumClicks)+                Class.Chirping (BreakRel brk) ->+                   let maxDev = Params.chirpingMainDurMaxDeviation params+                       brkTime = Params.toTime highRate brk+                       mainTime = Params.toTime measRate chirpMain+                   in  checkChirping params bnd+                       +++                       (checkWarn+                          ((Time $ realToFrac $ abs $ brkTime-mainTime)+                             <= maxDev) $+                        printf "deviating main duration: %f vs. %f"+                          brkTime mainTime)+                Class.Growling n ->+                   (checkWarn (n == numClicks) $+                     printf "deviating alternative click count: %d" n)+                Class.Ticking n -> checkTicking n+                _ -> [])+++type Result =+       (LabelChain.T Double (SoundMeasure Int),+        LabelTrack.T Double String,+        (Signal.LabelChain Rate.Measure+            (SpectralParameters Float, ClassFeatures),+         ([Float], Signal.T Rate.Measure [Named.Signal])))++fromClicks ::+   SPMethods.T -> Params.T -> Signal.SoxLabelled (SoundMeasure Int) -> Result+fromClicks sigProc params labelled =+   let (sig, classified) = FuncHT.unzip labelled+       (chunkFeats, measuresEnvelopes) = measureSignal sigProc params labelled+       classifiedMeas =+         LabelChain.zipWithList (,) chunkFeats $+         Signal.labelRealTimes classified+   in  (fmap (uncurry classLabelsFromChunkFeatures) classifiedMeas,+        suspiciousIntervalsFromClicks params (Signal.sampleRate sig) $+          LabelTrack.fromLabelChain classifiedMeas,+        measuresEnvelopes)++fromClicksFineIntervals ::+   SPMethods.T -> Params.T -> Signal.SoxLabelled String -> Result+fromClicksFineIntervals sigProc params sig =+   fromClicks sigProc params $+   fmap (mapSnd (classFromClicksInt params (Signal.sampleRate sig))) sig+++suspiciousIntervalsFromGlobal ::+   Params.T ->+   LabelTrack.T Double (Class.Sound rasping chirping Int growling) ->+   LabelTrack.T Double String+suspiciousIntervalsFromGlobal params =+   LabelTrack.concat .+   LabelTrack.mapWithTime+      (\bnd cls ->+         case cls of+            Class.Chirping _ -> checkChirping params bnd+            Class.Ticking numClicks -> checkTicking numClicks+            _ -> [])+++countClicksGlobal ::+   SPMethods.T -> Params.T ->+   Signal.SoxLabelled (Class.Sound rasping chirping ticking growling) ->+   LabelChain.T Double (Class.Sound Int (BreakRel Int) Int Int)+countClicksGlobal sigProc params sigClassified =+   {- ToDo:+   comparison could be made more lazy+   using lazy chunky numbers from non-negative package+   -}+   LabelChain.mergeRaspingGrowling NonEmpty.sum sum $+   LabelChain.zipWithList classLabelsFromChunkFeatures+      (fst $ measureSignal sigProc params sigClassified) $+   Signal.labelRealTimes $ fmap snd sigClassified++{- |+Works on sequences like rasping-rumble-rasping.+-}+classFromGlobalRumbleSolo ::+   SPMethods.T -> Params.T -> Signal.SoxLabelled String ->+   (LabelTrack.T Double String,+    LabelChain.T Double (SoundMeasure Int))+classFromGlobalRumbleSolo sigProc params sigClassified =+   let (rumbling, classifiedMeas) =+         LabelChain.unzipRumbling $+         {-+         The NonEmpty.head selects the information of the first chirping chunk.+         That carries a BreakRel value that becomes rather arbitrary+         after merging chirping with rumble.+         -}+         LabelChain.assimilateRumblingSolo+            NonEmpty.sum NonEmpty.head NonEmpty.sum+            (doubleFromTime $ Params.maxInterimRumblingDur params) $+         countClicksGlobal sigProc params $+         fmap (mapSnd (fmap Class.fromLabel)) sigClassified+   in  (rumbling,+        LabelChain.fuseTickingBouts NonEmpty.sum $+        LabelChain.tickingsFromRaspings+         (Params.raspingMinNumClicks params <=) $+        classifiedMeas)++{- |+Works on sequences like rasping-raspingRumble-rasping.+-}+classFromGlobalRumbleDuo ::+   SPMethods.T -> Params.T -> Signal.SoxLabelled String ->+   (LabelTrack.T Double String,+    LabelChain.T Double (SoundMeasure Int))+classFromGlobalRumbleDuo sigProc params sigClassified =+   let sigRumbleClassified =+         mapSnd+            (LabelChain.unzipRumbling .+             LabelChain.assimilateRumblingDuo .+             fmap (Class.checkPurity . Class.fromLabel))+         <$>+         sigClassified+   in  (LabelTrack.mergeNamesakes $+         LabelTrack.realTimes $ fst . snd <$> sigRumbleClassified,+        LabelChain.fuseTickingBouts NonEmpty.sum $+        LabelChain.tickingsFromRaspings (Params.raspingMinNumClicks params <=) $+        countClicksGlobal sigProc params $+        mapSnd snd <$> sigRumbleClassified)++{- ToDo:+Is it possible and sensible to split measureSignal,+such that we need to call it only once?+-}+fromGlobal ::+   SPMethods.T -> Params.T -> Signal.Sox ->+   (LabelTrack.T Double String, LabelChain.T Double (SoundMeasure Int)) ->+   Result+fromGlobal sigProc params sig (rumbling, classifiedMeas) =+   (classifiedMeas,+    LabelTrack.merge+     (suspiciousIntervalsFromGlobal params+        (LabelTrack.fromLabelChain classifiedMeas))+     rumbling,+    snd $ measureSignal sigProc params $+    Signal.addDiscretizedLabels sig classifiedMeas)++fromGlobalRumbleSolo ::+   SPMethods.T -> Params.T -> Signal.SoxLabelled String -> Result+fromGlobalRumbleSolo sigProc params labelled =+   fromGlobal sigProc params (fmap fst labelled) $+   classFromGlobalRumbleSolo sigProc params labelled++fromGlobalRumbleDuo ::+   SPMethods.T -> Params.T -> Signal.SoxLabelled String -> Result+fromGlobalRumbleDuo sigProc params labelled =+   fromGlobal sigProc params (fmap fst labelled) $+   classFromGlobalRumbleDuo sigProc params labelled
+ src/Feature.hs view
@@ -0,0 +1,788 @@+{-# 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 :: HMMNamed.Gaussian Double+   }++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 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 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)
+ src/Fourier.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE RebindableSyntax #-}+module Fourier where++import qualified Math.FFT as FFT++import qualified Synthesizer.Generic.Analysis as Ana++import qualified Data.StorableVector as SV+import qualified Data.StorableVector.CArray as SVCArr++import qualified Data.Array.CArray as CArray+import qualified Data.Array.IArray as IArray+import Data.Array.CArray (CArray)+import Data.Array.IArray ((//), (!))+import Data.Tuple.HT (mapFst)++import Foreign.Storable (Storable)++import Control.Monad (liftM2)++import qualified Data.Complex as Complex++import qualified Algebra.IntegralDomain as Integral+import qualified Algebra.Additive as Additive+import qualified Algebra.Ring as Ring+import NumericPrelude+import Prelude ()+++-- see synthesizer-core:Synthesizer.Basic.NumberTheory+{- |+It's not awfully efficient, but ok for our uses.+-}+ceilingPower :: (Integral.C a, Ord a) => a -> a -> a+ceilingPower base n = base ^ fromIntegral (ceilingLog base n)++ceilingLog :: (Integral.C a, Ord a) => a -> a -> Int+ceilingLog base =+   length . takeWhile (>0) . iterate (flip div base) . subtract 1+++{- |+It must hold @transformSize > chunkSize@.+-}+layoutBlocks :: Int -> Int -> SV.Vector Float -> CArray (Int, Int) Float+layoutBlocks transformSize chunkSize xs =+   let numChunks = Integral.divUp (SV.length xs) chunkSize+   in  CArray.listArray ((0,0), (numChunks-1, transformSize-1)) (repeat 0)+       //+       zip (liftM2 (,) [0..] (take chunkSize [0..])) (SV.unpack xs)++mul1d2d ::+   (Ring.C a, Storable a) =>+   CArray Int a -> CArray (Int,Int) a -> CArray (Int,Int) a+mul1d2d xs ys =+   IArray.array (IArray.bounds ys) $+   map (\((i,j),y) -> ((i,j), xs!j * y)) $+   IArray.assocs ys++permuteClip ::+   (IArray.Ix i, IArray.Ix j, Additive.C a, Storable a) =>+   (i -> j) -> (j,j) -> CArray i a -> CArray j a+permuteClip f bnds xs =+   IArray.accumArray (+) zero bnds $+   filter (IArray.inRange bnds . fst) $+   map (mapFst f) $ IArray.assocs xs++sizes :: Int -> (Int, Int)+sizes len =+   let transformSize = ceilingPower 2 $ 2 * len+       chunkSize = transformSize - len + 1+   in  (transformSize, chunkSize)++padRight :: Int -> SV.Vector Float -> SV.Vector Float+padRight size xs =+   SV.append xs $ SV.replicate (size - SV.length xs) 0++convolve :: SV.Vector Float -> SV.Vector Float -> SV.Vector Float+convolve xs ys =+   let (transformSize, chunkSize) = sizes $ SV.length xs+       dims = [1]+   in  SVCArr.from $+       permuteClip+          (\(i,j) -> i*chunkSize+j)+          (0, SV.length xs + SV.length ys - 2) $+       FFT.dftCRN dims $+       mul1d2d+          (FFT.dftRC $ SVCArr.to $ padRight transformSize xs)+          (FFT.dftRCN dims $ layoutBlocks transformSize chunkSize ys)++correlate :: SV.Vector Float -> SV.Vector Float -> SV.Vector Float+correlate xs ys =+   let (transformSize, chunkSize) = sizes $ SV.length xs+       dims = [1]+   in  SVCArr.from $+       permuteClip+          (\(i,j) -> i*chunkSize+j - SV.length xs + 1)+          (0, SV.length ys - 1) $+       FFT.dftCRN dims $+       mul1d2d+          (FFT.dftRC $ SVCArr.to $ padRight transformSize $ SV.reverse xs)+          (FFT.dftRCN dims $ layoutBlocks transformSize chunkSize ys)+++pillow :: Int -> CArray Int Float+pillow n =+   CArray.listArray (0, n-1) $+   map (\i -> sin (pi * fromIntegral i / fromIntegral n)) [(0::Int) .. ]++{- |+The array is not padded.+Instead we choose the longest array that only contains valid data.+-}+layoutOverlapBlocks :: Int -> Int -> SV.Vector Float -> CArray (Int, Int) Float+layoutOverlapBlocks shift chunkSize xs =+   let lastChunk = Integral.div (SV.length xs - chunkSize) shift+       bnds = ((0,0), (lastChunk, chunkSize-1))+   in  CArray.array bnds $ flip map (IArray.range bnds) $+       \(i,j) -> ((i,j), SV.index xs $ i*shift + j)++absoluteBlockSpectra :: Int -> Int -> SV.Vector Float -> CArray (Int, Int) Float+absoluteBlockSpectra shift chunkSize xs =+   CArray.amap Complex.magnitude $+   FFT.dftRCN [1] $ mul1d2d (pillow chunkSize) $+   layoutOverlapBlocks shift chunkSize xs++slice :: CArray (Int, Int) Float -> [SV.Vector Float]+slice arr =+   let ((firstChunk, firstElem), (lastChunk, lastElem)) = IArray.bounds arr+   in  map (\i ->+          SV.sample (IArray.rangeSize (firstElem, lastElem)) $+             \j -> arr ! (i, firstElem+j)) $+       IArray.range (firstChunk, lastChunk)++spectralFlatness :: SV.Vector Float -> Float+spectralFlatness xs =+   2 ** Ana.average (SV.map (logBase 2) xs) / Ana.average xs
+ src/HiddenMarkovModel.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE RebindableSyntax #-}+module HiddenMarkovModel where++import qualified LabelChain+import qualified Label+import qualified Named++import qualified Math.HiddenMarkovModel.Named as HMMNamed+import qualified Math.HiddenMarkovModel as HMM++import qualified Numeric.Container as NC+import qualified Data.Packed.Matrix as Matrix+import qualified Data.Packed.Vector as Vector+import Data.Packed.Vector (Vector)++import qualified Data.StorableVector.Lazy as SVL+import Foreign.Storable (Storable)++import Text.Printf (printf, )++import qualified Options.Applicative as OP+import qualified System.Path.PartClass as PathClass+import qualified System.Path as Path++import qualified Control.Monad.Exception.Synchronous as ME+import qualified Control.Parallel.Strategies as Par++import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Monoid.HT as Mn+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import qualified Data.Map as Map; import Data.Map (Map)+import qualified Data.Set as Set; import Data.Set (Set)+import Data.Traversable (Traversable)+import Data.Foldable (foldMap)+import Data.Monoid ((<>))+import Data.NonEmpty ((!:))+import Data.Tuple.HT (swap)++import NumericPrelude.Numeric+import NumericPrelude.Base++++allStates :: [String]+allStates =+   List.sort+      [Label.clickBegin, Label.clickEnd,+       Label.chirpingMain, Label.chirpingPause, Label.growling, Label.pause]+++admissibleTransitions :: [(String, [String])]+admissibleTransitions =+   (Label.pause,+      [Label.pause,+       Label.chirpingMain, Label.clickBegin, Label.growlingClickBegin]) :+   (Label.clickBegin, [Label.clickBegin, Label.clickEnd]) :+   (Label.clickEnd,+      [Label.clickBegin, Label.clickEnd,+       Label.chirpingMain, Label.growlingClickBegin, Label.pause]) :+   (Label.chirpingMain, [Label.chirpingMain, Label.chirpingPause]) :+   (Label.chirpingPause,+      [Label.chirpingMain, Label.chirpingPause,+       Label.clickBegin, Label.growlingClickBegin, Label.pause]) :+   (Label.growlingClickBegin,+      [Label.growlingClickBegin, Label.growlingClickEnd]) :+   (Label.growlingClickEnd,+      [Label.growlingClickBegin, Label.growlingClickEnd,+       Label.chirpingMain, Label.clickBegin, Label.pause]) :+   []++admissibleTransitionSet :: Set (String, String)+admissibleTransitionSet =+   foldMap+      (\(from, tos) -> Set.fromList $ map ((,) from) tos)+      admissibleTransitions++forbiddenTransitions ::+   Set (String, String) ->+   Map HMM.State String ->+   HMM.GaussianTrained Double -> Set (String, String)+forbiddenTransitions admissible dict =+   flip Set.difference admissible .+   foldMap+      (foldMap+         (\(row, (col, x)) ->+            Mn.when (x > 0) $+            Set.singleton+               (checkedLookup dict (HMM.state col),+                checkedLookup dict (HMM.state row)))) .+   zipWith (\k -> map ((,) k) . zip [0..]) [0..] .+   Matrix.toLists . HMM.trainedTransition+++inverseMap :: Map HMM.State String -> Map String HMM.State+inverseMap =+   Map.fromListWith (error "duplicate label") .+   map swap . Map.toList++checkedLookup :: (Ord k, Show k) => Map k a -> k -> a+checkedLookup m k =+   Map.findWithDefault+      (error $ "checkedLookup: unknown key " ++ show k) k m++mapsFromLabels :: [String] -> (Map String HMM.State, Map HMM.State String)+mapsFromLabels ss =+   let m = Map.fromList $ zip (map HMM.state [0..]) ss+   in  (inverseMap m, m)+++checkNonEmpty ::+   (PathClass.AbsRel ar) =>+   Path.File ar -> Named.Signal ->+   ME.Exceptional String Named.NonEmptySignal+checkNonEmpty path (Named.Cons name sig) =+   case SVL.viewL sig of+      Nothing ->+         ME.throw $+         printf "%s: %s: empty feature signal" (Path.toString path) name+      Just (x,xs) -> return $ Named.Cons name $ x !: xs++flattenStorableVectorLazy ::+   (Storable a) => NonEmpty.T SVL.Vector a -> SVL.Vector a+flattenStorableVectorLazy (NonEmpty.Cons x xs) = SVL.cons x xs++prepare :: [Named.NonEmptySignal] -> NonEmpty.T [] (Vector Double)+prepare nxs =+   let xs = map Named.body nxs+       vecFromList = NC.cmap realToFrac . Vector.fromList+   in  (vecFromList $ map NonEmpty.head xs)+       !:+       (map vecFromList $ List.transpose $ map (SVL.unpack . NonEmpty.tail) xs)++label :: HMM.Gaussian Double -> [Named.NonEmptySignal] -> [HMM.State]+label model = NonEmpty.flatten . HMM.reveal model . prepare++analyze ::+   HMMNamed.Gaussian Double ->+   [Named.NonEmptySignal] -> LabelChain.T Int String+analyze model =+   fmap (checkedLookup $ HMMNamed.nameFromStateMap model) .+   LabelChain.segment . label (HMMNamed.model model)+++flattenIntervals ::+   Map String HMM.State ->+   LabelChain.T Int String -> [HMM.State]+flattenIntervals dict =+   LabelChain.flattenLabels . fmap (checkedLookup dict)++trainSupervised ::+   (PathClass.AbsRel ar) =>+   Map String HMM.State -> Path.File ar ->+   [Named.NonEmptySignal] -> LabelChain.T Int String ->+   ME.Exceptional String (HMM.GaussianTrained Double)+trainSupervised dict input sig labels = do+   labelSig <-+      ME.fromMaybe+         (printf "%s: no labels for supervised training" $+          Path.toString input) $+      NonEmpty.fetch $ flattenIntervals dict labels+   return $+      HMM.trainSupervised (Map.size dict) $+      NonEmptyC.zip labelSig (prepare sig)++trainMany ::+   (Traversable f) =>+   (trainingData -> HMM.GaussianTrained Double) ->+   NonEmpty.T f trainingData -> HMM.Gaussian Double+trainMany train =+   HMM.finishTraining . NonEmpty.foldl1 HMM.mergeTrained .+   Par.withStrategy (Par.parTraversable Par.rdeepseq) . fmap train+++data Convergence =+   Convergence {+      cvgMaxIter, cvgSubIter :: Int,+      cvgTolerance :: Double+   }++convergenceOptions :: OP.Parser Convergence+convergenceOptions =+   OP.liftA3 Convergence+      (OP.option OP.auto $+            OP.value 100+         <> OP.long "max-iterations"+         <> OP.metavar "NUMBER"+         <> OP.help "maximal number of iterations for unsupervised training")+      (OP.option OP.auto $+            OP.value 10+         <> OP.long "sub-iterations"+         <> OP.metavar "NUMBER"+         <> OP.help "number of sub-iterations per iteration")+      (OP.option OP.auto $+            OP.value 1e-5+         <> OP.long "tolerance"+         <> OP.metavar "PROB"+         <> OP.help "convergence tolerance for unsupervised training")++takeUntilConvergence ::+   Convergence -> [HMM.Gaussian Double] -> [HMM.Gaussian Double]+takeUntilConvergence opt =+   (\(hmm:hmms) ->+      (hmm :) $ map snd . take (cvgMaxIter opt) . takeWhile fst $+      ListHT.mapAdjacent+         (\hmm0 hmm1 -> (HMM.deviation hmm0 hmm1 > cvgTolerance opt, hmm1))+         hmms) .+   ListHT.sieve (cvgSubIter opt)
+ src/HiddenMarkovModel/Hardwired.hs view
@@ -0,0 +1,158 @@+module HiddenMarkovModel.Hardwired where++import HiddenMarkovModel (inverseMap)+import qualified Label++import qualified Math.HiddenMarkovModel.Distribution as Distr+import qualified Math.HiddenMarkovModel.Pattern as Pat+import qualified Math.HiddenMarkovModel.Named as HMMNamed+import qualified Math.HiddenMarkovModel as HMM++import qualified Numeric.Container as NC+import qualified Data.Packed.Matrix as Matrix+import qualified Data.Packed.Vector as Vector+import Data.Packed.Matrix (Matrix)++import qualified Data.Map as Map; import Data.Map (Map)+import Data.Semigroup ((<>))+import Data.Tuple.HT (mapFst)++++pause, clickBegin, clickEnd, chirping, chirpingPause, growling :: HMM.State+pause         = HMM.state 0+clickBegin    = HMM.state 1+clickEnd      = HMM.state 2+chirping      = HMM.state 3+chirpingPause = HMM.state 4+growling      = HMM.state 5++numberOfStates :: Int+numberOfStates = 6++formatState :: Distr.State -> String+formatState (Distr.State s) =+   case s of+      1 -> "click begin"+      2 -> "click end"+      3 -> "chirping loop"+      4 -> "chirping pause"+      5 -> "growling"+      _ -> "pause"++labelFromStateMap :: Map HMM.State String+labelFromStateMap =+   Map.fromList $ map (mapFst HMM.state) $+      (0, Label.pause) :+      (1, Label.clickBegin) :+      (2, Label.clickEnd) :+      (3, Label.chirpingMain) :+      (4, Label.chirpingPause) :+      (5, Label.growling) :+      []++stateFromLabelMap :: Map String HMM.State+stateFromLabelMap =+   inverseMap labelFromStateMap++++infixr 7 *<>++(*<>) :: Int -> Pat.T Double -> Pat.T Double+(*<>) = Pat.replicate+++rasping :: Pat.T Double+rasping =+   15 *<>+      (600 *<> Pat.atom clickBegin+       <>+       600 *<> Pat.atom clickEnd)++pattern :: Pat.T Double+pattern =+   10000 *<> Pat.atom pause+   <>+   15 *<>+      (rasping+       <>+       6000 *<> Pat.atom chirping+       <>+       1500 *<> Pat.atom chirpingPause)+   <>+   rasping+   <>+   60000 *<> Pat.atom pause+   <>+   7 *<>+      (150 *<> Pat.atom growling+       <>+       1000 *<> Pat.atom pause)++++hmm :: HMM.Gaussian Double+hmm = hmmTrained++hmmTrained :: HMM.Gaussian Double+hmmTrained =+   HMM.Cons {+      HMM.initial =+         Vector.fromList [0.0,0.0,0.0,1.0,0.0,0.0],+      HMM.transition =+         Matrix.fromLists $+            [0.9994586913864266,0.0,2.100090303883067e-5,0.0,0.0,1.0218978102189781e-2] :+            [0.0,0.9855812349085892,4.09517609257198e-3,0.0,2.4915465385299874e-3,0.0] :+            [0.0,1.4418765091410832e-2,0.9956108112648844,0.0,0.0,0.0] :+            [0.0,0.0,2.730117395047987e-4,0.9994628194305887,0.0,0.0] :+            [0.0,0.0,0.0,5.371805694114036e-4,0.99750845346147,0.0] :+            [5.413086135733135e-4,0.0,0.0,0.0,0.0,0.9897810218978101] :+            [],+      HMM.distribution =+         Distr.gaussian $+            (Vector.fromList [0.9513191890047871], covariance [[0.17689006357223516]]) :+            (Vector.fromList [1.5879408507110250], covariance [[0.600575479836784]]) :+            (Vector.fromList [0.7454942099113683], covariance [[0.4088353694711163]]) :+            (Vector.fromList [1.0231037870319346], covariance [[0.19801719658707737]]) :+            (Vector.fromList [0.6214106323233616], covariance [[0.3085570412459857]]) :+            (Vector.fromList [1.5574159338071116], covariance [[0.6221472768351596]]) :+            []}++hmmPattern :: HMM.Gaussian Double+hmmPattern =+   (HMM.finishTraining $+    Pat.finish numberOfStates (Distr.GaussianTrained Map.empty) pattern)+       {HMM.distribution =+          Distr.gaussian $+            (Vector.fromList [1.00], covariance [[0.17]]) :+            (Vector.fromList [1.60], covariance [[0.60]]) :+            (Vector.fromList [0.75], covariance [[0.40]]) :+            (Vector.fromList [1.00], covariance [[0.20]]) :+            (Vector.fromList [0.60], covariance [[0.30]]) :+            (Vector.fromList [1.60], covariance [[0.60]]) :+            []}++hmmNamed :: HMMNamed.Gaussian Double+hmmNamed =+   HMMNamed.Cons {+      HMMNamed.model = hmm,+      HMMNamed.nameFromStateMap = labelFromStateMap,+      HMMNamed.stateFromNameMap = stateFromLabelMap+   }+++covariance :: [[Double]] -> Matrix Double+covariance xs =+   let m = Matrix.fromLists xs+   in  Matrix.trans m NC.<> m+++scaleStdDev :: Double -> HMM.Gaussian Double -> HMM.Gaussian Double+scaleStdDev k model =+   model {+      HMM.distribution =+         let Distr.Gaussian arr = HMM.distribution model+         in  Distr.Gaussian $+             fmap (\(center,dev,c) -> (center, NC.scale k dev, c/k)) arr+   }
+ src/Label.hs view
@@ -0,0 +1,36 @@+module Label where+++clickBegin, clickEnd, chirpingMain, chirpingPause,+   growlingClickBegin, growlingClickEnd, pause :: String+clickBegin = "r0"+clickEnd = "r1"+chirpingMain = "ch"+chirpingPause = "cp"+growlingClickBegin = "g0"+growlingClickEnd = "g1"+pause = "p"++clickParts :: (String, String)+clickParts = (clickBegin, clickEnd)++growlingClickParts :: (String, String)+growlingClickParts = (growlingClickBegin, growlingClickEnd)+++advertisement, rasping, chirping, ticking, growling,+   rumble, raspingRumble, chirpingRumble, growlingRumble,+   overlayedRumble :: String++advertisement = "advertisement"+rasping = "rasping"+chirping = "chirping"+ticking = "ticking"+growling = "growling"++rumble = "rumble"+raspingRumble = rasping ++ ' ' : rumble+chirpingRumble = chirping ++ ' ' : rumble+growlingRumble = growling ++ ' ' : rumble++overlayedRumble = "+rumble"
+ src/LabelChain.hs view
@@ -0,0 +1,984 @@+{-# LANGUAGE RebindableSyntax #-}+module LabelChain (+   T(..),+   fromAdjacentChunks,+   singleton,+   lift,+   segment,+   flattenLabels,+   toLabelTrack,+   fromLabelTrack,+   intervalSizes,+   mapTime,+   mapWithBounds,+   zipWithList,+   realTimes,+   concat,+   takeTime,+   trim,+   adjustLength,+   collectExceptions,+   writeFile,+   writeFileInt,++   splitChirping,++   -- click detection+   detectClicksDiff,+   detectClicksExtrema,+   detectClicksMonotony,+   detectClicksLaxMonotony,+   detectClicksThreshold,+   detectClicksWeakMonotony,+   fineFromCoarseIntervalsInt,+   fineFromCoarseIntervalsInt2,+   snapBoundaries,++   chopMonotony,+   spanWeakFalling,+   spanWeakRising,++   -- testing+   propSpanWeak,+   propExtremaSizes,+   propMaximaSizes,++   -- classification post-processing+   BreakRel(..),+   ClickAbs(..),+   ClickRels,+   abstractFromSoundClassIntervals,+   classFromFineIntervals,+   classRelativeFromAbsolute,++   -- fix of classification glitches+   correctShortChirping,+   fuseTickingBouts,+   mergeRaspingShortPause,+   tickingsFromRaspings,+   breakLongClicks,+   mergeRaspingGrowling,+   assimilateRumblingSolo, Rumbling(..),+   assimilateRumblingDuo,+   unzipRumbling,+   ) where++import qualified SignalProcessing as SP+import qualified Class+import qualified Rate+import qualified Parameters as Params+import qualified Durations as Durs+import qualified LabelPattern as Pat+import qualified Label+import LabelPattern ((&))++import qualified Sound.Audacity.LabelTrack as LabelTrack++import qualified Data.StorableVector.Lazy as SVL++import qualified System.Path.PartClass as PathClass+import qualified System.Path as Path++import qualified Control.Monad.Exception.Synchronous as ME+import qualified Control.Functor.HT as FuncHT+import Control.DeepSeq (NFData, rnf)+import Control.Monad (liftM3, guard)+import Control.Applicative (Applicative, pure, (<*>), (<$>), (<$), (<|>))++import qualified Data.NonEmpty.Mixed as NonEmptyM+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.List.Reverse.StrictSpine as RevSpine+import qualified Data.List.Match as Match+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Semigroup (Semigroup, (<>))+import Data.Foldable (foldMap)+import Data.NonEmpty ((!:))+import Data.Maybe.HT (toMaybe)+import Data.Maybe (maybeToList)+import Data.Tuple.HT (mapFst, mapSnd, mapPair)+import Data.Ord.HT (comparing)+import Data.Eq.HT (equating)++import qualified Algebra.RealRing as Real+import qualified Algebra.Additive as Additive+import NumericPrelude.Numeric+import NumericPrelude.Base hiding (readFile, writeFile, null, concat)+++{- |+Time stamps must be in ascending order.+-}+newtype T t a = Cons {decons :: [(t,a)]}++instance Functor (T t) where+   fmap f = lift $ map (mapSnd f)++instance Fold.Foldable (T t) where+   foldMap f = Fold.foldMap (f . snd) . decons++instance Trav.Traversable (T t) where+   sequenceA = fmap Cons . Trav.traverse (FuncHT.mapSnd id) . decons++instance (NFData t, NFData a) => NFData (T t a) where+   rnf = rnf . decons++singleton :: t -> a -> T t a+singleton t a = Cons [(t,a)]++mapTime :: (t -> s) -> T t a -> T s a+mapTime f = Cons . mapTimePlain f . decons++mapTimePlain :: (t -> s) -> [(t,a)] -> [(s,a)]+mapTimePlain f = map (mapFst f)++mapWithBounds :: (Additive.C t) => ((t,t) -> a -> b) -> T t a -> T t b+mapWithBounds f =+   fromLabelTrack . LabelTrack.mapWithTime f . toLabelTrack++zipWithList :: (a -> b -> c) -> [a] -> T t b -> T t c+zipWithList f = lift . zipWith (mapSnd . f)++realTimes :: (Rate.C rate) => rate -> T Int a -> T Double a+realTimes sampleRate = mapTime (Params.toTime sampleRate)++duration :: (Additive.C t) => T t a -> t+duration = ListHT.switchR zero (\_ (t,_) -> t) . decons++-- Attention: This deviates from LabelTrack.mconcat since it shifts the parts+concat :: (Additive.C t) => [T t a] -> T t a+concat =+   Cons . concatMap decons .+   uncurry (zipWith (\offset xs -> mapTime (offset+) xs)) .+   mapFst (scanl (+) zero) . unzip . map (\xs -> (duration xs, xs))+++fromAdjacentChunks :: (Additive.C t) => [(t, a)] -> T t a+fromAdjacentChunks =+   Cons . snd .+   Trav.mapAccumL (\t0 (d, lab) -> let t1=t0+d in (t1, (t1, lab))) zero++lift :: ([(t0,a)] -> [(t1,b)]) -> T t0 a -> T t1 b+lift f (Cons xs) = Cons $ f xs+++segmentChunks :: (Eq a) => [a] -> [(Int, a)]+segmentChunks =+   map (\ss -> (length (NonEmpty.flatten ss), NonEmpty.head ss)) .+   NonEmptyM.groupBy (==)++segment :: (Eq a) => [a] -> T Int a+segment  =  fromAdjacentChunks . segmentChunks++flattenLabels :: T Int a -> [a]+flattenLabels = foldMap (uncurry replicate) . intervalSizes++intervalSizes :: (Additive.C t) => T t a -> T t (t, a)+intervalSizes =+   Cons . ListHT.mapAdjacent1 (\n0 n1 lab -> (n1, (n1-n0, lab))) zero . decons++instance Durs.Track T where intervalSizes = intervalSizes++toLabelTrack :: (Additive.C t) => T t a -> LabelTrack.T t a+toLabelTrack =+   LabelTrack.Cons .+   ListHT.mapAdjacent1 (\l r lab -> ((l,r), lab)) Additive.zero . decons++{- |+Only allowed for consecutive intervals starting at zero.+This is not checked.+-}+fromLabelTrack :: LabelTrack.T t a -> T t a+fromLabelTrack = Cons . map (mapFst snd) . LabelTrack.decons+++takeTime :: (Additive.C t, Ord t) => t -> T t a -> T t a+takeTime =+   let go _ _ [] = []+       go t left (x@(right,lab):xs) =+         if t<=left+           then []+           else+               if t<right+                 then [(t, lab)]+                 else x : go t right xs+   in  lift . flip go zero++trim :: (Additive.C t, Ord t) => t -> T t a -> T t a+trim maxDur (Cons xt) =+   applyPattern Pat.flatten1+      (Pat.mapMaybe+         (\(x0,x1) -> toMaybe (Pat.dur x1 <= maxDur) (Pat.intervalLabel x0)) $+       Pat.atEnd $ Pat.fuse Pat.next Pat.next)+      $+      Cons $+      case xt of+         (t0,_) : xs -> if t0<=maxDur then xs else xt+         [] -> []++{- |+Extend or cut such that the chain has the desired length.+-}+adjustLength :: (Ord t) => t -> T t a -> T t a+adjustLength dur =+   let go (x0@(t,a), xs) =+         maybe [(dur,a)] (x0 :) $ do+            guard $ t<dur+            go <$> ListHT.viewL xs+   in  Cons . maybe [] go . ListHT.viewL . decons++collectExceptions :: T t (ME.Exceptional e a) -> ME.Exceptional [e] (T t a)+collectExceptions =+   (\(es,as) -> if List.null es then ME.Success (Cons as) else ME.throw es) .+   ListHT.unzipEithers .+   map (\(bnds,label) -> ME.switch Left (Right . (,) bnds) label) .+   decons+++writeFile ::+   (PathClass.AbsRel ar) =>+   Path.File ar -> T Double String -> IO ()+writeFile path =+   LabelTrack.writeFile (Path.toString path) . toLabelTrack++writeFileInt ::+   (Rate.C rate, PathClass.AbsRel ar) =>+   rate -> Path.File ar -> T Int String -> IO ()+writeFileInt rate path =+   LabelTrack.writeFileInt (Rate.unpack rate) (Path.toString path) .+   toLabelTrack++++splitChirping :: SVL.Vector Float -> T Int String+splitChirping xs =+   let len = SVL.length xs+       chirpLength = len - SP.chirpingPauseDur xs+   in  Cons $+          (chirpLength, Label.chirpingMain) :+          (len, Label.chirpingPause) :+          []+++applyPattern ::+   Additive.C t =>+   Pat.Flatten bnds fa t a -> Pat.T t a bnds fa -> T t a -> T t a+applyPattern flatten p =+   fromLabelTrack . Pat.apply flatten p . toLabelTrack++applyPatternDefault ::+   (Additive.C t) =>+   Pat.Flatten bnds fb t b -> (a -> b) -> Pat.T t a bnds fb -> T t a -> T t b+applyPatternDefault flatten f p =+   fromLabelTrack . Pat.applyDefault flatten f p . toLabelTrack+++mergeNamesakes :: (Eq a) => T t a -> T t a+mergeNamesakes =+   lift $+      map (mapPair (NonEmpty.last, NonEmpty.head) . FuncHT.unzip) .+      NonEmptyM.groupBy (equating snd)++removeEmptyIntervals :: T Int a -> T Int a+removeEmptyIntervals =+   fmap snd . lift (filter ((>0) . fst . snd)) . intervalSizes++avoidEmptyClickParts :: T Int String -> T Int String+avoidEmptyClickParts =+   applyPattern Pat.flatten2 $+      let p2 =+            Pat.alt+               (Pat.match2 Label.clickParts)+               (Pat.match2 Label.growlingClickParts)+          whenDur p = Pat.guard (\(x0,x1) -> p (Pat.dur x0) (Pat.dur x1))+      in  mapPair (Pat.intervalLabel, Pat.intervalLabel) <$>+          Pat.alt+            (whenDur (\dur0 dur1 -> dur0==0 && dur1>1) (Pat.move 1 p2))+            (whenDur (\dur0 dur1 -> dur0>1 && dur1==0) (Pat.move (-1) p2))++removeIsolatedClickParts :: Additive.C t => T t String -> T t String+removeIsolatedClickParts =+   let matchBegin (lab0, lab1) (labelBegin, labelEnd) =+         lab0 == labelBegin && lab1 /= labelEnd+       matchEnd (lab0, lab1) (labelBegin, labelEnd) =+         lab0 /= labelBegin && lab1 == labelEnd+       p1 = fmap Pat.intervalLabel Pat.next++   in  applyPattern Pat.flatten1 $+         Pat.mapMaybe+            (\labs ->+               toMaybe+                  (matchEnd labs Label.clickParts ||+                   matchEnd labs Label.growlingClickParts)+                  (fst labs)+               <|>+               toMaybe+                  (matchBegin labs Label.clickParts ||+                   matchBegin labs Label.growlingClickParts)+                  (snd labs))+            (Pat.fuse p1 p1)++{- |+This is a quick fix.+It would be better to write click detection in a way+that avoids empty intervals.+-}+fixDetectedClicks :: T Int String -> T Int String+fixDetectedClicks =+   mergeNamesakes . removeEmptyIntervals .+   avoidEmptyClickParts . removeIsolatedClickParts+++threshold :: (Ord b) => (a, a) -> b -> [b] -> [a]+threshold (low,high) thr =+   map (\y -> if y<thr then low else high)+++-- ToDo: maybe this should be NonEmpty a -> (NonEmpty a, [a]) ?+type Span a = [a] -> ([a], [a])++spanRising :: (Ord a) => Span a+spanRising xs =+   Match.splitAt (takeWhile id $ ListHT.mapAdjacent (<=) xs) xs++spanFalling :: (Ord a) => Span a+spanFalling xs =+   Match.splitAt (takeWhile id $ ListHT.mapAdjacent (>=) xs) xs+++{-+This one accepts negative steps above a certain threshold.+This way we accept many small successive negative steps.+Better use 'spanWeakRising'.+-}+spanLaxRising :: (Ord a, Additive.C a) => a -> Span a+spanLaxRising d xs =+   Match.splitAt (takeWhile (>= -d) $ ListHT.mapAdjacent subtract xs) xs++spanLaxFalling :: (Ord a, Additive.C a) => a -> Span a+spanLaxFalling d xs =+   Match.splitAt (takeWhile (>= -d) $ ListHT.mapAdjacent (-) xs) xs+++-- ToDo: could we benefit from a ArgMax semigroup?+{-+This one remembers the maximum value and position seen so far.+Every following value must be above a certain difference below that maximum.+This way we allow small negative steps, but not runs of small steps.+We only keep the values until the maximum.++If a run of falling steps accumulates too much,+we abort that run and return to the last maximum value.+An exception is the handling at the end of the signal:+If we reach the end within a flat run of falling steps,+then we append this run to the rising sequence.+Otherwise the following alternating 'spanWeakFalling' and 'spanWeakRising' steps+will divide the remaining signal into smaller and smaller chunks.+-}+spanWeakRising :: (Ord a, Additive.C a) => a -> Span a+spanWeakRising d = spanWeak SP.argMax (<=d)++spanWeakFalling :: (Ord a, Additive.C a) => a -> Span a+spanWeakFalling d = spanWeak SP.argMin (>= -d)++spanWeak ::+   (Additive.C a) =>+   ((Int,a) -> (Int,a) -> (Int,a)) -> (a -> Bool) -> Span a+spanWeak _ _ [] = ([], [])+spanWeak argextr cmp xt0@(x0:xs0) =+   let slope =+          NonEmpty.mapTail+             (takeWhile (\(x, (_kmax, xmax)) -> cmp $ xmax - x)) $+          NonEmptyC.zip (x0!:xs0) $+          NonEmpty.scanl argextr (0,x0) (zip [1..] xs0)+       len = length xt0+       pos =+          if length (NonEmpty.flatten slope) == len+            then len+            else 1 + (fst $ snd $ NonEmpty.last slope)+   in  splitAt pos xt0++propSpanWeak :: Double -> [Double] -> Bool+propSpanWeak d xs =+   mapPair (map negate, map negate) (spanWeakRising d xs)+   ==+   spanWeakFalling d (map negate xs)+++{- |+@lookAhead@ must be at least 1.+-}+spanUntilMaximum :: (Ord a) => Int -> Span a+spanUntilMaximum lookAhead xs =+   splitAt+      (fst $ List.maximumBy (comparing snd) $ zip [0..] $ take lookAhead xs)+      xs++spanUntilMinimum :: (Ord a) => Int -> Span a+spanUntilMinimum lookAhead xs =+   splitAt+      (fst $ List.minimumBy (comparing snd) $ zip [0..] $ take lookAhead xs)+      xs+++chopMonotony :: (Span a, Span a) -> [a] -> [[a]]+chopMonotony (spanRise, spanFall) =+   let rising [] = []+       rising [x] = [[x]]+       rising xs =+          let (ys,zs) = spanRise xs+          in  ys : falling zs+       falling [] = []+       falling [x] = [[x]]+       falling xs =+          let (ys,zs) = spanFall xs+          in  ys : rising zs+   in  rising++{- |+It is important to round the first number up and the second one down.+Since an attack phase has often only one sample period,+only this way the maximum will be the first value of a click.+-}+extremaSizes :: (Span a, Span a) -> [a] -> [Int]+extremaSizes fs =+   NonEmpty.mapAdjacent (\n m -> div m 2 - div (-n) 2)+   .+   NonEmpty.cons 0 . map length . chopMonotony fs++propExtremaSizes :: (Ord a) => [a] -> Bool+propExtremaSizes xs =+   sum (extremaSizes (spanRising, spanFalling) xs) == length xs+++mergePhases :: [[a]] -> [[a]]+mergePhases =+   let go (x0:x1:xs) = (x0++x1) : go xs+       go xs = xs+   in  go++{- |+Alternative to 'extremaSizes' which focuses on maxima.+It does not handle minima and maxima in the same way, as 'extremaSizes' does.+Instead it chooses all values around a local maxima down to a certain threshold.+-}+maximaSizes :: (Real.C a) => (Span a, Span a) -> a -> [a] -> [Int]+maximaSizes fs thres =+   List.concat+   .+   NonEmpty.mapAdjacent (\(_,_,r) (l,m,_) -> [r+l,m])+   .+   ((0,0,0)!:) . (++ [(0,0,0)])+   .+   map+      (\xs ->+         let xmax = maximum xs+             (left, right) =+{-+                (if head xs < last xs+                   then mapFst (max 1)+                   else mapSnd (max 1)) $+-}+                mapPair+                   (length . RevSpine.dropWhile (thres*xmax <=),+                    length . List.dropWhile (thres*xmax <=)) $+                break (xmax==) xs+         in  (left, length xs - (left+right), right))+   .+   mergePhases+   .+   chopMonotony fs++propMaximaSizes :: (Real.C a) => a -> [a] -> Bool+propMaximaSizes thres xs =+   sum (maximaSizes (spanRising, spanFalling) thres xs) == length xs+++data ClickPhase = ClickBegin | ClickEnd+   deriving (Eq, Ord, Show)++type DetectClicks label a = (label,label) -> [a] -> T Int label++clickLabelsDet :: (String, String)+clickLabelsDet = (Label.clickEnd, Label.clickBegin)++growlingClickLabelsDet :: (String, String)+growlingClickLabelsDet = (Label.growlingClickEnd, Label.growlingClickBegin)++detectClicksThreshold :: (Eq label, Ord a) => a -> DetectClicks label a+detectClicksThreshold thr labels =+   segment . threshold labels thr++detectClicksMonotony :: Ord a => DetectClicks label a+detectClicksMonotony labels =+   fromAdjacentChunks . attachClickLabels labels .+   extremaSizes (spanRising, spanFalling)++detectClicksLaxMonotony ::+   (Ord a, Additive.C a) => (a,a) -> DetectClicks label a+detectClicksLaxMonotony (dr,df) labels =+   fromAdjacentChunks . attachClickLabels labels .+   extremaSizes (spanLaxRising dr, spanLaxFalling df)++detectClicksWeakMonotony ::+   (Real.C a) => (a,a) -> a -> DetectClicks label a+detectClicksWeakMonotony (dr,df) thres labels =+   fromAdjacentChunks .+   RevSpine.dropWhile ((0==) . fst) .+   dropWhile ((0==) . fst) .+   attachClickLabels labels .+   maximaSizes (spanWeakRising dr, spanWeakFalling df) thres++detectClicksExtrema :: Ord a => (Int, Int) -> DetectClicks label a+detectClicksExtrema (lookAheadMaximum, lookAheadMinimum) labels =+   fromAdjacentChunks . attachClickLabels labels .+   extremaSizes+      (spanUntilMaximum lookAheadMaximum,+       spanUntilMinimum lookAheadMinimum)++attachClickLabels :: (label,label) -> [bnd] -> [(bnd, label)]+attachClickLabels (low,high) xs  =  zip xs (cycle [low, high])+++localMinimaAtBoundaries :: (Ord a) => [a] -> (Maybe (Int, a), Maybe (Int, a))+localMinimaAtBoundaries =+   let nextMinimum xs =+         case spanFalling xs of+            (falling, x:_) -> Just (length falling, x)+            _ -> Nothing+   in  \xs -> (nextMinimum xs, nextMinimum $ reverse xs)++snapBoundaries ::+   SVL.Vector Float ->+   T Int (Class.Sound rasping chirping ticking growling) ->+   T Int (Class.Sound rasping chirping ticking growling)+snapBoundaries env intervals =+   let (chunkSizes, labels) =+          unzip $ Fold.toList $ intervalSizes intervals+       modifiedTimes =+          (\(acc,ts) -> NonEmpty.tail $ NonEmpty.snoc ts (fst acc)) $+          List.mapAccumL+             (\(t0,mdr0i) (lab, d, (chunk,(mdl1i,mdr1))) ->+                let mmd =+                      guard+                         (case lab of+                             Class.Rasping _ -> True+                             Class.Chirping _ -> True+                             Class.Growling _ -> True+                             _ -> False)+                      >>+                      liftM3+                         (\(n0,y0) (n1,y1) (yh,_) ->+                             (toMaybe (y0<yh) (n0+1,y0),+                              toMaybe (y1<yh) (n1,y1)))+                         mdr0i mdl1i (SVL.viewL chunk)+                    offset md = 1 ++                      case md of+                         (Nothing, mdl1) -> maybe 0 fst mdl1+                         (Just (dr0,_), Nothing) ->+                            if 0 < d-dr0 then -dr0 else 0+                         (Just (dr0,y0), Just (dl1,y1)) ->+                            if (dr0,y0) < (dl1,y1) && 0 < d-dr0+                              then -dr0+                              else dl1+                in  ((t0+d, mdr1), t0 + maybe 0 offset mmd))+             (0,Nothing) $+          zip3 labels chunkSizes $+          map (\chunk -> (chunk, localMinimaAtBoundaries $ SVL.unpack chunk)) $+          SP.chop env chunkSizes+   in  Cons $ zip modifiedTimes labels++fineFromCoarseIntervalsInt ::+   DetectClicks String Float -> SVL.Vector Float ->+   T Int (Class.Sound rasping chirping ticking growling) ->+   T Int String+fineFromCoarseIntervalsInt detectClicks env intervals =+   let detClicks parts = detectClicks parts . SVL.unpack+       f bnds chunk lab =+          case lab of+             Class.Rasping _ -> detClicks clickLabelsDet chunk+             Class.Ticking _ -> detClicks clickLabelsDet chunk+             Class.Growling _ -> detClicks growlingClickLabelsDet chunk+             Class.Chirping _ -> splitChirping chunk+             Class.Other str -> singleton (uncurry subtract bnds) str+       (bounds, (chunkSizes, labels)) =+          mapSnd unzip $ unzip $ LabelTrack.decons $+          toLabelTrack $ intervalSizes intervals+   in  fixDetectedClicks $ concat $+       zipWith3 f bounds (SP.chop env chunkSizes) labels+++detectClicksDiff ::+   (Real.C a) => a -> a -> DetectClicks label a+detectClicksDiff thresSingle thresSum (low,high) =+   fromAdjacentChunks .+   map+      (\chunk ->+         (sum $ map snd $ NonEmpty.flatten chunk,+          if fst $ NonEmpty.head chunk then high else low)) .+   NonEmptyM.groupBy (equating fst) .+   map+      (\chunk ->+         (fst (NonEmpty.head chunk) &&+          sum (map snd (NonEmpty.flatten chunk)) >= thresSum,+             SP.foldLength chunk)) .+   NonEmptyM.groupBy (equating fst) .+   map (\x -> (x>=thresSingle, x))++fineFromCoarseIntervalsInt2 ::+   DetectClicks String Float ->+   SVL.Vector Float -> SVL.Vector Float ->+   T Int (Class.Sound rasping chirping ticking growling) ->+   T Int String+fineFromCoarseIntervalsInt2 detectClicks env diffEnv intervals =+   let detClicks parts = detectClicks parts . SVL.unpack+       f bnds diffChunk chunk lab =+          case lab of+             Class.Rasping _ -> detClicks clickLabelsDet diffChunk+             Class.Ticking _ -> detClicks clickLabelsDet diffChunk+             Class.Growling _ -> detClicks growlingClickLabelsDet diffChunk+             Class.Chirping _ -> splitChirping chunk+             Class.Other str -> singleton (uncurry subtract bnds) str+       (bounds, (chunkSizes, labels)) =+          mapSnd unzip $ unzip $ LabelTrack.decons $+          toLabelTrack $ intervalSizes intervals+   in  fixDetectedClicks $ concat $+       List.zipWith4 f+          bounds (SP.chop diffEnv chunkSizes) (SP.chop env chunkSizes) labels++++intervalFromClickAbss :: ClickAbss t -> Pat.Interval t (ClickAbss t)+intervalFromClickAbss clicks =+   Pat.Interval+      (case (NonEmpty.head clicks, NonEmpty.last clicks) of+         (ClickAbs start _ _, ClickAbs _ _ stop) -> (start, stop))+      clicks++data ClickAbs t = ClickAbs t t t+type ClickAbss t = NonEmpty.T [] (ClickAbs t)++newtype BreakAbs t = BreakAbs t++instance (NFData t) => NFData (BreakAbs t) where+   rnf (BreakAbs t) = rnf t+++classFromFineIntervals ::+   (Additive.C t) =>+   T t String ->+   T t (Class.Sound (ClickAbss t) (BreakAbs t) ticking (ClickAbss t))+classFromFineIntervals =+   applyPatternDefault Pat.flatten1 Class.Other $+      let collectClicks clickParts =+            Pat.snocMaybe+               (Pat.many1 $+                  (\(Pat.Interval bnd0 _lab0, Pat.Interval bnd1 _lab1) ->+                     uncurry ClickAbs bnd0 (snd bnd1)) <$>+                  (Pat.fusedMatch2 clickParts))+               (Pat.optional $+                  (\(Pat.Interval bnd0 _lab0) ->+                     uncurry ClickAbs bnd0 (snd bnd0)) <$>+                  Pat.atEnd (Pat.match (fst clickParts)))+      in  (Class.Chirping . BreakAbs . snd . Pat.intervalBounds+           <$>+           (fst <$> Pat.fusedMatch2 (Label.chirpingMain, Label.chirpingPause)+            `Pat.alt`+            Pat.atEnd (Pat.match Label.chirpingMain)))+          `Pat.alt`+          (Class.Rasping <$> collectClicks Label.clickParts)+          `Pat.alt`+          (Class.Growling <$> collectClicks Label.growlingClickParts)+++mergeClickLists ::+   (Ord count) =>+   (NonEmpty.T [] clicks -> clicks) ->+   ([clicks] -> count) ->+   NonEmpty.T [] (Bool, clicks) ->+   Class.Sound clicks chirping ticking clicks+mergeClickLists merge count clickLists =+   let rel =+         uncurry (comparing (count . map snd)) $+         ListHT.partition fst $ NonEmpty.flatten clickLists+   in  (case rel of GT -> Class.Growling; _ -> Class.Rasping) $+       merge $ fmap snd clickLists++{- |+Merge adjacent rasping and growling sounds+and label the concatenation according to the majority of clicks.+-}+mergeRaspingGrowling ::+   (Additive.C t, Ord count) =>+   (NonEmpty.T [] clicks -> clicks) ->+   ([clicks] -> count) ->+   T t (Class.Sound clicks chirping ticking clicks) ->+   T t (Class.Sound clicks chirping ticking clicks)+mergeRaspingGrowling merge count =+   applyPattern Pat.flatten1 $+   fmap (mergeClickLists merge count) $+   Pat.many1 $ Pat.maybeLabel $ \cls ->+      (,) False <$> Class.maybeRasping cls+      <|>+      (,) True <$> Class.maybeGrowling cls+++data+   Rumbling t a =+      Rumbling {rumblingIntervals :: [Pat.Bounds t], unrumbling :: a}++instance Functor (Rumbling t) where+   fmap f (Rumbling rumbles a) = Rumbling rumbles $ f a++instance Applicative (Rumbling t) where+   pure = Rumbling []+   Rumbling frumbles f <*> Rumbling rumbles a =+      Rumbling (frumbles ++ rumbles) (f a)++instance (Semigroup a) => Semigroup (Rumbling t a) where+   Rumbling r0 a0 <> Rumbling r1 a1 = Rumbling (r0++r1) (a0<>a1)+++unzipRumbling ::+   T t (Class.Sound+         (Rumbling t rasping) (Rumbling t chirping)+         ticking (Rumbling t growling)) ->+   (LabelTrack.T t String,+    T t (Class.Sound rasping chirping ticking growling))+unzipRumbling xs =+   (LabelTrack.Cons $ map (flip (,) Label.rumble) $+    flip foldMap xs $ \cl ->+      case cl of+         Class.Other _ -> []+         Class.Rasping x -> rumblingIntervals x+         Class.Chirping x -> rumblingIntervals x+         Class.Ticking _ -> []+         Class.Growling x -> rumblingIntervals x+    ,+    Class.mapRasping unrumbling .+    Class.mapChirping unrumbling .+    Class.mapGrowling unrumbling+    <$>+    xs)+++{- |+Eliminate short rumbles within other sounds+and keep rumble positions for creation of warnings.+-}+assimilateRumblingSolo ::+   (Additive.C t, Ord t) =>+   (NonEmpty.T [] rasping -> rasping) ->+   (NonEmpty.T [] chirping -> chirping) ->+   (NonEmpty.T [] growling -> growling) ->+   t ->+   T t (Class.Sound rasping chirping ticking growling) ->+   T t (Class.Sound+         (Rumbling t rasping) (Rumbling t chirping)+         ticking (Rumbling t growling))+assimilateRumblingSolo mergeRasping mergeChirping mergeGrowling maxDur =+   applyPatternDefault Pat.flatten1+         (Class.mapRasping (Rumbling []) .+          Class.mapChirping (Rumbling []) .+          Class.mapGrowling (Rumbling [])) $+      let alternating unpack =+            Pat.terminatedBy+               (\(call,rumble) ~(Rumbling rumbles calls) ->+                  Rumbling+                     (Pat.intervalBounds rumble : rumbles)+                     (NonEmptyC.cons call calls))+               (Pat.fuse+                  (Pat.maybeLabel unpack)+                  (Pat.guard (\x -> Pat.dur x <= maxDur) $+                   Pat.check ((Just Label.rumble ==) . Class.maybeOther)))+               (Rumbling [] . NonEmpty.singleton <$> Pat.maybeLabel unpack)+      in  Class.Rasping . fmap mergeRasping <$>+            alternating Class.maybeRasping+          `Pat.alt`+          Class.Chirping . fmap mergeChirping <$>+            alternating Class.maybeChirping+          `Pat.alt`+          Class.Growling . fmap mergeGrowling <$>+            alternating Class.maybeGrowling++{- |+Process rumbles that overlaps with frog sounds.+-}+assimilateRumblingDuo ::+   (Additive.C t, Ord t) =>+   T t (Class.Sound Class.Purity  Class.Purity ticking  Class.Purity) ->+   T t (Class.Sound (Rumbling t ()) (Rumbling t ()) ticking (Rumbling t ()))+assimilateRumblingDuo =+   applyPatternDefault Pat.flatten1+         (Class.mapRasping (const $ Rumbling [] ()) .+          Class.mapChirping (const $ Rumbling [] ()) .+          Class.mapGrowling (const $ Rumbling [] ())) $+      let alternating unpack =+            fmap (FuncHT.void . Trav.sequenceA . NonEmpty.flatten) $+            Pat.many1 $+            (\(Pat.Interval bnds x) ->+               flip Rumbling () $+               case x of+                  Class.Pure -> []+                  Class.Rumble -> [bnds]) <$>+            Pat.maybe unpack+      in  Class.Rasping <$> alternating Class.maybeRasping+          `Pat.alt`+          Class.Chirping <$> alternating Class.maybeChirping+          `Pat.alt`+          Class.Growling <$> alternating Class.maybeGrowling+++breakLongClicks ::+   (Real.C t) =>+   (t -> t) ->+   T t (Class.Sound (ClickAbss t) chirping ticking (ClickAbss t)) ->+   T t (Class.Sound (ClickAbss t) chirping ticking (ClickAbss t))+breakLongClicks relMaxDur =+   applyPattern Pat.flattenFoldable $ Pat.expand $+   let branch pack unpack =+         map (fmap pack) . breakLongClicksIntervals relMaxDur+         <$>+         Pat.maybeLabel unpack+   in  branch Class.Rasping Class.maybeRasping+       `Pat.alt`+       branch Class.Growling Class.maybeGrowling++breakLongClicksIntervals ::+   (Real.C t) => (t -> t) -> ClickAbss t -> [Pat.Interval t (ClickAbss t)]+breakLongClicksIntervals relMaxDur =+   map intervalFromClickAbss .+   uncurry (++) . mapSnd (maybeToList . NonEmpty.fetch) .+   breakLongClicksList relMaxDur . NonEmpty.flatten++breakLongClicksList ::+   (Real.C t) => (t -> t) -> [ClickAbs t] -> ([ClickAbss t], [ClickAbs t])+breakLongClicksList relMaxDur clicks =+   let dist (ClickAbs start _end next) = next-start+       maxDur = relMaxDur $ almostMedian $ map dist clicks+   in  NonEmptyM.segmentAfter (\click -> dist click > maxDur) clicks++almostMedian :: (Ord a) => [a] -> a+almostMedian xs =+   case drop (div (length xs) 2) $ List.sort xs of+      [] -> error "almostMedianKey: empty list"+      x:_ -> x+++{-+The input ticking type must also be 'clicks',+since we cannot simply throw away ticking phases.+-}+tickingsFromRaspings ::+   (clicks -> Bool) ->+   T t (Class.Sound clicks chirping clicks growling) ->+   T t (Class.Sound clicks chirping clicks growling)+tickingsFromRaspings validRasping =+   fmap+      (\cls ->+         case cls of+            Class.Rasping clicks ->+               if validRasping clicks+                 then cls+                 else Class.Ticking clicks+            _ -> cls)+++fuseTickingBouts ::+   (Additive.C t) =>+   (NonEmpty.T [] clicks -> clicks) ->+   T t (Class.Sound rasping chirping clicks growling) ->+   T t (Class.Sound rasping chirping clicks growling)+fuseTickingBouts merge =+   applyPattern Pat.flatten1 $+      Class.Ticking . merge <$>+         let tick = Pat.maybeLabel Class.maybeTicking+         in  Pat.precededBy tick $+             Pat.terminatedBy (flip const) (Pat.check Class.isPause) tick+++data ClickRel t = ClickRel t t+type ClickRels t = NonEmpty.T [] (ClickRel t)++newtype BreakRel t = BreakRel t++instance (NFData t) => NFData (BreakRel t) where+   rnf (BreakRel t) = rnf t+++clickRelFromAbs :: (Additive.C t) => ClickAbs t -> ClickRel t+clickRelFromAbs (ClickAbs start end next) =+   ClickRel (end-start) (next-end)++{- |+This does not maintain the pauses between ticks.+-}+classRelativeFromAbsolute ::+   (Additive.C t) =>+   T t (Class.Sound (ClickAbss t) (BreakAbs t) (ClickAbss t) (ClickAbss t)) ->+   T t (Class.Sound (ClickRels t) (BreakRel t) (ClickRels t) (ClickRels t))+classRelativeFromAbsolute =+   mapWithBounds $ \(from,_to) cls ->+      case cls of+         Class.Rasping clicks -> Class.Rasping $ fmap clickRelFromAbs clicks+         Class.Ticking clicks -> Class.Ticking $ fmap clickRelFromAbs clicks+         Class.Growling clicks -> Class.Growling $ fmap clickRelFromAbs clicks+         Class.Chirping (BreakAbs brk) -> Class.Chirping $ BreakRel (brk-from)+         Class.Other str -> Class.Other str+++abstractFromSoundClassIntervals ::+   (Additive.C t) =>+   T t (Class.Sound clicks chirping ticking clicks) ->+   T t (Class.Abstract t clicks chirping ticking clicks)+abstractFromSoundClassIntervals =+   let checkRasping =+         (\(Pat.Interval bnds x) -> Class.Advertisement (snd bnds) x)+         <$>+         (Pat.maybe $+          \cls -> Class.maybeRasping cls <|> Class.maybeGrowling cls)+       checkChirping = Pat.maybeLabel Class.maybeChirping+   in  applyPatternDefault+         (Pat.flattenPair Pat.flatten1 Pat.flattenFoldable)+         Class.NoAdvertisement $++         Pat.combine+            (Pat.fuseWith ($) checkRasping (Just <$> checkChirping))+            (Pat.optional+               (fmap ($Nothing) checkRasping+                  `Pat.notFollowedBy` checkChirping))+++{- |+This is a hack to restore rasping-clicks+that were misclassified as chirpings.+-}+correctShortChirping ::+   (Real.C t) => t -> T t String -> T t String+correctShortChirping maxDur =+   applyPattern Pat.flatten2 $ Label.clickParts <$+      (Pat.guard (\(x0,x1) -> Pat.dur (x0&x1) <= maxDur) $+       Pat.match2 (Label.chirpingMain, Label.chirpingPause))++{- |+In r0-r1-p-r0-r1 merge the p with the preceding r1+if the resulting r0-r1 is short enough to be admissible.+-}+mergeRaspingShortPause ::+   (Real.C t) => t -> T t String -> T t String+mergeRaspingShortPause maxDur =+   applyPattern Pat.flatten2 $+      Pat.mapMaybe+         (\(x0,(x1,x2)) -> do+            let x01 = x0&x1+            guard $ Pat.dur (x01&x2) <= maxDur+            return $ Pat.intervalLabel x01) $++      Pat.match Label.clickBegin+      `Pat.combine`+      Pat.fusedMatch2 (Label.clickEnd, Label.pause)+      `Pat.followedBy`+      Pat.match2 Label.clickParts
+ src/LabelChainShifted.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE RebindableSyntax #-}+module LabelChainShifted (+   T(..),+   fromLabelChain,+   shiftToLabelChain,+   toLabelTrack,+   chopChain,+   chopClosest,+   subdivideTrack,+   mask,+   ) where++import qualified Durations as Durs+import qualified LabelChain++import qualified Sound.Audacity.LabelTrack as LabelTrack++import qualified Synthesizer.Generic.Signal as SigG++import qualified Control.Monad.Exception.Synchronous as ME+import Control.Applicative ((<$>))++import qualified Data.Monoid.HT as Mn+import qualified Data.Foldable as Fold+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Maybe.HT (toMaybe)+import Data.Tuple.HT (mapFst, mapSnd)++import qualified Algebra.Absolute as Absolute+import qualified Algebra.Additive as Additive+import NumericPrelude.Numeric+import NumericPrelude.Base hiding (readFile, writeFile, null)+++{- |+A chain of labels with a starting time that may differ from zero.+-}+data T t a = Cons {offset :: t, chain :: [(t,a)]}++instance Functor (T t) where+   fmap f (Cons t xs) = Cons t $ map (mapSnd f) xs++instance Fold.Foldable (T t) where+   foldMap f = Fold.foldMap (f . snd) . chain++fromLabelChain :: (Additive.C t) => LabelChain.T t a -> T t a+fromLabelChain = Cons zero . LabelChain.decons++shiftToLabelChain :: (Additive.C t) => T t a -> LabelChain.T t a+shiftToLabelChain (Cons t xs) =+   LabelChain.Cons $ map (mapFst (subtract t)) xs++instance Durs.Track T where+   intervalSizes (Cons t xs) =+      Cons t $ ListHT.mapAdjacent1 (\n0 n1 lab -> (n1, (n1-n0, lab))) t xs++toLabelTrack :: T t a -> LabelTrack.T t a+toLabelTrack (Cons t xs) =+   LabelTrack.Cons . ListHT.mapAdjacent1 (\l r lab -> ((l,r), lab)) t $ xs+++chopChain :: (Ord t) => LabelChain.T t a -> T t b -> [(a, T t b)]+chopChain ts xs0 =+   SigG.crochetL+      (\(t,a) xs -> toMaybe (not $ null xs) $ mapFst ((,) a) $ splitAtTime t xs)+      xs0 (LabelChain.decons ts)++_chopPattern0, _chopPattern1 :: (Ord t) => [t] -> T t a -> [T t a]+_chopPattern0 ts xs0 =+   SigG.crochetL (\t xs -> toMaybe (not $ null xs) $ splitAtTime t xs) xs0 ts++_chopPattern1 ts0 =+   let go [] _ = []+       go (t:ts) xs =+         if null xs+           then []+           else+               case splitAtTime t xs of+                  (ys,zs) -> ys : go ts zs+   in  go ts0+++subdivideTrack :: (Ord t) => LabelTrack.T t a -> T t b -> T t (Maybe a, b)+subdivideTrack ts xs0 =+   (\(suffix, subd) ->+      Cons (offset xs0) $ concat subd ++ chain (fmap ((,) Nothing) suffix)) $+   List.mapAccumL+      (\xs ((t0,t1),a) ->+         let (prefix, (ys, suffix)) =+               mapSnd (splitAtTime t1) $ splitAtTime t0 xs+         in  (suffix,+              chain ((,) Nothing <$> prefix) +++              chain ((,) (Just a) <$> ys)))+      xs0 (LabelTrack.decons ts)+++null :: T t a -> Bool+null = List.null . chain++splitAtTime :: (Ord t) => t -> T t a -> (T t a, T t a)+splitAtTime t =+   let go xs@(Cons _ []) = (xs, Cons t [])+       go xt@(Cons left ((right,lab):xs)) =+         if t<=left+           then (Cons t [], xt)+           else+               mapFst (cons left lab) $+               if t<right+                 then (Cons t [], Cons t $ (right, lab) : xs)+                 else go $ Cons right xs+   in  go++{- |+Chop @xs :: T t a@ chain with respect to @ts :: LabelChain.T t ()@.+We expect that every break in @ts@ is also present in @xs@,+however, the precise position might be distorted by rounding errors.+The positions of @xs@ are maintained,+that is the chunk boundaries are not adapted to the breaks in @ts@.+-}+chopClosest ::+   (Absolute.C t, Ord t) =>+   t -> LabelChain.T t () -> T t a -> [ME.Exceptional (Maybe t) (T t a)]+chopClosest maxDev ts xs0 =+   (\(remainingXs, zss) ->+      zss ++ Mn.when (not $ null remainingXs) [ME.throw Nothing]) $+   List.mapAccumL+      (\xs (t,()) ->+         let (ys,zs) = splitAtClosestTime t xs+         in  (zs,+               if abs (t - offset zs) <= maxDev+                 then ME.Success ys+                 else ME.Exception (Just t)))+      xs0 (LabelChain.decons ts)++splitAtClosestTime :: (Additive.C t, Ord t) => t -> T t a -> (T t a, T t a)+splitAtClosestTime t =+   let go xs@(Cons _ []) = (xs, xs)+       go (Cons left ((right,lab):xs)) =+         if t<=right+           then+               mapFst (Cons left) $+               if t+t < left+right+                 then ([], Cons left ((right,lab):xs))+                 else ([(right,lab)], Cons right xs)+           else mapFst (cons left lab) $ go $ Cons right xs+   in  \xt@(Cons left _xs) ->+         if t<left+           then (Cons left [], xt)+           else go xt++{- |+It chooses the closest node for splitting,+but moves the node to the splitting time.+-}+_splitAtClosestTime :: (Additive.C t, Ord t) => t -> T t a -> (T t a, T t a)+_splitAtClosestTime t =+   let go xs@(Cons _ []) = (xs, Cons t [])+       go (Cons left ((right,lab):xs)) =+         if t<=right+           then+               if t+t < left+right+                 then (Cons t [], Cons t ((right,lab):xs))+                 else (Cons left [(t,lab)], Cons t xs)+           else mapFst (cons left lab) $ go $ Cons right xs+   in  \xt@(Cons left _xs) ->+         if t<left+           then (Cons t [], xt)+           else go xt++cons :: t -> a -> T t a -> T t a+cons t x xs = Cons t $ (offset xs, x) : chain xs++mask :: (Ord t) => (t,t) -> T t a -> T t a+mask (l,r) = snd . splitAtTime l . fst . splitAtTime r
+ src/LabelPattern.hs view
@@ -0,0 +1,306 @@+{- |+Non-monadic parsers of intervals+where we use a restricted set of operations that preserve the invariants:++* replacing intervals match the outer bounds of the replaced intervals++* produced intervals do not overlap.+-}+module LabelPattern (+   Interval(..),+   dur,+   (&),++   Bounds,+   fuseBounds,++   T,+   next,+   check,+   match,+   match2,+   fusedMatch2,+   maybe,+   maybeLabel,++   alt,+   combine,+   expand,+   fuse,+   fuseWith,+   guard,+   many1,+   mapMaybe,+   move,+   optional,+   followedBy,+   notFollowedBy,+   atEnd,+   precededBy,+   terminatedBy,+   snocMaybe,++   apply,+   applyDefault,+   Flatten,+   flatten1,+   flatten2,+   flattenFoldable,+   flattenPair,+   ) where++import qualified Sound.Audacity.LabelTrack as LabelTrack++import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad as Monad+import qualified Control.Functor.HT as FuncHT+import Control.Applicative (liftA2, (<$>), (<|>))+import Control.Functor.HT (void)++import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.List.HT as ListHT+import qualified Data.Foldable as Fold+import Data.Traversable (Traversable, traverse)+import Data.Foldable (Foldable)+import Data.Tuple.HT (mapPair, mapFst, mapSnd)+import Data.Maybe (isNothing)++import qualified Algebra.Additive as Additive+import NumericPrelude.Numeric+import NumericPrelude.Base hiding (maybe, map)++import qualified Prelude as P+++data Interval t a = Interval {intervalBounds :: Bounds t, intervalLabel :: a}++type Bounds t = (t,t)++instance Functor (Interval t) where+   fmap f (Interval bnds a) = Interval bnds $ f a++instance Foldable (Interval t) where+   foldMap f (Interval _bnds a) = f a++instance Traversable (Interval t) where+   traverse f (Interval bnds a) = fmap (Interval bnds) $ f a++pairFromInterval :: Interval t a -> LabelTrack.Interval t a+pairFromInterval (Interval bnds a) = (bnds, a)++dur :: (Additive.C t) => Interval t a -> t+dur = uncurry subtract . intervalBounds++{- |+The two intervals must be adjacent.+This is not checked.+-}+(&) ::+   Interval t a ->+   Interval t b ->+   Interval t (a,b)+Interval bnds0 a & Interval bnds1 b =+   Interval (fuseBounds bnds0 bnds1) (a,b)++fuseBounds :: Bounds t -> Bounds t -> Bounds t+fuseBounds bnds0 bnds1 = (fst bnds0, snd bnds1)++++newtype+   T t a bnds fb = Cons (MS.StateT (LabelTrack.T t a) Maybe (bnds, fb))++instance Functor (T t a bnds) where+   fmap = map++map :: (b -> c) -> T t a bnds b -> T t a bnds c+map f (Cons m) = Cons $ fmap (mapSnd f) m+++viewL :: LabelTrack.T t a -> Maybe (Interval t a, LabelTrack.T t a)+viewL (LabelTrack.Cons xt) =+   fmap (mapPair (uncurry Interval, LabelTrack.Cons)) $ ListHT.viewL xt++next :: T t a (Bounds t) (Interval t a)+next =+   Cons $ fmap (\x -> (intervalBounds x, x)) $ MS.StateT viewL+++-- like Monoid.<>+infixr 6 `combine`++combine :: T t a bnds0 b -> T t a bnds1 c -> T t a (bnds0,bnds1) (b,c)+combine (Cons f) (Cons g) =+   Cons $+   liftA2+      (\(bnds0,x0) (bnds1,x1) -> ((bnds0,bnds1), (x0,x1)))+      f g++fuseCombined :: T t a (Pair (Bounds t)) b -> T t a (Bounds t) b+fuseCombined (Cons f) = Cons $ fmap (mapFst (uncurry fuseBounds)) f++fuseWith ::+   (b -> c -> d) ->+   T t a (Bounds t) b -> T t a (Bounds t) c -> T t a (Bounds t) d+fuseWith h p q = uncurry h <$> fuse p q++fuse :: T t a (Bounds t) b -> T t a (Bounds t) c -> T t a (Bounds t) (b,c)+fuse p q = fuseCombined $ combine p q++move ::+   (Additive.C t) => t -> T t a (Pair (Bounds t)) b -> T t a (Pair (Bounds t)) b+move d (Cons m) =+   Cons $ fmap (mapFst (mapPair (mapSnd (d+), mapFst (d+)))) m++guard :: (b -> Bool) -> T t a bnds b -> T t a bnds b+guard p (Cons m) = Cons $ Monad.mfilter (p . snd) m++check :: (a -> Bool) -> T t a (Bounds t) (Interval t a)+check p = guard (p . intervalLabel) next++match :: (Eq a) => a -> T t a (Bounds t) (Interval t a)+match a = check (a==)++type Pair a = (a,a)++match2 :: (Eq a) => Pair a -> T t a (Pair (Bounds t)) (Pair (Interval t a))+match2 (x,y) = combine (match x) (match y)++fusedMatch2 :: (Eq a) => Pair a -> T t a (Bounds t) (Pair (Interval t a))+fusedMatch2 = fuseCombined . match2++infixl 3 `alt`++alt :: T t a f b -> T t a f b -> T t a f b+alt (Cons x) (Cons y) = Cons (x<|>y)++mapMaybe :: (b -> Maybe c) -> T t a bnds b -> T t a bnds c+mapMaybe f (Cons m) = Cons $ MT.lift . FuncHT.mapSnd f =<< m++maybe :: (a -> Maybe b) -> T t a (Bounds t) (Interval t b)+maybe f = mapMaybe (traverse f) next++maybeLabel :: (a -> Maybe b) -> T t a (Bounds t) b+maybeLabel f = mapMaybe (f . intervalLabel) next++optional :: T t a bnds fa -> T t a (Maybe bnds) (Maybe fa)+optional (Cons m) =+   Cons $  mapPair (Just, Just) <$> m  <|>  return (Nothing, Nothing)++{- |+This is dangerous,+because it is not checked whether the outer interval bounds match.+-}+expand ::+   (Functor f) =>+   T t a (Bounds t) (f (Interval t b)) -> T t a (f (Bounds t)) (f b)+expand (Cons m) = Cons (FuncHT.unzip . fmap pairFromInterval . snd <$> m)+++infixr 6 `followedBy`, `notFollowedBy`++followedBy :: T t a bnds0 b -> T t a bnds1 c -> T t a bnds0 b+followedBy (Cons p) (Cons q) =+   Cons $ do+      x0 <- p+      s <- MS.get+      void q+      MS.put s+      return x0++notFollowedBy :: T t a bnds0 b -> T t a bnds1 c -> T t a bnds0 b+notFollowedBy (Cons p) (Cons q) =+   Cons $ do+      x0 <- p+      Monad.guard =<< MS.gets (isNothing . MS.evalStateT q)+      return x0++atEnd :: T t a bnds b -> T t a bnds b+atEnd (Cons f) =+   Cons $ do+      x <- f+      Monad.guard . LabelTrack.null =<< MS.get+      return x+++oneMore ::+   T t a (Bounds t) b ->+   T t a (Bounds t) (NonEmpty.T [] b) ->+   T t a (Bounds t) (NonEmpty.T [] b)+oneMore p q =+   alt+      (fuseWith NonEmpty.cons p (NonEmpty.flatten <$> q))+      (NonEmpty.singleton <$> p)++many1 :: T t a (Pair t) b -> T t a (Pair t) (NonEmpty.T [] b)+many1 p =+   let go = oneMore p go+   in  go++precededBy ::+   T t a (Pair t) b -> T t a (Pair t) b -> T t a (Pair t) (NonEmpty.T [] b)+precededBy q p = oneMore q $ many1 p++terminatedBy ::+   (b -> c -> c) -> T t a (Pair t) b -> T t a (Pair t) c -> T t a (Pair t) c+terminatedBy f q p =+   let go = alt (fuseWith f q go) p+   in  go+++snocMaybe ::+   T t a (Bounds t) (NonEmpty.T [] b) ->+   T t a (Maybe (Bounds t)) (Maybe b) ->+   T t a (Bounds t) (NonEmpty.T [] b)+snocMaybe (Cons p) (Cons q) =+   Cons $ do+      (bndx, x) <- p+      (mbndy, my) <- q+      return+         (P.maybe bndx (fuseBounds bndx) mbndy,+          P.maybe x (NonEmptyC.snoc x) my)++++newtype+   Flatten bnds fa t a =+      Flatten {runFlatten :: bnds -> fa -> [LabelTrack.Interval t a]}++flatten1 :: Flatten (Bounds t) a t a+flatten1 = Flatten $ \bnds a -> [(bnds,a)]++flatten2 :: Flatten (Pair (Bounds t)) (Pair a) t a+flatten2 = Flatten $ \(bnds0,bnds1) (a0,a1) -> [(bnds0,a0), (bnds1,a1)]++flattenFoldable :: (Foldable f) => Flatten (f (Bounds t)) (f a) t a+flattenFoldable =+   Flatten $ \bndss as -> zip (Fold.toList bndss) (Fold.toList as)++flattenPair ::+   Flatten bnds0 a0 t fa -> Flatten bnds1 a1 t fa ->+   Flatten (bnds0, bnds1) (a0, a1) t fa+flattenPair (Flatten flattenFst) (Flatten flattenSnd) =+   Flatten $+      \(bnds0,bnds1) (a0,a1) -> flattenFst bnds0 a0 ++ flattenSnd bnds1 a1+++apply ::+   Flatten iv fa t a -> T t a iv fa -> LabelTrack.T t a -> LabelTrack.T t a+apply flatten = applyDefault flatten id++applyDefault ::+   Flatten iv fb t b ->+   (a -> b) -> T t a iv fb -> LabelTrack.T t a -> LabelTrack.T t b+applyDefault flatten f (Cons p) =+   let go xt =+         case MS.runStateT p xt of+            Just ((bnds,labs),xs) ->+               LabelTrack.lift (runFlatten flatten bnds labs ++) $ go xs+            Nothing ->+               case viewL xt of+                  Just (x,xs) ->+                     LabelTrack.lift (pairFromInterval (fmap f x) :) $ go xs+                  Nothing -> LabelTrack.empty+   in  go
+ src/LabelTrack.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE RebindableSyntax #-}+module LabelTrack (+   LabelTrack.T(..),+   LabelTrack.Interval,+   fromLabelChain,+   maybeToLabelChain,++   LabelTrack.mapWithTime,+   discretizeTimes,+   discretizeTrack,+   checkGaps,+   checkOverlap,+   realTimes,+   shift,+   LabelTrack.concat,+   mergeNamesakes,+   merge,+   partition,+   sortTime,++   -- in/out+   readFile,+   writeFile,+   writeFileInt,+   ) where++import qualified LabelPattern as Pat+import qualified LabelChain+import qualified Rate++import qualified Sound.Audacity.LabelTrack as ALabelTrack+import qualified Sound.Audacity.LabelTrack as LabelTrack+import qualified Signal+import Parameters (toTime)++import qualified System.Path.PartClass as PathClass+import qualified System.Path as Path+import Text.Printf (printf, )++import qualified Control.Monad.Exception.Synchronous as ME+import qualified Control.Functor.HT as FuncHT+import Control.Applicative ((<$), (<$>))++import qualified Data.NonEmpty.Mixed as NonEmptyM+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Foldable as Fold+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Function.HT (compose2)+import Data.Tuple.HT (swap, mapPair)+import Data.Ord.HT (comparing)+import Data.Maybe.HT (toMaybe)+import Data.Maybe (catMaybes)++import qualified Algebra.RealRing as Real+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive+import NumericPrelude.Numeric+import NumericPrelude.Base hiding (readFile, writeFile)+++fromLabelChain :: (Additive.C t) => LabelChain.T t a -> LabelTrack.T t a+fromLabelChain = LabelChain.toLabelTrack++shift :: (Ring.C t) => t -> LabelTrack.T t a -> LabelTrack.T t a+shift d = LabelTrack.mapTime (d+)++concat :: LabelTrack.T time [a] -> LabelTrack.T time a+concat =+   Fold.fold .+   LabelTrack.mapWithTime+      (\bnd msgs -> Fold.foldMap (LabelTrack.singleton bnd) msgs)++_resizeChunks :: Double -> [Int] -> [Int]+_resizeChunks ratio =+   snd .+   List.mapAccumL+      (\frac size ->+         swap $ Real.splitFraction $ fromIntegral size * ratio + frac)+      0+++{- |+Sort labels with respect to start time and fail if intervals overlap.+-}+checkOverlap ::+   (Rate.C rate) =>+   Signal.LabelTrack rate a -> ME.Exceptional String (Signal.LabelTrack rate a)+checkOverlap (Signal.Cons rate xs) = do+   let sorted = sortTime xs+       overlaps =+         catMaybes $+         ListHT.mapAdjacent+            (\(f0,t0) (f1,t1) ->+               toMaybe (t0>f1) $+                   printf "\nintervals (%f,%f) and (%f,%f) overlap"+                      (toTime rate f0) (toTime rate t0)+                      (toTime rate f1) (toTime rate t1)) $+         map fst $ LabelTrack.decons sorted+   if null overlaps+     then return $ Signal.Cons rate sorted+     else ME.throw $ List.concat overlaps++checkGaps ::+   (Rate.C rate) =>+   Signal.LabelTrack rate a -> ME.Exceptional String (Signal.LabelChain rate a)+checkGaps sig@(Signal.Cons rate xs) = do+   let gaps =+         catMaybes .+         ListHT.mapAdjacent1+            (\(_,t0) (t1,_) _lab ->+               toMaybe (t0 /= t1) $+                  printf "\ngap between: %f and %f"+                     (toTime rate t0) (toTime rate t1))+            (0,0) .+         LabelTrack.decons+          $ xs++   if null gaps+     then return $ LabelChain.fromLabelTrack <$> sig+     else ME.throw $ List.concat gaps++discretizeTimes ::+   (Rate.C rate) => rate -> LabelTrack.T Double a -> Signal.LabelTrack rate a+discretizeTimes sampleRate =+   Signal.Cons sampleRate .+   LabelTrack.mapTime (round . (Rate.unpack sampleRate *))++discretizeTrack ::+   (Rate.C rate) =>+   rate -> LabelTrack.T Double a ->+   ME.Exceptional String (Signal.LabelChain rate a)+discretizeTrack sampleRate =+   checkGaps . discretizeTimes sampleRate++maybeToLabelChain ::+   (Rate.C rate) =>+   rate -> LabelTrack.T Double a ->+   ME.Exceptional String (LabelChain.T Double a)+maybeToLabelChain rate xs =+   LabelChain.fromLabelTrack xs <$ discretizeTrack rate xs+++realTimes ::+   (Rate.C rate) => Signal.LabelTrack rate label -> LabelTrack.T Double label+realTimes (Signal.Cons rate xs) = ALabelTrack.realTimes (Rate.unpack rate) xs+++fuseMany :: NonEmpty.T [] (Pat.Bounds t) -> Pat.Bounds t+fuseMany bnds = Pat.fuseBounds (NonEmpty.head bnds) (NonEmpty.last bnds)++mergeNamesakes :: (Eq t, Eq a) => LabelTrack.T t a -> LabelTrack.T t a+mergeNamesakes =+   LabelTrack.lift $+      map (mapPair (fuseMany, NonEmpty.head) . FuncHT.unzip) .+      NonEmptyM.groupBy+         (\(bnds0,lab0) (bnds1,lab1) -> snd bnds0 == fst bnds1 && lab0 == lab1)++merge :: (Ord t) => LabelTrack.T t a -> LabelTrack.T t a -> LabelTrack.T t a+merge = LabelTrack.lift2 $ ListHT.mergeBy (compose2 (<=) fst)++partition ::+   (a -> Bool) -> LabelTrack.T t a -> (LabelTrack.T t a, LabelTrack.T t a)+partition p =+   mapPair (LabelTrack.Cons, LabelTrack.Cons) .+   List.partition (p . snd) . LabelTrack.decons++sortTime :: (Ord t) => LabelTrack.T t a -> LabelTrack.T t a+sortTime = LabelTrack.lift $ List.sortBy (comparing fst)+++readFile ::+   (PathClass.AbsRel ar) =>+   Path.File ar -> IO (LabelTrack.T Double String)+readFile = ALabelTrack.readFile . Path.toString++writeFile ::+   (PathClass.AbsRel ar) =>+   Path.File ar -> LabelTrack.T Double String -> IO ()+writeFile = ALabelTrack.writeFile . Path.toString++writeFileInt ::+   (Rate.C rate, PathClass.AbsRel ar) =>+   rate -> Path.File ar -> LabelTrack.T Int String -> IO ()+writeFileInt rate = ALabelTrack.writeFileInt (Rate.unpack rate) . Path.toString
+ src/Main.hs view
@@ -0,0 +1,2042 @@+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeFamilies #-}+module Main where++import qualified HiddenMarkovModel as HMM+import qualified Math.HiddenMarkovModel.Distribution as Distr+import qualified Math.HiddenMarkovModel.Named as HMMNamed+import qualified Math.HiddenMarkovModel as HMM0++import qualified Durations as Durs+import qualified LabelTrack+import qualified LabelChainShifted+import qualified LabelChain+import qualified Fourier+import qualified Feature+import qualified Class+import qualified Named+import qualified Parameters as Params+import qualified SignalProcessingOption as SPOption+import qualified SignalProcessingMethods as SPMethods+import qualified SignalProcessing as SP+import qualified Signal+import qualified Rate+import Measurement (measureSignal, )+import SignalProcessingSpecific (filterBand, dehum, )+import SignalProcessing (bandpass, lowpassTwoPass, lag2, svlConcat, )+import Parameters (Time(Time), Freq(Freq), time, )++import qualified Option+import qualified Options.Applicative as OP+import Option+         (Flags,+          TrainingFlags+            (TrainingFlags, trainingFeature, trainingSignalProcessing))++import qualified Time+import qualified Data.Time.LocalTime as LocalTime+import qualified Data.Time.Format as TimeFormat+import Data.Time.LocalTime (LocalTime)++import qualified Synthesizer.Generic.Filter.Recursive.Comb as Comb+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Basic.Binary as Bin++import qualified Sound.Audacity.Project.Track.Label as ProjectLabelTrack+import qualified Sound.Audacity.Project.Track.Wave.Summary as ProjectWaveSummary+import qualified Sound.Audacity.Project as Audacity+import qualified Audacity.TrackName as TrackName+import qualified Sound.SoxLib as SoxLib+import Sox (withSound, writeChannels, writeFeatures)+import Audacity (+   projectLabelChain, projectLabelTrack,+   projectWaveTrackConcat, projectWaveTrackFeatures,+   projectWaveTrackInput, projectWaveTrackInputSummary,+   summary, waveSummaryEval,+   writeFeatureTracks, writeLabelTrackInt,+   zoomFullSignal, zoomWidth,+   OriginPaths, originsFromRecordingTrack, originsFromOriginTrack,+   getOriginRoot, dirFromAudPath,+   createProject,+   )++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV++import qualified Text.HTML.Tagchup.Parser as TagParser++import qualified Spreadsheet.Formula as CalcForm+import qualified Spreadsheet.Format as Format+import Spreadsheet.Format (Results, formatTables, (<->), )++import qualified Data.Text.IO as TextIO+import qualified Data.Text as Text+import Data.Text (Text)++import qualified Graphics.Gnuplot.Frame.OptionSet as Opts+import qualified Graphics.Gnuplot.Frame as Frame+import qualified Graphics.Gnuplot.LineSpecification as LineSpec+import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D+import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D+import qualified Graphics.Gnuplot.Terminal.Default as DefaultTerm+import qualified Graphics.Gnuplot.Advanced as GP++import qualified Control.Parallel.Strategies as Par+import qualified Control.Concurrent.PooledIO.Final as Parallel+import qualified Control.Concurrent.PooledIO.Sequence as Sequence+import qualified Control.Concurrent.Split.MVar as MVar+import Control.Concurrent (forkIO, getNumCapabilities, )++import qualified Control.Monad.Exception.Synchronous as ME+import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Arrow as Arrow+import qualified Control.Functor.HT as FuncHT+import qualified GHC.IO.Exception as GHCExc+import qualified System.IO.Error as IOErr+import Control.Exception (bracket)+import Control.DeepSeq (NFData, rnf, ($!!), )+import Control.Arrow ((^<<), (<<^), )+import Control.Category (id, )+import Control.Monad.IO.Class (MonadIO, )+import Control.Monad.HT ((<=<), )+import Control.Monad (when, guard, void, liftM2, liftM3, )+import Control.Applicative (pure, liftA2, (<*>), (<|>), (<$), (<$>), )++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.Array as Array+import qualified Data.List.Match as Match+import qualified Data.List.Key as Key+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import qualified Data.Monoid.HT as Mn+import qualified Data.NonEmpty.Map as NonEmptyMap+import qualified Data.NonEmpty.Mixed as NonEmptyMixed+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Empty as Empty+import Data.Map (Map, ); import qualified Data.Map as Map+import Data.Set (Set, ); import qualified Data.Set as Set+import Data.NonEmpty ((!:), )+import Data.Biapplicative (biliftA2, )+import Data.Bitraversable (bisequenceA, )+import Data.Traversable (forM, )+import Data.Foldable (forM_, )+import Data.Monoid (mconcat, (<>), )+import Data.Tuple.HT (mapPair, mapFst, mapSnd, )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (fromMaybe, mapMaybe, catMaybes, maybeToList, )+import Data.Ord.HT (inRange, comparing, )+import Data.Bool.HT (if', )+import Data.Char (toLower, isDigit, )++import qualified System.Path.PartClass as PathClass+import qualified System.Path.Part as PathPart+import qualified System.Path.Directory as Dir+import qualified System.Path.IO as PathIO+import qualified System.Path as Path+import qualified System.FilePath.Find as Find+import System.FilePath.Find ((==?), (||?), )+import System.Path ((</>), (<.>), )+import Text.Printf (printf, )++import qualified Numeric.Container as NC++import qualified Algebra.RealRing as Real+import qualified Algebra.Ring as Ring+import NumericPrelude.Numeric+import NumericPrelude.Base hiding (id)+++-- * computation++localMaxima :: (Real.C a) => Causal.T a (Maybe a)+localMaxima =+   (\(x0,x1,x2) -> toMaybe (x1 >= x0 && x1 >= x2) x1)+   ^<<+   lag2++pruneCloseMaxima :: (Ord a) => Int -> [(Int, a)] -> [(Int, a)]+pruneCloseMaxima dist =+   let go (p0@(t0,y0):p1@(t1,y1):ls) =+          if t0+dist<=t1+            then p0 : go (p1:ls)+            else+               go $+               if y0<=y1+                 then p1:ls+                 else p0:ls+       go ls = ls+   in  go++sigCatMaybes :: SigS.T (Maybe a) -> [a]+sigCatMaybes = SigG.foldR (maybe id (:)) []++symDifference :: Int -> SVL.Vector Float -> SVL.Vector Float+symDifference halfDiffDist env =+   let pause = SVL.fromChunks [SV.replicate halfDiffDist 0]+   in  SVL.zipWith (-)+          (SVL.drop halfDiffDist env <> pause)+          (pause <> env)++causalMaxima :: Float -> Causal.T (Float, Float) (Maybe Float)+causalMaxima minClickAttack =+   (\(v,mx) -> do+      x <- mx+      guard (x > minClickAttack * v)+      return (x/v))+   ^<<+   Arrow.second localMaxima++maximaFromEnv ::+   Float -> Int ->+   SVL.Vector Float -> SVL.Vector Float -> [(Int, Float)]+maximaFromEnv minClickAttack halfDiffDist volume diffEnv =+   pruneCloseMaxima (2*halfDiffDist) $ sigCatMaybes $+   SigS.zipWith+      (\pos mx -> (,) pos <$> mx)+      (SigS.iterate (1+) (-1::Int)) $+   Causal.apply (causalMaxima minClickAttack) $+   SigG.zip+      (SigG.toState $ SVL.cons zero volume)+      (SigG.toState $ SigG.snoc diffEnv zero)+++histogramReal :: (Ord a, Ring.C b) => [(a,b)] -> [(a, b)]+histogramReal  =  Map.toAscList . Map.fromListWith (+)++histogram :: (Ord a) => [a] -> [(a, Int)]+histogram  =  histogramReal . map (flip (,) 1)+++combFilter ::+   Rate.Sample -> Float -> Time -> SVL.Vector Float -> SVL.Vector Float+combFilter rate gain delay =+   Comb.run (time rate delay) gain+++distancePenalty :: Params.T -> Rate.Sample -> Int -> Float+distancePenalty params rate =+   let softLow  = time rate $ Time 0.022+       softHigh = time rate $ Time 0.034+       hardLow  = time rate $ Params.hardLowDist params+       hardHigh = time rate $ Params.hardHighDist params+       interpolate (soft,hard) dist =+          fromIntegral (dist-soft) / fromIntegral (hard-soft)+   in  \dist ->+          if' (dist < softLow) (interpolate (softLow,hardLow) dist) $+          if' (dist > softHigh) (interpolate (softHigh,hardHigh) dist) 0++updatePenalty :: Params.T -> Rate.Sample -> Int -> Float -> Float -> Maybe Float+updatePenalty params rate dist y penalty = do+   let hardLowDist  = time rate $ Params.hardLowDist params+   let hardHighDist = time rate $ Params.hardHighDist params+   guard $ inRange (hardLowDist, hardHighDist) dist+   let newPenalty = penalty + max 0 (1-y) + distancePenalty params rate dist+   guard $ newPenalty <= 2+   return newPenalty++raspingsFromClicksDynProg ::+   Params.T -> Rate.Sample -> [(Int, Float)] -> [NonEmpty.T [] Int]+raspingsFromClicksDynProg params rate =+   let selectBest = NonEmpty.reverse . fst . NonEmpty.minimumBy (comparing snd)+       hardHighDist = time rate $ Params.hardHighDist params+   in  (\(queue,mxs) ->+          catMaybes $ mxs ++ [selectBest <$> NonEmpty.fetch queue]) .+       List.mapAccumL+          (\bestSoFar (pos, y) ->+             case NonEmpty.fetch bestSoFar of+                Nothing -> ([(NonEmpty.singleton pos, 0)], Nothing)+                Just neBestSoFar ->+                   let updatedBests =+                         mapMaybe+                           (\(chain@(NonEmpty.Cons lastPos _), penalty) ->+                              (,) (NonEmptyC.cons pos chain) <$>+                              updatePenalty params rate (pos-lastPos) y penalty) $+                         NonEmpty.flatten neBestSoFar+                   in  case NonEmpty.fetch updatedBests of+                          Nothing ->+                             ([(NonEmpty.singleton pos, 0)],+                              Just $ selectBest neBestSoFar)+                          Just neUpdatedBests ->+                             (NonEmpty.minimumBy (comparing snd) neUpdatedBests+                              :+                              (filter ((pos - hardHighDist <) . NonEmpty.head . fst) $+                               map+                                  (\(chain, penalty) -> (chain, penalty+y))+                                  bestSoFar),+                              Nothing))+          []++raspingsFromClicks :: Rate.Sample -> [(Int, Float)] -> [NonEmpty.T [] Int]+raspingsFromClicks rate maxima =+   map+      (\xs ->+         NonEmpty.cons (fst (NonEmpty.head xs))+            (map snd $ NonEmpty.flatten xs)) $+   NonEmptyMixed.filterToInfixes+      (inRange+         (time rate (Time 0.020),+          time rate (Time 0.050)) .+       uncurry subtract) $+   ListHT.mapAdjacent (,) $+   map fst maxima++++-- * driver++runDehum ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Flags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()+runDehum flags input output =+   withSound flags input $ \fmtIn (Signal.Cons rate sig) ->+   writeChannels fmtIn rate output $ (:[]) $+         Causal.apply+            (Bin.fromCanonicalWith Real.roundSimple+             ^<<+             bandpass rate 2 (Freq 2000)+             <<^+             Bin.toCanonical) $+         sig+++runDetectAdvertiseSlope ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Params.T -> Flags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()+runDetectAdvertiseSlope params flags input output =+   withSound flags input $ \fmtIn (Signal.Cons rate xs) ->+         let clean = Causal.apply (dehum rate <<^ Bin.toCanonical) xs+             volume = lowpassTwoPass rate (Params.volumeFrequency params) clean+             env = lowpassTwoPass rate (Params.envelopeFrequency params) clean+             halfDiffDist = time rate $ Params.halfDiffDist params+             diffEnv = symDifference halfDiffDist env+             minClickAttack = Params.minClickAttack params+             maxima =+                Causal.apply (fromMaybe 0 ^<< causalMaxima minClickAttack) $+                SVL.zipWith (,) (SVL.cons zero volume) (SigG.snoc diffEnv zero)+             maximaList =+                maximaFromEnv minClickAttack halfDiffDist volume diffEnv++             outputStem = Path.dropExtension output++         in  do LabelTrack.writeFileInt rate+                      (outputStem <-> "ticks-labels.txt") $+                   LabelTrack.Cons $+                   ListHT.mapAdjacent+                      (\(from,y) (to,_) -> ((from, to), show y)) maximaList+                LabelTrack.writeFileInt rate+                      (outputStem <-> "rasping-labels.txt") $+                   LabelTrack.Cons $+                   map+                      (\sequ ->+                         ((NonEmpty.head sequ, NonEmpty.last sequ),+                          printf "%d ticks" $ length $ NonEmpty.tail sequ)) $+                   raspingsFromClicksDynProg params rate maximaList+                void $ GP.plotDefault $+                   Plot2D.list Graph2D.points $ histogram $+                   ListHT.mapAdjacent subtract $+                   map fst maximaList+                void $ GP.plotDefault $+                   Plot2D.list Graph2D.points $ histogramReal $+                   ListHT.mapAdjacent+                      (\(from,y) (to,_) -> (to-from, y)) maximaList+                writeChannels fmtIn rate output $+                   map (SVL.map (Bin.fromCanonicalWith Real.roundSimple)) $+                      [diffEnv, SVL.drop 1 maxima]+++averageSignals ::+   NonEmpty.T [] (SV.Vector Float, SV.Vector Float) -> SV.Vector Float+averageSignals xs =+   let sumAll = NonEmpty.foldl1 (SV.zipWith (+))+       (vols, sigs) = FuncHT.unzip xs+   in  SV.zipWith (/) (sumAll sigs) (sumAll vols)++averageSignalsMinLength ::+   Int -> [(SV.Vector Float, SV.Vector Float)] -> SV.Vector Float+averageSignalsMinLength minLen xs =+   Fold.foldMap averageSignals $ NonEmpty.fetch $+   filter ((>=minLen) . SV.length . snd) xs+++runExtractPatterns ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Params.T -> Flags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()+runExtractPatterns params flags input output =+   withSound flags input $ \fmtIn (Signal.Cons rate xs) -> do+      (chunkSizes, labels) <-+         fmap (unzip . Fold.toList .+               LabelChain.intervalSizes . fmap Class.fromLabel . Signal.body) $+         userErrorFromExc . LabelTrack.discretizeTrack rate =<<+         LabelTrack.readFile (Path.dropExtension input <-> "coarse.txt")++      let (outputStem, outputExt) = Path.splitExtensions output++      let clean = Causal.apply (dehum rate <<^ Bin.toCanonical) xs+          cleanAbs = SVL.map abs clean+          volume = lowpassTwoPass rate (Params.volumeFrequency params) cleanAbs+          env = lowpassTwoPass rate (Params.envelopeFrequency params) cleanAbs+          halfDiffDist = time rate $ Params.halfDiffDist params+          diffEnv = symDifference halfDiffDist env+      let raspingChunks =+            catMaybes $+            zipWith (\lab chunk -> chunk <$ Class.maybeRasping lab) labels $+            zip (SP.chop clean chunkSizes) $+            zip (SP.chop volume chunkSizes) (SP.chop diffEnv chunkSizes)+          starts = scanl (+) 0 $ map (SVL.length . fst) raspingChunks+          maximaList = maximaFromEnv (Params.minClickAttack params) halfDiffDist+          raspingClicks = map (uncurry maximaList . snd) raspingChunks+          clickLength = time rate $ Params.minClickDur params+          takeClick pos =+            SV.concat . SVL.chunks . SVL.take clickLength . SVL.drop pos+          avg =+            SV.map (0.25*) $+            averageSignalsMinLength clickLength $+            concat $+            zipWith+               (\(sig,(vol,_)) ->+                  map (\(pos, _) -> (takeClick pos vol, takeClick pos sig)))+               raspingChunks raspingClicks+          clickLabels =+            mconcat $+            zipWith LabelTrack.shift starts $+            map+               (LabelTrack.Cons .+                ListHT.mapAdjacent (\(from,x) (to,_) -> ((from,to), x)))+               raspingClicks+      writeChannels fmtIn rate output $+         map (SVL.map (Bin.fromCanonicalWith Real.roundSimple)) $+         [SVL.concat $ map fst raspingChunks,+          SVL.concat $ map (fst.snd) raspingChunks,+          SVL.concat $ map (snd.snd) raspingChunks]+      writeChannels fmtIn rate (outputStem <-> "click" <.> outputExt) $+         [SVL.map (Bin.fromCanonicalWith Real.roundSimple) $+          SVL.fromChunks [avg]]+      writeChannels fmtIn rate (outputStem <-> "clicks" <.> outputExt) $+         [SVL.map (Bin.fromCanonicalWith Real.roundSimple) $+          SVL.fromChunks $ replicate 20 avg]+      LabelTrack.writeFileInt rate (outputStem <-> "clicks.txt") $+         fmap show clickLabels+++runMatchPatterns ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1, PathClass.AbsRel ar2) =>+   Path.FilePath ar0 -> Params.T -> Flags ->+   Path.FilePath ar1 -> Path.FilePath ar2 -> IO ()+runMatchPatterns patternPath params flags input output =+   withSound flags patternPath $ \ _fmtPat (Signal.Cons ratePat ys) ->+   withSound flags input $ \fmtIn (Signal.Cons rate xs) -> do+      when (ratePat /= rate) $ ioError $ userError $+         printf "rate of pattern (%f) and signal differ (%f)"+            (Rate.unpack ratePat) (Rate.unpack rate)++      let fac = 0.3 / (SigG.sum $ SVL.map (abs . Bin.toCanonical) ys)+          clean = Causal.apply (dehum rate <<^ Bin.toCanonical) xs+          volume =+            lowpassTwoPass rate (Params.volumeFrequency params) $+            SVL.map abs clean+      writeChannels fmtIn rate output $+         [SVL.fromChunks $ (:[]) $+          SV.map (Bin.fromCanonicalWith Real.roundSimple) $+          Fourier.correlate+            (svlConcat $ SVL.map ((fac*) . Bin.toCanonical) ys)+            (svlConcat $ SVL.zipWith (/) clean volume)]+++newtype PlotProcess = PlotProcess (MVar.Out ())++waitPlot :: PlotProcess -> IO ()+waitPlot (PlotProcess mvarOut) = MVar.take mvarOut++waitPlots :: [PlotProcess] -> IO ()+waitPlots = mapM_ waitPlot++plotStateEmissions ::+   String -> Map HMM0.State String ->+   String -> [(HMM0.State, (Float, Float))] -> IO PlotProcess+plotStateEmissions title dict subTitle ps = do+   (mvarIn, mvarOut) <- MVar.newEmpty+   let header = title ++ ": " ++ subTitle+   void $ forkIO $ plotStateEmissionsSync dict header ps >> MVar.put mvarIn ()+   return $ PlotProcess mvarOut++plotStateEmissionsSync ::+   Map HMM0.State String ->+   String -> [(HMM0.State, (Float, Float))] -> IO ()+plotStateEmissionsSync dict title ps =+   void $ GP.plotSync DefaultTerm.cons $+   Frame.cons (Opts.title title Opts.deflt) $+   Fold.foldMap+      (\(state, emissions) ->+         Graph2D.lineSpec+            (LineSpec.title (HMM.checkedLookup dict state) LineSpec.deflt) <$>+         Plot2D.list Graph2D.points emissions) $+   Array.assocs $+   Array.accumArray (flip (:)) []+      (fst $ Map.findMin dict, fst $ Map.findMax dict) ps++emissionPairs :: [Named.Signal] -> [(String, [(Float, Float)])]+emissionPairs =+   map+      (\(NonEmpty.Cons (Named.Cons n xs)+           (NonEmpty.Cons (Named.Cons m ys) Empty.Cons)) ->+         (m ++ " vs. " ++ n, zip ys xs)) .+   NonEmptyMixed.choose . map (fmap SVL.unpack)++plotStateEmissionsSingle ::+   Bool -> String ->+   Map HMM0.State String ->+   [(String, [(Float, Float)])] ->+   [HMM0.State] -> IO [PlotProcess]+plotStateEmissionsSingle plot title labelFromStateMap featPoints labelled =+   guardPlot plot $+   forM featPoints $ \(n,xs) ->+      plotStateEmissions title labelFromStateMap n $ zip labelled xs++plotStateEmissionsMulti ::+   (Functor map, Fold.Foldable map) =>+   Bool -> String ->+   Map String HMM0.State ->+   Map HMM0.State String ->+   map ([Named.NonEmptySignal], LabelChain.T Int String) ->+   IO [PlotProcess]+plotStateEmissionsMulti plot title stateFromLabelMap labelFromStateMap =+   guardPlot plot . Trav.sequence . Map.elems .+   Map.mapWithKey (plotStateEmissions title labelFromStateMap) .+   Fold.foldr1 (Map.unionWith (++)) .+   fmap+      (\(featSigs, intervals) ->+         fmap (zip (HMM.flattenIntervals stateFromLabelMap intervals)) $+         Map.fromList $ emissionPairs $+         map (fmap HMM.flattenStorableVectorLazy) featSigs)+++checkAdmissibilityTrans ::+   (PathClass.AbsRel ar) =>+   Set (String, String) -> Map HMM0.State String ->+   Path.FilePath ar -> HMM0.GaussianTrained Double -> IO ()+checkAdmissibilityTrans+      admissibleTransitions labelFromStateMap path hmmTrained = do+   let forbiddenTransitions =+         HMM.forbiddenTransitions admissibleTransitions+            labelFromStateMap hmmTrained+   when (not $ Set.null forbiddenTransitions) $+      ioError $ userError $ unlines $+         printf "detected forbidden transitions in %s:" (Path.toString path) :+         map (\(from,to) -> printf "%s -> %s" from to)+            (Set.toList forbiddenTransitions)++checkEmptyIntervals ::+   (PathClass.AbsRel ar) =>+   Rate.Feature -> Path.FilePath ar -> LabelChain.T Int String -> IO ()+checkEmptyIntervals rate path intervals = do+   let emptyIntervals =+          filter (uncurry (==) . fst) $+          LabelTrack.decons $ LabelTrack.fromLabelChain intervals+   when (not $ null emptyIntervals) $+      ioError $ userError $ unlines $+         printf "empty intervals found in %s:" (Path.toString path) :+         map+            (\((from,_to), label) ->+               printf "%f: %s" (Params.toTime rate from) label)+            emptyIntervals+++printLabelCounts :: Map String HMM0.State -> [(String, Int)] -> IO ()+printLabelCounts stateFromLabelMap labelCounts =+   forM_ labelCounts $ \(label,count) -> do+      printf "%003d %s\t%5d\n"+         (case stateFromLabelMap Map.! label of Distr.State s -> s)+         label count++{-+We only consider the difference of the transition matrix.+HMM0.deviation is too pessimistic+because it also compares initial probabilities+and these are based on little data, namely one number per audio file.+-}+printModelDifference :: HMM0.Gaussian Double -> HMM0.Gaussian Double -> IO ()+printModelDifference hmmSup hmmUnsup =+   void $ printf "difference between supervised and unsupervised: %f\n" $+      NC.maxElement $ NC.cmap abs $+      NC.sub (HMM0.transition hmmSup) (HMM0.transition hmmUnsup)++++supervisedName, hmmSupervisedName :: String+unsupervisedName, hmmUnsupervisedName :: String+supervisedName = "supervised"+hmmSupervisedName = "hmm-supervised.csv"+unsupervisedName = "unsupervised"+hmmUnsupervisedName = "hmm-unsupervised.csv"+++writeMLPackEmissions ::+   (PathClass.AbsRel ar) =>+   Path.FilePath ar -> [Named.T (SVL.Vector Float)] -> IO ()+writeMLPackEmissions outputStem featSigs =+   PathIO.writeFile (outputStem <-> "mlpack-emissions.csv") $ unlines $+      map (List.intercalate "," . map show) $+      List.transpose $ map (SVL.unpack . Named.body) featSigs++writeMLPackStates ::+   (PathClass.AbsRel ar) =>+   Path.FilePath ar -> String -> [HMM0.State] -> IO ()+writeMLPackStates outputStem part =+   PathIO.writeFile (outputStem <-> "mlpack" <-> part <.> "csv") . unlines .+      map (\(Distr.State s) -> show s)++++userErrorFromExc :: ME.Exceptional String a -> IO a+userErrorFromExc =+   ME.switch (ioError . userError) return++collectExceptions :: [ME.Exceptional e a] -> ME.Exceptional [e] [a]+collectExceptions =+   (\(es,as) -> if List.null es then ME.Success as else ME.throw es) .+   ListHT.unzipEithers . map (ME.switch Left Right)+++guardPlot :: Bool -> IO [a] -> IO [a]+guardPlot plot act = if plot then act else return []++featureSignals ::+   (PathClass.AbsRel ar) =>+   SPMethods.T -> Feature.Class ->+   Path.FilePath ar -> Signal.Sox ->+   IO (Signal.T Rate.Feature [Named.Signal], [Named.NonEmptySignal])+featureSignals sigProc feature input sig = do+   let featSigs = Feature.signals feature sigProc sig+   featSigsNE <-+      userErrorFromExc $ mapM (HMM.checkNonEmpty input) $ Signal.body featSigs+   return (featSigs, featSigsNE)++hmmTrainings ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Flags -> TrainingFlags ->+   Path.FilePath ar0 ->+   SoxLib.Format mode ->+   Signal.Sox ->+   LabelChain.T Int String ->+   Path.FilePath ar1 ->+   (Signal.T Rate.Feature [Named.Signal], [Named.NonEmptySignal]) -> IO ()+hmmTrainings flags (TrainingFlags _sigProc feature cvg mlpack plot)+      input fmtIn sig intervals+      output (rateFeatSigs@(Signal.Cons rate featSigs), featSigsNE) = do+   let outputStem = Path.dropExtension output+   featureTracksSum <-+      writeFeatureTracks fmtIn output (Feature.scale feature) rateFeatSigs+   checkEmptyIntervals rate outputStem intervals+   when mlpack $ writeMLPackEmissions outputStem featSigs+   let labelCounts = histogram $ Fold.toList intervals+       (stateFromLabelMap, labelFromStateMap) =+         HMM.mapsFromLabels $ map fst labelCounts+   Option.infoAction flags $ do+      putStrLn "encountered labels with assigned state number and frequency"+      printLabelCounts stateFromLabelMap labelCounts+   let states = HMM.flattenIntervals stateFromLabelMap intervals+   when mlpack $ writeMLPackStates outputStem "states" states+   let featPoints = emissionPairs featSigs+   waits0 <-+      plotStateEmissionsSingle plot supervisedName+         labelFromStateMap featPoints states+   hmmTrained <-+      userErrorFromExc $+      HMM.trainSupervised stateFromLabelMap input featSigsNE intervals+   checkAdmissibilityTrans (Feature.admissibleTransitions feature)+      labelFromStateMap outputStem hmmTrained+   Option.notice flags "supervised training"+   let hmm = HMM0.finishTraining hmmTrained+       addNames model =+         Feature.HMM {+            Feature.hmmClass = feature,+            Feature.hmmodel =+               HMMNamed.Cons {+                  HMMNamed.model = model,+                  HMMNamed.nameFromStateMap = labelFromStateMap,+                  HMMNamed.stateFromNameMap = stateFromLabelMap+               }+         }+   Feature.writeHMM (outputStem <-> hmmSupervisedName) $ addNames hmm+   Option.infoMsg flags $ HMM0.toCSV hmm++   Option.notice flags "classify using trained model"+   let newIntervals = HMM.label hmm featSigsNE+   supervisedTrack <-+      writeLabelTrackInt rate outputStem supervisedName $+      HMM.checkedLookup labelFromStateMap <$>+      LabelChain.segment newIntervals+   when mlpack $ writeMLPackStates outputStem "classified" newIntervals++   Option.notice flags "unsupervised training"+   let prep = HMM.prepare featSigsNE+       step model = HMM0.finishTraining $ HMM0.trainUnsupervised model prep+       hmms = HMM.takeUntilConvergence cvg $ iterate step hmm+       lastHMM = last hmms+       lastFeatureHMM = addNames lastHMM+   mapM_ (Option.infoMsg flags . HMM0.toCSV) hmms+   Option.noticeAction flags $ printModelDifference hmm lastHMM++   Option.notice flags "classify using trained model"+   Feature.writeHMM (outputStem <-> hmmUnsupervisedName) lastFeatureHMM+   let labelledUnsupervised =+         HMM.analyze (Feature.hmmodel lastFeatureHMM) featSigsNE+   waits1 <-+      plotStateEmissionsSingle+         plot unsupervisedName labelFromStateMap featPoints $+      HMM.flattenIntervals stateFromLabelMap labelledUnsupervised++   unsupervisedTrack <-+      writeLabelTrackInt rate outputStem unsupervisedName labelledUnsupervised+   ((audPath, audFormat), (inputTrack, featSigTracks)) <-+      waveSummaryEval outputStem $+      liftM2 (,) (projectWaveTrackInput (sig, input)) featureTracksSum+   PathIO.writeFile audPath $ audFormat $+      createProject (zoomFullSignal sig) $+         inputTrack :+         featSigTracks +++         projectLabelChain "fine" (LabelChain.realTimes rate intervals) :+         supervisedTrack :+         unsupervisedTrack :+         []++   waitPlots $ waits0 ++ waits1++runHMMTrainingUnsupervised ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Flags -> TrainingFlags -> Int ->+   Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()+runHMMTrainingUnsupervised+      flags (TrainingFlags sigProc feature cvg mlpack plot) numStates+      input output =+   withSound flags input $ \fmtIn sig -> do+      (rateFeatSigs@(Signal.Cons featRate featSigs), featSigsNE) <-+         featureSignals sigProc feature input sig+      let outputStem = Path.dropExtension output++      featureTracksSum <-+         writeFeatureTracks fmtIn output (Feature.scale feature) rateFeatSigs+      when mlpack $ writeMLPackEmissions outputStem featSigs++      Option.notice flags "train HMM"+      let prep = HMM.prepare featSigsNE+          step model =+            HMM0.finishTraining $+            HMM0.trainUnsupervised model prep+          states = HMM0.state 0 !: take (numStates-1) [HMM0.state 1 ..]+          hmms =+            HMM.takeUntilConvergence cvg $ iterate step $+            HMM0.uniform $ HMM0.distribution $+            HMM0.finishTraining $ HMM0.trainSupervised numStates $+            NonEmptyC.zip (NonEmpty.cycle states) prep+          hmm = last hmms+          labelFromStateMap =+            Map.fromList $ map (\s -> (s, show $ fromEnum s)) $+            NonEmpty.flatten states+          addNames model =+            Feature.HMM {+               Feature.hmmClass = feature,+               Feature.hmmodel =+                  HMMNamed.Cons {+                     HMMNamed.model = model,+                     HMMNamed.nameFromStateMap = labelFromStateMap,+                     HMMNamed.stateFromNameMap =+                        HMM.inverseMap labelFromStateMap+                  }+            }+      mapM_ (Option.infoMsg flags . HMM0.toCSV) hmms+      Feature.writeHMM (outputStem <-> hmmUnsupervisedName) $ addNames hmm++      Option.notice flags "classify using trained model"+      let labelled = HMM.label hmm featSigsNE+      unsupervisedTrack <-+         writeLabelTrackInt featRate outputStem unsupervisedName $+         (\(Distr.State s) -> show s) <$> LabelChain.segment labelled+      when mlpack $ writeMLPackStates outputStem "classified" labelled++      ((audPath, audFormat), (inputTrack, featSigTracks)) <-+         waveSummaryEval outputStem $+         liftM2 (,) (projectWaveTrackInput (sig, input)) featureTracksSum+      PathIO.writeFile audPath $ audFormat $+         createProject (zoomFullSignal sig) $+            inputTrack :+            featSigTracks +++            unsupervisedTrack :+            []++      waitPlots =<<+         plotStateEmissionsSingle plot unsupervisedName+            labelFromStateMap (emissionPairs featSigs) labelled++++textWriteFile ::+   (PathClass.AbsRel ar) =>+   Path.FilePath ar -> Text -> IO ()+textWriteFile = TextIO.writeFile . Path.toString++type+   DetectionParams =+      (SPMethods.T, Feature.HMM, (Format.Flags, Bool), Params.T, Flags)++runDetectHMM ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   DetectionParams -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()+runDetectHMM dp@(_,_,_,_,flags) input output =+   withSound flags input $ \fmtIn sig ->+      let startTime = Time.parseRecordingName $ Path.takeBaseName input+      in  void $ runDetectHMMMain dp id startTime fmtIn sig input output++type+   GlobalLabelTracks =+      NonEmpty.T (NonEmpty.T (NonEmpty.T Maybe)) (LabelTrack.T Double String)++runDetectHMMMain ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   DetectionParams ->+   (IO () -> IO ()) ->+   Maybe LocalTime ->+   SoxLib.Format mode -> Signal.Sox ->+   Path.FilePath ar0 -> Path.FilePath ar1 ->+   IO ((Map String Int, Results),+       (Signal.T Rate.Sample [ProjectWaveSummary.T], GlobalLabelTracks))+runDetectHMMMain (sigProc, featureHMM, (fmtFlags, emitTrack), params, flags)+      emit startTime fmtIn sig@(Signal.Cons highRate xs) input output = do+   let feature = Feature.hmmClass featureHMM+   (featSigs@(Signal.Cons featRate _), featSigsNE) <-+      featureSignals sigProc feature input sig+   let (outputStem, outputExt) = Path.splitExtensions output+       outputEnv = outputStem <-> "env" <.> outputExt+       hmmNamed = Feature.hmmodel featureHMM+       {-+       We need to quantize the label boundaries to the sampling grid+       for the following reasons:++       1. We need to quantize for perfect reconstruction+          of label boundaries in the measurement process.+       2. The sample period is the only quantization unit+          that is still available in the measurement process,+          whereas the feature rate is no longer accessible then.++       If we leave the label boundaries at the feature rate positions+       then it happens occasionally,+       that a 0.5 time value is rounded to 0 at classification+       and later when read back from the audacity project+       and shifted according to the beginning of the recording part+       it becomes 0.50000001 and is rounded to 1.+       Rounding to multiples of the sampling period means+       that time values like 0.5 cannot occur at all.+       -}+       sigIntervals =+         fmap (mapSnd (LabelChain.adjustLength (CutG.length xs))) $+         Signal.addDiscretizedLabels sig $+         Signal.labelRealTimes $ Signal.Cons featRate $+         HMM.analyze hmmNamed featSigsNE+       (classified, warningIntervals,+        (measures, (envelopeScales, envelope))) =+          Feature.evaluateFromIntervals feature sigProc params sigIntervals+       classifiedAbstractly =+          LabelChain.abstractFromSoundClassIntervals classified+       classifiedTrack = LabelTrack.fromLabelChain classified+       classifiedAbstractlyTrack =+          LabelTrack.fromLabelChain classifiedAbstractly+       maybeAbsTimeLabels =+         LabelTrack.fromLabelChain .+         Time.timeLabels (Signal.duration sig) . LocalTime.localTimeOfDay+            <$> startTime+       maybeHours =+         LabelChain.takeTime (Signal.duration sig) . Time.hours <$> startTime+       maybeHourLabels =+         LabelTrack.fromLabelChain .+         fmap (Time.formatHour "%Y-%m-%d %H") <$> maybeHours+       durationsHourly =+         flip fmap maybeHours $ \hours ->+            fmap Durs.sum $ Map.fromList $+            LabelChainShifted.chopChain hours $+            LabelChainShifted.fromLabelChain classifiedAbstractly++   do+       when emitTrack $ do+          let labelsWriteFile part =+               emit . LabelTrack.writeFile (outputStem <-> part <.> "txt")+          labelsWriteFile "hmm-labels" $!!+             LabelTrack.fromLabelChain $+             Signal.labelRealTimes $ fmap snd sigIntervals+          labelsWriteFile "hmm-labels-coarse" $!!+             fmap Class.toLabel classifiedTrack+          labelsWriteFile "hmm-labels-abstract" $!!+             fmap Class.abstractToLabel classifiedAbstractlyTrack+          labelsWriteFile "warnings" $!! warningIntervals+          Fold.mapM_ (labelsWriteFile "abstimes") $!! maybeAbsTimeLabels++       do+          inputAbs <- Path.genericMakeAbsoluteFromCwd input+          let (results, tableFiles) =+                MW.runWriter $+                formatTables fmtFlags highRate inputAbs outputStem measures+          mapM_ (emit . uncurry textWriteFile $!!) tableFiles++          let emitFeatures ::+                (PathClass.AbsRel ar, Rate.C rate, MonadIO m) =>+                Path.File ar -> [Float] -> Signal.T rate [Named.Signal] ->+                IO (ProjectWaveSummary.Monad m [Audacity.Track])+              emitFeatures path scales sigs = do+                emit . writeFeatures fmtIn path scales $!! sigs+                return $ projectWaveTrackFeatures ((scales, sigs), path)+          sigProj <- emitFeatures output (Feature.scale feature) featSigs+          envelopeProj <- emitFeatures outputEnv envelopeScales envelope++          let inputSummary = Signal.map (summary . SVL.map Bin.toCanonical) sig+          do+             ((audPath, audFormat),+              (inputTrack, featSigTracks, envelopeTracks)) <-+                waveSummaryEval outputStem $+                liftM3 (,,)+                   (projectWaveTrackInputSummary (inputSummary, inputAbs))+                   sigProj envelopeProj+             emit . textWriteFile audPath $!!+                Text.pack $ audFormat $+                createProject (zoomFullSignal sig) $+                   inputTrack :+                   featSigTracks +++                   envelopeTracks +++                   projectLabelTrack TrackName.coarse+                      (fmap Class.toLabel classifiedTrack) :+                   projectLabelTrack TrackName.abstract+                      (fmap Class.abstractToLabel classifiedAbstractlyTrack) :+                   projectLabelTrack TrackName.warnings warningIntervals :+                   maybeToList+                      (projectLabelTrack TrackName.time <$>+                         maybeAbsTimeLabels) +++                   maybeToList+                      (projectLabelTrack TrackName.hour <$>+                         maybeHourLabels) +++                   []++          Option.infoAction flags $+             emit . putStrLn $!!+             ("update HMM\n" ++) $+             HMM0.toCSV $ HMM0.finishTraining $+                HMM0.trainUnsupervised (HMMNamed.model hmmNamed) $+                HMM.prepare featSigsNE++          return+             ((Class.countOthers classified,+               (Durs.sum classifiedAbstractly,+                Fold.fold durationsHourly, results)),+              (inputSummary,+                 fmap Class.toLabel classifiedTrack !:+                 fmap Class.abstractToLabel classifiedAbstractlyTrack !:+                 warningIntervals !:+                 maybeHourLabels))+++isSeparator :: Char -> Bool+isSeparator = flip elem ['-', ' ']++numericPattern ::+   (PathClass.FileDir fd) => Path.Rel fd -> [Either Integer String]+numericPattern =+   let go [] = []+       go (x:xs) =+          let b = isDigit x+              (ys,zs) = mapFst (x:) $ span ((b==) . isDigit) xs+          in  (if b+                 then Left $ read ys+                 else Right $ filter (not . isSeparator) ys)+               : go zs+   in  go . Path.toString+++type Sort a = [(Path.RelDir, a)] -> IO [(Int, (Path.RelDir, a))]++readCustomOrder :: (PathClass.AbsRel ar) => Path.FilePath ar -> IO (Sort a)+readCustomOrder path = do+   content <- PathIO.readFile path+   let dict = Map.fromList $ flip zip [0..] $ lines content+   return $ \pairs ->+      fmap (List.sortBy (comparing fst)) $+      forM pairs $ \pair@(name,_) ->+         case Map.lookup (Path.toString name) dict of+            Just pos -> return (pos, pair)+            Nothing ->+               ioError $ userError $+                  printf "directory name \"%s\" not found in \"%s\""+                     (Path.toString name) (Path.toString path)++getDirectoryContents ::+   (PathClass.AbsRel ar, PathClass.FileDir fd) =>+   Path.DirPath ar -> IO [Path.Rel fd]+getDirectoryContents =+   fmap (List.sort . mapMaybe Path.fromFileDir) . Dir.getDirectoryContents++infixr 9 +~+++(+~+) :: String -> String -> String+xs +~+ ys  =  xs ++ ' ' : ys++getDirectoryErrorMsg :: IOErr.IOError -> Maybe String+getDirectoryErrorMsg e =+   toMaybe+      (case IOErr.ioeGetErrorType e of+         GHCExc.InappropriateType -> True+         GHCExc.InvalidArgument -> True+         _ -> False)+      (unlines $+       "Tried to read directory content, but it is not a directory." :+       "There could be several reasons:" :+       "There are additional files in the directory tree" +~++        "not belonging to the project." :+       "You did not use the project main directory as input," +~++        "but a sub-directory." :+       "You did not give a project directory at all," +~++        "but e.g. swapped input and output directory." :+       [])++getDirectoryContentsFull ::+   (PathClass.AbsRel ar, PathClass.FileDir fd) =>+   Path.DirPath ar -> IO [(Path.Rel fd, Path.Path ar fd)]+getDirectoryContentsFull dir =+   IOErr.modifyIOError+      (\e ->+         maybe e (\msg -> e{GHCExc.ioe_description = msg}) $+         getDirectoryErrorMsg e) $+   map (\entry -> (entry, dir</>entry)) <$> getDirectoryContents dir++runDetectHMMThread ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   DetectionParams -> Sequence.In ->+   Maybe LocalTime ->+   Path.FilePath ar0 -> Path.FilePath ar1 ->+   IO ((Map String Int, Results),+       (Signal.T Rate.Sample [ProjectWaveSummary.T], GlobalLabelTracks))+runDetectHMMThread dp@(_,_,_,_,flags) seqIn startTime input output = do+   (fmtIn, sig) <-+      Sequence.sync seqIn $+         withSound flags input $+            \fmtIn sig -> return . (,) fmtIn $!! sig+   Sequence.sync seqIn . return =<<+      runDetectHMMMain dp (Sequence.async seqIn)+         startTime fmtIn sig input output+++matchFileName :: [String] -> Path.FilePath ar -> Bool+matchFileName exts caseName =+   let name = map toLower $ Path.toString $ Path.takeFileName caseName+   in  any (flip List.isSuffixOf name) exts++matchWaveName :: Path.FilePath ar -> Bool+matchWaveName = matchFileName [".wav", ".flac"]++matchLogName :: Path.FilePath ar -> Bool+matchLogName = matchFileName [".log"]++getStartTimes ::+   (PathClass.AbsRel ar, PathClass.AbsRel ar0) =>+   Flags -> Path.DirPath ar0 ->+   [(Path.RelFile, Path.FilePath ar)] ->+   IO [(Maybe LocalTime, (Path.RelFile, Path.FilePath ar))]+getStartTimes flags dir files = do+   let (logFiles, otherFiles) = List.partition (matchLogName . fst) files+   let fmtPath path = Path.toString path+   case logFiles of+      [] -> do+         Option.warn flags $+            printf "\n%s: Log file not found\n" $ fmtPath dir+         return $+            map+               (\file2 ->+                  let startTime = Time.parseRecordingName $ fst file2+                  in  (startTime, file2)) $+            filter (matchWaveName . fst) otherFiles++      [(_,logFile)] -> do+         (unparseable, entries) <-+            ListHT.unzipEithers . Time.parseLog <$> PathIO.readFile logFile+         when (not $ null unparseable) $+            Option.warn flags $ unlines $+               printf "\n%s:1: Found ill-formated lines:" (fmtPath logFile) :+               unparseable+         let (recordings, clashing) =+               clashingMapFromList $+               flip mapMaybe entries $ \(startTime,e) ->+                  case e of+                     Time.Recording name _ ->+                        Just (Path.dropExtension name, startTime)+                     _ -> Nothing+         let formatTime =+               TimeFormat.formatTime TimeFormat.defaultTimeLocale+                  "%Y-%m-%d %H:%M:%S"+         checkClash "logged recordings with the same name stem:" $+            Map.map (fmap formatTime) clashing+         let (otherFileMap, otherClashing) =+               clashingMapFromList $+               map (\file2 -> (Path.dropExtension $ fst file2, file2))+                  otherFiles+         checkClash "found file name with the same name stem:" $+            Map.map (Path.toString . fst <$>) otherClashing+         let missing = Map.difference recordings otherFileMap+          in when (not $ Map.null missing) $+               Option.warn flags $ unlines $+                  printf+                     "\n%s:1: Listed recordings without actual audio files:"+                     (fmtPath logFile) :+                  map Path.toString (Map.keys missing)+         let missing = Map.difference otherFileMap recordings+          in when False $+             when (not $ Map.null missing) $+               Option.warn flags $ unlines $+                  printf+                     "\n%s:1: Found files that are not registered in the log file:"+                     (fmtPath logFile) :+                  map (Path.toString . snd) (Map.elems missing)+         return $ Map.elems $+            Map.intersectionWith (,) (fmap Just recordings) otherFileMap++      _ ->+         ioError $ userError $ unlines $+            printf "\n%s: Found multiple log files:" (fmtPath dir) :+            map (Path.toString . fst) logFiles+++parallelRun :: (NFData a) => (Sequence.In -> [IO a]) -> IO [a]+parallelRun acts = do+   (seqIn, seqOut) <- Sequence.new+   void $ forkIO $ Sequence.run seqOut+   numCap <- getNumCapabilities+   Parallel.runLimited (max 1 $ numCap-1) $+      Trav.traverse Parallel.fork $ acts seqIn++{- |+Consider namings like this one:++> Ko1 VIN+> Ko2 VIN+> Ko3 VIN+> VIN 10-10M - 1+> VIN 10-10M - 2+> VIN 10-10M - 3+-}+takeTreatmentName :: String -> String+takeTreatmentName str =+   let (revSuffix, revPrefix) = break isDigit $ reverse str+   in  (reverse . dropWhile isSeparator . dropWhile isDigit $ revPrefix) +++       case dropWhile isSeparator . reverse $ revSuffix of+         "" -> ""+         suffix -> " " ++ suffix++fmapDeep :: (Monad m, NFData b) => (a -> b) -> m a -> m b+fmapDeep f act = (return $!!) . f =<< act++forAnimals ::+   (PathClass.AbsRel ar, PathClass.AbsRel ar1) =>+   Format.AllPaths ar -> Path.AbsDir -> Path.RelDir ->+   [(Int, (Path.RelDir, Path.Path ar1 fd))] ->+   ((Path.RelDir, Path.Path ar1 fd) ->+    IO [(Path.RelFile, (Map String Int, Results))]) ->+   IO (Map String Int)+forAnimals overviewPaths inputAbs dir0 dirs1 act = do+   let treatments =+         NonEmptyMixed.groupKey+            (takeTreatmentName . Path.toString . fst . snd) dirs1+   fmapDeep (Map.unionsWith (+)) $+      forM treatments $ \(treatment, animals) -> do+         totalDursResultss <-+            forM (NonEmpty.flatten animals)+               (\(animal, (dir1,fullDir1)) -> do+                  totalDursResults <- act (dir1,fullDir1)+                  Format.appendOverview overviewPaths+                     inputAbs dir0 dir1 animal $+                        map (mapSnd snd) totalDursResults+                  return totalDursResults)+         Format.appendTreatmentOverview overviewPaths inputAbs dir0 treatment $+            map (map (mapSnd snd)) totalDursResultss+         return $!!+            Map.unionsWith (+) $ concatMap (map (fst . snd)) totalDursResultss++reportIgnoredIntervals :: Flags -> [Map String Int] -> IO ()+reportIgnoredIntervals flags countss =+   ($ Map.unionsWith (+) countss) $ \counts ->+   when (not $ Map.null counts) $+      Option.warn flags $ unlines $+         "" : "Ignored interval labels:" :+         Map.elems (Map.mapWithKey (printf "%s: %d times") counts)++withOverviewPaths ::+   (PathClass.AbsRel ar) =>+   Format.Flags -> Path.DirPath ar -> (Format.AllPaths ar -> IO a) -> IO a+withOverviewPaths fmtFlags output act = do+   Dir.createDirectoryIfMissing True output+   bracket+      (Format.writeOverviewHead fmtFlags output) Format.writeOverviewFoot act++runDetectHMMMulti ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Sort (Path.DirPath ar0) -> DetectionParams ->+   Path.DirPath ar0 -> Path.DirPath ar1 -> IO ()+runDetectHMMMulti sort dp@(_,_,fmtFlags,_,flags) input output =+  withOverviewPaths (fst fmtFlags) output $ \overviewPaths -> do++   dirs0 <- getDirectoryContentsFull input+   inputAbs <- Path.genericMakeAbsoluteFromCwd input+   (reportIgnoredIntervals flags =<<) $+    forM (Key.sort (numericPattern . fst) dirs0) $ \(dir0,fullDir0) -> do+      dirs1 <- sort =<< getDirectoryContentsFull fullDir0+      forAnimals overviewPaths inputAbs dir0 dirs1 $ \(dir1,fullDir1) -> do+         {-+         Retrieve directory content first,+         in order to make sure that it is really a directory.+         -}+         files <-+            getStartTimes flags fullDir1 =<< getDirectoryContentsFull fullDir1+         let outDir = output </> dir0 </> dir1+         Dir.createDirectoryIfMissing True outDir+         (totalDursResults, sigs) <-+            fmap unzip $+            parallelRun $ \seqIn ->+            map+               (\(startTime, (file, fullFile)) ->+                  mapPair ((,) file, (,) fullFile) <$>+                  runDetectHMMThread dp seqIn+                     startTime fullFile (outDir </> file)) $+            files++         let outputStem =+               fromMaybe (error "outDir: empty path") $ Path.fileFromDir outDir+         ((audPath, audFormat),+          (totalDur, inputTrack, labelTrack, originTrack)) <-+            waveSummaryEval outputStem $+            projectWaveTrackConcat+               (TrackName.classes !: TrackName.abstract !: TrackName.warnings !:+                Just TrackName.hour) $+            sigs+         PathIO.writeFile audPath $ audFormat $+            createProject (zoomWidth / totalDur) $+               inputTrack :+               Fold.toList labelTrack +++               originTrack :+               []++         return totalDursResults+++runMeasureMain ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   SPMethods.T -> (Format.Flags, Bool) -> Params.T ->+   (IO () -> IO ()) ->+   LabelChain.T Double Time.Hour ->+   LabelChain.T Double (Class.Sound clicks chirping ticking clicks) ->+   SoxLib.Format mode ->+   Signal.Sox ->+   Path.FilePath ar0 -> Path.FilePath ar1 ->+   IO (Map String Int, Results)+runMeasureMain sigProc (fmtFlags, emitTrack) params emit hours classified fmtIn+      sig@(Signal.Cons highRate _) input output =+   let (outputStem, outputExt) = Path.splitExtensions output+       outputEnv = outputStem <-> "env" <.> outputExt+       {-+       We must discretize 'classified' in order to eliminate rounding errors+       from parsing decimal time values+       and from dissection of concatenated label tracks.+       -}+       sigClassified = Signal.addDiscretizedLabels sig classified+       (measures, (envelopeScales, envelope)) =+          snd $ measureSignal sigProc params sigClassified+       classifiedAbstractly =+          LabelChain.abstractFromSoundClassIntervals $+          Signal.labelRealTimes $ fmap snd sigClassified+       (results, tableFiles) =+          MW.runWriter $+          formatTables fmtFlags highRate input outputStem measures+       durationsHourly =+          Map.fromListWith (liftA2 (+)) $+          map (mapSnd Durs.sum) $+          LabelChainShifted.chopChain hours $+          LabelChainShifted.fromLabelChain classifiedAbstractly+   in  do+          when emitTrack $+             emit . writeFeatures fmtIn outputEnv envelopeScales $!! envelope+          mapM_ (emit . uncurry textWriteFile $!!) tableFiles+          return+             (Class.countOthers classified,+              (Durs.sum classifiedAbstractly, durationsHourly, results))+++whenDirectory ::+   (PathClass.AbsRel ar) => a -> Path.DirPath ar -> IO a -> IO a+whenDirectory deflt dir act =+   Dir.doesDirectoryExist dir >>= \b -> if b then act else return deflt++readConcatAudacityProject ::+   PathClass.AbsRel ar =>+   Params.T ->+   Path.FilePath ar ->+   IO (LabelChain.T Double+         (OriginPaths PathPart.AbsRel,+          (LabelChain.T Double Time.Hour,+           LabelChain.T Double Class.SoundParsed)))+readConcatAudacityProject params fullAup1 = do+   tagsoup <- TagParser.runSoup <$> PathIO.readFile fullAup1+   let fullAup1Str = Path.toString fullAup1+   trackMap <-+      userErrorFromExc $+      ME.mapException (printf "when reading '%s':\n%s" fullAup1Str) $+      Map.fromList .+      map (\track ->+             (ProjectLabelTrack.name_ track,+              ProjectLabelTrack.track_ track)) <$>+      ProjectLabelTrack.tracksFromXML tagsoup+   let lookupTrack name =+         userErrorFromExc $+         ME.fromMaybe (printf "%s: missing track '%s'" fullAup1Str name) $+         Map.lookup name trackMap+   let userErrorFromTrackExc ::+         String -> (e -> Either String [String]) -> ME.Exceptional e a -> IO a+       userErrorFromTrackExc trackName procMsg =+         let header = printf "%s: In track '%s':" fullAup1Str trackName+         in  userErrorFromExc .+             ME.mapException+               (either (header +~+) (unlines . (header :)) . procMsg)+   let toLabelChain ::+         String -> LabelTrack.T Double a -> IO (LabelChain.T Double a)+       toLabelChain name =+         userErrorFromTrackExc name Left .+         LabelTrack.maybeToLabelChain (Params.measureSampleRate params)++   origins <- do+      let labelChainFromIntervals ::+            String ->+            [ME.Exceptional String+               (LabelTrack.Interval Double (OriginPaths PathPart.AbsRel))] ->+            IO (LabelChain.T Double (OriginPaths PathPart.AbsRel))+          labelChainFromIntervals name =+            toLabelChain name . LabelTrack.Cons <=<+            userErrorFromTrackExc name Right . collectExceptions+      if True+        then labelChainFromIntervals TrackName.recording =<<+             originsFromRecordingTrack fullAup1 tagsoup+        else labelChainFromIntervals TrackName.origin =<<+             originsFromOriginTrack tagsoup lookupTrack++   let chopLabelTrack ::+         String -> LabelChain.T Double a -> IO [LabelChain.T Double a]+       chopLabelTrack name =+         userErrorFromTrackExc name+            (\bndErrors ->+               Right $+               case ListHT.partitionMaybe id bndErrors of+                  (matchErrors, endErrors) ->+                     (Mn.when (not $ null matchErrors) $+                      "Could not find recording boundaries at:" :+                      map (printf "%.6f") matchErrors)+                     +++                     (Mn.when (not $ null endErrors)+                        ["There are more labels than recordings."])) .+         collectExceptions .+         map (fmap LabelChainShifted.shiftToLabelChain) .+         LabelChainShifted.chopClosest+            (recip $ Rate.unpack $ Params.measureSampleRate params)+            (void origins) .+         LabelChainShifted.fromLabelChain+   classifiedChunks <-+      fmap (map (fmap Class.fromLabel)) $+      chopLabelTrack TrackName.classes+      =<<+      toLabelChain TrackName.classes+      =<<+      lookupTrack TrackName.classes+   hoursChunks <-+      chopLabelTrack TrackName.hour+      =<<+      userErrorFromTrackExc+         TrackName.hour (Right . ("Could not parse hours:" :)) .+      LabelChain.collectExceptions .+      fmap+         (\label ->+            maybe (ME.throw label) ME.Success $+            Time.parseHour "%Y-%m-%d %H" label)+      =<<+      toLabelChain TrackName.hour+      =<<+      lookupTrack TrackName.hour++   return $+      LabelChain.zipWithList (flip (,))+         (zip hoursChunks classifiedChunks) origins++runMeasureMulti ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Sort (Path.FilePath ar0) -> SPMethods.T -> (Format.Flags, Bool) ->+   Params.T -> Flags ->+   Path.DirPath ar0 -> Path.DirPath ar1 -> IO ()+runMeasureMulti sort sigProc fmtFlags params flags input output =+  withOverviewPaths (fst fmtFlags) output $ \overviewPaths -> do++   origRoot <- getOriginRoot input+   dirs0 <- getDirectoryContentsFull input+   (reportIgnoredIntervals flags =<<) $+    forM (Key.sort (numericPattern . fst) dirs0) $ \(dir0,fullDir0) ->+         whenDirectory Map.empty fullDir0 $ do+      aups1 <-+         sort . mapMaybe (FuncHT.mapFst dirFromAudPath)+          =<< getDirectoryContentsFull fullDir0+      forAnimals overviewPaths origRoot dir0 aups1 $ \(dir1,fullAup1) -> do+         let outDir = output </> dir0 </> dir1+         Dir.createDirectoryIfMissing True outDir+         chunks <- readConcatAudacityProject params fullAup1+         parallelRun $ \seqIn ->+            flip map (LabelTrack.decons $ LabelChain.toLabelTrack chunks) $+                  \(bnd, ((origin, originPath), (hours, classified))) -> do+               (fmtIn, sig) <-+                  Sequence.sync seqIn $+                     withSound flags originPath $+                        \ fmtIn sig -> return . (,) fmtIn $!! sig+               Option.infoMsg flags $+                printf "%s: signal length %f, interval %s, labels %d\n"+                  (Path.toString origin) (Signal.duration sig) (show bnd)+                  (SP.foldLength classified)++               fmap ((,) origin) $+                  -- wait for the completion of the emissions+                  Sequence.sync seqIn . return =<<+                     runMeasureMain+                        sigProc fmtFlags params (Sequence.async seqIn)+                        hours classified fmtIn sig+                        originPath (outDir </> origin)++++{-+You can compare results with mlpack's HMM implementation:++$ hmm_train -t gaussian -i /tmp/out-emissions.csv -l /tmp/out-states.csv -n 6+$ hmm_viterbi -m output_hmm.xml -i /tmp/out-emissions.csv+-}+runHMMTrainingSupervised ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Flags -> TrainingFlags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()+runHMMTrainingSupervised flags trainingFlags input output =+   withSound flags input $ \fmtIn sig -> do+      featSigs <-+         featureSignals+            (trainingSignalProcessing trainingFlags)+            (trainingFeature trainingFlags) input sig+      let featureRate = Signal.sampleRate $ fst featSigs+      intervals <-+         fmap Signal.body .+         userErrorFromExc . LabelTrack.discretizeTrack featureRate =<<+         LabelTrack.readFile (Path.dropExtension input <.> "txt")+      hmmTrainings flags trainingFlags+         input fmtIn sig intervals output featSigs+++fineSnappedFromCoarseIntervals ::+   Feature.Class -> Params.T -> Rate.Feature -> Signal.Sox ->+   LabelTrack.T Double String ->+   ME.Exceptional String (LabelChain.T Int String)+fineSnappedFromCoarseIntervals feature params rate sig =+   Feature.fineSnappedFromCoarseIntervals feature params rate sig .+   fmap Class.fromLabel+++runHMMTrainingSupervisedCoarse ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Params.T -> Flags -> TrainingFlags ->+   Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()+runHMMTrainingSupervisedCoarse params flags trainingFlags input output =+   withSound flags input $ \fmtIn sig -> do+      let feature = trainingFeature trainingFlags+      let sigProc = trainingSignalProcessing trainingFlags+      featSigs <- featureSignals sigProc feature input sig+      let featureRate = Signal.sampleRate $ fst featSigs+      fineIntervals <-+         userErrorFromExc .+         fineSnappedFromCoarseIntervals feature params featureRate sig =<<+         LabelTrack.readFile (Path.dropExtension input <-> "coarse.txt")++      LabelChain.writeFileInt featureRate+         (Path.dropExtension output <-> "fine.txt") fineIntervals+      hmmTrainings flags trainingFlags+         input fmtIn sig fineIntervals output featSigs+++{- |+This function requires absolute paths+in order to check for files with coinciding base name.+Optimally we would have canonicalized paths (e.g. links resolved).+-}+makePathMap :: [Path.AbsFile] -> IO (Map Path.AbsFile Path.AbsFile)+makePathMap paths = do+   let (uniquePaths, clashingPaths) =+         clashingMapFromList $+         map (\path -> (Path.dropExtension path, path)) paths+   checkClash "audio files with the same stem:" $+      Map.map (fmap Path.toString) clashingPaths+   return uniquePaths++{-+Clashing Map even contains lists with at least two elements+but we cannot make use of it. Thus, no nested NonEmpty.+-}+clashingMapFromList :: (Ord k) => [(k,a)] -> (Map k a, Map k (NonEmpty.T [] a))+clashingMapFromList =+   Map.mapEither+      (\ps ->+         case ps of+            NonEmpty.Cons p [] -> Left p+            _ -> Right ps) .+   Map.fromListWith NonEmptyC.append .+   map (mapSnd NonEmpty.singleton)++checkClash ::+   (PathClass.AbsRel ar) =>+   String -> Map (Path.FilePath ar) (NonEmpty.T [] String) -> IO ()+checkClash msg clashing =+   when (not $ Map.null clashing) $+      ioError $ userError $ unlines $+      msg :+      (Map.elems $+       Map.mapWithKey+         (\path ps ->+            Path.toString path ++ ": " +++            List.intercalate ", " (NonEmpty.flatten ps))+         clashing)++nonEmptyMapForWithKeyM_ ::+   (Monad m, Ord k) => NonEmptyMap.T k a -> (k -> a -> m ()) -> m ()+nonEmptyMapForWithKeyM_ xs f =+   Fold.sequence_ $ NonEmptyMap.mapWithKey f xs++nonEmptyMapForWithKeyM ::+   (Monad m, Ord k) =>+   NonEmptyMap.T k a -> (k -> a -> m b) -> m (NonEmptyMap.T k b)+nonEmptyMapForWithKeyM xs f =+   Trav.sequence $ NonEmptyMap.mapWithKey f xs++mapForWithKeyM_ ::+   (Monad m, Ord k) => Map k a -> (k -> a -> m ()) -> m ()+mapForWithKeyM_ xs f = Fold.sequence_ $ Map.mapWithKey f xs++mapForWithKeyM ::+   (Monad m, Ord k) => Map k a -> (k -> a -> m b) -> m (Map k b)+mapForWithKeyM xs f = Trav.sequence $ Map.mapWithKey f xs+++completeDirectories ::+   (PathClass.AbsRel ar) =>+   [Path.FileDir ar] -> IO [Path.FilePath ar]+completeDirectories =+   let isFile =+         Find.fileType ==? Find.RegularFile ||?+         Find.fileType ==? Find.SymbolicLink+   in  fmap (map Path.path . concat) .+       mapM (Find.find Find.always isFile . Path.toString)++scanTrainingInputs ::+   (PathClass.AbsRel ar) =>+   Flags -> [Path.FileDir ar] -> IO [Path.FilePath ar]+scanTrainingInputs flags inputDirs = do+   inputs <- completeDirectories inputDirs+   Option.infoMsg flags $+      filesMessage "training using following files:" inputs+   return inputs++filesMessage ::+   (PathClass.AbsRel ar) =>+   String -> [Path.FilePath ar] -> String+filesMessage header paths =+   unlines $ header : map Path.toString paths++isSuffixOfPath ::+   (PathClass.AbsRel ar) =>+   String -> Path.FilePath ar -> Bool+isSuffixOfPath suffix path =+   List.isSuffixOf suffix $ Path.toString $ Path.takeFileName path++maybeSuffixOfPath ::+   (PathClass.AbsRel ar) =>+   String -> Path.FilePath ar -> Maybe (Path.FilePath ar)+maybeSuffixOfPath suffix path =+   toMaybe (isSuffixOfPath suffix path) $+      Path.mapFileName (Match.dropRev suffix) path+++{- |+For all label files in the list of input files+we start a supervised training with respect+to the corresponding signal file.+Then an unsupervised training with all signals is performed.++All input signals must have the same sample rate+or the 'Feature.Class' must convert to a specific sample rate.+-}+runHMMTrainingMixedMulti ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   SPMethods.T -> Feature.Class -> Bool ->+   Params.T -> Flags -> HMM.Convergence ->+   [Path.FileDir ar0] -> Path.DirPath ar1 -> IO ()+runHMMTrainingMixedMulti sigProc feature plot params flags cvg inputDirs output = do+   Dir.createDirectoryIfMissing True output+   inputs <- scanTrainingInputs flags inputDirs+   inputsAbs <- Trav.mapM Path.genericMakeAbsoluteFromCwd inputs+   let (labelPaths, signalPaths) =+         ListHT.partition (isSuffixOfPath ".txt") inputsAbs+   intervalss <- Trav.mapM LabelTrack.readFile labelPaths++   featSigsMap <- readFeatureSignalMap sigProc feature flags signalPaths output++   rateLocFeatSigs@(Signal.Cons lowRate _locFeatSigs) <-+      bundleFeatureSignals $ snd . fst <$> featSigsMap++   let (coarseIntervalsMap, fineIntervalsMap) =+         mapPair+            (Map.fromList, Map.fromList . map (mapFst Path.dropExtension)) $+         ListHT.partitionMaybe+            (FuncHT.mapFst (maybeSuffixOfPath "-coarse.txt")) $+         zip labelPaths intervalss+   case Set.toAscList $+        Set.intersection+           (Map.keysSet coarseIntervalsMap)+           (Map.keysSet fineIntervalsMap) of+      [] -> return ()+      clashing ->+         ioError $ userError $+            filesMessage "clashing fine and coarse label files:" clashing++   let perFileExc =+         userErrorFromExc . Trav.sequence .+         Map.mapWithKey+            (\name -> ME.mapException (printf "%s: %s" $ Path.toString name))+   refinedIntervalsMap <-+      perFileExc $+      Map.intersectionWith+         (fineSnappedFromCoarseIntervals feature params lowRate)+         (fst.fst <$> featSigsMap) coarseIntervalsMap+   mapForWithKeyM_ refinedIntervalsMap $ \fileName intervals ->+      LabelChain.writeFileInt lowRate+         (output </> Path.takeBaseName fileName <-> "fine.txt") intervals++   intervalsMap <-+      fmap (Map.union refinedIntervalsMap) $ perFileExc $+      fmap (fmap Signal.body . LabelTrack.discretizeTrack lowRate) fineIntervalsMap++   {-+   That's not the same as (Map.keysSet intervalsMap)+   since some filenames may already have been removed by+   Map.intersectionWith in refinedIntervalsMap+   -}+   let allIntervalsNamesSet =+         Set.union+            (Map.keysSet fineIntervalsMap)+            (Map.keysSet coarseIntervalsMap)+   case Set.toAscList $+        Set.difference allIntervalsNamesSet (Map.keysSet featSigsMap) of+      [] -> return ()+      missing ->+         ioError $ userError $+            filesMessage+               "missing signal files for following label files:" missing++   mapForWithKeyM_ intervalsMap $ checkEmptyIntervals lowRate++   let labelCounts = histogram $ Fold.foldMap Fold.toList intervalsMap+       (stateFromLabelMap, labelFromStateMap) =+         HMM.mapsFromLabels $ map fst labelCounts++   Option.infoAction flags $ do+      putStrLn "encountered labels with assigned state number and frequency"+      printLabelCounts stateFromLabelMap labelCounts++   labelledSignals <-+      userErrorFromExc $+      ME.fromMaybe+         "no matching label and signal files for supervised training" $+      NonEmptyMap.fetch $+      Map.intersectionWith (,)+         (Signal.body . snd . fst <$> featSigsMap) intervalsMap++   waits0 <-+      plotStateEmissionsMulti plot supervisedName+         stateFromLabelMap labelFromStateMap labelledSignals++   hmmsTrained <-+      userErrorFromExc $ Trav.sequence $+      Par.withStrategy (Par.parTraversable Par.rdeepseq) $+      NonEmptyMap.mapWithKey+         (uncurry . HMM.trainSupervised stateFromLabelMap)+         labelledSignals+   forM_ (NonEmptyMap.toAscList hmmsTrained) $ uncurry $+      checkAdmissibilityTrans+         (Feature.admissibleTransitions feature) labelFromStateMap+   let hmm = HMM0.trainMany id $ NonEmptyMap.elems hmmsTrained+       hmmNamed =+         HMMNamed.Cons {+            HMMNamed.nameFromStateMap = labelFromStateMap,+            HMMNamed.stateFromNameMap = stateFromLabelMap,+            HMMNamed.model = hmm+         }+       featureHMM =+         Feature.HMM {+            Feature.hmmClass = feature,+            Feature.hmmodel = hmmNamed+         }++   Feature.writeHMM (output </> Path.path hmmSupervisedName) featureHMM+   Option.infoMsg flags $ HMM0.toCSV hmm++   Option.notice flags "classify using trained model"+   supervisedTracks <- writeAnalyzedTracks hmmNamed rateLocFeatSigs output++   (waits1, unsupervisedTracks) <-+      hmmTrainingsUnsupervised featureHMM plot flags cvg rateLocFeatSigs output++   let fineTracks =+         projectLabelChain "fine" . LabelChain.realTimes lowRate <$>+         intervalsMap++   writeMultiTrainingProject (fmap snd featSigsMap)+      [fineTracks, supervisedTracks, unsupervisedTracks] output++   waitPlots $ waits0 ++ waits1++runHMMTrainingUnsupervisedMulti ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   SPMethods.T -> Feature.HMM -> Bool -> Params.T -> Flags -> HMM.Convergence ->+   [Path.FileDir ar0] -> Path.DirPath ar1 -> IO ()+runHMMTrainingUnsupervisedMulti+      sigProc featureHMM plot _params flags cvg inputDirs output = do++   Dir.createDirectoryIfMissing True output++   inputs <- scanTrainingInputs flags inputDirs+   inputsAbs <- Trav.mapM Path.genericMakeAbsoluteFromCwd inputs+   featSigsMap <-+      readFeatureSignalMap+         sigProc (Feature.hmmClass featureHMM) flags inputsAbs output++   rateLocFeatSigs <- bundleFeatureSignals $ snd . fst <$> featSigsMap++   Option.notice flags "classify using old model"+   supervisedTracks <-+      writeAnalyzedTracks (Feature.hmmodel featureHMM) rateLocFeatSigs output++   (waits, unsupervisedTracks) <-+      hmmTrainingsUnsupervised featureHMM plot flags cvg rateLocFeatSigs output++   writeMultiTrainingProject (fmap snd featSigsMap)+      [supervisedTracks, unsupervisedTracks] output++   waitPlots waits++writeAnalyzedTracks ::+   (Rate.C rate, PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   HMMNamed.Gaussian Double ->+   Signal.T rate (NonEmptyMap.T (Path.FilePath ar0) [Named.NonEmptySignal]) ->+   Path.DirPath ar1 -> IO (Map (Path.FilePath ar0) Audacity.Track)+writeAnalyzedTracks hmmNamed (Signal.Cons featRate locFeatSigs) output =+   mapForWithKeyM (NonEmptyMap.flatten locFeatSigs) $ \fileName featSigs ->+      writeLabelTrackInt featRate+            (output </> Path.takeBaseName fileName) supervisedName $+         HMM.analyze hmmNamed featSigs++writeMultiTrainingProject ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Map (Path.FilePath ar0)+      (Double,+       ProjectWaveSummary.Monad IO (Audacity.Track, [Audacity.Track])) ->+   [Map (Path.FilePath ar0) Audacity.Track] -> Path.DirPath ar1 -> IO ()+writeMultiTrainingProject featSigsMap labelTrackMaps output =+   mapForWithKeyM_ featSigsMap $ \fileName (zoom, waveTracksSum) -> do+      let outputStem = output </> Path.takeBaseName fileName+      ((audPath, audFormat), (inputTrack, featSigTracks)) <-+         waveSummaryEval outputStem waveTracksSum+      PathIO.writeFile audPath $ audFormat $+         createProject zoom $+            inputTrack :+            featSigTracks +++            mapMaybe (Map.lookup fileName) labelTrackMaps +++            []++readFeatureSignalMap ::+   (PathClass.AbsRel ar, MonadIO m) =>+   SPMethods.T -> Feature.Class -> Flags -> [Path.AbsFile] -> Path.DirPath ar ->+   IO (Map Path.AbsFile+        ((Signal.Sox, Signal.T Rate.Feature [Named.NonEmptySignal]),+         (Double,+          ProjectWaveSummary.Monad m (Audacity.Track, [Audacity.Track]))))+readFeatureSignalMap sigProc feature flags inputs output = do+   inputPathMap <- makePathMap inputs+   forM inputPathMap $ \input ->+      withSound flags input $ \ fmtIn sig ->+         case rnf sig of+            () -> do+               (featSigs, featSigsNE) <-+                  featureSignals sigProc feature input sig+               featSigTrack <-+                  writeFeatureTracks fmtIn+                     (output </> Path.takeBaseName input <.> "wav")+                     (Feature.scale feature) featSigs+               let waveTracks =+                     liftM2 (,)+                        (projectWaveTrackInput (sig, input)) featSigTrack+               return+                  ((sig, featSigsNE <$ featSigs),+                   (zoomFullSignal sig, waveTracks))++bundleFeatureSignals ::+   (Ord loc) =>+   Map loc (Signal.T rate signal) ->+   IO (Signal.T rate (NonEmptyMap.T loc signal))+bundleFeatureSignals locFeatSigs =+   userErrorFromExc $+   ME.fromMaybe "missing training signals" $+   (\nonEmptyFeatSigs ->+      Signal.Cons+         (Signal.sampleRate $ snd $ fst $+          NonEmptyMap.minViewWithKey nonEmptyFeatSigs)+         (fmap Signal.body nonEmptyFeatSigs)) <$>+   NonEmptyMap.fetch locFeatSigs++hmmTrainingsUnsupervised ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Feature.HMM -> Bool -> Flags -> HMM.Convergence ->+   Signal.T Rate.Feature+      (NonEmptyMap.T (Path.FilePath ar0) [Named.NonEmptySignal]) ->+   Path.DirPath ar1 ->+   IO ([PlotProcess], Map (Path.FilePath ar0) Audacity.Track)+hmmTrainingsUnsupervised+      featureHMM plot flags cvg (Signal.Cons lowRate locFeatSigs) output = do+   Option.notice flags "unsupervised training"+   let hmmNamed = Feature.hmmodel featureHMM+       prep = NonEmptyMap.elems $ fmap HMM.prepare locFeatSigs+       step model = HMM.trainMany (HMM0.trainUnsupervised model) prep+       hmms =+         HMM.takeUntilConvergence cvg $ iterate step $ HMMNamed.model hmmNamed+       lastHMM = last hmms+       lastHMMNamed = hmmNamed{HMMNamed.model = lastHMM}+   mapM_ (Option.infoMsg flags . HMM0.toCSV) hmms+   Option.noticeAction flags $+      printModelDifference (HMMNamed.model hmmNamed) lastHMM++   Option.notice flags "classify using trained model"+   Feature.writeHMM (output </> Path.path hmmUnsupervisedName) $+      (featureHMM {Feature.hmmodel = lastHMMNamed})+   let labelleds =+         fmap+            (\featSigs -> (featSigs, HMM.analyze lastHMMNamed featSigs))+            locFeatSigs++   labelTracks <-+      mapForWithKeyM (NonEmptyMap.flatten labelleds) $ \fileName (_, labelled) ->+         writeLabelTrackInt lowRate+            (output </> Path.takeBaseName fileName)+            unsupervisedName labelled++   waits <-+      plotStateEmissionsMulti+         plot unsupervisedName+         (HMMNamed.stateFromNameMap hmmNamed)+         (HMMNamed.nameFromStateMap hmmNamed)+         labelleds++   return (waits, labelTracks)+++runDetectAdvertiseBandpass ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Flags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()+runDetectAdvertiseBandpass flags input output =+   withSound flags input $ \fmtIn sig@(Signal.Cons rate _) ->+             writeChannels fmtIn rate output $+             flip map [38,69] $ \f ->+             Causal.apply+                (Bin.fromCanonicalWith Real.roundSimple+                 ^<<+                 bandpass rate 10 (Freq f)) $+             Named.body $+             filterBand 2 (Freq 2000) sig++runDetectAdvertiseComb ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Flags -> Path.FilePath ar0 -> Path.FilePath ar1 -> IO ()+runDetectAdvertiseComb flags input output =+   withSound flags input $ \fmtIn sig@(Signal.Cons rate _) ->+             writeChannels fmtIn rate output $+             flip map [38,69] $ \f ->+             SVL.map (Bin.fromCanonicalWith Real.roundSimple) $+             combFilter rate 0.9 (Time $ recip f) $+             Named.body $+             filterBand 2 (Freq 2000) sig+++orderOption :: OP.Parser (IO (Sort path))+orderOption =+   let attachNumbers sort = return $ return . zip [0..] . sort+   in  OP.option (fmap readCustomOrder Option.path)+          (OP.long "custom-order" <>+           OP.metavar "PATH" <>+           OP.help "sort animals according to explicit list from file")+       <|>+       OP.flag' (attachNumbers $ List.sortBy (comparing fst))+          (OP.long "lexicographic-order" <>+           OP.help "sort animals in lexicographic order")+       <|>+       OP.flag+          (attachNumbers $ Key.sort (numericPattern . fst))+          (attachNumbers $ Key.sort (numericPattern . fst))+          (OP.long "numeric-order" <>+           OP.help "sort animals in number-aware lexicographic order")++emitTableOption :: OP.Parser Format.Flags+emitTableOption =+   let switch = uncurry . Option.switch+       (Format.Flags formulaNumberFlags tableFormats recordingFlags divTH) =+          Format.defaultFlags+   in  pure Format.Flags+        <*> (bisequenceA $ biliftA2 switch switch formulaNumberFlags $+             CalcForm.Tracked+               ("emit-formula", "emit table files containing formulas")+               ("emit-number", "emit table files containing numbers"))+        <*> (Trav.sequenceA $ OP.liftA2 switch tableFormats $+             Format.TableFormats+               ("emit-csv", "emit table files in CSV format")+               ("emit-html", "emit table files in HTML format")+               ("emit-xml-2003", "emit table files in Excel 2003 XML format"))+        <*> (Trav.sequenceA $ OP.liftA2 switch recordingFlags $+             Format.RecordingFlags+               ("emit-single", "emit table files per recording and sound type")+               ("emit-multi", "emit table files per recording"))+        <*> Option.switch divTH "divided-table-head"+               "use two rows and merged cells for summary table headers"++emitOption :: OP.Parser (Format.Flags, Bool)+emitOption =+   liftA2 (,)+      emitTableOption+      (Option.switch False "emit-track"+         "emit audio and label tracks as individual files")+++parseAction2 :: Params.T -> Option.Commands (Flags -> IO ())+parseAction2 params =+   (Option.transferActionApp "trains" "supervised training" $+    fmap+      (\getTrainingFlags flags input output -> do+         trainingFlags <- getTrainingFlags+         runHMMTrainingSupervised flags trainingFlags input output)+      (Option.trainingFlags SPOption.opt params))+   <>+   (Option.transferActionApp+      "trainsc" "training with coarsely labelled recordings" $+    fmap+      (\getTrainingFlags flags input output -> do+         trainingFlags <- getTrainingFlags+         runHMMTrainingSupervisedCoarse params flags trainingFlags input output)+      (Option.trainingFlags SPOption.opt params))+   <>+   (Option.transferActionApp "trainu" "unsupervised training" $+    OP.liftA2+      (\getTrainingFlags numStates flags input output -> do+         trainingFlags <- getTrainingFlags+         runHMMTrainingUnsupervised flags trainingFlags numStates input output)+      (Option.trainingFlags SPOption.opt params)+      Option.numStates)+   <>+   (Option.transferActionApp "hmm" "detect sounds using HMM" $+    pure+      (\sigProc readHMM fmtFlags flags input output -> do+         hmm <- readHMM+         runDetectHMM (sigProc, hmm, fmtFlags, params, flags) input output)+      <*> SPOption.opt+      <*> Option.model+      <*> emitOption)+   <>+   (Option.transferActionApp "hmmm" "batched sound detection using HMM" $+    pure+      (\initOrder sigProc readHMM fmtFlags flags input output -> do+         hmm <- readHMM+         order <- initOrder+         runDetectHMMMulti order+            (sigProc, hmm, fmtFlags, params, flags) input output)+      <*> orderOption+      <*> SPOption.opt+      <*> Option.model+      <*> emitOption)+   <>+   (Option.transferActionApp+      "measurem" "batched measurement of classified sounds" $+    pure+      (\initOrder sigProc fmtFlags flags input output -> do+         order <- initOrder+         runMeasureMulti order sigProc fmtFlags params flags input output)+      <*> orderOption+      <*> SPOption.opt+      <*> emitOption)+   <>+   (Option.transferActionApp "match" "match with patterns" $+    fmap+      (\pattern -> runMatchPatterns pattern params)+      (OP.option Option.path $ OP.long "pattern" <> OP.metavar "PATH"))+   <>+   Option.transferAction "dehum" "remove pink noise from recording" runDehum+   <>+   Option.transferAction "slope" "detect rasping clicks by steep attacks"+      (runDetectAdvertiseSlope params)+   <>+   Option.transferAction "band" "detect rasping by a bandpass at click rate"+      runDetectAdvertiseBandpass+   <>+   Option.transferAction "comb" "detect rasping by a comb filter at click rate"+      runDetectAdvertiseComb+   <>+   Option.transferAction "extract" "extract patterns from labelled tracks"+      (runExtractPatterns params)+++parseActionMulti :: Params.T -> Option.Commands (Flags -> IO ())+parseActionMulti params =+   (Option.multiAction "trainm"+         "supervised and unsupervised training with multiple recordings" $+      pure+         (\sigProc cvg lookupFeature plot input output flags -> do+            feature <- lookupFeature+            runHMMTrainingMixedMulti+               sigProc feature plot params flags cvg input output)+         <*>+         SPOption.opt+         <*>+         HMM.convergenceOptions+         <*>+         Option.feature params)+   <>+   (Option.multiAction "trainum"+         "unsupervised training with multiple recordings" $+      pure+         (\sigProc cvg readHMM plot inputs output flags -> do+            hmm <- readHMM+            runHMMTrainingUnsupervisedMulti+               sigProc hmm plot params flags cvg inputs output)+         <*>+         SPOption.opt+         <*>+         HMM.convergenceOptions+         <*>+         Option.model)+++main :: IO ()+main = SoxLib.formatWith $ do+   let params = Params.deflt++   action <-+      OP.execParser $ Option.info $+         pure (flip ($))+          <*> Option.parseFlags+          <*> OP.subparser (parseActionMulti params <> parseAction2 params)++   action
+ src/Measurement.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE RebindableSyntax #-}+module Measurement where++import qualified LabelChain+import qualified Fourier+import qualified Class+import qualified Named+import qualified SpectralDistribution as SD+import qualified Arithmetic as Arith+import qualified Parameters as Params+import qualified Rate+import qualified Signal+import qualified SignalProcessingMethods as SPMethods+import qualified SignalProcessing as SP+import SignalProcessingMethods (Triple, )+import Parameters (Freq(Freq), )++import qualified Synthesizer.Generic.Analysis as AnaG+import qualified Synthesizer.Basic.Binary as Bin++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV++import qualified Control.Applicative.HT as AppHT+import qualified Control.Functor.HT as FuncHT+import Control.DeepSeq (NFData, rnf, )+import Control.Applicative (Applicative, pure, (<*>), )++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.NonEmpty as NonEmpty+import Data.Tuple.HT (mapPair, )+import Data.Maybe (mapMaybe, )++import qualified Algebra.Field as Field+import NumericPrelude.Numeric+import NumericPrelude.Base hiding (id)+++-- | LabelChain.mergePhases drops a trailing isolated chunk+mergeClickPhases :: [[a]] -> [[a]]+mergeClickPhases =+   let go (x0:x1:xs) = (x0++x1) : go xs+       go _ = []+   in  go++halfLife :: (Ord a, Field.C a) => NonEmpty.T [] a -> Int+halfLife xs =+   let xm = NonEmpty.maximum xs+   in  length $ takeWhile (>= xm / 2) $+       dropWhile (<xm) $ NonEmpty.flatten xs+++countEmphasized :: Params.T -> [Float] -> Int+countEmphasized params clickAmplitudes =+   let progression = iterate (one+) zero+       (c0,c1) = Arith.linearRegression $ zip progression clickAmplitudes+   in  length $ takeWhile (zero<) $ zipWith (-) clickAmplitudes $+       map (\k -> Params.emphasisExcess params * (c0+c1*k)) progression+++type ClassFeatures = Class.Sound (Int, Int, Int) Int Int (Int, Int, Int)++type ChunkFeatures = ((Int, Int, Int), Int)++chunkFeatures ::+   Params.T -> SVL.Vector Float -> SVL.Vector Float -> ChunkFeatures+chunkFeatures params volume featSig =+   let clicks =+         mergeClickPhases $+         LabelChain.chopMonotony+            (mapPair (LabelChain.spanWeakRising, LabelChain.spanWeakFalling) $+             Params.weakCounterSlopeSizes params) $+         SVL.unpack featSig+   in  ((length clicks,+         sum $ map halfLife $ mapMaybe NonEmpty.fetch clicks,+         countEmphasized params $+         map NonEmpty.maximum $ mapMaybe (NonEmpty.fetch . SVL.unpack) $+         flip SP.chop (map length clicks) $+         SVL.zipWith (*) volume featSig),+        SP.chirpingMainDur featSig)+++bandFreq0, bandFreq1, bandFreq2 :: Float+bandFreq0 = 1000+bandFreq1 = 2500+bandFreq2 = 4000++bandFreqs :: Triple Freq+bandFreqs = (Freq bandFreq0, Freq bandFreq1, Freq bandFreq2)+++data SpectralParameters a =+   SpectralParameters {+      spectralFlatness, spectralMaximum :: a,+      spectralBandParams :: (a,a),+      spectralDistribution :: (SD.T a)+   } deriving Show++instance (NFData a) => NFData (SpectralParameters a) where+   rnf (SpectralParameters specFlat specMax bands distr) =+      rnf (specFlat, specMax, bands, distr)++instance Functor SpectralParameters where+   fmap = Trav.fmapDefault++instance Fold.Foldable SpectralParameters where+   foldMap = Trav.foldMapDefault++instance Trav.Traversable SpectralParameters where+   traverse f (SpectralParameters specFlat specMax bands distr) =+      pure SpectralParameters+         <*> f specFlat <*> f specMax+         <*> AppHT.mapPair (f,f) bands+         <*> Trav.traverse f distr++instance Applicative SpectralParameters where+   pure x = SpectralParameters x x (x,x) (pure x)+   SpectralParameters fSpecFlat fSpecMax fbands fdistr <*>+      SpectralParameters specFlat specMax bands distr =+         SpectralParameters+            (fSpecFlat specFlat) (fSpecMax specMax)+            (mapPair fbands bands) (fdistr <*> distr)+++spectralParameters ::+   (Float, Float) -> ((Float, Float), SD.T Float) ->+   SpectralParameters Float+spectralParameters (flat, maxf) (bp, distr) =+   SpectralParameters flat maxf bp distr++spectrogramParameters :: [SV.Vector Float] -> (Float, Float)+spectrogramParameters specs =+   (let blockFlats = map Fourier.spectralFlatness specs+    in  if null blockFlats then 1 else AnaG.average blockFlats,+    let amax block =+           fromIntegral (fst (SP.argMaximum block))+           /+           fromIntegral (2 * (SV.length block-1))+        blockMaxs = map amax specs+    in  if null blockMaxs then 0 else AnaG.average blockMaxs)+++classFromChunkFeatures ::+   ChunkFeatures -> Class.Sound rasping chirping ticking growling ->+   ClassFeatures+classFromChunkFeatures (clickMeasure@(numClicks, _, _), chirpMain) cls =+   case cls of+      Class.Rasping _ -> Class.Rasping clickMeasure+      Class.Chirping _ -> Class.Chirping chirpMain+      Class.Ticking _ -> Class.Ticking numClicks+      Class.Growling _ -> Class.Growling clickMeasure+      Class.Other str -> Class.Other str++measureSignal ::+   SPMethods.T -> Params.T ->+   Signal.SoxLabelled (Class.Sound rasping chirping ticking growling) ->+   ([ChunkFeatures],+    (Signal.LabelChain Rate.Measure (SpectralParameters Float, ClassFeatures),+     ([Float], Signal.T Rate.Measure [Named.Signal])))+measureSignal sigProc params labelled =+   let (sig, classified) = FuncHT.unzip labelled+       intervalSizes = Fold.toList . fmap fst . LabelChain.intervalSizes+       measRate = Params.measureSampleRate params+       classifiedHighRate = Signal.body classified+       classifiedMeasRate =+          Signal.body $ Signal.labelResample measRate classified+       dehummed = SPMethods.dehum sigProc sig+       (volume, relEnv) = SPMethods.envelopeLowRate sigProc measRate dehummed+       chunkFeats =+          case intervalSizes classifiedMeasRate of+             chunkSizes ->+                zipWith (chunkFeatures params)+                   (SP.chop volume chunkSizes)+                   (SP.chop relEnv chunkSizes)+       fourierStep = Params.fourierBlockStep params+       fourierSize = Params.fourierBlockSize params+       chunkSizesBlockRate =+          intervalSizes $+          LabelChain.mapTime (max 0) $+          LabelChain.mapTime+             (\n -> div (n + div (fourierStep-fourierSize) 2) fourierStep) $+          classifiedHighRate+       spectroParams =+          map spectrogramParameters $+          flip SP.chop chunkSizesBlockRate $+          Fourier.slice $+          Fourier.absoluteBlockSpectra fourierStep fourierSize $+          SP.svlConcat $ SVL.map Bin.toCanonical $ Signal.body sig+       spectralDists =+          zipWith spectralParameters spectroParams $+          SPMethods.bandParameters sigProc bandFreqs dehummed $+          intervalSizes classifiedHighRate+   in  (chunkFeats,+        (Signal.Cons measRate $+         LabelChain.zipWithList (,) spectralDists $+         LabelChain.zipWithList classFromChunkFeatures+            chunkFeats classifiedMeasRate,+         ([1, 0.4],+          Signal.Cons measRate+            [Named.Cons "volume" volume, Named.Cons "envelope" relEnv])))
+ src/Named.hs view
@@ -0,0 +1,20 @@+module Named where++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.NonEmpty as NonEmpty+import Control.DeepSeq (NFData, rnf, )+++data T a = Cons {name :: String, body :: a}+type Signal = T (SVL.Vector Float)+type NonEmptySignal = T (NonEmpty.T SVL.Vector Float)++instance NFData body => NFData (T body) where+   rnf (Cons rate xs) = rnf (rate, xs)++instance Functor T where+   fmap f (Cons str xs) = Cons str $ f xs++apply :: String -> (a -> b) -> T a -> T b+apply prefix f (Cons str xs) =+   Cons (prefix ++ " " ++ str) $ f xs
+ src/Option.hs view
@@ -0,0 +1,228 @@+module Option where++import qualified Feature+import qualified Parameters as Params+import qualified HiddenMarkovModel as HMM++import qualified Distribution.Verbosity as Verbosity+import qualified Distribution.ReadE as ReadE+import Distribution.Verbosity (Verbosity)++import qualified Options.Applicative as OP++import qualified SignalProcessingMethods as SPMethods+import qualified Data.StorableVector.Lazy as SVL+import qualified Sound.SoxLib as SoxLib++import qualified System.Path.PartClass as PathClass+import qualified System.Path as Path+import qualified System.IO as IO+import Text.Printf (printf, )++import Control.Monad (when, )+import Control.Applicative (pure, (<*>), (<$>), (<|>), )+import Control.Applicative.HT (liftA5, )++import qualified Data.Map as Map+import qualified Data.List as List+import Data.Monoid ((<>), )++++data Flags =+   Flags {+      verbosity :: Verbosity,+      chunkSize :: SVL.ChunkSize,+      sampleRate :: Maybe SoxLib.Rate+   }+   deriving (Show)+++optionVerbosity :: OP.ReadM Verbosity+optionVerbosity =+   OP.eitherReader $ ReadE.runReadE Verbosity.flagToVerbosity++-- cf. Distribution.Simple.Utils+noticeAction :: Flags -> IO () -> IO ()+noticeAction flags emit =+   when (verbosity flags >= Verbosity.normal) emit++notice :: Flags -> String -> IO ()+notice flags msg = noticeAction flags (putStrLn msg)++infoAction :: Flags -> IO () -> IO ()+infoAction flags emit =+   when (verbosity flags >= Verbosity.verbose) emit++infoMsg :: Flags -> String -> IO ()+infoMsg flags msg = infoAction flags (putStrLn msg)++warn :: Flags -> String -> IO ()+warn flags msg =+   when (verbosity flags >= Verbosity.normal) $ do+      IO.hFlush IO.stdout+      IO.hPutStr IO.stderr msg+++parseFlags :: OP.Parser Flags+parseFlags =+   pure Flags+    <*> OP.option optionVerbosity+           ( OP.value Verbosity.normal+          <> OP.short 'v'+          <> OP.long "verbose"+          <> OP.metavar "0..3"+          <> OP.help "verbosity" )+    <*> OP.option (fmap SVL.chunkSize OP.auto)+           ( OP.value (SVL.chunkSize 65536) -- crashes SoX' FLAC writer+          <> OP.long "chunksize"+          <> OP.metavar "NUMSAMPLES"+          <> OP.help "size of processing units" )+    <*> OP.option (fmap Just OP.auto)+           ( OP.value Nothing+          <> OP.long "samplerate"+          <> OP.metavar "HERTZ"+          <> OP.help "override sample rate of input files" )++model :: OP.Parser (IO Feature.HMM)+model =+   OP.option (Feature.readHMM <$> path) $+      OP.long "model" <>+      OP.metavar "PATH" <>+      OP.value (return Feature.hmmHardwired) <>+      OP.help "CSV file containing HMM parameters"++path :: (PathClass.FileDir fd) => OP.ReadM (Path.AbsRel fd)+path = OP.eitherReader Path.parse++numStates :: OP.Parser Int+numStates =+   OP.option+         (OP.eitherReader $ \str ->+            case reads str of+               [(n, "")] ->+                  if n>0+                    then Right n+                    else Left "not positive"+               _ -> Left "not an integer") $+      OP.long "numstates" <>+      OP.metavar "NUMBER" <>+      OP.help "number of states for Hidden Markov Model" <>+      OP.value 6+++data TrainingFlags =+   TrainingFlags {+      trainingSignalProcessing :: SPMethods.T,+      trainingFeature :: Feature.Class,+      trainingConvergence :: HMM.Convergence,+      trainingMLPack :: Bool,+      trainingPlot :: Bool+   }++formatBool :: Bool -> String+formatBool b = if b then "yes" else "no"++switch :: Bool -> String -> String -> OP.Parser Bool+switch deflt name helpMsg =+   OP.flag' False (OP.long ("no-" ++ name))+   <|>+   OP.flag deflt True+      (OP.long name <>+       OP.help (printf "%s (default: %s)" helpMsg (formatBool deflt)))++feature :: Params.T -> OP.Parser (IO Feature.Class)+feature params =+   let lookupFeature name =+         case Map.lookup name Feature.dictionaryMerged of+            Just feat -> return feat+            Nothing ->+               ioError $ userError $ unlines $+                  printf "unknown feature \"%s\"" name :+                  "known features:" :+                  Map.keys Feature.dictionaryMerged+   in  OP.option (fmap lookupFeature OP.str) $+         OP.long "feature" <>+         OP.metavar "NAME" <>+         OP.value+            (return $ Feature.lowRateSqrt $ Params.featureSampleRate params) <>+         OP.help+            ("one of " +++             List.intercalate ", " (Map.keys Feature.dictionaryMerged))++plot :: OP.Parser Bool+plot =+   OP.switch $+      OP.long "plot" <>+      OP.help "show feature vectors grouped by model states"++mlpack :: OP.Parser Bool+mlpack =+   OP.switch $+      OP.long "mlpack" <>+      OP.help "emit files that let you perform training using mlpack"++trainingFlags ::+   OP.Parser SPMethods.T -> Params.T -> OP.Parser (IO TrainingFlags)+trainingFlags signalProcessing params =+   liftA5+      (\sigProc lookupFeature cvg mlp plt -> do+         feat <- lookupFeature+         return $ TrainingFlags sigProc feat cvg mlp plt)+      signalProcessing (feature params) HMM.convergenceOptions mlpack plot+++type Commands = OP.Mod OP.CommandFields++simpleAction :: String -> String -> OP.Parser a -> Commands a+simpleAction name helpText act =+   OP.command name $ OP.info (OP.helper <*> act) (OP.progDesc helpText)++withInOutPaths ::+   (PathClass.FileDir fd0, PathClass.FileDir fd1) =>+   (Flags -> Path.AbsRel fd0 -> Path.AbsRel fd1 -> IO ()) ->+   (FilePath -> FilePath -> Flags -> IO ())+withInOutPaths act =+   \inputStr outputStr flags -> do+      let ioExc = either (ioError . userError) return+      input <- ioExc $ Path.parse inputStr+      output <- ioExc $ Path.parse outputStr+      act flags input output++transferActionApp ::+   (PathClass.FileDir fd0, PathClass.FileDir fd1) =>+   String -> String ->+   OP.Parser+      (Flags -> Path.AbsRel fd0 -> Path.AbsRel fd1 -> IO ()) ->+   Commands (Flags -> IO ())+transferActionApp name msg parser =+   simpleAction name msg $+   OP.liftA3 withInOutPaths parser+      (OP.strArgument (OP.metavar "SRC"))+      (OP.strArgument (OP.metavar "DST"))++transferAction ::+   (PathClass.FileDir fd0, PathClass.FileDir fd1) =>+   String -> String ->+   (Flags -> Path.AbsRel fd0 -> Path.AbsRel fd1 -> IO ()) ->+   Commands (Flags -> IO ())+transferAction name msg = transferActionApp name msg . pure++multiAction ::+   (PathClass.FileDir fd0, PathClass.FileDir fd1) =>+   String -> String ->+   OP.Parser (Bool -> [Path.AbsRel fd0] -> Path.AbsRel fd1 -> a) ->+   Commands a+multiAction name msg parse =+   simpleAction name msg $+   parse+      <*> plot+      <*> OP.some (OP.argument path (OP.metavar "SRC"))+      <*> OP.option path (OP.long "output" <> OP.metavar "DST")+++info :: OP.Parser a -> OP.ParserInfo a+info parser =+   OP.info+      (OP.helper <*> parser)+      (OP.fullDesc <> OP.progDesc "Classify sounds of xenopus laevis")
+ src/Parameters.hs view
@@ -0,0 +1,110 @@+module Parameters where++import qualified Rate++import Text.Printf (printf, )+++newtype Time = Time Float+   deriving (Eq, Ord, Show)++newtype Freq = Freq Float+   deriving (Eq, Ord, Show)++getTime :: Time -> Float+getTime (Time t) = t++getFreq :: Freq -> Float+getFreq (Freq f) = f+++freq :: (Rate.C rate) => rate -> Freq -> Float+freq sr (Freq f) = f / realToFrac (Rate.unpack sr)++time :: (Rate.C rate) => rate -> Time -> Int+time sr (Time t) = round (t * realToFrac (Rate.unpack sr))++timeCeil :: (Rate.C rate) => rate -> Time -> Int+timeCeil sr (Time t) = ceiling (t * realToFrac (Rate.unpack sr))++toTime :: (Rate.C rate) => rate -> Int -> Double+toTime rate n = fromIntegral n / Rate.unpack rate+++formatFreq :: Freq -> String+formatFreq (Freq f) = printf "%.0fHz" f+++data T =+   Cons {+      hardLowDist, hardHighDist, softLowDist, softHighDist :: Time,+      minClickAttack :: Float,+      halfDiffDist :: Time,+      minClickDur :: Time,+      volumeFrequency :: Freq,+      envelopeFrequency :: Freq,++      emphasisExcess :: Float,+      raspingMinNumClicks :: Int,+      raspingMaxRelativeClickDistance :: Float,+      maxInterimRumblingDur :: Time,+      chirpingHackDur, chirpingMinDur, chirpingMaxDur :: Time,+      chirpingMainDurMaxDeviation :: Time,+      weakCounterSlopeSizes :: (Float, Float),+      sampleRate :: Rate.Sample,+      featureSampleRate :: Rate.Feature,+      measureSampleRate :: Rate.Measure,+      fourierBlockSize, fourierBlockStep :: Int+   }++deflt :: T+deflt =+   Cons {+      {-+      mode for high part of the advertisement call:+         0.015++      separation between low and high part of advertisement call:+         0.018++      modes for rasping:+         0.026, 0.031++      interval for regular values:+         0.022 - 0.034++      some outlier distances at the beginning:+         0.049, 0.044, 0.047, 0.049, 0.048++      some outlier distances within the rasping sound:+         0.053, 0.082, 0.053+      -}+      hardLowDist  = Time 0.018,+      hardHighDist = Time 0.090,+      softLowDist  = Time 0.022,+      softHighDist = Time 0.034,+      minClickAttack = 0.2,+      halfDiffDist = Time 0.0014,+      minClickDur = Time 0.025,+      volumeFrequency = Freq 10,+      envelopeFrequency = Freq 70,++      emphasisExcess = 1.1,+      raspingMinNumClicks = 3,+      raspingMaxRelativeClickDistance = 1.5,+      maxInterimRumblingDur = Time 0.1,+      chirpingHackDur = Time 0.08,+      chirpingMinDur = Time 0.15,+      chirpingMaxDur = Time 0.8,+      chirpingMainDurMaxDeviation = Time 0.01,+      -- value 3 avoids zero-length r1 intervals in training1500.WAV+      -- value 2 was better for counting clicks in some cases+      -- weakCounterSlopeSizesBand20 = (3,3),+      weakCounterSlopeSizes = (0.6,0.6),+      sampleRate = Rate.Sample 11025,+      featureSampleRate = Rate.Feature 200,+      measureSampleRate = Rate.Measure 200,+      -- Main.spectralParameters expects even block size+      fourierBlockSize = 256,+      fourierBlockStep = 128+   }
+ src/Quantile.hs view
@@ -0,0 +1,43 @@+{-+See also: statistics, order-statistics, interpolation+-}+module Quantile where++import qualified Data.NonEmpty.Set as NESet+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import Data.NonEmpty ((!:))++import qualified Algebra.RealRing as Real+import qualified Algebra.Field as Field+import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++{- |+The function @discrete xs@ is the inverse cumulative distribution function+of the discrete distribution represented by @xs@.+It is a piecewise linear interpolation+between all numbers in @xs@ in ascending order.+In @discrete xs r@ the parameter @r@ must be between 0 and 1.+It is @discrete xs 0 == minimum xs@,+@discrete xs 1 == maximum xs@,+and @discrete xs 0 == median xs@.+-}+discrete :: (Field.C a, Real.C a) => NonEmpty.T [] a -> a -> a+discrete (NonEmpty.Cons x []) = const x+discrete xs =+   case NESet.fromList $ NonEmptyC.zip xs $ (0::Int) !: [1 ..] of+      set -> \r ->+         if r==one+           then fst $ NESet.findMax set+           else+            {-+            'Set.elemAt' would be faster than 'drop',+            but is only available since GHC-7.8.4.+            -}+            let (k, frac) = splitFraction $ fromIntegral (NESet.size set - 1) * r+            in  case drop k $ NonEmpty.flatten $ NESet.toAscList set of+                   (x0,_):(x1,_):_ -> x0*(one-frac) + x1*frac+                   _ -> error "Quantile.discrete: unexpected empty list"
+ src/Rate.hs view
@@ -0,0 +1,22 @@+module Rate where++import qualified Sound.SoxLib as SoxLib+++class C rate where unpack :: rate -> SoxLib.Rate++newtype Sample = Sample SoxLib.Rate deriving (Eq)+instance C Sample where unpack (Sample rate) = rate++newtype Feature = Feature SoxLib.Rate deriving (Eq)+instance C Feature where unpack (Feature rate) = rate++newtype Measure = Measure SoxLib.Rate deriving (Eq)+instance C Measure where unpack (Measure rate) = rate+++ratio :: (C rate0, C rate1) => rate0 -> rate1 -> SoxLib.Rate+ratio r0 r1 = unpack r0 / unpack r1++featureFromSample :: Sample -> Feature+featureFromSample (Sample rate) = Feature rate
+ src/Signal.hs view
@@ -0,0 +1,73 @@+module Signal where++import qualified Rate++import qualified LabelChain+import qualified Sound.Audacity.LabelTrack as LabelTrack++import qualified Synthesizer.Generic.Cut as CutG+import qualified Data.StorableVector.Lazy as SVL++import Control.DeepSeq (NFData, rnf, )++import Data.Traversable (Traversable, traverse)+import Data.Foldable (Foldable, foldMap)++import Data.Int (Int32, )+++data T rate body =+   Cons {+      sampleRate :: rate,+      body :: body+   }++type LabelTrack rate a = T rate (LabelTrack.T Int a)+type LabelChain rate a = T rate (LabelChain.T Int a)++type Sampled a = T Rate.Sample (SVL.Vector a)+type Sox = Sampled Int32+type SoxLabelled a = T Rate.Sample (SVL.Vector Int32, LabelChain.T Int a)+++instance (Rate.C rate, NFData body) => NFData (T rate body) where+   rnf (Cons rate xs) = rnf (Rate.unpack rate, xs)++instance Functor (T rate) where+   fmap f (Cons rate xs) = Cons rate $ f xs++instance Foldable (T rate) where+   foldMap f (Cons _rate xs) = f xs++instance Traversable (T rate) where+   traverse f (Cons rate xs) = fmap (Cons rate) $ f xs+++-- | more descriptive than 'fmap'+map :: (a -> b) -> T rate a -> T rate b+map = fmap++duration :: (Rate.C rate, CutG.Read signal) => T rate signal -> Double+duration (Cons rate xs) =+   fromIntegral (CutG.length xs) / Rate.unpack rate++labelRealTimes ::+   (Rate.C rate) => LabelChain rate a -> LabelChain.T Double a+labelRealTimes (Cons rate xs) = LabelChain.realTimes rate xs++labelDiscretizeTimes ::+   (Rate.C rate) =>+   rate -> LabelChain.T Double a -> LabelChain rate a+labelDiscretizeTimes rate =+   Cons rate . LabelChain.mapTime (round . (Rate.unpack rate *))++labelResample ::+   (Rate.C rate0, Rate.C rate1) =>+   rate1 -> LabelChain rate0 a -> LabelChain rate1 a+labelResample rate = labelDiscretizeTimes rate . labelRealTimes++addDiscretizedLabels ::+   (Rate.C rate) =>+   T rate a -> LabelChain.T Double b -> T rate (a, LabelChain.T Int b)+addDiscretizedLabels (Cons rate as) bs =+   Cons rate (as, body $ labelDiscretizeTimes rate bs)
+ src/SignalProcessing.hs view
@@ -0,0 +1,303 @@+module SignalProcessing where++import qualified Rate+import Parameters (Freq, freq, )++import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilt+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1+import qualified Synthesizer.Plain.Filter.Recursive as FiltRec+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Generic.Analysis as Ana+import qualified Synthesizer.Generic.Cut as Cut+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.State.Signal as SigS++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import Foreign.Storable (Storable, )++import qualified Control.Category as Cat+import Control.Arrow (Arrow, (^<<), (<<<), (&&&))+import Control.DeepSeq (NFData, ($!!))++import qualified Data.NonEmpty as NonEmpty+import qualified Data.Foldable as Fold+import qualified Data.List.Match as Match+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Traversable (Traversable, mapAccumL)+import Data.Foldable (Foldable, )+import Data.Maybe.HT (toMaybe, )+import Data.Tuple.HT (swap, )++import qualified Algebra.RealRing as Real+import qualified Algebra.Field as Field+import qualified Algebra.Additive as Additive+import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()++++{-# INLINE zerothMoment #-}+zerothMoment :: Causal.T Float Float+zerothMoment =+   Causal.consInit 0++{-# INLINE firstMoment #-}+firstMoment :: Causal.T Float Float+firstMoment =+   (\(x0,_x1,x2) -> (x2-x0)/2) ^<< lag2++{-# INLINE secondMoment #-}+secondMoment :: Causal.T Float Float+secondMoment =+   (\(x0,x1,x2) -> x2-2*x1+x0) ^<< lag2++{-# INLINE lag2 #-}+lag2 :: (Additive.C a) => Causal.T a (a,a,a)+lag2 = lag2Init zero++{-# INLINE lag2Init #-}+lag2Init :: a -> Causal.T a (a,a,a)+lag2Init x =+   (\((x0,x1),x2) -> (x0,x1,x2))+   ^<<+   (Causal.consInit x &&& Cat.id <<< Causal.consInit x) &&& Cat.id+++{-# INLINE bandpass #-}+bandpass :: (Rate.C rate) => rate -> Float -> Freq -> Causal.T Float Float+bandpass rate q f =+   UniFilt.bandpass+   ^<<+   UniFilt.causal+   <<<+   Causal.feedConstFst (UniFilt.parameter (FiltRec.Pole q (freq rate f)))++{-# INLINE highpass #-}+highpass :: (Rate.C rate) => rate -> Float -> Freq -> Causal.T Float Float+highpass rate q f =+   UniFilt.highpass+   ^<<+   UniFilt.causal+   <<<+   Causal.feedConstFst (UniFilt.parameter (FiltRec.Pole q (freq rate f)))++{-# INLINE lowpass #-}+lowpass :: (Rate.C rate) => rate -> Float -> Freq -> Causal.T Float Float+lowpass rate q f =+   UniFilt.lowpass+   ^<<+   UniFilt.causal+   <<<+   Causal.feedConstFst (UniFilt.parameter (FiltRec.Pole q (freq rate f)))+++twoPasses ::+   (Storable a) =>+   (SVL.Vector a -> SVL.Vector a) -> SVL.Vector a -> SVL.Vector a+twoPasses f  =  SVL.reverse . f . SVL.reverse . f++lowpassOnePass ::+   (Rate.C rate) => rate -> Freq -> SVL.Vector Float -> SVL.Vector Float+lowpassOnePass rate f sig =+   let fr = freq rate f+   in  Causal.apply+          (Filt1.lowpass_+           ^<<+           Filt1.causalInit+              (Ana.average $ Cut.take (ceiling (1/fr)) $ SigG.toState sig)+           <<<+           Causal.feedConstFst (Filt1.parameter fr))+          sig++lowpassTwoPass ::+   (Rate.C rate) => rate -> Freq -> SVL.Vector Float -> SVL.Vector Float+lowpassTwoPass rate f = twoPasses (lowpassOnePass rate f)++++-- ToDo: move to synthesizer-core:Causal.Filter+{-# INLINE differentiate #-}+differentiate :: Causal.T Float Float+differentiate =+   Cat.id - Causal.consInit zero++{-# INLINE differentiateMin3 #-}+differentiateMin3 :: Causal.T Float Float+differentiateMin3 = differentiateMin3Init zero++{-# INLINE differentiateMin3Init #-}+differentiateMin3Init :: Float -> Causal.T Float Float+differentiateMin3Init x =+   Cat.id+   -+   ((\(x0,x1,x2) -> x0 `min` x1 `min` x2) ^<< lag2Init x+      <<< Causal.consInit x)++{- |+This one produces narrow pikes for the click beginnings.+However this turns out to make the click recognition worse.+-}+differentiateMin3Narrow :: Causal.T Float Float+differentiateMin3Narrow =+   (\(x, (x0,x1,x2)) ->+       let xmin = x0 `min` x1 `min` x2+           xmax = x0 `max` x1 `max` x2+       in  if x>xmax then x-xmin else x-x2) ^<<+      Cat.id &&& (lag2 <<< Causal.consInit zero)+++downSampleMax :: Int -> SVL.Vector Float -> SVL.Vector Float+downSampleMax k =+   SigG.fromState SigG.defaultLazySize .+   fmap SVL.maximum . Cut.sliceVertical k+++downSampleChunkSizes ::+   (Field.C t, Real.C t) =>+   t -> SigS.T Int+downSampleChunkSizes sizeFrac =+   SigS.unfoldR+      (\sizeRem -> Just $ splitFraction $ sizeRem + sizeFrac)+      zero+++{-+ToDo: move to synthesizer-core+could be generalized to Causal arrows+sometimes reversed parameter seems to be more appropriate+-}+chop :: (Traversable f, Cut.Transform sig) => sig -> f Int -> f sig+chop xs  =  snd . mapAccumL (\xsr d -> swap $ Cut.splitAt d xsr) xs+++chopFrac :: Double -> SVL.Vector Float -> SigS.T (SVL.Vector Float)+chopFrac sizeFrac xs =+   SigG.crochetL (\n xi -> toMaybe (not $ SVL.null xi) $ SVL.splitAt n xi) xs $+   downSampleChunkSizes sizeFrac++{- |+It must be @sizeFrac >= 1@.+-}+downSampleMaxFrac :: Double -> SVL.Vector Float -> SVL.Vector Float+downSampleMaxFrac sizeFrac =+   SigG.fromState SigG.defaultLazySize . fmap SVL.maximum .+   chopFrac sizeFrac++downSampleMaxAbsFrac :: Double -> SVL.Vector Float -> SVL.Vector Float+downSampleMaxAbsFrac sizeFrac =+   SigG.fromState SigG.defaultLazySize . fmap Ana.volumeMaximum .+   chopFrac sizeFrac++downSampleAvgFrac :: Double -> SVL.Vector Float -> SVL.Vector Float+downSampleAvgFrac sizeFrac =+   SigG.fromState SigG.defaultLazySize . fmap Ana.average .+   chopFrac sizeFrac++++takeSlices :: (Cut.Transform sig) => Int -> sig -> [sig] -> [sig]+takeSlices blockSize xs =+   Match.take (SigS.toList $ Cut.sliceVertical blockSize xs)++-- ToDo: move to synthesizer-core+sliceOverlappingAbs, sliceOverlappingDiff, sliceOverlappingRel,+   sliceOverlapping :: (Cut.Transform sig) => Int -> (Int,Int) -> sig -> [sig]++sliceOverlappingAbs blockSize (pre,suf) xs =+   takeSlices blockSize xs $+   map+      (\t ->+         let start = max 0 $ t-pre+             stop = t+blockSize+suf+         in  Cut.take (stop-start) $ Cut.drop start xs) $+   iterate (blockSize+) 0++sliceOverlappingDiff blockSize (pre,suf) xs =+   let offsets = iterate (blockSize+) (-pre)+   in  takeSlices blockSize xs $+       zipWith (\offset -> Cut.take (blockSize+pre+suf+min 0 offset)) offsets $+       snd $ List.mapAccumL (\xsi k -> (Cut.drop k xsi, xsi)) xs $+       ListHT.mapAdjacent subtract $ map (max 0) offsets++sliceOverlappingRel blockSize (pre,suf) xs =+   let offsets = iterate (min 0 . (blockSize+)) (-pre)+   in  takeSlices blockSize xs $+       zipWith (\offset -> Cut.take (blockSize+pre+suf+offset)) offsets $ snd $+       List.mapAccumL+          (\xsi offset -> (Cut.drop (max 0 $ offset+blockSize) xsi, xsi))+          xs offsets++sliceOverlapping = sliceOverlappingRel++propSliceOverlapping :: NonEmpty.T [] Int -> ([Int], [Int]) -> String -> Bool+propSliceOverlapping blockSizeList (preList,sufList) xs =+   let blockSize = length $ NonEmpty.flatten blockSizeList+       pre = length preList+       suf = length sufList+   in  ListHT.allEqual $+          sliceOverlappingAbs blockSize (pre,suf) xs :+          sliceOverlappingDiff blockSize (pre,suf) xs :+          sliceOverlappingRel blockSize (pre,suf) xs :+          []+++centroidVariance3 ::+   Field.C a => (a, a) -> (a, a) -> (a, a) -> (a, a)+centroidVariance3 (f0,x0) (f1,x1) (f2,x2) =+   let s = x0+x1+x2+       mean y0 y1 y2 = (y0*x0 + y1*x1 + y2*x2) / s+       center = mean f0 f1 f2+   in  (center, mean ((f0-center)^2) ((f1-center)^2) ((f2-center)^2))+++svlConcat :: SVL.Vector Float -> SV.Vector Float+svlConcat = SV.concat . SVL.chunks+++foldLength :: (Foldable f) => f a -> Int+foldLength = length . Fold.toList+++{-+ToDo: move to utility-ht?+could be the basis of a Synthesizer.State.argmax function+it is now included in 'semigroups' but with swapped order+better maxKey :: (Ord b) => (a -> b) -> a -> a -> a ?+-}+argMax :: (Ord b) => (a,b) -> (a,b) -> (a,b)+argMax x0 x1 =+   if snd x0 >= snd x1 then x0 else x1++argMin :: (Ord b) => (a,b) -> (a,b) -> (a,b)+argMin x0 x1 =+   if snd x0 <= snd x1 then x0 else x1++-- ToDo: move to synthesizer-core+argMaximum ::+   (NFData a, Ord a, Additive.C a, SigG.Read sig a) => sig a -> (Int, a)+argMaximum =+   SigS.foldL (\x y -> (argMax $!! x) y) (0,zero) .+   SigS.zip (SigS.iterate (1+) 0) . SigG.toState++++{-# INLINE fanout3 #-}+fanout3 ::+   (Arrow arrow) =>+   arrow a b -> arrow a c -> arrow a d -> arrow a (b,c,d)+fanout3 arrb arrc arrd =+   (\(b,(c,d)) -> (b,c,d)) ^<< arrb &&& arrc &&& arrd++++chirpingPauseDur :: SVL.Vector Float -> Int+chirpingPauseDur xs =+   let x = Ana.average xs+   in  SVL.length $ SVL.takeWhile (<=x) $ SVL.reverse xs++chirpingMainDur :: SVL.Vector Float -> Int+chirpingMainDur xs =+   SVL.length xs - chirpingPauseDur xs
+ src/SignalProcessingMethods.hs view
@@ -0,0 +1,43 @@+module SignalProcessingMethods where++import qualified SpectralDistribution as SD+import qualified Signal+import qualified Rate+import SignalProcessing (lowpassTwoPass, )+import Parameters (Freq(Freq), )++import qualified Sound.SoxLib as SoxLib+import qualified Data.StorableVector.Lazy as SVL+++type Triple a = (a,a,a)++data T =+   Cons {+      dehum :: Signal.Sox -> Signal.Sampled Float,+      rumble :: Signal.Sox -> Signal.Sampled Float,+      downSampleAbs ::+         SoxLib.Rate -> Signal.Sampled Float -> SVL.Vector Float,+      bandpassDownSample ::+         Rate.Feature -> Freq -> Signal.Sox -> SVL.Vector Float,+      bandParameters ::+         Triple Freq -> Signal.Sampled Float ->+         [Int] -> [((Float, Float), SD.T Float)]+   }++envelopeLowRate ::+   (Rate.C rate) =>+   T -> rate -> Signal.Sampled Float ->+   (SVL.Vector Float, SVL.Vector Float)+envelopeLowRate methods featRate sig =+   let env = downSampleAbs methods (Rate.unpack featRate) sig+       volume = lowpassTwoPass featRate (Freq 20) env+   in  (volume, SVL.zipWith (/) env volume)++dehummedEnvelopeLowRate ::+   (Rate.C rate) =>+   T -> rate -> Signal.Sox -> (SVL.Vector Float, SVL.Vector Float)+dehummedEnvelopeLowRate methods featRate sig =+   let env = downSampleAbs methods (Rate.unpack featRate) $ dehum methods sig+       volume = lowpassTwoPass featRate (Freq 20) env+   in  (volume, SVL.zipWith (/) env volume)
+ src/SignalProcessingSpecific.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE RebindableSyntax #-}+module SignalProcessingSpecific where++import qualified Signal+import qualified Named+import qualified Rate+import Parameters (Freq(Freq), formatFreq, )++import qualified SpectralDistribution as SD+import qualified SignalProcessingMethods as Methods+import qualified SignalProcessing as SP+import SignalProcessingMethods (Triple, )+import SignalProcessing+          (bandpass, highpass, lowpassTwoPass,+           downSampleMaxFrac, downSampleMaxAbsFrac, fanout3, )++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 Data.StorableVector as SV++import qualified Data.List as List+import Control.Arrow ((&&&), (^<<), (<<^), )+import Data.Tuple.HT (mapSnd, fst3, snd3, thd3, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++{-# INLINE dehum #-}+dehum :: Rate.Sample -> Causal.T Float Float+dehum rate = highpass rate 1 (Freq 800)+++filterBand :: Float -> Freq -> Signal.Sox -> Named.Signal+filterBand q f (Signal.Cons rate sig) =+   Named.Cons ("band " ++ formatFreq f) $+   Causal.apply (abs ^<< bandpass rate q f <<^ Bin.toCanonical) sig++{-+We have checked with a chirp that the bands slightly overlap.+-}+filterBands ::+   Signal.Sox -> (Named.Signal, (Named.Signal, Named.Signal, Named.Signal))+filterBands sig =+   ((filterBand 2 (Freq 1600) sig) {Named.name = "dehummed"},+    (filterBand 10 (Freq 1200) sig,+     filterBand 10 (Freq 2000) sig,+     filterBand 10 (Freq 4000) sig))++bandEnvelopes ::+   Signal.Sox -> (Named.Signal, (Named.Signal, Named.Signal, Named.Signal))+bandEnvelopes sig@(Signal.Cons rate _) =+   let (broadband, (band12, band20, band40)) = filterBands sig+       volume = lowpassTwoPass rate (Freq 20) $ Named.body broadband+       envelope xs = SVL.zipWith (/) (lowpassTwoPass rate (Freq 200) xs) volume+   in  (Named.Cons "volume" volume,+        (fmap envelope band12, fmap envelope band20, fmap envelope band40))+++bandEnvelopesLowRate ::+   Rate.Feature -> Signal.Sox ->+   (Named.Signal, (Named.Signal, Named.Signal, Named.Signal))+bandEnvelopesLowRate featRate sig =+   let (broadband, (band12, band20, band40)) = filterBands sig+       -- ToDo: would be simpler, if broadband contains the sample rate+       k = Rate.ratio (Signal.sampleRate sig) featRate+       volume =+          lowpassTwoPass featRate (Freq 20) $+          downSampleMaxFrac k $ Named.body broadband+       envelope xs = SVL.zipWith (/) (downSampleMaxFrac k xs) volume+   in  (Named.Cons "volume" volume,+        (fmap envelope band12, fmap envelope band20, fmap envelope band40))+++{-# INLINE bandsDerivatives #-}+bandsDerivatives ::+   Triple Freq -> Signal.Sampled Float ->+   SVL.Vector (Triple Float, Triple Float)+bandsDerivatives bandFreqs (Signal.Cons rate sig) =+   Causal.apply+      (let band f = bandpass rate 10 (f bandFreqs)+       in  fanout3 (band fst3) (band snd3) (band thd3)+       &&&+       fanout3 SP.zerothMoment SP.firstMoment SP.secondMoment)+      sig+++spectralDistribution1Slow, spectralDistribution2Slow ::+   SVL.Vector (Triple Float) -> SD.T Float+spectralDistribution1Slow chunk =+   let partSum sel = SigG.sum $ SigG.map (abs.sel) $ SigG.toState chunk+   in  SD.spectralDistribution1+          (partSum fst3) (partSum snd3) (partSum thd3)++spectralDistribution2Slow chunk =+   let partSum sel = SigG.sum $ SigG.map ((^2).sel) $ SigG.toState chunk+   in  SD.spectralDistribution2+          (partSum fst3) (partSum snd3) (partSum thd3)+++sumSV :: SV.Vector Float -> Float+sumSV = SV.foldl' (+) 0++_sumSVL :: SVL.Vector Float -> Float+_sumSVL = sum . map sumSV . SVL.chunks+++addSumSV :: Float -> SV.Vector Float -> Float+addSumSV = SV.foldl' (+)++{- |+Consistently sum with left associativity.+This is consistent with the LLVM implementation.+-}+sumSVL :: SVL.Vector Float -> Float+sumSVL = List.foldl' addSumSV 0 . SVL.chunks+++spectralDistribution1, spectralDistribution2 ::+   SVL.Vector (Triple Float) -> SD.T Float+spectralDistribution1 chunk =+   SD.spectralDistribution1+      (sumSVL $ SVL.map (abs.fst3) chunk)+      (sumSVL $ SVL.map (abs.snd3) chunk)+      (sumSVL $ SVL.map (abs.thd3) chunk)++spectralDistribution2 chunk =+   SD.spectralDistribution2+      (sumSVL $ SVL.map ((^2).fst3) chunk)+      (sumSVL $ SVL.map ((^2).snd3) chunk)+      (sumSVL $ SVL.map ((^2).thd3) chunk)+++spectralBandDistr :: Triple Freq -> SVL.Vector (Triple Float) -> (Float, Float)+spectralBandDistr (Freq bandFreq0, Freq bandFreq1, Freq bandFreq2) chunk =+   mapSnd sqrt $+   SP.centroidVariance3+      (bandFreq0, sumSVL $ SVL.map (abs.fst3) chunk)+      (bandFreq1, sumSVL $ SVL.map (abs.snd3) chunk)+      (bandFreq2, sumSVL $ SVL.map (abs.thd3) chunk)++bandParameters ::+   Triple Freq -> SVL.Vector (Triple Float, Triple Float) ->+   ((Float, Float), SD.T Float)+bandParameters bandFreqs chunk =+   (spectralBandDistr bandFreqs (SVL.map fst chunk),+    spectralDistribution1 (SVL.map snd chunk))+++methods :: Methods.T+methods =+   Methods.Cons {+      Methods.dehum =+         \(Signal.Cons rate xs) ->+            Signal.Cons rate $ Causal.apply (dehum rate <<^ Bin.toCanonical) xs,++      Methods.rumble =+         \(Signal.Cons rate xs) ->+            Signal.Cons rate $+            Causal.apply (SP.lowpass rate 5 (Freq 220) <<^ Bin.toCanonical) xs,++      Methods.downSampleAbs =+         \featRate (Signal.Cons rate xs) ->+            downSampleMaxAbsFrac (Rate.unpack rate / featRate) xs,++      Methods.bandpassDownSample =+         \featRate f (Signal.Cons rate xs) ->+            downSampleMaxAbsFrac (Rate.ratio rate featRate) $+            Causal.apply (bandpass rate 10 f <<^ Bin.toCanonical) xs,++      Methods.bandParameters =+         \bandFreqs sig sizes ->+            map (bandParameters bandFreqs) $+            SP.chop (bandsDerivatives bandFreqs sig) sizes+   }
+ src/Sox.hs view
@@ -0,0 +1,110 @@+module Sox where++import qualified Named+import qualified Parameters as Params+import qualified Signal+import qualified Rate++import qualified Option++import qualified Synthesizer.Basic.Binary as Bin+import qualified Sound.SoxLib as SoxLib++import qualified Data.StorableVector.Lazy as SVL+import Foreign.Storable (peek)++import Control.Monad (when)+import Control.Applicative ((<$>))++import qualified Data.List as List+import Data.Maybe (fromMaybe)++import qualified System.Path.PartClass as PathClass+import qualified System.Path.IO as PathIO+import qualified System.Path as Path+import Text.Printf (printf)++import qualified Algebra.RealRing as Real++import Data.Int (Int32)+++withSound ::+   (PathClass.AbsRel ar) =>+   Option.Flags -> Path.FilePath ar ->+   (SoxLib.Format SoxLib.ReadMode -> Signal.Sox -> IO b) ->+   IO b+withSound flags path act =+   SoxLib.withRead SoxLib.defaultReaderInfo (Path.toString path) $ \fmtPtr -> do+      fmt <- peek fmtPtr+      let numChan = fromMaybe 1 $ SoxLib.channels $ SoxLib.signalInfo fmt+          rate =+            case Option.sampleRate flags of+               Just r -> Rate.Sample r+               Nothing ->+                  case SoxLib.rate $ SoxLib.signalInfo fmt of+                     Just r -> Rate.Sample r+                     Nothing -> Params.sampleRate Params.deflt+      when (numChan/=1) $+         ioError $ userError $+         printf "expected mono file but got %d channels" numChan+      act fmt . Signal.Cons rate =<<+         SoxLib.readStorableVectorLazy fmtPtr+            (case Option.chunkSize flags of+               SVL.ChunkSize size -> SVL.ChunkSize $ numChan * size)+++multiInfoFromFormat ::+   (Rate.C rate) => Int -> SoxLib.Format mode -> rate -> SoxLib.WriterInfo+multiInfoFromFormat numChannels fmtIn rate =+   SoxLib.defaultWriterInfo {+      SoxLib.writerSignalInfo = Just $+         (SoxLib.signalInfo fmtIn) {+            SoxLib.channels = Just numChannels,+            SoxLib.length =+               (numChannels *) <$> SoxLib.length (SoxLib.signalInfo fmtIn),+            SoxLib.rate = Just $ Rate.unpack rate+         }+   }++writerInfoFromFormat ::+   (Rate.C rate) => SoxLib.Format mode -> rate -> SoxLib.WriterInfo+writerInfoFromFormat fmtIn rate =+   SoxLib.defaultWriterInfo {+      SoxLib.writerSignalInfo = Just $+         (SoxLib.signalInfo fmtIn) {+            SoxLib.rate = Just $ Rate.unpack rate+         }+   }+++writeChannels ::+   (Rate.C rate, PathClass.AbsRel ar) =>+   SoxLib.Format mode -> rate -> Path.FilePath ar ->+   [SVL.Vector Int32] -> IO ()+writeChannels fmtIn rate output sigs =+   SoxLib.withWrite (multiInfoFromFormat (length sigs) fmtIn rate)+      (Path.toString output) $ \fmtOut ->+         SoxLib.writeStorableVectorLazy fmtOut $+         SVL.interleaveFirstPattern sigs++writeFeatures ::+   (Rate.C rate, PathClass.AbsRel ar) =>+   SoxLib.Format mode -> Path.FilePath ar ->+   [Float] -> Signal.T rate [Named.Signal] -> IO ()+writeFeatures fmtIn output scales (Signal.Cons rate featSigs) =+   writeChannels fmtIn rate output $+   zipWith+      (\c ->+         SVL.map (Bin.fromCanonicalWith Real.roundSimple . (c*)) . Named.body)+      scales featSigs++_writeFeatures ::+   (Rate.C rate, PathClass.AbsRel ar) =>+   SoxLib.Format mode -> Path.FilePath ar ->+   [Float] -> Signal.T rate [Named.Signal] -> IO ()+_writeFeatures _fmtIn output _scales (Signal.Cons rate featSigs) =+   PathIO.writeFile (Path.replaceExtension output "dat") $ unlines $+      show (Rate.unpack rate) :+      (map (unwords . map show) $ List.transpose $+       map (SVL.unpack . Named.body) featSigs)
+ src/SpectralDistribution.hs view
@@ -0,0 +1,68 @@+module SpectralDistribution where++import Control.Applicative (Applicative, liftA2, pure, (<*>), )+import Control.DeepSeq (NFData, rnf, )++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold++import Foreign.Storable.Record as Store+import Foreign.Storable (Storable (..), )++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++data T a = Cons {centroid, spread :: a}+   deriving (Eq, Show)++instance (NFData a) => NFData (T a) where+   rnf (Cons c s) = rnf (c,s)++instance Functor T where+   fmap = Trav.fmapDefault++instance Applicative T where+   pure x = Cons x x+   Cons fc fs <*> Cons c s = Cons (fc c) (fs s)++instance Fold.Foldable T where+   foldMap = Trav.foldMapDefault++instance Trav.Traversable T where+   traverse f (Cons c s) = liftA2 Cons (f c) (f s)+++store :: Storable a => Store.Dictionary (T a)+store =+   Store.run $+   liftA2 Cons+      (Store.element centroid)+      (Store.element spread)++instance Storable a => Storable (T a) where+   sizeOf = Store.sizeOf store+   alignment = Store.alignment store+   peek = Store.peek store+   poke = Store.poke store+++mapSpread :: (a -> a) -> T a -> T a+mapSpread f (Cons c s) = Cons c (f s)+++{-# INLINE spectralDistribution1 #-}+spectralDistribution1 :: Float -> Float -> Float -> T Float+spectralDistribution1 d0 d1 d2 =+   let r1 = d1/d0 in Cons r1 (d2/d0 - r1^2)+++{-# INLINE signedSqrt #-}+signedSqrt :: Float -> Float+signedSqrt x = signum x * sqrt (abs x)++{-# INLINE spectralDistribution2 #-}+spectralDistribution2 :: Float -> Float -> Float -> T Float+spectralDistribution2 d0 d1 d2 =+   let r1 = d1/d0 in Cons (sqrt r1) (signedSqrt (d2/d0 - r1^2))
+ src/SpectralDistributionTest.hs view
@@ -0,0 +1,179 @@+module Main where++import qualified SpectralDistribution as SD+import qualified SignalProcessing as SP++import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilt+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1+import qualified Synthesizer.Plain.Filter.Recursive as FiltRec+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.State.Filter.NonRecursive as FiltNR+import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.State.Oscillator as Osci+import qualified Synthesizer.State.Displacement as Disp+import qualified Synthesizer.State.Control as Ctrl+import qualified Synthesizer.State.Noise as Noise+import qualified Synthesizer.Causal.Process as Causal++import Synthesizer.Causal.Class (($<), ($*), )++import qualified Data.StorableVector.Lazy as SVL++import Control.Arrow ((&&&), (<<<), (^<<), (<<^), )+import Control.Monad (liftM2, )++import Data.Foldable (forM_, )++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++frequency :: Float+frequency = 0.01++duration :: Int+duration = 50000++toneEnvelope :: SigS.T Float+toneEnvelope =+   FiltNR.envelope (Ctrl.exponential 20000 1) $+   Osci.staticSine zero frequency++toneChirp :: SigS.T Float+toneChirp =+   Osci.freqModSine zero $+   Ctrl.exponential 10000 (0.1::Float)++{- |+@sqrt@ asserts that the spectral centroid stays constant.+This works, because our time-domain definition of spectral centroid+computes the quadratic mean of frequencies.+-}+toneBroaden :: SigS.T Float+toneBroaden =+   FiltNR.amplify 0.5 $+   Disp.mix+      (Osci.freqModSine zero $ fmap sqrt $+       Ctrl.line duration (0.01, 0.02::Float))+      (Osci.freqModSine zero $ fmap sqrt $+       Ctrl.line duration (0.01, 0::Float))+++toneMix :: Float -> Float -> SigS.T Float+toneMix freq0 freq1 =+   FiltNR.amplify 0.5 $+   Disp.mix+      (Osci.staticSine zero freq0)+      (Osci.staticSine zero freq1)++++noiseEnvelope :: SigS.T Float+noiseEnvelope =+   FiltNR.envelope (Ctrl.exponential 20000 1) Noise.white++noiseChirp :: SigS.T Float+noiseChirp =+   (UniFilt.bandpass ^<< UniFilt.causal)+    $< SigS.map+          (UniFilt.parameter . FiltRec.Pole 10)+          (Ctrl.exponential 10000 (0.1::Float))+    $* Noise.white++noiseBroaden :: SigS.T Float+noiseBroaden =+   (UniFilt.bandpass ^<< UniFilt.causal)+    $< SigS.map+          (UniFilt.parameter . flip FiltRec.Pole frequency)+          (Ctrl.exponential 10000 (100::Float))+    $* FiltNR.amplify 0.5 Noise.white++++smooth :: Causal.T Float Float+smooth =+   Filt1.lowpass_+   ^<<+   Filt1.causal+   <<<+   Causal.feedConstFst (Filt1.parameter (0.0002::Float))+++volume :: SigS.T Float -> Float+volume  =  SigS.sum . SigS.map abs++followEnvelope :: Causal.T Float Float+followEnvelope  =  smooth <<^ abs++spectralDistribution1 :: Causal.T Float (SD.T Float)+spectralDistribution1 =+   (\(d0,(d1,d2)) ->+      SD.mapSpread SD.signedSqrt $ SD.spectralDistribution1 d0 d1 d2)+   ^<<+   (followEnvelope <<< SP.zerothMoment) &&&+   (followEnvelope <<< SP.firstMoment) &&&+   (followEnvelope <<< SP.secondMoment)+++volumeSquare :: SigS.T Float -> Float+volumeSquare  =  SigS.sum . SigS.map (^2)++meanSquare :: Causal.T Float Float+meanSquare  =  smooth <<^ (^2)++spectralDistribution2 :: Causal.T Float (SD.T Float)+spectralDistribution2 =+   (\(d0,(d1,d2)) ->+      SD.mapSpread SD.signedSqrt $ SD.spectralDistribution2 d0 d1 d2)+   ^<<+   (meanSquare <<< SP.zerothMoment) &&&+   (meanSquare <<< SP.firstMoment) &&&+   (meanSquare <<< SP.secondMoment)+++main :: IO ()+main = do+   forM_ [(0.01, 0.01), (0.01, 0.01*sqrt 2), (0.01, 0.02), (0.01, 0.04)] $+         \(freq0,freq1) ->+      let sig = SigS.take 100000 $ toneMix freq0 freq1+          d0 = volume $ Causal.apply SP.zerothMoment sig+          d1 = volume $ Causal.apply SP.firstMoment  sig+          d2 = volume $ Causal.apply SP.secondMoment sig+          (SD.Cons centroid1 spread1) = SD.spectralDistribution1 d0 d1 d2+          s0 = volumeSquare $ Causal.apply SP.zerothMoment sig+          s1 = volumeSquare $ Causal.apply SP.firstMoment  sig+          s2 = volumeSquare $ Causal.apply SP.secondMoment sig+          (SD.Cons centroid2 spread2) = SD.spectralDistribution2 s0 s1 s2+          r1 = s1/s0+      in  do+          putStrLn $ "\nfreqs: " ++ show (freq0,freq1)+          print (s0, s1, s2, s1/s0, s2/s1)+          print (s2/s0, r1^2, s2/s0-r1^2)+          print+             (sqrt ((freq0^2+freq1^2)/2),+              (centroid1 / (2*pi), sqrt spread1 / (2*pi)),+              (centroid2 / (2*pi), sqrt spread2 / (2*pi)))++   let signals =+          ("tone-env", toneEnvelope) :+          ("tone-chirp", toneChirp) :+          ("tone-broaden", toneBroaden) :+          ("noise-env", noiseEnvelope) :+          ("noise-chirp", noiseChirp) :+          ("noise-broaden", noiseBroaden) :+          []+       write process filename =+          SVL.writeFile filename .+          SigG.fromState SigG.defaultLazySize . SigS.take duration . process+       renderers =+          ("", write id) :+          ("-distribution1", write $ Causal.apply spectralDistribution1) :+          ("-distribution2", write $ Causal.apply spectralDistribution2) :+          []++   sequence_ $+      liftM2+         (\(featureName,render) (signalName,signal) ->+            render ("/tmp/" ++ signalName ++ featureName ++ ".f32") signal)+         renderers signals
+ src/Spreadsheet/Format.hs view
@@ -0,0 +1,1153 @@+{-# LANGUAGE RebindableSyntax #-}+module Spreadsheet.Format (+   Results,+   Measurements,+   AllPaths,+   TableFormats(..),++   Flags(..), defaultFlags,+   RecordingFlags(..),++   writeOverviewHead,+   writeOverviewFoot,+   appendOverview,+   appendTreatmentOverview,+   formatTables,++   -- * utility+   (<->),+   ) where++import qualified LabelTrack+import qualified LabelChain+import qualified Durations as Durs+import qualified ClassRecord+import qualified Class+import qualified Time+import qualified SpectralDistribution as SD+import qualified Signal+import qualified Rate+import Measurement+         (SpectralParameters(SpectralParameters, spectralFlatness),+          ClassFeatures, )++import qualified Spreadsheet.Formula as CalcForm+import qualified Spreadsheet.Palisade as Palisade+import qualified Spreadsheet.Row as CalcRow+import qualified Text.CSV.Lazy.String as CSV+import Spreadsheet.Row (FieldTracked, Precision(Prec0, Prec3, Prec6))++import qualified Data.Text as Text+import Data.Text (Text, )++import qualified Control.Monad.Trans.Writer as MW+import Control.DeepSeq (NFData, rnf, force, )+import Control.Monad (void, liftM2, liftM3, when, )+import Control.Applicative (Applicative, liftA2, liftA3, pure, (<*>), )+import Data.Biapplicative (bipure, (<<*>>), )++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.NonEmpty as NonEmpty+import qualified Data.List.Match as Match+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Monoid.HT as Mn+import qualified Data.Semigroup as Sg+import qualified Data.Char as Char+import Data.IORef (IORef, newIORef, readIORef, modifyIORef, )+import Data.Foldable (foldMap, fold, )+import Data.Monoid (Monoid, mempty, mappend, (<>), )+import Data.Tuple.HT (mapPair, mapSnd, fst3, snd3, thd3, )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (mapMaybe, )+import Data.Map (Map, )++import qualified System.FilePath.Find as Find+import qualified System.Path.PartClass as PathClass+import qualified System.Path.Directory as Dir+import qualified System.Path.IO as PathIO+import qualified System.Path as Path+import System.FilePath.Find ((~~?), (==?), (&&?), (||?), )+import System.Path ((</>), (<.>), )+import Text.Printf (printf, )++import qualified Algebra.RealRing as Real+import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import Algebra.ToRational (realToField)+import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude (Num)+++spectralParametersReal ::+   (Trans.C a) =>+   Formula a -> SpectralParameters Float ->+   SpectralParameters (Formula a)+spectralParametersReal+      rate (SpectralParameters flatness maxFreq (centroid,deviation) distr) =+   SpectralParameters+      (realToField flatness) (rate * realToField maxFreq)+      (realToField centroid, realToField deviation)+      (spectralDistributionReal rate distr)++spectralDistributionReal ::+   (Trans.C a) =>+   Formula a -> SD.T Float -> SD.T (Formula a)+spectralDistributionReal rate (SD.Cons centroid spread) =+   let angularRate = rate / (Ring.fromInteger 2 * CalcForm.pi)+   in  SD.Cons+          (realToField centroid * angularRate)+          (realToField (SD.signedSqrt spread) * angularRate)+++type Cell = CalcForm.CellTracked+type Formula = CalcForm.FormulaTracked+++palBounds ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (Cell a) a+palBounds =+   Palisade.colNoSum "Start/s"+   `Palisade.right`+   Palisade.colNoSum "Stop/s"+   `Palisade.right`+   Palisade.colSum Prec6 "Duration/s"++rowBounds ::+   (CalcRow.Fraction a) =>+   Formula a -> (Int,Int) -> CalcRow.M (Cell a)+rowBounds rate bounds = do+   start <- CalcRow.putFractionFormula Prec6 $ fromIntegral (fst bounds) / rate+   stop  <- CalcRow.putFractionFormula Prec6 $ fromIntegral (snd bounds) / rate+   CalcRow.putFraction Prec6 $ stop - start+++precSpectral :: SpectralParameters Precision+precSpectral = (pure Prec0) {spectralFlatness = Prec3}++palSpectral ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (SpectralParameters (Cell a)) (SpectralParameters a)+palSpectral =+   Palisade.Cons+      (map (flip (,) True) $ Fold.toList $+       SpectralParameters+          "WienerEntropy" "MaxFreq/Hz"+          ("BandCentroid/Hz", "BandDeviation/Hz")+          (SD.Cons "SpecCentroid/Hz" "SpecSpread/Hz"))+      (fold . liftA2 Palisade.summarySum5 precSpectral . Trav.sequenceA)+      (fmap CalcForm.trackedNumber)+      (fold . liftA2 Palisade.summary5String precSpectral . Trav.sequenceA)++rowSpectral ::+   (CalcRow.Fraction a) =>+   SpectralParameters (Formula a) ->+   CalcRow.M (SpectralParameters (Cell a))+rowSpectral =+   Trav.sequence . liftA2 CalcRow.putFraction precSpectral+++_palClickDur :: (CalcRow.Fraction a, Real.C a) => Palisade.T (Cell a) a+_palClickDur = Palisade.colSum5 Prec6 "ClickDur/s"++_rowClickDur ::+   (CalcRow.Fraction a) =>+   Formula a -> [LabelChain.ClickAbs Int] -> CalcRow.M (Cell a)+_rowClickDur rate clicks =+   CalcRow.putFraction Prec6 $+      fromIntegral (sum (map (\(LabelChain.ClickAbs t0 t1 _) -> t1-t0) clicks))+      /+      (rate * fromIntegral (length clicks))+++type Advertisement a = (BoundRasping a, Maybe (BoundChirping a))++type BoundAdvertisement a = (a, Advertisement a)++palBoundAdvertisement ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (BoundAdvertisement (Cell a)) (BoundAdvertisement a)+palBoundAdvertisement =+   Palisade.pair palBounds $+   Palisade.pair+      (Palisade.mapHeaders ("Slow " ++) $+       Palisade.pair (Palisade.colSum5 Prec6 "Dur/s") palRasping)+      (Palisade.maybe $+       Palisade.mapHeaders ("Fast " ++) $+       Palisade.pair (Palisade.colSum5 Prec6 "Dur/s") palChirping)++type Rasping a = ((a, a), (a, a, a), SpectralParameters a)++palRasping ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (Rasping (Cell a)) (Rasping a)+palRasping =+   Palisade.triple+      (Palisade.pair+         (Palisade.colSum Prec3 "NumClicks")+         (Palisade.colSum Prec3 "NumEmphasized"))+      (Palisade.triple+         (Palisade.colSum5 Prec3 "ClickRate/Hz")+         (Palisade.colSum5 Prec6 "ClickHalfLife/s")+         (Palisade.colSum5 Prec6 "ClickPause/s"))+      palSpectral++rowRasping ::+   (CalcRow.Fraction a) =>+   Formula a -> Formula a ->+   ((Int, Int, Int), SpectralParameters (Formula a)) ->+   CalcRow.M (Rasping (Cell a))+rowRasping rate dur+      ((numClicksInt, sumHalfLifes, numEmphasizedInt), spectralDistr) = do+   numClicksCell <- CalcRow.putInt numClicksInt+   let numClicks = CalcForm.trackedVar numClicksCell+   numEmphasized <- CalcRow.putInt numEmphasizedInt+   clickRate <- CalcRow.putFraction Prec3 $ numClicks / dur+   hlife <-+      CalcRow.putFraction Prec6 $+      fromIntegral sumHalfLifes / (numClicks * rate)+   clickPause <-+      CalcRow.putFraction Prec6 $ dur / numClicks - CalcForm.trackedVar hlife+   spectral <- rowSpectral spectralDistr+   return+      ((numClicksCell, numEmphasized),+       (clickRate, hlife, clickPause),+       spectral)++type BoundRasping a = (a, Rasping a)++palBoundRasping ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (BoundRasping (Cell a)) (BoundRasping a)+palBoundRasping = Palisade.pair palBounds palRasping+++type Chirping a = (a, SpectralParameters a)++palChirping ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (Chirping (Cell a)) (Chirping a)+palChirping =+   Palisade.pair (Palisade.colSum5 Prec6 "MainDur/s") palSpectral++rowChirping ::+   (CalcRow.Fraction a) =>+   Formula a ->+   (Int, SpectralParameters (Formula a)) ->+   CalcRow.M (Chirping (Cell a))+rowChirping rate (brk, spectralDistr) = do+   mainDur <- CalcRow.putFraction Prec6 $ fromIntegral brk / rate+   spectral <- rowSpectral spectralDistr+   return (mainDur, spectral)++rowNoChirping :: CalcRow.M ()+rowNoChirping =+   case palChirping ::+         Palisade.T (Chirping (Cell Double)) (Chirping Double) of+      Palisade.Cons tabHeadChirping _ _ _ ->+         sequence_ $ Match.replicate tabHeadChirping CalcRow.putEmpty++type BoundChirping a = (a, Chirping a)++palBoundChirping ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (BoundChirping (Cell a)) (BoundChirping a)+palBoundChirping = Palisade.pair palBounds palChirping+++type Ticking a = (a, a, SpectralParameters a)++palTicking ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (Ticking (Cell a)) (Ticking a)+palTicking =+   Palisade.triple+      (Palisade.colSum5 Prec3 "NumClicks")+      (Palisade.colSum Prec3 "ClickRate/Hz")+      palSpectral++rowTicking ::+   (CalcRow.Fraction a) =>+   Formula a ->+   (Int, SpectralParameters (Formula a)) ->+   CalcRow.M (Ticking (Cell a))+rowTicking dur (numClicksInt, spectralDistr) = do+   numClicks <- CalcRow.putInt numClicksInt+   clickRate <- CalcRow.putFraction Prec3 $ CalcForm.trackedVar numClicks / dur+   spectral <- rowSpectral spectralDistr+   return (numClicks, clickRate, spectral)++type BoundTicking a = (a, Ticking a)++palBoundTicking ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (BoundTicking (Cell a)) (BoundTicking a)+palBoundTicking = Palisade.pair palBounds palTicking+++type Growling a = Rasping a++palGrowling ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (Growling (Cell a)) (Growling a)+palGrowling = palRasping++rowGrowling ::+   (CalcRow.Fraction a) =>+   Formula a -> Formula a ->+   ((Int, Int, Int), SpectralParameters (Formula a)) ->+   CalcRow.M (Growling (Cell a))+rowGrowling = rowRasping++type BoundGrowling a = (a, Growling a)++palBoundGrowling ::+   (CalcRow.Fraction a, Real.C a) =>+   Palisade.T (BoundGrowling (Cell a)) (BoundGrowling a)+palBoundGrowling = Palisade.pair palBounds palGrowling+++data EvalType = Number | Formula+   deriving (Eq, Ord, Show, Enum)++typeName :: EvalType -> String+typeName typ =+   case typ of+      Formula -> "formula"+      Number -> "number"++typeSelect :: EvalType -> CalcForm.Tracked a a -> a+typeSelect typ =+   case typ of+      Formula -> CalcForm.trackedFormula+      Number -> CalcForm.trackedNumber+++infixl 7 <->++(<->) :: Path.File ar -> String -> Path.File ar+path <-> var = Path.mapFileName (++ "-" ++ var) path++formatTable ::+   (PathClass.AbsRel ar) =>+   Path.File ar -> EvalType -> String -> [[FieldTracked]] ->+   TableFormats (Path.File ar, Text)+formatTable outputStem typ cls content =+   liftA2 (,)+      (fmap+         (\ext -> outputStem <-> map Char.toLower cls <-> typeName typ <.> ext)+         formatExtensions)+      (fmap+         (\fmt ->+            Text.pack $+            formatOpen fmt cls ++ formatRows fmt typ content ++ formatClose fmt) $+       formats)+++formatMultiTable ::+   (PathClass.AbsRel ar) =>+   Path.File ar -> EvalType ->+   ClassRecord.T (String, [[FieldTracked]]) ->+   TableFormats (Path.File ar, Text)+formatMultiTable outputStem typ tables =+   liftA2 (,)+      (fmap (\ext -> outputStem <-> typeName typ <.> ext) formatExtensions)+      (fmap+         (\fmt ->+            Text.pack $+               formatFileOpen fmt +++               foldMap (uncurry (formatSheet fmt typ)) tables +++               formatFileClose fmt)+       formats)++renderTable2 ::+   Palisade.T a b -> [CalcRow.M a] -> ([[FieldTracked]], [b])+renderTable2 (Palisade.Cons tabHead aggregate select _) table =+   let (meass, content) = unzip $ zipWith CalcRow.run [1..] table+   in  ((map tableHead $ "Source" : map fst tabHead) :+        content +++        [] :+        List.transpose+          (map tableHead (Fold.toList Palisade.summary5Names ++ ["Sum"]) :+           flip map (aggregate meass)+             (\(sum5, sumRes) -> Fold.toList sum5 ++ [sumRes]))+        ,+        map select meass)+++data TableFormats a = TableFormats {tableCSV, tableHTML, tableXML2003 :: a}+type TablePaths ar = TableFormats (Maybe (Path.File ar))+data Resolutions a = Resolutions {resTreatment, resAnimal, resRecording :: a}+type ResPaths ar = Resolutions (TablePaths ar)+type ClassPaths ar = ClassRecord.T (ResPaths ar)+type DurPaths ar = ((TablePaths ar, TablePaths ar), IORef Int)+type AllPaths ar = (DurPaths ar, ClassPaths ar, (Path.Dir ar, String, String))+++instance Functor TableFormats where+   fmap = Trav.fmapDefault++instance Fold.Foldable TableFormats where+   foldMap = Trav.foldMapDefault++instance Trav.Traversable TableFormats where+   traverse f (TableFormats csv html xml2003) =+      liftA3 TableFormats (f csv) (f html) (f xml2003)++instance Applicative TableFormats where+   pure a = TableFormats a a a+   TableFormats fCSV fHTML fXML2003 <*> TableFormats xCSV xHTML xXML2003 =+      TableFormats (fCSV xCSV) (fHTML xHTML) (fXML2003 xXML2003)++formatExtensions :: TableFormats String+formatExtensions = TableFormats "csv" "html" "xml"+++instance Fold.Foldable Resolutions where+   foldMap f (Resolutions treatment animal recording) =+      f treatment <> f animal <> f recording+++tableHead :: String -> FieldTracked+tableHead content =+   (tableField content) {+      CalcRow.fieldHead = True+   }++tableSpanHead :: Int -> String -> FieldTracked+tableSpanHead colSpan content =+   (tableHead content) {+      CalcRow.fieldSpan = colSpan+   }++tableField :: String -> FieldTracked+tableField content =+   CalcRow.TableField {+      CalcRow.fieldType = CalcRow.TypeString,+      CalcRow.fieldQuoted = False,+      CalcRow.fieldAnchor = "",+      CalcRow.fieldHead = False,+      CalcRow.fieldSpan = 1,+      CalcRow.fieldPrecision = Nothing,+      CalcRow.fieldContent = CalcForm.untracked content+   }++tableFieldInt :: Int -> FieldTracked+tableFieldInt number =+   (tableField $ show number) {+      CalcRow.fieldType = CalcRow.TypeNumber+   }++tableFieldAnchor ::+   (PathClass.FileDir fd) =>+   Path.AbsDir -> Path.Rel fd -> FieldTracked+tableFieldAnchor path file =+   (tableField $ Path.toString file) {+      CalcRow.fieldAnchor = Path.toString $ path </> file+   }+++initFile ::+   (PathClass.AbsRel ar) =>+   Path.File ar -> String -> IO (Path.File ar)+initFile path str = do+   PathIO.writeFile path str+   return path++++data+   Format =+      Format {+         formatOpen :: String -> String,+         formatClose :: String,+         formatRows :: EvalType -> [[FieldTracked]] -> String,+         formatFileOpen :: String,+         formatFileClose :: String,+         formatSheet :: EvalType -> String -> [[FieldTracked]] -> String+      }++formats :: TableFormats Format+formats =+   TableFormats {+      tableCSV = formatCSV,+      tableHTML = formatHTML,+      tableXML2003 = formatXML2003+   }++formatCSV, formatHTML, formatXML2003 :: Format+formatCSV =+   Format {+      formatOpen = const "",+      formatClose = "",+      formatRows = formatCSVRows,+      formatFileOpen = "",+      formatFileClose = "",+      formatSheet = \typ name content ->+         (prettyCSVTable [[name]])+         +++         formatCSVRows typ content+         +++         (prettyCSVTable [[]])+   }++formatHTML =+   let fileOpenNamed name =+         "<html lang=en>" :+         printf "<head><title>%s</title></head>" name :+         "<body>" :+         []++       fileOpen =+         "<html lang=en>" :+         "<body>" :+         []++       tableOpen =+         "<table>" :+         []++       tableClose =+         "</table>" :+         []++       fileClose =+         "</body>" :+         "</html>" :+         []++   in  Format {+          formatOpen = \name -> unlines $ fileOpenNamed name ++ tableOpen,+          formatClose = unlines $ tableClose ++ fileClose,+          formatRows = (unlines .) . formatHTMLRows,+          formatFileOpen = unlines fileOpen,+          formatFileClose = unlines fileClose,+          formatSheet = \typ name content -> unlines $+             printf "<h1>%s</h1>" name+             :+             tableOpen+             +++             formatHTMLRows typ content+             +++             tableClose+       }++formatXML2003 =+   let fileOpen =+         "<?xml version='1.0' encoding='UTF-8'?>" :+         "<?mso-application progid='Excel.Sheet'?>" :+         "<Workbook" :+         "  xmlns='urn:schemas-microsoft-com:office:spreadsheet'" :+         "  xmlns:c='urn:schemas-microsoft-com:office:component:spreadsheet'" :+         "  xmlns:o='urn:schemas-microsoft-com:office:office'" :+         "  xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet'" :+         "  xmlns:x2='http://schemas.microsoft.com/office/excel/2003/xml'" :+         "  xmlns:x='urn:schemas-microsoft-com:office:excel'>" :+         "<Styles>" :+         "<Style ss:ID='head'>" :+         "  <Alignment ss:Horizontal='Center'/>" :+         "  <Font ss:Bold='1'/>" :+         "</Style>" :+         "<Style ss:ID='frac0'>" :+         "  <NumberFormat ss:Format='0'/>" :+         "</Style>" :+         "<Style ss:ID='frac3'>" :+         "  <NumberFormat ss:Format='0.000'/>" :+         "</Style>" :+         "<Style ss:ID='frac6'>" :+         "  <NumberFormat ss:Format='0.000000'/>" :+         "</Style>" :+         "</Styles>" :+         []++       tableOpen name =+         printf "<ss:Worksheet ss:Name='%s'>" name :+         "<Table>" :+         []++       tableClose =+         "</Table>" :+         "</ss:Worksheet>" :+         []++       fileClose =+         "</Workbook>" :+         []++   in  Format {+          formatOpen = \name -> unlines $ fileOpen ++ tableOpen name,+          formatClose = unlines $ tableClose ++ fileClose,+          formatRows = (unlines .) . formatXML2003Rows,+          formatFileOpen = unlines fileOpen,+          formatFileClose = unlines fileClose,+          formatSheet = \typ name content -> unlines $+             tableOpen name+             +++             formatXML2003Rows typ content+             +++             tableClose+       }++++writeTableInit ::+   (PathClass.AbsRel ar) =>+   TableFormats Bool -> Path.File ar ->+   [[FieldTracked]] -> IO (TablePaths ar)+writeTableInit mask path content = do+   let name = Path.toString $ Path.takeFileName path+   Trav.sequence $+      liftA3+         (\enable ext fmt ->+            Trav.sequence $ toMaybe enable $+            initFile (path <.> ext)+               (formatOpen fmt name ++ formatRows fmt Number content))+         mask formatExtensions formats+++expandTableHead1 :: [(String, [String])] -> [[FieldTracked]]+expandTableHead1 =+   (:[]) .+   concatMap (\(top,below) -> map (tableHead . ((top++"\n") ++)) below)++expandTableHead2 :: [(String, [String])] -> [[FieldTracked]]+expandTableHead2 =+   (\(top,below) -> [top, concat below]) . unzip .+   map (\(top,below) -> (tableSpanHead (length below) top, map tableHead below))++{-+ToDo:+We could try to write the median for every recording+immediately after the processing of the recording is finished.+However this would require more effort to bring the rows in order,+since the recordings are processed in parallel.+-}+writeMedianHead ::+   (PathClass.AbsRel ar) =>+   TableFormats Bool -> Bool -> Path.Dir ar ->+   Palisade.T (Cell Double, a) (Double, b) ->+   String -> IO (ResPaths ar)+writeMedianHead mask divTH output pal cls = do+   let headers = map fst $ filter snd $ Palisade.header pal+   let summ5Names = Fold.toList Palisade.summary5Names+   let writeHead resolution leading = do+         writeTableInit mask+               (output </> Path.path (map Char.toLower cls) <-> resolution) $+            (if divTH then expandTableHead2 else expandTableHead1) $+            map (flip (,) [""]) leading ++ map (flip (,) summ5Names) headers+   liftM3 Resolutions+      (writeHead "treatment" $ "Night" : "Treatment" : "Number" : [])+      (writeHead "animal" $ "Night" : "Animal" : "Trial" : "Number" : [])+      (writeHead "recording" $+         "Night" : "Animal" : "Trial" : "Recording" : "Number" : [])++findAdvertisementData ::+   (PathClass.AbsRel ar) => String -> Path.Dir ar -> IO [Path.File ar]+findAdvertisementData fmt =+   let isAdv =+         Find.fileName ~~? printf fmt "*" &&?+         (Find.fileType ==? Find.RegularFile ||?+          Find.fileType ==? Find.SymbolicLink)+   in  fmap (map Path.path) . Find.find (Find.depth ==? 0) isAdv . Path.toString++writeOverviewHead ::+   (PathClass.AbsRel ar) => Flags -> Path.Dir ar -> IO (AllPaths ar)+writeOverviewHead flags output = do+   let backup pathFmt =+         findAdvertisementData pathFmt output >>=+            mapM_ (\path -> Dir.renameFile path (path <.> "bak"))+   let advertisementHourlyFmt = "advertisement-hourly-%s.ssv"+   let advertisementFmt = "advertisement-%s.ssv"+   backup advertisementHourlyFmt+   backup advertisementFmt+   let durHead =+         map tableHead $+         ["Night", "Animal", "Trial"] +++         Fold.toList (fmap (++"/s") Durs.names) +++         "Sum/s" : Fold.toList (fmap (++" rel") ClassRecord.names)+   let (CalcForm.Tracked emitForm emitNumber) = emitFormula flags+   let writeDurationHead enable typ =+         writeTableInit (fmap (enable&&) $ emitFormats flags)+            (output </> Path.path "duration" <-> typeName typ) [durHead]+   durationTable <-+      liftM2 (,)+         (writeDurationHead emitForm Formula)+         (writeDurationHead emitNumber Number)+   rowRef <- newIORef 0+   let writeMedHead =+         writeMedianHead (emitFormats flags) (dividedTableHead flags) output+   medianTables <-+      Trav.sequence $+         ClassRecord.Cons+            (writeMedHead palBoundAdvertisement)+            (writeMedHead palBoundRasping)+            (writeMedHead palBoundChirping)+            (writeMedHead palBoundTicking)+            (writeMedHead palBoundGrowling)+         <*>+         ClassRecord.names+   return ((durationTable, rowRef), medianTables,+           (output, advertisementFmt, advertisementHourlyFmt))++for2_ ::+   (Applicative t, Applicative f, Fold.Foldable t) =>+   t a -> t b -> (a -> b -> f ()) -> f ()+for2_ xs ys act =+   Fold.sequenceA_ $ liftA2 act xs ys++writeOverviewFoot ::+   (PathClass.AbsRel ar) => AllPaths ar -> IO ()+writeOverviewFoot+      (((durationFormulaTable, durationNumberTable), _rowRef),+       classTables, _advertisementPath) = do+   let closeTable paths =+         for2_ paths formats $ \mpath format ->+            Fold.for_ mpath $ \path ->+               PathIO.appendFile path $ formatClose format+   closeTable durationFormulaTable+   closeTable durationNumberTable+   Fold.mapM_ (Fold.mapM_ closeTable) classTables+++formatField :: EvalType -> FieldTracked -> String+formatField typ x =+   case CalcRow.fieldContent x of+      CalcForm.Tracked formula str ->+         case typ of+            Number -> str+            Formula -> maybe str (('=':) . CalcForm.formatCSV) formula++prettyCSVTable :: [[String]] -> String+prettyCSVTable = CSV.ppCSVTable . snd . CSV.toCSVTable++formatCSVRows :: EvalType -> [[FieldTracked]] -> String+formatCSVRows typ =+   prettyCSVTable .+   map+      (concatMap+         (\x -> take (CalcRow.fieldSpan x) $ formatField typ x : repeat ""))++formatHTMLRows :: EvalType -> [[FieldTracked]] -> [String]+formatHTMLRows typ =+   map (\row -> "<tr>"++row++"</tr>") .+   map (concatMap+      (\x ->+         let tag = if CalcRow.fieldHead x then "th" else "td"+             colSpan, anchorOpen, anchorClose :: String+             colSpan =+               Mn.when (CalcRow.fieldSpan x > 1) $+                  printf " colspan=%d" (CalcRow.fieldSpan x)+             (anchorOpen, anchorClose) =+               Mn.when (not $ null $ CalcRow.fieldAnchor x)+                  (printf "<a href='%s'>" $ CalcRow.fieldAnchor x, "</a>")+             escape = concatMap (\c -> if c=='\n' then "<br>" else [c])+         in  printf "<%s%s>%s%s%s</%s>"+               tag colSpan anchorOpen+               (escape $ formatField typ x) anchorClose tag))++formatXML2003Rows :: EvalType -> [[FieldTracked]] -> [String]+formatXML2003Rows ftyp =+   concatMap (\row -> "<Row>" : row ++ "</Row>" : []) .+   map (map+      (\x ->+         let style, colSpan, anchor :: String+             style =+               if CalcRow.fieldHead x+                 then " ss:StyleID='head'"+                 else foldMap+                        (printf " ss:StyleID='%s'" . precision)+                        (CalcRow.fieldPrecision x)+             precision prec =+               case prec of+                  Prec0 -> "frac0"+                  Prec3 -> "frac3"+                  Prec6 -> "frac6"+             colSpan =+               Mn.when (CalcRow.fieldSpan x > 1) $+                  printf " ss:MergeAcross='%d'" $ CalcRow.fieldSpan x - 1+             anchor =+               Mn.when (not $ null $ CalcRow.fieldAnchor x) $+                  printf " ss:HRef='%s'" $ CalcRow.fieldAnchor x+             CalcForm.Tracked mformula display = CalcRow.fieldContent x+             escape = concatMap (\c -> if c=='\n' then "&#10;" else [c])+             formula =+               case ftyp of+                  Number -> ""+                  Formula ->+                     foldMap+                        (printf " ss:Formula='=%s'" . CalcForm.formatXML2003)+                        mformula+             typ =+               case CalcRow.fieldType x of+                  CalcRow.TypeString -> "String"+                  CalcRow.TypeNumber -> "Number"+         in  printf "<Cell%s%s%s%s><Data ss:Type='%s'>%s</Data></Cell>"+               style colSpan anchor formula typ (escape display)))++appendTable ::+   (PathClass.AbsRel ar) =>+   EvalType -> TablePaths ar -> [[FieldTracked]] -> IO ()+appendTable typ paths content =+   for2_ paths formats $ \mpath format ->+      Fold.for_ mpath $ \path ->+         PathIO.appendFile path $ formatRows format typ content++appendMedian ::+   (PathClass.AbsRel ar) =>+   [FieldTracked] -> [meas] ->+   Palisade.T a b -> (meas -> [b]) -> TablePaths ar ->+   IO ()+appendMedian source totalDursMeass pal selectMeas tablePath =+   appendTable Number tablePath $+      let meass = concatMap selectMeas totalDursMeass+      in  [source +++           tableFieldInt (length meass) :+           concatMap Fold.toList (Palisade.selectedSummary5 pal meass)]++appendMedian2 ::+   (PathClass.AbsRel ar) =>+   [FieldTracked] -> Path.AbsDir -> [(Path.RelFile, meas)] ->+   Palisade.T a b -> (meas -> [b]) -> ResPaths ar ->+   IO ()+appendMedian2 source fullDir1 totalDursMeass pal selectMeas+      (Resolutions {resAnimal = animalPath, resRecording = recordingPath}) = do+   appendMedian source (map snd totalDursMeass) pal selectMeas animalPath+   appendTable Number recordingPath $+      flip map (map (mapSnd selectMeas) totalDursMeass) $+         \(name,meass) ->+            source ++ tableFieldAnchor fullDir1 name :+            tableFieldInt (length meass) :+            concatMap Fold.toList (Palisade.selectedSummary5 pal meass)+++calcFormPutAnchor ::+   (PathClass.FileDir fd, PathClass.AbsRel ar) =>+   Path.Path ar fd -> Path.Rel fd -> CalcRow.M ()+calcFormPutAnchor url disp =+   CalcRow.putAnchor (Path.toString url) (Path.toString disp)+++type+   Results =+      (Durs.T Double, Map Time.Hour (Durs.T Double), Measurements Double)++appendOverview ::+   (PathClass.AbsRel ar) =>+   AllPaths ar ->+   Path.AbsDir -> Path.RelDir -> Path.RelDir -> Int ->+   [(Path.RelFile, Results)] -> IO ()+appendOverview+      (((durationFormulaTable, durationNumberTable), rowRef),+       classTables, _advertisementPath)+      input dir0 dir1 animal totalDursMeass = do++   modifyIORef rowRef succ+   rowPos <- readIORef rowRef+   let fullDir0 = input </> dir0+   let fullDir1 = fullDir0 </> dir1+   let row =+         CalcRow.exec rowPos $ do+            calcFormPutAnchor fullDir0 dir0+            void $ CalcRow.putNumber animal+            calcFormPutAnchor fullDir1 dir1+            durClasses <-+               fmap (fmap CalcForm.trackedVar . Durs.classes) $+               Trav.traverse (CalcRow.putPlainFraction Prec3) $+               List.foldl' (\x y -> force $ liftA2 (+) x y) (pure 0) $+               map (fst3 . snd) totalDursMeass+            durSum <-+               CalcRow.putFractionFormula Prec3 $ Fold.foldl1 (+) durClasses+            Fold.mapM_ (CalcRow.putFraction Prec3 . (/durSum)) durClasses+   appendTable Formula durationFormulaTable [row]+   appendTable Number  durationNumberTable  [row]++   let source =+         tableFieldAnchor input dir0 :+         tableFieldInt animal :+         tableFieldAnchor fullDir0 dir1 :+         []+   let appendMed =+         appendMedian2 source fullDir1 $ map (mapSnd thd3) totalDursMeass++   Fold.sequence_ $+      ClassRecord.Cons+         (appendMed palBoundAdvertisement measAdvertisement)+         (appendMed palBoundRasping measRasping)+         (appendMed palBoundChirping measChirping)+         (appendMed palBoundTicking measTicking)+         (appendMed palBoundGrowling measGrowling)+      <*>+      classTables+++summary5 ::+   (Field.C a, Real.C a, Num a) =>+   [[ClassRecord.T a]] -> Maybe (Palisade.FiveNumberSummary a)+summary5 =+   fmap Palisade.summary5Number .+   NonEmpty.fetch . map (uncurry (/)) . filter ((/=0) . snd) .+   map+      (\durs ->+         (sum (map ClassRecord.advertisement durs),+          sum (map Fold.sum durs)))++transposeMapList :: (Ord k) => [Map k a] -> Map k [a]+transposeMapList = Map.unionsWith (++) . map (fmap (:[]))++appendTreatmentOverview ::+   (PathClass.AbsRel ar) =>+   AllPaths ar -> Path.AbsDir -> Path.RelDir -> String ->+   [[(Path.RelFile, Results)]] -> IO ()+appendTreatmentOverview+      (_durationTable, classTables,+       (output, advertisementFmt, advertisementHourlyFmt))+      input dir0 treatment fileTotalDursMeass = do++   let totalDursMeass = map (map snd) fileTotalDursMeass+   let appendMed =+         appendMedian+            [tableFieldAnchor input dir0, tableField treatment]+            (map thd3 $ concat totalDursMeass)++   Fold.sequence_ $+      ClassRecord.Cons+         (appendMed palBoundAdvertisement measAdvertisement)+         (appendMed palBoundRasping measRasping)+         (appendMed palBoundChirping measChirping)+         (appendMed palBoundTicking measTicking)+         (appendMed palBoundGrowling measGrowling)+      <*>+      fmap resTreatment classTables++   let hourSumms =+         map (mapPair+            (Time.formatHour "%Y-%m-%d %H",+             Fold.toList . fmap (printf "%.3f"))) $+         Map.toAscList $+         Map.mapMaybe summary5 $+         transposeMapList $+         map+            (transposeMapList . map (fmap Durs.classes . snd3))+            totalDursMeass++   PathIO.writeFile+         (output </> dir0 </>+          Path.relFile (printf advertisementHourlyFmt treatment)) $+      unlines $+      map (\(hour,summ) -> unwords $ hour : summ) $+      hourSumms++   PathIO.appendFile+         (output </>+          Path.relFile (printf advertisementHourlyFmt treatment)) $+      unlines $+      map (\(hour,summ) -> unwords $ hour : summ) $+      ListHT.switchR []+         (\_xs (hour,summ) ->+            hourSumms ++ [(hour, Match.replicate summ "NaN")]) $+         hourSumms++   PathIO.appendFile+         (output </> Path.path (printf advertisementFmt treatment)) $+      printf "\"%s\" %s\n" (Path.toString dir0) $+      List.intercalate " " $ Fold.toList $+      maybe (pure "NaN") (fmap (printf "%.3f")) $ summary5 $+      map (map (Durs.classes . fst3))+      totalDursMeass+++data+   Measurements a =+      Measurements {+         measAdvertisement :: [BoundAdvertisement a],+         measRasping :: [BoundRasping a],+         measChirping :: [BoundChirping a],+         measTicking :: [BoundTicking a],+         measGrowling :: [BoundGrowling a]+      }++instance Sg.Semigroup (Measurements a) where+   Measurements a0 r0 c0 t0 g0 <> Measurements a1 r1 c1 t1 g1 =+      Measurements (a0++a1) (r0++r1) (c0++c1) (t0++t1) (g0++g1)++instance Monoid (Measurements a) where+   mempty = Measurements [] [] [] [] []+   mappend = (<>)++instance (NFData a) => NFData (Measurements a) where+   rnf (Measurements a r c t g) = rnf (a,r,c,t,g)+++data+   Flags =+      Flags {+         emitFormula :: CalcForm.Tracked Bool Bool,+         emitFormats :: TableFormats Bool,+         emitRecording :: RecordingFlags Bool,+         dividedTableHead :: Bool+      }++data RecordingFlags a = RecordingFlags {emitSingle, emitMulti :: a}++instance Functor RecordingFlags where+   fmap = Trav.fmapDefault++instance Fold.Foldable RecordingFlags where+   foldMap = Trav.foldMapDefault++instance Trav.Traversable RecordingFlags where+   traverse f (RecordingFlags single multi) =+      liftA2 RecordingFlags (f single) (f multi)++instance Applicative RecordingFlags where+   pure a = RecordingFlags a a+   RecordingFlags fSingle fMulti <*> RecordingFlags single multi =+      RecordingFlags (fSingle single) (fMulti multi)++defaultFlags :: Flags+defaultFlags =+   Flags {+      emitFormula = CalcForm.Tracked True True,+      emitFormats =+         TableFormats {tableCSV = False, tableHTML = True, tableXML2003 = True},+      emitRecording = RecordingFlags {emitSingle = False, emitMulti = True},+      dividedTableHead = False+   }+++formatTables ::+   (PathClass.AbsRel ar0, PathClass.AbsRel ar1) =>+   Flags ->+   Rate.Sample -> Path.File ar0 -> Path.File ar1 ->+   Signal.LabelChain Rate.Measure (SpectralParameters Float, ClassFeatures) ->+   MW.Writer [(Path.File ar1, Text)] (Measurements Double)+formatTables+      (Flags formFlags fmtFlags recFlags _divTH)+      highRateReal input outputStem+      (Signal.Cons lowRateReal measures) = do+   let putInput = calcFormPutAnchor input $ Path.takeBaseName input+       lowRate = CalcForm.trackFraction $ Rate.unpack lowRateReal+       highRate = CalcForm.trackFraction $ Rate.unpack highRateReal+       classMeasures =+         LabelTrack.decons $ LabelTrack.fromLabelChain $+         LabelChain.abstractFromSoundClassIntervals $+         fmap+            (\(spec, cls) ->+               let spectralDistr = spectralParametersReal highRate spec+               in  case cls of+                      Class.Rasping clickMeasure ->+                         Class.Rasping (clickMeasure, spectralDistr)+                      Class.Chirping chirpMain ->+                         Class.Chirping (chirpMain, spectralDistr)+                      Class.Ticking numClicks ->+                         Class.Ticking (numClicks, spectralDistr)+                      Class.Growling clickMeasure ->+                         Class.Growling (clickMeasure, spectralDistr)+                      Class.Other str -> Class.Other str) $+         measures++       renderTable pal renderRow =+          renderTable2 pal $ mapMaybe renderRow classMeasures++       (tables, meass) =+         bipure ClassRecord.Cons Measurements+         <<*>>+         (renderTable palBoundAdvertisement $ \(bnd,cls) ->+            case cls of+               Class.Advertisement brk raspingMeas mchirpingMeas ->+                  Just $ do+                     putInput+                     durCell <- rowBounds lowRate bnd+                     durRaspingCell <-+                        CalcRow.putFraction Prec6 $+                           (fromIntegral brk - fromIntegral (fst bnd)) / lowRate+                     let dur = CalcForm.trackedVar durCell+                     let durRasping = CalcForm.trackedVar durRaspingCell+                     rasping <- rowRasping lowRate durRasping raspingMeas+                     chirping <-+                        case mchirpingMeas of+                           Nothing -> do+                              CalcRow.putEmpty+                              rowNoChirping+                              return Nothing+                           Just chirping ->+                              fmap Just $+                              liftM2 (,)+                                 (CalcRow.putFraction Prec6 $ dur - durRasping)+                                 (rowChirping lowRate chirping)+                     return (durCell, ((durRaspingCell, rasping), chirping))+               _ -> Nothing)+         <<*>>+         (renderTable palBoundRasping $ \(bnd,cls) ->+            case cls of+               Class.NoAdvertisement (Class.Rasping measured) ->+                  Just $ do+                     putInput+                     dur <- rowBounds lowRate bnd+                     rasping <-+                        rowRasping lowRate (CalcForm.trackedVar dur) measured+                     return (dur, rasping)+               _ -> Nothing)+         <<*>>+         (renderTable palBoundChirping $ \(bnd,cls) ->+            case cls of+               Class.NoAdvertisement (Class.Chirping measured) ->+                  Just $ do+                     putInput+                     dur <- rowBounds lowRate bnd+                     chirping <- rowChirping lowRate measured+                     return (dur, chirping)+               _ -> Nothing)+         <<*>>+         (renderTable palBoundTicking $ \(bnd,cls) ->+            case cls of+               Class.NoAdvertisement (Class.Ticking measured) ->+                  Just $ do+                     putInput+                     dur <- rowBounds lowRate bnd+                     ticking <- rowTicking (CalcForm.trackedVar dur) measured+                     return (dur, ticking)+               _ -> Nothing)+         <<*>>+         (renderTable palBoundGrowling $ \(bnd,cls) ->+            case cls of+               Class.NoAdvertisement (Class.Growling measured) ->+                  Just $ do+                     putInput+                     dur <- rowBounds lowRate bnd+                     rasping <-+                        rowGrowling lowRate (CalcForm.trackedVar dur) measured+                     return (dur, rasping)+               _ -> Nothing)++   let tellSelected mask tbls =+         for2_ mask tbls $ \enable table -> when enable $ MW.tell [table]+   let formatSelected typ mask makeTables =+         when (typeSelect typ formFlags) $+            tellSelected mask $ makeTables typ+   let whenFormula formulaFormats numberFormats makeTables = do+         formatSelected Formula formulaFormats makeTables+         formatSelected Number  numberFormats  makeTables++   when (emitSingle recFlags) $+      for2_ ClassRecord.names tables $ \cls table ->+         whenFormula fmtFlags fmtFlags $ \typ ->+            formatTable outputStem typ cls table++   {-+   In CSV and HTML files the cell references in formulas+   become invalid by concatenating tables.+   Thus we allow to skip CSV and HTML creation for formula tables.+   -}+   let fmtFormFlags = fmtFlags {tableCSV = False, tableHTML = False}+   when (emitMulti recFlags) $+      whenFormula fmtFormFlags fmtFlags $ \typ ->+         formatMultiTable outputStem typ $+         liftA2 (,) ClassRecord.names tables++   return meass
+ src/Spreadsheet/Formula.hs view
@@ -0,0 +1,240 @@+module Spreadsheet.Formula (+   Formula,+   CellId(CellId),+   Agg(..),+   constant,+   pi,+   fromInt,+   formatCSV,+   formatXML2003,+   aggregate,+   sum,++   Tracked(..),+   untracked,+   CellTracked,+   FormulaTracked,+   trackFraction,+   trackedVar,+   ) where++import qualified Data.Bifunctor as Bifunc+import Control.Applicative (liftA2)+import Data.Bitraversable (Bitraversable, bitraverse, bifoldMapDefault, )+import Data.Bifoldable (Bifoldable, bifoldMap, )+import Data.Biapplicative (Biapplicative, bipure, biliftA2, (<<*>>), )+import Data.Bifunctor (Bifunctor, bimap, )++import qualified Data.NonEmpty as NonEmpty+import qualified Data.List as List+import Data.Tuple.HT (swap)+import Data.Maybe.HT (toMaybe)+import Text.Printf (printf)+import Data.Char (ord, chr)+import Data.Ord.HT (comparing)+import Data.Eq.HT (equating)++import qualified Algebra.ToRational as ToRational+import qualified Algebra.RealRing as Real+import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive+import Algebra.ToRational (realToField)+import NumericPrelude.Numeric hiding (sum, pi)+import NumericPrelude.Base+import Prelude ()+++data Formula =+     Const Integer+   | Any String+   | Var CellId+   | Infix Infix Formula Formula+   | Agg Agg [Either Formula (CellId, CellId)]+++data CellId = CellId Int Int+   deriving (Eq, Ord, Show)++data Infix = Times | Divide | Plus | Minus+   deriving (Show)++data Precedence = PrecSum | PrecProduct | PrecLiteral+   deriving (Eq, Ord, Enum)++data Agg = Sum | Minimum | Maximum | Median | Quartile Int+   deriving (Show)++format :: (CellId -> String) -> Formula -> String+format fmtCellId =+   let go paren form =+         case form of+            Const a -> show a+            Any str -> str+            Var cell -> fmtCellId cell+            Agg agg cells ->+               printf (formatAgg agg) $ List.intercalate ";" $+               map (either (go (PrecSum>)) (cellRange fmtCellId)) cells+            Infix Times x y ->+               parentheses (paren PrecProduct) $+               go (PrecProduct>) x ++ "*" ++ go (PrecProduct>) y+            Infix Divide x y ->+               parentheses (paren PrecProduct) $+               go (PrecProduct>) x ++ "/" ++ go (PrecProduct>=) y+            Infix Plus x y ->+               parentheses (paren PrecSum) $+               go (PrecSum>) x ++ "+" ++ go (PrecSum>) y+            Infix Minus x y ->+               parentheses (paren PrecSum) $+               go (PrecSum>) x ++ "-" ++ go (PrecSum>=) y+   in  go (const False)++formatCSV :: Formula -> String+formatCSV = format formatCellId++formatCellId :: CellId -> String+formatCellId (CellId row column) = formatColumnId column ++ show (row+1)++formatColumnId :: Int -> String+formatColumnId =+   let range = ord 'Z' - ord 'A' + 1+   in  map chr . map (ord 'A' +) . reverse .+       List.unfoldr (\k -> toMaybe (k>0) $ swap $ divMod (k-1) range) . (1+)++formatXML2003 :: Formula -> String+formatXML2003 = format formatCellIdXML2003++formatCellIdXML2003 :: CellId -> String+formatCellIdXML2003 (CellId row column) =+   printf "R%dC%d" (row+1) (column+1)++formatAgg :: Agg -> String+formatAgg agg =+   case agg of+      -- ToDo: SUMME in German locale+      Sum -> "SUM(%s)"+      Minimum -> "MIN(%s)"+      Maximum -> "MAX(%s)"+      Median -> "MEDIAN(%s)"+      Quartile n -> "QUARTILE(%s;" ++ show n ++ ")"++parentheses :: Bool -> String -> String+parentheses b xs =+   if b+     then '(' : xs ++ ")"+     else xs+++constant :: Integer -> Formula+constant = Const+++instance Additive.C Formula where+   zero = Const zero+   x + y  =  Infix Plus x y+   x - y  =  Infix Minus x y++instance Ring.C Formula where+   fromInteger = Const . Ring.fromInteger+   one = Const one+   x * y  =  Infix Times x y++instance Field.C Formula where+   x / y  =  Infix Divide x y+++{- |+This type tracks the operations applied to the @a@-typed value.+Cf. EFA.Equation.Pair+-}+data Tracked formula a = Tracked {trackedFormula :: formula, trackedNumber :: a}+   deriving (Show)++instance Bifunctor Tracked where+   bimap f g (Tracked formula number) = Tracked (f formula) (g number)++instance Biapplicative Tracked where+   bipure = Tracked+   Tracked ff f <<*>> Tracked fx x  =  Tracked (ff fx) (f x)++instance Bifoldable Tracked where+   bifoldMap = bifoldMapDefault++instance Bitraversable Tracked where+   bitraverse f g (Tracked formula number) =+      liftA2 Tracked (f formula) (g number)++type FormulaTracked = Tracked Formula+type CellTracked = Tracked CellId++untracked :: String -> Tracked (Maybe Formula) String+untracked = Tracked Nothing+++instance (Eq a) => Eq (Tracked formula a) where+   (==)  =  equating trackedNumber++instance (Ord a) => Ord (Tracked formula a) where+   compare  =  comparing trackedNumber+++instance+   (Additive.C formula, Additive.C a) =>+      Additive.C (Tracked formula a) where+   zero = bipure zero zero+   (+) = biliftA2 (+) (+)+   (-) = biliftA2 (-) (-)++instance (Ring.C formula, Ring.C a) => Ring.C (Tracked formula a) where+   fromInteger n = bipure (Ring.fromInteger n) (Ring.fromInteger n)+   one = bipure one one+   (*) = biliftA2 (*) (*)++instance (Field.C formula, Field.C a) => Field.C (Tracked formula a) where+   (/) = biliftA2 (/) (/)+++trackFraction :: (Real.C a, ToRational.C a) => a -> FormulaTracked a+trackFraction x =+   case splitFraction x of+      (i, frac) ->+         Tracked (if isZero frac then constant i else realToField x) x++trackedVar :: CellTracked a -> FormulaTracked a+trackedVar = Bifunc.first Var++fromInt :: (Ring.C a) => Tracked formula Int -> Tracked formula a+fromInt = Bifunc.second fromIntegral+++pi :: (Trans.C a) => FormulaTracked a+pi = Tracked (Any "PI()") Trans.pi++++{- |+Simplified implementation that works only for a rectangle of cells.+-}+cellRange :: (CellId -> String) -> (CellId, CellId) -> String+cellRange fmtCellId (from, to) =+   printf "%s:%s" (fmtCellId from) (fmtCellId to)++{- |+The set of cells must form a rectangle.+It is an unchecked error if that does not apply.+-}+aggregate ::+   Agg -> (NonEmpty.T [] a -> a) ->+   NonEmpty.T [] (CellTracked a) -> FormulaTracked a+aggregate op agg xs =+   Tracked+      (Agg op+         (let cells = fmap trackedFormula xs+          in  [Right (NonEmpty.minimum cells, NonEmpty.maximum cells)]))+      (agg $ fmap trackedNumber xs)++sum :: (Additive.C a) => [CellTracked a] -> FormulaTracked a+sum =+   maybe zero (aggregate Sum (Additive.sum . NonEmpty.flatten)) .+   NonEmpty.fetch
+ src/Spreadsheet/Palisade.hs view
@@ -0,0 +1,217 @@+module Spreadsheet.Palisade (+   FiveNumberSummary(..),+   summary5Names,+   summary5Number,++   T(..),+   summarySum5,+   summary5String,+   colNoSum,+   colSum5,+   colSum,+   right,+   pair,+   triple,+   maybe,+   mapHeaders,+   ) where++import qualified Spreadsheet.Formula as CalcForm+import Spreadsheet.Formula (CellTracked, trackedNumber)+import Spreadsheet.Row+         (Fraction, Precision, FieldTracked,+          emptyField, fractionField, fracFieldFromTracked)++import qualified Quantile++import Control.Applicative (Applicative, pure, liftA2, (<*>))++import qualified Data.Foldable as Fold+import qualified Data.NonEmpty as NonEmpty+import Data.Tuple.HT (mapPair, mapTriple, mapFst)+import Data.Maybe (catMaybes)+import Data.Monoid ((<>))++import qualified Algebra.RealRing as Real+import qualified Algebra.Field as Field+import NumericPrelude.Numeric+import NumericPrelude.Base hiding (maybe)++import qualified Prelude as P++++data FiveNumberSummary a =+   FiveNumberSummary {+      summaryMinimum, summaryQuartile1, summaryMedian,+      summaryQuartile3, summaryMaximum :: a+   }++percentages :: (Field.C a) => FiveNumberSummary a+percentages =+   fmap (\k -> fromInteger k / fromInteger 4) $+   FiveNumberSummary {+      summaryMinimum = 0,+      summaryQuartile1 = 1,+      summaryMedian = 2,+      summaryQuartile3 = 3,+      summaryMaximum = 4+   }++quartileAggs :: FiveNumberSummary CalcForm.Agg+quartileAggs =+   FiveNumberSummary {+      summaryMinimum = CalcForm.Minimum,+      summaryQuartile1 = CalcForm.Quartile 1,+      summaryMedian = CalcForm.Median,+      summaryQuartile3 = CalcForm.Quartile 3,+      summaryMaximum = CalcForm.Maximum+   }++summary5 ::+   (Field.C a, Real.C a) =>+   NonEmpty.T [] (CellTracked a) ->+   FiveNumberSummary (CalcForm.FormulaTracked a)+summary5 xs =+   liftA2+      (\op k -> CalcForm.aggregate op (flip Quantile.discrete k) xs)+      quartileAggs percentages++summary5Number ::+   (Field.C a, Real.C a) => NonEmpty.T [] a -> FiveNumberSummary a+summary5Number xs =+   fmap (Quantile.discrete xs) percentages++summary5Names :: FiveNumberSummary String+summary5Names =+   FiveNumberSummary {+      summaryMinimum = "Minimum",+      summaryQuartile1 = "Quartile 1",+      summaryMedian = "Median",+      summaryQuartile3 = "Quartile 3",+      summaryMaximum = "Maximum"+   }+++instance Functor FiveNumberSummary where+   fmap f (FiveNumberSummary q0 q1 q2 q3 q4) =+      FiveNumberSummary (f q0) (f q1) (f q2) (f q3) (f q4)++instance Applicative FiveNumberSummary where+   pure q = FiveNumberSummary q q q q q+   FiveNumberSummary p0 p1 p2 p3 p4 <*> FiveNumberSummary q0 q1 q2 q3 q4 =+      FiveNumberSummary (p0 q0) (p1 q1) (p2 q2) (p3 q3) (p4 q4)++instance Fold.Foldable FiveNumberSummary where+   foldMap f (FiveNumberSummary q0 q1 q2 q3 q4) =+      f q0 <> f q1 <> f q2 <> f q3 <> f q4++++{- |+The 'T' type ensures that aggregations match the column headers.+Unfortunately, they do not assert that the aggregation values+are positioned below the aggregated data.+So far I have not found a way to achieve that.+It would certainly mean to give up the M monad.++For more clarity we could replace+the list types by two type constructor variables,+one for vertical and one for horizontal lists.+-}+data T a b =+   Cons {+      header :: [(String,Bool)],+      aggregator :: Aggregator a,+      selector :: a -> b,+      selectedSummary5 :: [b] -> [FiveNumberSummary FieldTracked]+   }++mapHeaders :: (String -> String) -> T a b -> T a b+mapHeaders f pal =+   pal{header = map (mapFst f) $ header pal}++type Aggregator a = [a] -> [(FiveNumberSummary FieldTracked, FieldTracked)]++aggSummary5 ::+   (Fraction a, Real.C a) =>+   Precision -> [CellTracked a] -> FiveNumberSummary FieldTracked+aggSummary5 prec =+   P.maybe (pure emptyField) (fmap (fracFieldFromTracked prec) . summary5) .+   NonEmpty.fetch++summarySum :: (Fraction a, Real.C a) => Precision -> Aggregator (CellTracked a)+summarySum prec cells =+   [(aggSummary5 prec cells, fracFieldFromTracked prec $ CalcForm.sum cells)]++summarySum5 :: (Fraction a, Real.C a) => Precision -> Aggregator (CellTracked a)+summarySum5 prec cells = [(aggSummary5 prec cells, emptyField)]+++colNoSum :: String -> T () ()+colNoSum name =+   Cons [(name,False)] (const [(pure emptyField, emptyField)]) id (const [])+++summary5String ::+   (Fraction a, Real.C a) =>+   Precision -> [a] -> [FiveNumberSummary FieldTracked]+summary5String prec =+   (:[]) .+   P.maybe (pure emptyField) (fmap (fractionField prec) . summary5Number) .+   NonEmpty.fetch++{-+The Precision given here should be the same as the one+given to the corresponding Row.putFraction,+but currently we cannot check that statically.+-}+colSum :: (Fraction a, Real.C a) => Precision -> String -> T (CellTracked a) a+colSum prec name =+   Cons [(name,True)] (summarySum prec) trackedNumber (summary5String prec)++colSum5 :: (Fraction a, Real.C a) => Precision -> String -> T (CellTracked a) a+colSum5 prec name =+   Cons [(name,True)] (summarySum5 prec) trackedNumber (summary5String prec)+++summRight :: ([r0] -> [a]) -> ([r1] -> [a]) -> [r1] -> [a]+summRight f0 f1 cells = f0 [] ++ f1 cells++infixr 5 `right`++right :: T () () -> T a b -> T a b+right (Cons name0 agg0 _sel0 med0) (Cons name1 agg1 sel1 med1) =+   Cons (name0++name1) (summRight agg0 agg1) sel1 (summRight med0 med1)++summPair :: ([r0] -> [a]) -> ([r1] -> [a]) -> [(r0,r1)] -> [a]+summPair f0 f1 cells =+   let (cells0,cells1) = unzip cells+   in  f0 cells0 ++ f1 cells1++pair :: T a0 b0 -> T a1 b1 -> T (a0,a1) (b0,b1)+pair (Cons name0 agg0 sel0 med0) (Cons name1 agg1 sel1 med1) =+   Cons (name0++name1)+      (summPair agg0 agg1)+      (mapPair (sel0, sel1))+      (summPair med0 med1)++summTriple ::+   ([r0] -> [a]) -> ([r1] -> [a]) -> ([r2] -> [a]) -> [(r0,r1,r2)] -> [a]+summTriple f0 f1 f2 cells =+   let (cells0,cells1,cells2) = unzip3 cells+   in  f0 cells0 ++ f1 cells1 ++ f2 cells2++triple :: T a0 b0 -> T a1 b1 -> T a2 b2 -> T (a0,a1,a2) (b0,b1,b2)+triple+      (Cons name0 agg0 sel0 med0)+      (Cons name1 agg1 sel1 med1)+      (Cons name2 agg2 sel2 med2) =+   Cons (name0++name1++name2)+      (summTriple agg0 agg1 agg2)+      (mapTriple (sel0, sel1, sel2))+      (summTriple med0 med1 med2)++maybe :: T a b -> T (Maybe a) (Maybe b)+maybe (Cons name agg sel med) =+   Cons name (agg . catMaybes) (fmap sel) (med . catMaybes)
+ src/Spreadsheet/Row.hs view
@@ -0,0 +1,203 @@+module Spreadsheet.Row (+   M,+   exec,+   run,++   Value,+   Fraction,+   Precision(..),++   putEmpty,+   putValueFormula,+   putValue,+   putFractionFormula,+   putFraction,+   putPlainFraction,+   putString,+   putAnchor,+   putInt,+   putNumber,++   FieldTracked,+   FieldType(..),+   TableField(..),+   emptyField,+   fractionField,+   fracFieldFromTracked,+   ) where++import qualified Spreadsheet.Formula as CalcForm+import Spreadsheet.Formula+         (FormulaTracked, CellTracked, Tracked(Tracked), untracked)++import qualified Control.Monad.Trans.RWS as MRWS+import Control.Monad (liftM2)+import Data.Bifunctor (bimap, )++import Text.Printf (PrintfArg, printf)++import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++data FieldType = TypeString | TypeNumber+   deriving (Eq, Ord, Enum, Show)++type FieldTracked = TableField (Tracked (Maybe CalcForm.Formula) String)+data TableField a =+   TableField {+      fieldType :: FieldType,+      fieldQuoted :: Bool,+      fieldAnchor :: String,+      fieldHead :: Bool,+      fieldSpan :: Int,+      fieldPrecision :: Maybe Precision,+      fieldContent :: a+   }++instance Functor TableField where+   fmap f x = x{fieldContent = f $ fieldContent x}+++type M = MRWS.RWS Int [FieldTracked] Int++exec :: Int -> M () -> [FieldTracked]+exec row act = snd $ run row act++run :: Int -> M row -> (row, [FieldTracked])+run row act = MRWS.evalRWS act row 0+++makeField :: Bool -> a -> TableField a+makeField quote content =+   TableField {+      fieldType = TypeString,+      fieldQuoted = quote,+      fieldAnchor = "",+      fieldHead = False,+      fieldSpan = 1,+      fieldPrecision = Nothing,+      fieldContent = content+   }++putString :: String -> M ()+putString str =+   put $ makeField True $ untracked str++putAnchor :: String -> String -> M ()+putAnchor ref str =+   put $ (makeField True $ untracked str) {fieldAnchor = ref}+++put :: FieldTracked -> M ()+put x = do+   column <- MRWS.get+   MRWS.tell [x]+   MRWS.put $! column + fieldSpan x+++putEmpty :: M ()+putEmpty = put emptyField++putInt :: (Ring.C a) => Int -> M (CellTracked a)+putInt = fmap CalcForm.fromInt . putNumber++getCellName :: M CalcForm.CellId+getCellName = liftM2 CalcForm.CellId MRWS.ask MRWS.get++putNumber :: (Value a) => a -> M (CellTracked a)+putNumber x = do+   cell <- getCellName+   put $ (makeField False $ untracked $ formatValue x) {fieldType = TypeNumber}+   return $ Tracked cell x++putValue :: (Value a) => FormulaTracked a -> M (CellTracked a)+putValue x = do+   cell <- getCellName+   put $ fieldFromTracked x+   return $ x{CalcForm.trackedFormula = cell}++putValueFormula :: (Value a) => FormulaTracked a -> M (FormulaTracked a)+putValueFormula = fmap CalcForm.trackedVar . putValue++putFraction ::+   (Fraction a) => Precision -> FormulaTracked a -> M (CellTracked a)+putFraction prec x = do+   cell <- getCellName+   put $ fracFieldFromTracked prec x+   return $ x{CalcForm.trackedFormula = cell}++putPlainFraction :: (Fraction a) => Precision -> a -> M (CellTracked a)+putPlainFraction prec x = do+   cell <- getCellName+   put $ fractionField prec x+   return $ Tracked cell x++putFractionFormula ::+   (Fraction a) => Precision -> FormulaTracked a -> M (FormulaTracked a)+putFractionFormula prec = fmap CalcForm.trackedVar . putFraction prec+++class Value a where+   {- |+   Convert a value to a text representation+   that is compatible to spreadsheet processors.+   -}+   formatValue :: a -> String++instance Value Int where+   formatValue = show++instance Value Integer where+   formatValue = show++instance Value Float where+   formatValue = show++instance Value Double where+   formatValue = show+++data Precision = Prec0 | Prec3 | Prec6+   deriving (Eq, Ord, Enum)++class (Value a, Field.C a) => Fraction a where+   formatFraction :: Precision -> a -> String++instance Fraction Float where+   formatFraction = formatFractionDefault++instance Fraction Double where+   formatFraction = formatFractionDefault++formatFractionDefault :: (PrintfArg a) => Precision -> a -> String+formatFractionDefault prec = printf (precisionFormat prec)++precisionFormat :: Precision -> String+precisionFormat prec =+   case prec of+      Prec0 -> "%.0f"+      Prec3 -> "%.3f"+      Prec6 -> "%.6f"+++fieldFromTracked :: Value a => Tracked CalcForm.Formula a -> FieldTracked+fieldFromTracked x =+   (makeField False $ bimap Just formatValue x) {fieldType = TypeNumber}++fracFieldFromTracked ::+   Fraction a => Precision -> Tracked CalcForm.Formula a -> FieldTracked+fracFieldFromTracked prec x =+   (makeField False $ bimap Just (formatFraction prec) x)+      {fieldType = TypeNumber, fieldPrecision = Just prec}++emptyField :: FieldTracked+emptyField = makeField False $ untracked ""++fractionField :: (Fraction a) => Precision -> a -> FieldTracked+fractionField prec a =+   (makeField False $ untracked $ formatFraction prec a)+      {fieldType = TypeNumber, fieldPrecision = Just prec}
+ src/Time.hs view
@@ -0,0 +1,150 @@+module Time (+   parseRecordingName, timeLabels,+   parseLog, LogEntry(..),+   Hour(..), hours, formatHour, parseHour, splitHour, nextHour,+   ) where++import qualified Data.Time.Format as TimeFormat+import qualified Data.Time.LocalTime as LocalTime+import qualified Data.Time.Clock as Clock+import Data.Time.LocalTime (LocalTime, TimeOfDay)+import Data.Time.Calendar (Day, addDays)++import qualified LabelChain++import qualified System.Path as Path++import Control.DeepSeq (NFData, rnf)+import Control.Monad (guard)++import qualified Data.List.Reverse.StrictElement as Rev+import qualified Data.List.HT as ListHT+import Data.Maybe (listToMaybe)+import Data.Char (isSpace)+++{- |+Parse time from file names like @T2014-03-11_18-01-27_0000111.WAV@.+-}+parseRecordingName :: Path.RelFile -> Maybe LocalTime+parseRecordingName =+   TimeFormat.parseTimeM True+      TimeFormat.defaultTimeLocale "T%Y-%m-%d_%H-%M-%S_" .+   take (length "T2014-03-11_18-01-27_") .+   Path.toString++timeLabels :: Double -> TimeOfDay -> LabelChain.T Double String+timeLabels duration =+   fmap (TimeFormat.formatTime TimeFormat.defaultTimeLocale "%H:%M:%S") .+   LabelChain.fromAdjacentChunks .+   zip (chopDuration duration) . iterate nextSecond++chopDuration :: Double -> [Double]+chopDuration =+   let go dur = if dur>1 then 1 : go (dur-1) else [dur]+   in  go++nextSecond :: TimeOfDay -> TimeOfDay+nextSecond =+   LocalTime.timeToTimeOfDay .+   (Clock.secondsToDiffTime 1 +) .+   LocalTime.timeOfDayToTime+++parseLogTime :: (String,String) -> Maybe LocalTime+parseLogTime (date,time) =+   TimeFormat.parseTimeM True TimeFormat.defaultTimeLocale "%m/%d/%y %H:%M:%S" $+   date ++ " " ++ time+++data LogEntry = Start FilePath | Stop | Recording Path.RelFile Double+   deriving Show++parseLog :: String -> [Either String (LocalTime, LogEntry)]+parseLog =+   filter (either (not . null) (const True)) .+   mergeAdjacent+      (\row0 row1 ->+         case (row0,row1) of+            ((fileName, Nothing), (_, Just (time, ["Monitoring_started"]))) ->+               Just $ Right (time, Start fileName)+            _ -> Nothing)+      (\(row,remd) -> maybe (Left row) Right $ do+         (time, ss) <- remd+         fmap ((,) time) $+            case ss of+               ["Monitoring_stopped"] -> Just Stop+               [fileName, durStr] -> do+                  path <- Path.maybe fileName+                  listToMaybe $ do+                     (dur, seconds) <- reads durStr+                     guard (dropWhile isSpace seconds == "s")+                     return $ Recording path dur+               _ -> Nothing) .+   map+      (\row -> (,) row $ do+         s0:s1:ss <- Just $ ListHT.chop ('\t'==) row+         dateTime <- parseLogTime (s0,s1)+         return (dateTime, ss)) .+   map (Rev.dropWhile ('\r'==)) .+   lines++mergeAdjacent :: (a -> a -> Maybe b) -> (a -> b) -> [a] -> [b]+mergeAdjacent g f =+   let go [] = []+       go [x] = [f x]+       go (x0:x0s@(x1:x1s)) =+         case g x0 x1 of+            Nothing -> f x0 : go x0s+            Just y -> y : go x1s+   in  go+++data Hour = Hour {hourDay :: Day, hourOfDay :: Int}+   deriving (Eq, Ord, Show)++instance NFData Hour where+   rnf (Hour day hour) = rnf (day, hour)++hours :: LocalTime -> LabelChain.T Double Hour+hours start =+   let (h,s) = splitHour start+   in  LabelChain.fromAdjacentChunks .+       zip (max 0 (3600 - s) : repeat 3600) . iterate nextHour $ h++formatHour :: String -> Hour -> String+formatHour fmt =+   TimeFormat.formatTime TimeFormat.defaultTimeLocale fmt . localTimeFromHour++localTimeFromHour :: Hour -> LocalTime+localTimeFromHour (Hour day hour) =+   LocalTime.LocalTime {+      LocalTime.localDay = day,+      LocalTime.localTimeOfDay = LocalTime.midnight{LocalTime.todHour = hour}+   }++parseHour :: String -> String -> Maybe Hour+parseHour fmt =+   fmap hourFromLocalTime .+   TimeFormat.parseTimeM True TimeFormat.defaultTimeLocale fmt++hourFromLocalTime :: LocalTime -> Hour+hourFromLocalTime time =+   Hour+      (LocalTime.localDay time)+      (LocalTime.todHour $ LocalTime.localTimeOfDay time)++splitHour :: LocalTime -> (Hour, Double)+splitHour+      (LocalTime.LocalTime {+         LocalTime.localDay = day,+         LocalTime.localTimeOfDay = tod+      }) =+   (Hour day (LocalTime.todHour tod),+    fromIntegral (LocalTime.todMin tod) * 60 ++      realToFrac (LocalTime.todSec tod))++nextHour :: Hour -> Hour+nextHour (Hour day hour0) =+   let (dayInc, hour1) = divMod (hour0+1) 24+   in  Hour (addDays (fromIntegral dayInc) day) hour1