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