classify-frog-0.2.3: src/LabelTrack.hs

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