interval-algebra-2.2.0: src/IntervalAlgebra/IntervalUtilities.hs
{-|
Module : Interval Algebra Utilities
Description : Functions for operating on containers of Intervals.
Copyright : (c) NoviSci, Inc 2020-2022
TargetRWE, 2023
License : BSD3
Maintainer : bsaul@novisci.com 2020-2022, bbrown@targetrwe.com 2023
Stability : experimental
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module IntervalAlgebra.IntervalUtilities
(
-- * Fold over sequential intervals
combineIntervals
, combineIntervalsFromSorted
, rangeInterval
-- * Combining intervals
, (><)
, (.+.)
-- * Functions for manipulating intervals
, lookback
, lookahead
-- * Gaps
, gaps
, pairGaps
-- * Misc utilities
, relations
, intersect
, clip
, durations
) where
import Control.Applicative (Applicative (pure), liftA2,
(<$>), (<*>))
import qualified Control.Foldl as L
import Control.Monad (Functor (fmap))
import Data.Bool (Bool (..), not, otherwise,
(&&), (||))
import Data.Eq (Eq ((==)))
import Data.Foldable (Foldable (foldl', foldr, null, toList),
all, any, or)
import Data.Function (flip, ($), (.))
import Data.List (map, reverse, sortOn)
import Data.Maybe (Maybe (..), mapMaybe, maybe,
maybeToList)
import Data.Monoid (Monoid (mempty))
import Data.Ord (Ord (max, min), (<), (>=))
import Data.Semigroup (Semigroup ((<>)))
import Data.Traversable (Traversable (sequenceA))
import Data.Tuple (fst, uncurry)
import GHC.Int (Int)
import GHC.Show (Show)
import IntervalAlgebra.Core
import IntervalAlgebra.PairedInterval (PairedInterval, equalPairData,
getPairData,
makePairedInterval)
{- $setup
>>> import GHC.List ( (++), zip )
>>> import IntervalAlgebra.IntervalDiagram
>>> import Prettyprinter ( pretty )
-}
-------------------------------------------------
-- Unexported utilties used in functions below --
-------------------------------------------------
-- | Gets the durations of gaps (via '(><)') between all pairs of the input.
pairGaps
:: (Intervallic i, SizedIv (Interval a), Ord a, Ord (Moment (Interval a)))
=> [i a]
-> [Maybe (Moment (Interval a))]
pairGaps es = fmap (fmap duration . uncurry (><)) (pairs es)
-- Generate all pair-wise combinations of a single list.
-- pairs :: [a] -> [(a, a)]
-- copied from the hgeometry library
-- (https://hackage.haskell.org/package/hgeometry-0.12.0.4/docs/src/Data.Geometry.Arrangement.Internal.html#allPairs)
where
pairs = go
where
go [] = []
go (x : xs) = fmap (x, ) xs <> go xs
-- | Creates a new @Interval@ of a provided lookback duration ending at the
-- 'begin' of the input interval.
--
-- >>> lookback 4 (beginerval 10 (1 :: Int))
-- (-3, 1)
lookback
:: (Intervallic i, SizedIv (Interval a), Ord (Moment (Interval a)))
=> Moment (Interval a) -- ^ lookback duration
-> i a
-> Interval a
lookback d x = enderval d (begin x)
-- | Creates a new @Interval@ of a provided lookahead duration beginning at the
-- 'end' of the input interval.
--
-- >>> lookahead 4 (beginerval 1 (1 :: Int))
-- (2, 6)
lookahead
:: (Intervallic i, SizedIv (Interval a), Ord (Moment (Interval a)))
=> Moment (Interval a) -- ^ lookahead duration
-> i a
-> Interval a
lookahead d x = beginerval d (end x)
-- | Returns a list of the 'IntervalRelation' between each consecutive pair of @i a@.
--
-- >>> relations [beginerval 1 0, beginerval 1 1]
-- [Meets]
-- >>> relations [beginerval 1 0, beginerval 1 1, beginerval 2 1]
-- [Meets,Starts]
-- >>> relations [beginerval 1 0]
-- []
relations
:: ( Intervallic i
, Iv (Interval a)
)
=> [i a]
-> [IntervalRelation]
relations [] = []
relations [x] = []
relations (x : y : xs) = relate x y : relations (y : xs)
-- | Forms 'Just' a new interval from the intersection of two intervals,
-- provided the intervals are not 'disjoint'.
--
-- >>> intersect (bi 5 0) (bi 2 3)
-- Just (3, 5)
--
intersect
:: (Intervallic i, SizedIv (Interval a), Ord a, Ord (Moment (Interval a))) => i a -> i a -> Maybe (Interval a)
intersect x y | disjoint x y = Nothing
| otherwise = Just $ safeInterval (b, e)
where
b = max (begin x) (begin y)
e = min (end x) (end y)
{- | Returns a list of intervals consisting of the gaps between
consecutive intervals in the input, after they have been sorted by
interval ordering.
>>> x1 = bi 4 1
>>> x2 = bi 4 8
>>> x3 = bi 3 11
>>> ivs = [x1, x2, x3]
>>> ivs
[(1, 5),(8, 12),(11, 14)]
>>> gaps ivs
[(5, 8)]
>>> pretty $ standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) []
---- <- [x1]
---- <- [x2]
--- <- [x3]
==============
>>> x1 = bi 4 1
>>> x2 = bi 3 7
>>> x3 = bi 2 13
>>> ivs = [x1, x2, x3]
>>> ivs
[(1, 5),(7, 10),(13, 15)]
>>> gapIvs = gaps ivs
>>> gapIvs
[(5, 7),(10, 13)]
>>> :{
pretty $
standardExampleDiagram (zip ivs ["x1", "x2", "x3"]) [(gapIvs, "gapIvs")]
:}
---- <- [x1]
--- <- [x2]
-- <- [x3]
-- --- <- [gapIvs]
===============
-}
gaps :: (
SizedIv (Interval a),
Intervallic i,
Ord a,
Ord (Moment (Interval a))
) =>
[i a] ->
[Interval a]
gaps xs = mapMaybe (uncurry (><)) $ pair $ sortOn getInterval xs
where pair [] = []
pair [x] = []
pair (x : y : ys) = (x, y) : pair (y : ys)
-- | Returns the 'duration' of each 'Intervallic i a' in the 'Functor' @f@.
--
-- >>> durations [bi 9 1, bi 10 2, bi 1 5 :: Interval Int]
-- [9,10,1]
--
durations :: (Functor f, Intervallic i, SizedIv (Interval a)) => f (i a) -> f (Moment (Interval a))
durations = fmap (duration . getInterval)
-- | In the case that x y are not disjoint, clips y to the extent of x.
--
-- >>> clip (bi 5 0) ((bi 3 3) :: Interval Int)
-- Just (3, 5)
--
-- >>> clip (bi 3 0) ((bi 2 4) :: Interval Int)
-- Nothing
--
clip
:: (Intervallic i0, Intervallic i1, SizedIv (Interval a), Ord a, Ord (Moment (Interval a)))
=> i0 a
-> i1 a
-> Maybe (Interval a)
clip x y
| overlaps x y = Just $ safeInterval (begin y, end x)
| overlappedBy x y = Just $ safeInterval (begin x, end y)
| jx x y = Just (getInterval x)
| jy x y = Just (getInterval y)
| otherwise = Nothing {- disjoint x y case -}
where
jy = equals <|> startedBy <|> contains <|> finishedBy
jx = starts <|> during <|> finishes
{-# INLINABLE clip #-}
{- | Returns a list of intervals where any intervals that meet or share support
are combined into one interval. This function sorts the input. If you know the
input intervals are sorted, use @combineIntervalsLFromSorted@.
>>> x1 = bi 10 0
>>> x2 = bi 5 2
>>> x3 = bi 2 10
>>> x4 = bi 2 13
>>> ivs = [x1, x2, x3, x4]
>>> ivs
[(0, 10),(2, 7),(10, 12),(13, 15)]
>>> xComb = combineIntervals ivs
>>> xComb
[(0, 12),(13, 15)]
>>> :{
pretty $
standardExampleDiagram
(zip ivs ["x1", "x2", "x3", "x4"])
[(xComb, "xComb")]
:}
---------- <- [x1]
----- <- [x2]
-- <- [x3]
-- <- [x4]
------------ -- <- [xComb]
===============
-}
combineIntervals :: (SizedIv (Interval a), Intervallic i, Ord a) => [i a] -> [Interval a]
combineIntervals = combineIntervalsFromSorted . sortOn getInterval
{- | Returns a list of intervals where any intervals that meet or share support
are combined into one interval. The operation is applied cumulatively, from left
to right, so
__to work properly, the input list should be sorted in increasing order__.
>>> combineIntervalsFromSorted [bi 10 0, bi 5 2, bi 2 10, bi 2 13]
[(0, 12),(13, 15)]
>>> combineIntervalsFromSorted [bi 10 0, bi 5 2, bi 0 8]
[(0, 10)]
-}
combineIntervalsFromSorted
:: forall a i . (Ord a, Intervallic i, SizedIv (Interval a)) => [i a] -> [Interval a]
combineIntervalsFromSorted = reverse . foldl' op []
where
op [] y = [getInterval y]
op (x : xs) y = if x `before` y
-- Since x <= y, not (x `before` y) iff they meet or share support
then yiv : x : xs
else extenterval x yiv : xs
where yiv = getInterval y
{- | @Maybe@ form an @Interval a@ from @Control.Foldl t => t (Interval a)@
spanning the range of all intervals in the list, i.e. whose @begin@ is the
minimum of @begin@ across intervals in the list and whose @end@ is the maximum
of @end@.
>>> rangeInterval ([] :: [Interval Int])
Nothing
>>> x1 = bi 2 2
>>> x2 = bi 3 6
>>> x3 = bi 4 7
>>> ivs = [x1, x2, x3] :: [Interval Int]
>>> ivs
[(2, 4),(6, 9),(7, 11)]
>>> spanIv = rangeInterval ivs
>>> spanIv
Just (2, 11)
>>> :{
case spanIv of
Nothing -> pretty ""
(Just x) -> pretty $ standardExampleDiagram
(zip (ivs ++ [x]) ["x1", "x2", "x3", "spanIv"])
[]
:}
-- <- [x1]
--- <- [x2]
---- <- [x3]
--------- <- [spanIv]
===========
>>> rangeInterval (Nothing :: Maybe (Interval Int))
Nothing
>>> rangeInterval (Just (bi 1 0))
Just (0, 1)
-}
rangeInterval :: (L.Foldable t, Ord a, SizedIv (Interval a)) => t (Interval a) -> Maybe (Interval a)
rangeInterval = L.fold (liftA2 extenterval <$> L.minimum <*> L.maximum)
{- Combining intervals -}
-- | If @x@ is 'before' @y@, then form a new @Just Interval a@ from the
-- interval in the "gap" between @x@ and @y@ from the 'end' of @x@ to the
-- 'begin' of @y@. Otherwise, 'Nothing'.
(><) :: (Iv (Interval a), Ord (Moment (Interval a)), SizedIv (Interval a), Intervallic i) => i a -> i a -> Maybe (Interval a)
(><) x y
| x `before` y = Just $ safeInterval (end x, begin y)
| otherwise = Nothing
-- | Maybe form a new @Interval a@ by the union of two @Interval a@s that 'meets'.
(.+.) :: (Iv (Interval a), Ord (Moment (Interval a)), SizedIv (Interval a), Intervallic i) => i a -> i a -> Maybe (Interval a)
(.+.) x y
| x `meets` y = Just $ safeInterval (begin x, end y)
| otherwise = Nothing