classify-frog-0.2.3: src/LabelPattern.hs

{- |
Non-monadic parsers of intervals
where we use a restricted set of operations that preserve the invariants:

* replacing intervals match the outer bounds of the replaced intervals

* produced intervals do not overlap.
-}
module LabelPattern (
   Interval(..),
   dur,
   (&),

   Bounds,
   fuseBounds,

   T,
   next,
   check,
   match,
   match2,
   fusedMatch2,
   maybe,
   maybeLabel,

   alt,
   combine,
   expand,
   fuse,
   fuseWith,
   guard,
   many1,
   mapMaybe,
   move,
   optional,
   followedBy,
   notFollowedBy,
   atEnd,
   precededBy,
   terminatedBy,
   snocMaybe,

   apply,
   applyDefault,
   Flatten,
   flatten1,
   flatten2,
   flattenFoldable,
   flattenPair,
   ) where

import qualified Sound.Audacity.LabelTrack as LabelTrack

import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad as Monad
import qualified Control.Functor.HT as FuncHT
import Control.Applicative (liftA2, (<$>), (<|>))
import Control.Functor.HT (void)

import qualified Data.NonEmpty.Class as NonEmptyC
import qualified Data.NonEmpty as NonEmpty
import qualified Data.List.HT as ListHT
import qualified Data.Foldable as Fold
import Data.Traversable (Traversable, traverse)
import Data.Foldable (Foldable)
import Data.Tuple.HT (mapPair, mapFst, mapSnd)
import Data.Maybe (isNothing)

import qualified Algebra.Additive as Additive
import NumericPrelude.Numeric
import NumericPrelude.Base hiding (maybe, map)

import qualified Prelude as P


data Interval t a = Interval {intervalBounds :: Bounds t, intervalLabel :: a}

type Bounds t = (t,t)

instance Functor (Interval t) where
   fmap f (Interval bnds a) = Interval bnds $ f a

instance Foldable (Interval t) where
   foldMap f (Interval _bnds a) = f a

instance Traversable (Interval t) where
   traverse f (Interval bnds a) = fmap (Interval bnds) $ f a

pairFromInterval :: Interval t a -> LabelTrack.Interval t a
pairFromInterval (Interval bnds a) = (bnds, a)

dur :: (Additive.C t) => Interval t a -> t
dur = uncurry subtract . intervalBounds

{- |
The two intervals must be adjacent.
This is not checked.
-}
(&) ::
   Interval t a ->
   Interval t b ->
   Interval t (a,b)
Interval bnds0 a & Interval bnds1 b =
   Interval (fuseBounds bnds0 bnds1) (a,b)

fuseBounds :: Bounds t -> Bounds t -> Bounds t
fuseBounds bnds0 bnds1 = (fst bnds0, snd bnds1)



newtype
   T t a bnds fb = Cons (MS.StateT (LabelTrack.T t a) Maybe (bnds, fb))

instance Functor (T t a bnds) where
   fmap = map

map :: (b -> c) -> T t a bnds b -> T t a bnds c
map f (Cons m) = Cons $ fmap (mapSnd f) m


viewL :: LabelTrack.T t a -> Maybe (Interval t a, LabelTrack.T t a)
viewL (LabelTrack.Cons xt) =
   fmap (mapPair (uncurry Interval, LabelTrack.Cons)) $ ListHT.viewL xt

next :: T t a (Bounds t) (Interval t a)
next =
   Cons $ fmap (\x -> (intervalBounds x, x)) $ MS.StateT viewL


-- like Monoid.<>
infixr 6 `combine`

combine :: T t a bnds0 b -> T t a bnds1 c -> T t a (bnds0,bnds1) (b,c)
combine (Cons f) (Cons g) =
   Cons $
   liftA2
      (\(bnds0,x0) (bnds1,x1) -> ((bnds0,bnds1), (x0,x1)))
      f g

fuseCombined :: T t a (Pair (Bounds t)) b -> T t a (Bounds t) b
fuseCombined (Cons f) = Cons $ fmap (mapFst (uncurry fuseBounds)) f

fuseWith ::
   (b -> c -> d) ->
   T t a (Bounds t) b -> T t a (Bounds t) c -> T t a (Bounds t) d
fuseWith h p q = uncurry h <$> fuse p q

fuse :: T t a (Bounds t) b -> T t a (Bounds t) c -> T t a (Bounds t) (b,c)
fuse p q = fuseCombined $ combine p q

move ::
   (Additive.C t) => t -> T t a (Pair (Bounds t)) b -> T t a (Pair (Bounds t)) b
move d (Cons m) =
   Cons $ fmap (mapFst (mapPair (mapSnd (d+), mapFst (d+)))) m

guard :: (b -> Bool) -> T t a bnds b -> T t a bnds b
guard p (Cons m) = Cons $ Monad.mfilter (p . snd) m

check :: (a -> Bool) -> T t a (Bounds t) (Interval t a)
check p = guard (p . intervalLabel) next

match :: (Eq a) => a -> T t a (Bounds t) (Interval t a)
match a = check (a==)

type Pair a = (a,a)

match2 :: (Eq a) => Pair a -> T t a (Pair (Bounds t)) (Pair (Interval t a))
match2 (x,y) = combine (match x) (match y)

