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