classify-frog-0.2.3: src/LabelChainShifted.hs

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