fusedMatch2 :: (Eq a) => Pair a -> T t a (Bounds t) (Pair (Interval t a))
fusedMatch2 = fuseCombined . match2

infixl 3 `alt`

alt :: T t a f b -> T t a f b -> T t a f b
alt (Cons x) (Cons y) = Cons (x<|>y)

mapMaybe :: (b -> Maybe c) -> T t a bnds b -> T t a bnds c
mapMaybe f (Cons m) = Cons $ MT.lift . FuncHT.mapSnd f =<< m

maybe :: (a -> Maybe b) -> T t a (Bounds t) (Interval t b)
maybe f = mapMaybe (traverse f) next

maybeLabel :: (a -> Maybe b) -> T t a (Bounds t) b
maybeLabel f = mapMaybe (f . intervalLabel) next

optional :: T t a bnds fa -> T t a (Maybe bnds) (Maybe fa)
optional (Cons m) =
   Cons $  mapPair (Just, Just) <$> m  <|>  return (Nothing, Nothing)

{- |
This is dangerous,
because it is not checked whether the outer interval bounds match.
-}
expand ::
   (Functor f) =>
   T t a (Bounds t) (f (Interval t b)) -> T t a (f (Bounds t)) (f b)
expand (Cons m) = Cons (FuncHT.unzip . fmap pairFromInterval . snd <$> m)


infixr 6 `followedBy`, `notFollowedBy`

followedBy :: T t a bnds0 b -> T t a bnds1 c -> T t a bnds0 b
followedBy (Cons p) (Cons q) =
   Cons $ do
      x0 <- p
      s <- MS.get
      void q
      MS.put s
      return x0

notFollowedBy :: T t a bnds0 b -> T t a bnds1 c -> T t a bnds0 b
notFollowedBy (Cons p) (Cons q) =
   Cons $ do
      x0 <- p
      Monad.guard =<< MS.gets (isNothing . MS.evalStateT q)
      return x0

atEnd :: T t a bnds b -> T t a bnds b
atEnd (Cons f) =
   Cons $ do
      x <- f
      Monad.guard . LabelTrack.null =<< MS.get
      return x


oneMore ::
   T t a (Bounds t) b ->
   T t a (Bounds t) (NonEmpty.T [] b) ->
   T t a (Bounds t) (NonEmpty.T [] b)
oneMore p q =
   alt
      (fuseWith NonEmpty.cons p (NonEmpty.flatten <$> q))
      (NonEmpty.singleton <$> p)

many1 :: T t a (Pair t) b -> T t a (Pair t) (NonEmpty.T [] b)
many1 p =
   let go = oneMore p go
   in  go

precededBy ::
   T t a (Pair t) b -> T t a (Pair t) b -> T t a (Pair t) (NonEmpty.T [] b)
precededBy q p = oneMore q $ many1 p

terminatedBy ::
   (b -> c -> c) -> T t a (Pair t) b -> T t a (Pair t) c -> T t a (Pair t) c
terminatedBy f q p =
   let go = alt (fuseWith f q go) p
   in  go


snocMaybe ::
   T t a (Bounds t) (NonEmpty.T [] b) ->
   T t a (Maybe (Bounds t)) (Maybe b) ->
   T t a (Bounds t) (NonEmpty.T [] b)
snocMaybe (Cons p) (Cons q) =
   Cons $ do
      (bndx, x) <- p
      (mbndy, my) <- q
      return
         (P.maybe bndx (fuseBounds bndx) mbndy,
          P.maybe x (NonEmptyC.snoc x) my)



newtype
   Flatten bnds fa t a =
      Flatten {runFlatten :: bnds -> fa -> [LabelTrack.Interval t a]}

flatten1 :: Flatten (Bounds t) a t a
flatten1 = Flatten $ \bnds a -> [(bnds,a)]

flatten2 :: Flatten (Pair (Bounds t)) (Pair a) t a
flatten2 = Flatten $ \(bnds0,bnds1) (a0,a1) -> [(bnds0,a0), (bnds1,a1)]

flattenFoldable :: (Foldable f) => Flatten (f (Bounds t)) (f a) t a
flattenFoldable =
   Flatten $ \bndss as -> zip (Fold.toList bndss) (Fold.toList as)

flattenPair ::
   Flatten bnds0 a0 t fa -> Flatten bnds1 a1 t fa ->
   Flatten (bnds0, bnds1) (a0, a1) t fa
flattenPair (Flatten flattenFst) (Flatten flattenSnd) =
   Flatten $
      \(bnds0,bnds1) (a0,a1) -> flattenFst bnds0 a0 ++ flattenSnd bnds1 a1


apply ::
   Flatten iv fa t a -> T t a iv fa -> LabelTrack.T t a -> LabelTrack.T t a
apply flatten = applyDefault flatten id

applyDefault ::
   Flatten iv fb t b ->
   (a -> b) -> T t a iv fb -> LabelTrack.T t a -> LabelTrack.T t b
applyDefault flatten f (Cons p) =
   let go xt =
         case MS.runStateT p xt of
            Just ((bnds,labs),xs) ->
               LabelTrack.lift (runFlatten flatten bnds labs ++) $ go xs
            Nothing ->
               case viewL xt of
                  Just (x,xs) ->
                     LabelTrack.lift (pairFromInterval (fmap f x) :) $ go xs
                  Nothing -> LabelTrack.empty
   in  go