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