{-# 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