{-|
Module      : Data.Interval
Description : Closed intervals of totally ordered types, e.g. time intervals
Copyright   : (c) Lackmann Phymetric
License     : GPL-3
Maintainer  : olaf.klinke@phymetric.de
Stability   : experimental

This module provides the two-parameter type class 'Interval' of types 
that represent closed intervals (meaning the end-points are included) 
possibly with some extra annotation. 
This approach is shared by the Data.IntervalMap.Generic.Interval module of the 
<https://hackage.haskell.org/package/IntervalMap IntervalMap> package. 
A particular use case are time intervals annotated with event data. 
The simplest example of an interval type @i@ with end points of type @e@ 
is the type @i = (e,e)@. 

The functions exported from this module are mainly concerned with overlap queries, 
that is, to identify which intervals in a collection overlap a given interval 
and if so, to what extent. 
This functionality is encapsuled in the class 'IntersectionQuery'. 
If the collection of intervals is known to overlap in end-points only, 
one can simply use a sequence ordered by left end-point as the search structure. 
For arbitrary collections we provide the 'ITree' structure 
(centered interval tree) which stores intervals in subtrees and bins 
that are annotated with their convex hull, so that it can be decided 
easily whether there is an interval inside which overlaps a given interval. 


The behaviour of the functions is undefined for intervals that 
violate the implicit assumption that the left end-point is less than or equal to 
the right end-point. 

The functionality provided is similar to the Interval data type in the  
<https://hackage.haskell.org/package/data-interval data-interval> package 
but we focus on closed intervals and let the user decide which 
concrete data type to use. 

Most functions are property-checked for correctness. 
Checks were implemented by Henning Thielemann. 
-}
{-# LANGUAGE FlexibleInstances,FlexibleContexts,FunctionalDependencies,MultiParamTypeClasses,CPP #-}
module Data.Interval (
    -- * Type classes

    Interval(..),
    IntersectionQuery(..),
    Adjust(..),
    TimeDifference(..),
    -- * Comparing intervals

    intersects,properlyIntersects,contains,properlyContains,
    covered,coveredBy,overlapTime,prevailing,fractionCovered,
    overlap,
    properOverlap,
    intervalDuration,
    -- * Operations on intervals

    maybeUnion,maybeIntersection,
    hull,
    hullSeq,
    without,
    contiguous,components,componentsSeq,
    sortByLeft,
    fromEndPoints,
    -- * Streaming intervals

    splitIntersecting,
    splitProperlyIntersecting,
    -- * Interval search tree

    ITree,
    itree,
    emptyITree,
    insert,
    hullOfTree,
    intersecting,getIntersectsIT,getProperIntersectsIT,
    someIntersectsIT,someProperlyIntersectsIT,
    leftmostInterval,
    -- * Non-overlapping intervals

    findSeq, existsSeq, hullSeqNonOverlap,
    -- * Debug

    invariant, toTree,
    -- * Testing

    intersectingProperly,
    filterM,
    joinSeq,
    splitSeq,
    ) where

import Data.Tree (Tree)
import qualified Data.Tree as Tree
import qualified Data.Sequence as Seq
import qualified Data.Monoid ((<>))
import Data.Traversable (Traversable)
import Data.Foldable (toList, maximumBy, foldl', foldr')
import Data.Sequence (Seq, ViewL(EmptyL,(:<)), ViewR(EmptyR,(:>)), (><), (<|))
import Data.Function (on)
import Data.Functor.Identity (Identity(Identity, runIdentity))
import Data.Maybe (catMaybes)
import Data.Time (UTCTime, addUTCTime, diffUTCTime, utc, NominalDiffTime)
#if MIN_VERSION_time(1,9,0)
import Data.Time (LocalTime, utcToLocalTime, zonedTimeToLocalTime, diffLocalTime, addLocalTime)
#else
import Data.Time (LocalTime, utcToLocalTime, zonedTimeToLocalTime)
#endif
import Data.Time (ZonedTime, localTimeToUTC, zonedTimeToUTC)
import Control.Arrow ((***))
import Control.Applicative (Alternative, empty, (<|>))


-- $setup

-- >>> import Data.IntervalTest

-- >>> import qualified Data.Sequence as Seq

-- >>> import qualified Data.List as List

-- >>> import Data.Function (on)

-- >>> import Data.Maybe (isJust, fromJust, catMaybes)

-- >>> import Data.Foldable (toList)

-- >>> import qualified Test.QuickCheck as QC

-- >>> import Test.QuickCheck ((==>))

-- >>> without' :: (Int,Int) -> (Int,Int) -> [(Int,Int)]; without' = without



-- | class of intervals with end points in a totally ordered type

class (Ord e) => Interval e i | i -> e where
    lb :: i -> e -- ^ lower bound

    lb = (e, e) -> e
forall a b. (a, b) -> a
fst((e, e) -> e) -> (i -> (e, e)) -> i -> e
forall b c a. (b -> c) -> (a -> b) -> a -> c
.i -> (e, e)
forall e i. Interval e i => i -> (e, e)
endPoints
    ub :: i -> e -- ^ upper bound

    ub = (e, e) -> e
forall a b. (a, b) -> b
snd((e, e) -> e) -> (i -> (e, e)) -> i -> e
forall b c a. (b -> c) -> (a -> b) -> a -> c
.i -> (e, e)
forall e i. Interval e i => i -> (e, e)
endPoints
    endPoints :: i -> (e,e) -- ^ end points (inclusive)

    endPoints i
i = (i -> e
forall e i. Interval e i => i -> e
lb i
i,i -> e
forall e i. Interval e i => i -> e
ub i
i)
    {-# MINIMAL (lb,ub) | endPoints #-}

instance (Ord e) => Interval e (e,e) where
    endPoints :: (e, e) -> (e, e)
endPoints = (e, e) -> (e, e)
forall a. a -> a
id

instance (Ord e) => Interval e (Identity e) where
    lb :: Identity e -> e
lb = Identity e -> e
forall a. Identity a -> a
runIdentity
    ub :: Identity e -> e
ub = Identity e -> e
forall a. Identity a -> a
runIdentity

-- | class of search structures for interval intersection queries,

-- returning a 'Foldable' of intervals.

class Foldable f => IntersectionQuery t e f | t -> f where
    getIntersects :: (Interval e i, Interval e j) => i -> t j -> f j
    -- ^ all intervalls touching the first one

    getProperIntersects :: (Interval e i, Interval e j) => i -> t j -> f j
    -- ^ all intervals properly intersecting the first one

    someIntersects :: (Interval e i, Interval e j) => i -> t j -> Bool
    -- ^ does any interval touch the first one?

    someProperlyIntersects :: (Interval e i, Interval e j) => i -> t j -> Bool
    -- ^ does any interval properly intersect the first one?

    maybeBounds :: Interval e i => t i -> Maybe (e,e)
    -- ^ the convex hull of the contents

instance Ord e => IntersectionQuery (ITree e) e Seq where
    getIntersects :: i -> ITree e j -> Seq j
getIntersects = i -> ITree e j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
i -> ITree e j -> Seq j
getIntersectsIT
    getProperIntersects :: i -> ITree e j -> Seq j
getProperIntersects = i -> ITree e j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
i -> ITree e j -> Seq j
getProperIntersectsIT
    someIntersects :: i -> ITree e j -> Bool
someIntersects = i -> ITree e j -> Bool
forall e i j.
(Interval e i, Interval e j) =>
i -> ITree e j -> Bool
someIntersectsIT
    someProperlyIntersects :: i -> ITree e j -> Bool
someProperlyIntersects = i -> ITree e j -> Bool
forall e i j.
(Interval e i, Interval e j) =>
i -> ITree e j -> Bool
someProperlyIntersectsIT
    maybeBounds :: ITree e i -> Maybe (e, e)
maybeBounds = ITree e i -> Maybe (e, e)
forall e i. Interval e i => ITree e i -> Maybe (e, e)
hullOfTree 
instance Ord e => IntersectionQuery Seq e Seq where
    getIntersects :: i -> Seq j -> Seq j
getIntersects = (i -> (e, e) -> Bool) -> i -> Seq j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
(i -> (e, e) -> Bool) -> i -> Seq j -> Seq j
findSeq i -> (e, e) -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
intersects
    getProperIntersects :: i -> Seq j -> Seq j
getProperIntersects = (i -> (e, e) -> Bool) -> i -> Seq j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
(i -> (e, e) -> Bool) -> i -> Seq j -> Seq j
findSeq i -> (e, e) -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
properlyIntersects
    someIntersects :: i -> Seq j -> Bool
someIntersects = (i -> (e, e) -> Bool) -> i -> Seq j -> Bool
forall e i j.
(Interval e i, Interval e j) =>
(i -> (e, e) -> Bool) -> i -> Seq j -> Bool
existsSeq i -> (e, e) -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
intersects
    someProperlyIntersects :: i -> Seq j -> Bool
someProperlyIntersects = (i -> (e, e) -> Bool) -> i -> Seq j -> Bool
forall e i j.
(Interval e i, Interval e j) =>
(i -> (e, e) -> Bool) -> i -> Seq j -> Bool
existsSeq i -> (e, e) -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
properlyIntersects
    maybeBounds :: Seq i -> Maybe (e, e)
maybeBounds = Seq i -> Maybe (e, e)
forall e i. Interval e i => Seq i -> Maybe (e, e)
hullSeqNonOverlap 

-- | Time types supporting differences

class TimeDifference t where
    diffTime :: t -> t -> NominalDiffTime
    addTime :: NominalDiffTime -> t -> t
instance TimeDifference UTCTime where
    diffTime :: UTCTime -> UTCTime -> NominalDiffTime
diffTime = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime
    addTime :: NominalDiffTime -> UTCTime -> UTCTime
addTime  = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime
#if MIN_VERSION_time(1,9,0)
instance TimeDifference LocalTime where
    diffTime :: LocalTime -> LocalTime -> NominalDiffTime
diffTime = LocalTime -> LocalTime -> NominalDiffTime
diffLocalTime
    addTime :: NominalDiffTime -> LocalTime -> LocalTime
addTime  = NominalDiffTime -> LocalTime -> LocalTime
addLocalTime
#else
instance TimeDifference LocalTime where
    diffTime x y = diffUTCTime (localTimeToUTC utc x) (localTimeToUTC utc y)
    addTime x = utcToLocalTime utc . addUTCTime x . localTimeToUTC utc
#endif
-- | 'addTime' preserves the 'TimeZone'

instance TimeDifference ZonedTime where
    diffTime :: ZonedTime -> ZonedTime -> NominalDiffTime
diffTime ZonedTime
x ZonedTime
y = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime (ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
x) (ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
y)
    addTime :: NominalDiffTime -> ZonedTime -> ZonedTime
addTime NominalDiffTime
x ZonedTime
z = ZonedTime
z {zonedTimeToLocalTime :: LocalTime
zonedTimeToLocalTime = NominalDiffTime -> LocalTime -> LocalTime
forall t. TimeDifference t => NominalDiffTime -> t -> t
addTime NominalDiffTime
x (ZonedTime -> LocalTime
zonedTimeToLocalTime ZonedTime
z)}

-- | Convenience function, the 'diffTime' between the 'endPoints'.

intervalDuration :: (TimeDifference t, Interval t i) => i -> NominalDiffTime
intervalDuration :: i -> NominalDiffTime
intervalDuration i
i = t -> t -> NominalDiffTime
forall t. TimeDifference t => t -> t -> NominalDiffTime
diffTime (i -> t
forall e i. Interval e i => i -> e
ub i
i) (i -> t
forall e i. Interval e i => i -> e
lb i
i)

-- | Find out the overlap of two time intervals.

--

-- prop> genInterval /\ \i -> overlapTime i i == intervalDuration i

-- prop> genInterval /\* \i j -> not (i `properlyIntersects` j) ==> overlapTime i j == 0

-- prop> genInterval /\* \i j -> overlapTime i j == (sum $ fmap intervalDuration $ maybeIntersection i j)

overlapTime :: (TimeDifference t, Interval t i, Interval t j) =>
    i -> j -> NominalDiffTime
overlapTime :: i -> j -> NominalDiffTime
overlapTime i
i j
j = let
    x :: t
x = t -> t -> t
forall a. Ord a => a -> a -> a
max (i -> t
forall e i. Interval e i => i -> e
lb i
i) (j -> t
forall e i. Interval e i => i -> e
lb j
j)
    y :: t
y = t -> t -> t
forall a. Ord a => a -> a -> a
min (i -> t
forall e i. Interval e i => i -> e
ub i
i) (j -> t
forall e i. Interval e i => i -> e
ub j
j)
    in if t
x t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
y then t -> t -> NominalDiffTime
forall t. TimeDifference t => t -> t -> NominalDiffTime
diffTime t
y t
x else NominalDiffTime
0

-- | Prevailing annotation in the first time interval

--

-- prop> genInterval /\ \i c -> prevailing i (Seq.singleton (c,i)) == Just (c::Char)

-- prop> genInterval /\ \i -> genLabeledSeq /\ \js -> isJust (prevailing i js) == any (intersects i . snd) js

-- prop> genInterval /\ \i -> genLabeledSeq /\* \js ks -> all (flip elem $ catMaybes [prevailing i js, prevailing i ks]) $ prevailing i (js<>ks)

prevailing :: (Interval t i, Interval t j, TimeDifference t) =>
    i -> Seq (a,j) -> Maybe a
prevailing :: i -> Seq (a, j) -> Maybe a
prevailing i
i Seq (a, j)
js =
    let ks :: Seq (a, j)
ks = ((a, j) -> Bool) -> Seq (a, j) -> Seq (a, j)
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (i -> j -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
intersects i
i (j -> Bool) -> ((a, j) -> j) -> (a, j) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, j) -> j
forall a b. (a, b) -> b
snd) Seq (a, j)
js
    in  if Seq (a, j) -> Bool
forall a. Seq a -> Bool
Seq.null Seq (a, j)
ks
            then Maybe a
forall a. Maybe a
Nothing
            else a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ (a, j) -> a
forall a b. (a, b) -> a
fst ((a, j) -> a) -> (a, j) -> a
forall a b. (a -> b) -> a -> b
$ ((a, j) -> (a, j) -> Ordering) -> Seq (a, j) -> (a, j)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (NominalDiffTime -> NominalDiffTime -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (NominalDiffTime -> NominalDiffTime -> Ordering)
-> ((a, j) -> NominalDiffTime) -> (a, j) -> (a, j) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (i -> j -> NominalDiffTime
forall t i j.
(TimeDifference t, Interval t i, Interval t j) =>
i -> j -> NominalDiffTime
overlapTime i
i (j -> NominalDiffTime)
-> ((a, j) -> j) -> (a, j) -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, j) -> j
forall a b. (a, b) -> b
snd)) Seq (a, j)
ks
            -- ExtPkg: non-empty - partial maximumBy -> NonEmpty.maximumBy



-- | class of Intervals whose bounds can be adjusted

class Interval e i => Adjust e i | i -> e where
    adjustBounds :: (e -> e) -> (e -> e) -> i -> i -- ^  adjust lower and upper bound

    shift :: (e -> e) -> i -> i -- ^ change both bounds using the same function

    shift e -> e
f = (e -> e) -> (e -> e) -> i -> i
forall e i. Adjust e i => (e -> e) -> (e -> e) -> i -> i
adjustBounds e -> e
f e -> e
f
    {-# MINIMAL (adjustBounds) #-}

instance Ord e => Adjust e (e,e) where
    adjustBounds :: (e -> e) -> (e -> e) -> (e, e) -> (e, e)
adjustBounds e -> e
f e -> e
g (e
x,e
y) = (e -> e
f e
x,e -> e
g e
y)

-- | the union of two intervals is an interval if they intersect.

--

-- prop> genInterval /\* \i j -> isJust (maybeUnion i j) ==> fromJust (maybeUnion i j) `contains` i && fromJust (maybeUnion i j) `contains` j

-- prop> genInterval /\* \i j -> i `intersects` j ==> (maybeUnion i j >>= maybeIntersection i) == Just i

maybeUnion :: (Interval e j, Interval e i, Adjust e i) => j -> i -> Maybe i
maybeUnion :: j -> i -> Maybe i
maybeUnion j
j i
i = if j
j j -> i -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`intersects` i
i
    then i -> Maybe i
forall a. a -> Maybe a
Just ((e -> e) -> (e -> e) -> i -> i
forall e i. Adjust e i => (e -> e) -> (e -> e) -> i -> i
adjustBounds (e -> e -> e
forall a. Ord a => a -> a -> a
min (j -> e
forall e i. Interval e i => i -> e
lb j
j)) (e -> e -> e
forall a. Ord a => a -> a -> a
max (j -> e
forall e i. Interval e i => i -> e
ub j
j)) i
i)
    else Maybe i
forall a. Maybe a
Nothing

-- | the intersection of two intervals is either empty or an interval.

--

-- prop> genInterval /\* \i j -> i `intersects` j ==> i `contains` fromJust (maybeIntersection i j)

maybeIntersection :: (Interval e j, Interval e i, Adjust e i) => j -> i -> Maybe i
maybeIntersection :: j -> i -> Maybe i
maybeIntersection j
j i
i = if j
j j -> i -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`intersects` i
i
    then i -> Maybe i
forall a. a -> Maybe a
Just ((e -> e) -> (e -> e) -> i -> i
forall e i. Adjust e i => (e -> e) -> (e -> e) -> i -> i
adjustBounds (e -> e -> e
forall a. Ord a => a -> a -> a
max (j -> e
forall e i. Interval e i => i -> e
lb j
j)) (e -> e -> e
forall a. Ord a => a -> a -> a
min (j -> e
forall e i. Interval e i => i -> e
ub j
j)) i
i)
    else Maybe i
forall a. Maybe a
Nothing

-- | convex hull

--

-- prop> \xs -> isJust (hull xs) ==> all (\x -> fromJust (hull xs) `contains` x) (xs :: [(Int,Int)])

hull :: (Interval e i,Foldable f,Functor f) => f i -> Maybe (e,e)
hull :: f i -> Maybe (e, e)
hull f i
xs = if f i -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f i
xs
    then Maybe (e, e)
forall a. Maybe a
Nothing
    else (e, e) -> Maybe (e, e)
forall a. a -> Maybe a
Just (f e -> e
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((i -> e) -> f i -> f e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap i -> e
forall e i. Interval e i => i -> e
lb f i
xs), f e -> e
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((i -> e) -> f i -> f e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap i -> e
forall e i. Interval e i => i -> e
ub f i
xs))

-- | Set difference. The resulting list has zero, one or two elements.

--

-- >>> without' (1,5) (4,5)

-- [(1,4)]

-- >>> without' (1,5) (2,3)

-- [(1,2),(3,5)]

-- >>> without' (1,5) (1,5)

-- []

-- >>> without' (1,5) (0,1)

-- [(1,5)]

--

-- prop> genInterval /\* \i j -> length (i `without` j) <= 2

-- prop> genInterval /\ \i -> i `without` i == []

-- prop> genInterval /\* \i j -> all (contains i) (i `without` j)

-- prop> genInterval /\* \i j -> not $ any (properlyIntersects j) (i `without` j)

without :: (Adjust e i,Interval e j) => i -> j -> [i]
without :: i -> j -> [i]
without i
i j
j = if j
j j -> i -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`contains` i
i then [] else
    if j -> e
forall e i. Interval e i => i -> e
ub j
j e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= i -> e
forall e i. Interval e i => i -> e
lb i
i Bool -> Bool -> Bool
|| j -> e
forall e i. Interval e i => i -> e
lb j
j e -> e -> Bool
forall a. Ord a => a -> a -> Bool
>= i -> e
forall e i. Interval e i => i -> e
ub i
i
        then [i
i] -- intervals don't overlap

        else if i
i i -> j -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`properlyContains` j
j
            then [(e -> e) -> (e -> e) -> i -> i
forall e i. Adjust e i => (e -> e) -> (e -> e) -> i -> i
adjustBounds e -> e
forall a. a -> a
id (e -> e -> e
forall a b. a -> b -> a
const (j -> e
forall e i. Interval e i => i -> e
lb j
j)) i
i,(e -> e) -> (e -> e) -> i -> i
forall e i. Adjust e i => (e -> e) -> (e -> e) -> i -> i
adjustBounds (e -> e -> e
forall a b. a -> b -> a
const (j -> e
forall e i. Interval e i => i -> e
ub j
j)) e -> e
forall a. a -> a
id i
i] -- slashed in half

            else if j -> e
forall e i. Interval e i => i -> e
lb j
j e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= i -> e
forall e i. Interval e i => i -> e
lb i
i
                then [(e -> e) -> (e -> e) -> i -> i
forall e i. Adjust e i => (e -> e) -> (e -> e) -> i -> i
adjustBounds (e -> e -> e
forall a b. a -> b -> a
const (j -> e
forall e i. Interval e i => i -> e
ub j
j)) e -> e
forall a. a -> a
id i
i] -- j overhangs on the left

                else [(e -> e) -> (e -> e) -> i -> i
forall e i. Adjust e i => (e -> e) -> (e -> e) -> i -> i
adjustBounds e -> e
forall a. a -> a
id (e -> e -> e
forall a b. a -> b -> a
const (j -> e
forall e i. Interval e i => i -> e
lb j
j)) i
i] -- j overhangs on the right


-- | 'intersects' is not an equivalence relation, because it is not transitive.

-- Hence 'groupBy' 'intersects' does not do what one might expect.

-- This function does the expected and groups overlapping intervals

-- into contiguous blocks.

--

-- prop> genSortedIntervals /\ all (\xs -> and $ List.zipWith intersects xs (tail xs)) . contiguous

contiguous :: Interval e i => [i] -> [[i]]
contiguous :: [i] -> [[i]]
contiguous [] = []
contiguous (i
i:[i]
is) = (i
ii -> [i] -> [i]
forall a. a -> [a] -> [a]
:[i]
js) [i] -> [[i]] -> [[i]]
forall a. a -> [a] -> [a]
: [i] -> [[i]]
forall e i. Interval e i => [i] -> [[i]]
contiguous [i]
ks where
    ([i]
js,[i]
ks) = (e, e) -> [i] -> ([i], [i])
forall e i. Interval e i => (e, e) -> [i] -> ([i], [i])
go (i -> (e, e)
forall e i. Interval e i => i -> (e, e)
endPoints i
i) [i]
is
    go :: Interval e i => (e,e) -> [i] -> ([i],[i])
    go :: (e, e) -> [i] -> ([i], [i])
go j :: (e, e)
j@(e
x,e
_y) ls :: [i]
ls@(i
l:[i]
ls') = if (e, e)
j (e, e) -> i -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`intersects` i
l
        then let ([i]
foo,[i]
bar) = (e, e) -> [i] -> ([i], [i])
forall e i. Interval e i => (e, e) -> [i] -> ([i], [i])
go (e
x,i -> e
forall e i. Interval e i => i -> e
ub i
l) [i]
ls' in (i
li -> [i] -> [i]
forall a. a -> [a] -> [a]
:[i]
foo,[i]
bar)
        else ([],[i]
ls)
    go (e, e)
_ [] = ([],[])

-- | Connected components of a list sorted by 'sortByLeft',

-- akin to 'groupBy' 'intersects'.

-- The precondition is not checked.

--

-- prop> genSortedIntervals /\ \xs -> all (\i -> any (flip contains i) (components xs)) xs

components :: (Interval e i, Adjust e i) => [i] -> [i]
components :: [i] -> [i]
components [] = []
components (i
i:[i]
is) = i -> [i] -> [i]
forall e t. Adjust e t => t -> [t] -> [t]
c i
i [i]
is where
    c :: t -> [t] -> [t]
c t
x [] = [t
x]
    c t
x (t
y:[t]
ys) = case t -> t -> Maybe t
forall e j i.
(Interval e j, Interval e i, Adjust e i) =>
j -> i -> Maybe i
maybeUnion t
x t
y of
        Maybe t
Nothing -> t
x t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t] -> [t]
c t
y [t]
ys
        Just t
z  -> t -> [t] -> [t]
c t
z [t]
ys

-- | same as 'components'. Is there a way to unify both?

--

-- prop> genSortedIntervals /\ \xs -> componentsSeq (Seq.fromList xs) == Seq.fromList (components xs)

componentsSeq :: (Interval e i, Adjust e i) => Seq i -> Seq i
componentsSeq :: Seq i -> Seq i
componentsSeq Seq i
ys = case Seq i -> ViewL i
forall a. Seq a -> ViewL a
Seq.viewl Seq i
ys of
    ViewL i
EmptyL  -> Seq i
forall (f :: * -> *) a. Alternative f => f a
empty
    i
x :< Seq i
xs -> i -> Seq i -> Seq i
forall e t. Adjust e t => t -> Seq t -> Seq t
c i
x Seq i
xs where
        c :: t -> Seq t -> Seq t
c t
a Seq t
bs = case Seq t -> ViewL t
forall a. Seq a -> ViewL a
Seq.viewl Seq t
bs of
            ViewL t
EmptyL  -> t -> Seq t
forall a. a -> Seq a
Seq.singleton t
a
            t
b :< Seq t
bs' -> case t -> t -> Maybe t
forall e j i.
(Interval e j, Interval e i, Adjust e i) =>
j -> i -> Maybe i
maybeUnion t
a t
b of
                Maybe t
Nothing -> t
a t -> Seq t -> Seq t
forall a. a -> Seq a -> Seq a
<| t -> Seq t -> Seq t
c t
b Seq t
bs'
                Just t
ab -> t -> Seq t -> Seq t
c t
ab Seq t
bs'

-- | compute the components of the part of @i@ covered by the intervals.

--

-- prop> genInterval /\ \i -> genIntervalSeq /\ \js -> all (contains i) (covered i js)

-- prop> genInterval /\ \i -> genIntervalSeq /\ \js -> covered i (covered i js) == covered i js

covered :: (Interval e i,Interval e j,Adjust e j) => i -> Seq j -> Seq j
covered :: i -> Seq j -> Seq j
covered i
i =
    let mapMaybe :: (a -> t a) -> t a -> Seq a
mapMaybe a -> t a
f = (a -> Seq a) -> t a -> Seq a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> Seq a) -> t a -> Seq a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Seq a
forall a. a -> Seq a
Seq.singleton (t a -> Seq a) -> (a -> t a) -> a -> Seq a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t a
f)
    in  Seq j -> Seq j
forall e i. (Interval e i, Adjust e i) => Seq i -> Seq i
componentsSeq (Seq j -> Seq j) -> (Seq j -> Seq j) -> Seq j -> Seq j
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq j -> Seq j
forall e i. Interval e i => Seq i -> Seq i
sortByLeft (Seq j -> Seq j) -> (Seq j -> Seq j) -> Seq j -> Seq j
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (j -> Maybe j) -> Seq j -> Seq j
forall (t :: * -> *) (t :: * -> *) a a.
(Foldable t, Foldable t) =>
(a -> t a) -> t a -> Seq a
mapMaybe (i -> j -> Maybe j
forall e j i.
(Interval e j, Interval e i, Adjust e i) =>
j -> i -> Maybe i
maybeIntersection i
i)

-- | 'True' if the first interval is completely covered by the given intervals

--

-- prop> genInterval /\* \i j -> j `contains` i == i `coveredBy` [j]

-- prop> genInterval /\ \i -> genSortedIntervals /\ \js -> i `coveredBy` js ==> any (flip contains i) (components js)

coveredBy :: (Interval e i, Interval e j, Foldable f) => i -> f j -> Bool
i
i coveredBy :: i -> f j -> Bool
`coveredBy` f j
js = [(e, e)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(e, e)] -> Bool) -> [(e, e)] -> Bool
forall a b. (a -> b) -> a -> b
$ ([(e, e)] -> j -> [(e, e)]) -> [(e, e)] -> f j -> [(e, e)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[(e, e)]
remains j
j -> ((e, e) -> j -> [(e, e)]) -> j -> (e, e) -> [(e, e)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (e, e) -> j -> [(e, e)]
forall e i j. (Adjust e i, Interval e j) => i -> j -> [i]
without j
j ((e, e) -> [(e, e)]) -> [(e, e)] -> [(e, e)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(e, e)]
remains) [i -> (e, e)
forall e i. Interval e i => i -> (e, e)
endPoints i
i] f j
js

-- | percentage of coverage of the first interval by the second sequence of intervals

--

-- prop> genNonEmptyInterval /\ \i -> genIntervalSeq /\ \js -> i `coveredBy` js == (fractionCovered i js >= (1::Rational))

-- prop> genNonEmptyInterval /\ \i -> genNonEmptyIntervalSeq /\ \js -> any (properlyIntersects i) js == (fractionCovered i js > (0::Rational))

fractionCovered :: (TimeDifference t, Interval t i, Interval t j, Fractional a) =>
    j -> Seq i -> a
fractionCovered :: j -> Seq i -> a
fractionCovered j
i Seq i
xs = let
    totalTime :: NominalDiffTime
totalTime   = j -> NominalDiffTime
forall t i.
(TimeDifference t, Interval t i) =>
i -> NominalDiffTime
intervalDuration j
i
    coveredTime :: NominalDiffTime
coveredTime = (NominalDiffTime -> (t, t) -> NominalDiffTime)
-> NominalDiffTime -> Seq (t, t) -> NominalDiffTime
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\NominalDiffTime
s (t, t)
j -> NominalDiffTime
s NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ (t, t) -> NominalDiffTime
forall t i.
(TimeDifference t, Interval t i) =>
i -> NominalDiffTime
intervalDuration (t, t)
j) NominalDiffTime
0 (Seq (t, t) -> NominalDiffTime) -> Seq (t, t) -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ j -> Seq (t, t) -> Seq (t, t)
forall e i j.
(Interval e i, Interval e j, Adjust e j) =>
i -> Seq j -> Seq j
covered j
i (Seq (t, t) -> Seq (t, t)) -> Seq (t, t) -> Seq (t, t)
forall a b. (a -> b) -> a -> b
$ (i -> (t, t)) -> Seq i -> Seq (t, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap i -> (t, t)
forall e i. Interval e i => i -> (e, e)
endPoints Seq i
xs
    -- ^ sum of the lengths of the interections with i

    in if NominalDiffTime
totalTimeNominalDiffTime -> NominalDiffTime -> Bool
forall a. Eq a => a -> a -> Bool
==NominalDiffTime
0 then a
1 else (Rational -> a
forall a. Fractional a => Rational -> a
fromRational(Rational -> a)
-> (NominalDiffTime -> Rational) -> NominalDiffTime -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational) (NominalDiffTime
coveredTimeNominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/NominalDiffTime
totalTime) -- (fromInteger (round (coveredTime*100/totalTime)))/100


-- | Overlap ordering. Returns 'LT' or 'GT' if the intervals are disjoint,

-- 'EQ' if the intervals overlap.

-- Note that this violates the following property:

--

-- @

-- 'overlap' x y == 'EQ' && 'overlap' y z == 'EQ' => 'overlap' x z == 'EQ'

-- @

--

-- i.e., 'overlap' is not transitive.

--

-- prop> genInterval /\* \i j -> i `intersects` j  ==  (overlap i j == EQ)

overlap :: (Interval e i, Interval e j) => i -> j -> Ordering
overlap :: i -> j -> Ordering
overlap i
i j
j = case (e -> e -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (i -> e
forall e i. Interval e i => i -> e
ub i
i) (j -> e
forall e i. Interval e i => i -> e
lb j
j),e -> e -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (j -> e
forall e i. Interval e i => i -> e
ub j
j) (i -> e
forall e i. Interval e i => i -> e
lb i
i)) of
    (Ordering
LT,Ordering
_) -> Ordering
LT
    (Ordering
_,Ordering
LT) -> Ordering
GT
    (Ordering, Ordering)
_      -> Ordering
EQ

-- | Overlap ordering. Returns 'LT' or 'GT' if the intervals 

-- are disjoint or touch in end point(s) only,

-- 'EQ' if the intervals properly overlap.

-- Note that this violates the following property:

--

-- @

-- 'properOverlap' x y == 'EQ' && 'properOverlap' y z == 'EQ' => 'properOverlap' x z == 'EQ'

-- @

--

-- i.e., 'properOverlap' is not transitive.

--

-- prop> genInterval /\* \i j -> i `properlyIntersects` j  ==  (properOverlap i j == EQ)

properOverlap :: (Interval e i, Interval e j) => i -> j -> Ordering
properOverlap :: i -> j -> Ordering
properOverlap i
i j
j = case ((i -> e
forall e i. Interval e i => i -> e
ub i
i) e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= (j -> e
forall e i. Interval e i => i -> e
lb j
j),(j -> e
forall e i. Interval e i => i -> e
ub j
j) e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= (i -> e
forall e i. Interval e i => i -> e
lb i
i)) of
    (Bool
True,Bool
_) -> Ordering
LT
    (Bool
_,Bool
True) -> Ordering
GT
    (Bool, Bool)
_      -> Ordering
EQ

-- | intersection query.

--

-- >>> ((1,2)::(Int,Int)) `intersects` ((2,3)::(Int,Int))

-- True

--

-- prop> genInterval /\* \i j -> (lb i <= ub i && lb j <= ub j && i `intersects` j)  ==  (max (lb i) (lb j) <= min (ub i) (ub j))

intersects :: (Interval e i,Interval e j) => i -> j -> Bool
i
i intersects :: i -> j -> Bool
`intersects` j
j = Bool -> Bool
not (i -> e
forall e i. Interval e i => i -> e
ub i
i e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< j -> e
forall e i. Interval e i => i -> e
lb j
j Bool -> Bool -> Bool
|| j -> e
forall e i. Interval e i => i -> e
ub j
j e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< i -> e
forall e i. Interval e i => i -> e
lb i
i)
-- The definition of 'intersects' yields the following algorithm

-- for intersection queries.

-- Given the query interval i, sort the list of possible intersecting intervals

-- by 'ub' and consider the suffix of intervals j with lb i <= ub j.

-- Sort that suffix by 'lb' and take the prefix with lb j <= ub i.


-- | proper intersection.

--

-- prop> genInterval /\* \i j -> ((i `intersects` j) && not (i `properlyIntersects` j))  ==  (ub i == lb j || ub j == lb i)

properlyIntersects :: (Interval e i,Interval e j) => i -> j -> Bool
i
i properlyIntersects :: i -> j -> Bool
`properlyIntersects` j
j = Bool -> Bool
not (i -> e
forall e i. Interval e i => i -> e
ub i
i e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= j -> e
forall e i. Interval e i => i -> e
lb j
j Bool -> Bool -> Bool
|| j -> e
forall e i. Interval e i => i -> e
ub j
j e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= i -> e
forall e i. Interval e i => i -> e
lb i
i)

-- | subset containment

--

-- prop> genInterval /\ \i -> i `contains` i

-- prop> genInterval /\* \i j -> (i `contains` j && j `contains` i) == (i==j)

-- prop> genInterval /\* \i j -> i `contains` j == (maybeUnion i j == Just i)

contains :: (Interval e i,Interval e j) => i -> j -> Bool
i
i contains :: i -> j -> Bool
`contains` j
j = i -> e
forall e i. Interval e i => i -> e
lb i
i e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= j -> e
forall e i. Interval e i => i -> e
lb j
j Bool -> Bool -> Bool
&& j -> e
forall e i. Interval e i => i -> e
ub j
j e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= i -> e
forall e i. Interval e i => i -> e
ub i
i

-- | proper subset containment

properlyContains :: (Interval e i,Interval e j) => i -> j -> Bool
i
i properlyContains :: i -> j -> Bool
`properlyContains` j
j = i -> e
forall e i. Interval e i => i -> e
lb i
i e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< j -> e
forall e i. Interval e i => i -> e
lb j
j Bool -> Bool -> Bool
&& i -> e
forall e i. Interval e i => i -> e
ub i
i e -> e -> Bool
forall a. Ord a => a -> a -> Bool
> j -> e
forall e i. Interval e i => i -> e
ub j
j

-- | construct a sorted sequence of intervals

-- from a sorted sequence of bounds.

-- Fails if the input sequence is not sorted.

--

-- prop> genSortedList /\ \xs -> (components $ toList $ fromEndPoints xs) == if length xs < 2 then [] else [(head xs, last xs)]

fromEndPoints :: (Ord e) => [e] -> Seq (e,e)
fromEndPoints :: [e] -> Seq (e, e)
fromEndPoints [] = Seq (e, e)
forall (f :: * -> *) a. Alternative f => f a
empty
fromEndPoints [e
_] = Seq (e, e)
forall (f :: * -> *) a. Alternative f => f a
empty
fromEndPoints [e
x,e
y] = if e
x e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
y then (e, e) -> Seq (e, e)
forall a. a -> Seq a
Seq.singleton (e
x,e
y) else [Char] -> Seq (e, e)
forall a. HasCallStack => [Char] -> a
error [Char]
"unsorted list"
fromEndPoints (e
x:[e]
xs) = let s :: Seq (e, e)
s  = [e] -> Seq (e, e)
forall e. Ord e => [e] -> Seq (e, e)
fromEndPoints [e]
xs in case Seq (e, e) -> ViewL (e, e)
forall a. Seq a -> ViewL a
Seq.viewl Seq (e, e)
s of
    (e
y,e
_) :< Seq (e, e)
_ -> (e
x,e
y) (e, e) -> Seq (e, e) -> Seq (e, e)
forall a. a -> Seq a -> Seq a
<| Seq (e, e)
s
    ViewL (e, e)
EmptyL     -> [Char] -> Seq (e, e)
forall a. HasCallStack => [Char] -> a
error [Char]
"Intervals.fromEndPoints: this should never happen"

-- | lexicographical sort by 'lb', then inverse 'ub'.

-- In the resulting list, the intervals intersecting

-- a given interval form a contiguous sublist.

--

-- prop> genInterval /\ \i -> genSortedIntervalSeq /\ \js -> toList (getIntersects i js) `List.isSubsequenceOf` toList js

sortByLeft :: (Interval e i) => Seq i -> Seq i
sortByLeft :: Seq i -> Seq i
sortByLeft = (i -> i -> Ordering) -> Seq i -> Seq i
forall a. (a -> a -> Ordering) -> Seq a -> Seq a
Seq.sortBy (\i
i i
j -> e -> e -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (i -> e
forall e i. Interval e i => i -> e
lb i
i) (i -> e
forall e i. Interval e i => i -> e
lb i
j) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> e -> e -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (i -> e
forall e i. Interval e i => i -> e
ub i
j) (i -> e
forall e i. Interval e i => i -> e
ub i
i))

-- | extract all intervals intersecting a given one.

intersecting :: (Interval e i,Interval e j) => j -> Seq i -> Seq i
intersecting :: j -> Seq i -> Seq i
intersecting j
j = (i -> Bool) -> Seq i -> Seq i
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (j -> i -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
intersects j
j)

-- | extract all intervals properly intersecting a given one.

intersectingProperly :: (Interval e i,Interval e j) => j -> Seq i -> Seq i
intersectingProperly :: j -> Seq i -> Seq i
intersectingProperly j
j = (i -> Bool) -> Seq i -> Seq i
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (j -> i -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
properlyIntersects j
j)
--intersectingProperly j = (takeWhileL (properlyIntersects j)).(dropWhileL (not.(properlyIntersects j)))


-- | convex hull of a sorted sequence of intervals.

-- the lower bound is guaranteed to be in the leftmost interval,

-- but we have no guarantee of the upper bound.

--

-- prop> genSortedIntervalSeq /\ \xs -> hullSeq xs == hull (toList xs)

hullSeq :: Interval e i => Seq i -> Maybe (e,e)
hullSeq :: Seq i -> Maybe (e, e)
hullSeq Seq i
xs = case Seq i -> ViewL i
forall a. Seq a -> ViewL a
Seq.viewl Seq i
xs of
    ViewL i
EmptyL -> Maybe (e, e)
forall a. Maybe a
Nothing
    i
leftmost :< Seq i
_others -> (e, e) -> Maybe (e, e)
forall a. a -> Maybe a
Just (i -> e
forall e i. Interval e i => i -> e
lb i
leftmost, Seq e -> e
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((i -> e) -> Seq i -> Seq e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap i -> e
forall e i. Interval e i => i -> e
ub Seq i
xs))

-- | When you face the problem of matching two series of intervals against each other, 

-- a streaming approach might be more efficient than transforming 

-- one of the streams into a search structure. 

-- This function drops intervals from the list until 

-- the (contiguous, see 'sortByLeft') block of intersecting intervals 

-- is found. This block (except intervals containing the 'ub' of the query) 

-- is removed from the stream. 

-- When used as a state transformer on a stream @[i]@ of non-properly overlapping intervals, 

-- then one obtains the stream of blocks intersecting the stream of queries. 

-- 

-- >>> splitIntersecting ((2,5) :: (Int,Int)) ([(0,1),(2,3),(2,2),(3,6),(6,7)] :: [(Int,Int)])

-- ([(2,3),(2,2),(3,6)],[(3,6),(6,7)])

--

-- prop> genInterval /\ \i -> genSortedIntervals /\ \js -> fst (splitIntersecting i js) == filter (intersects i) js

-- prop> genInterval /\ \i -> genSortedIntervals /\ \js -> all (\j -> not (ub j < ub i)) (snd (splitIntersecting i js))

splitIntersecting :: (Interval e i, Interval e j) => i -> [j] -> ([j],[j])
splitIntersecting :: i -> [j] -> ([j], [j])
splitIntersecting i
_ [] = ([],[])
splitIntersecting i
i js :: [j]
js@(j
j:[j]
js') = case i
i i -> j -> Ordering
forall e i j. (Interval e i, Interval e j) => i -> j -> Ordering
`overlap` j
j of
    Ordering
GT -> i -> [j] -> ([j], [j])
forall e i j.
(Interval e i, Interval e j) =>
i -> [j] -> ([j], [j])
splitIntersecting i
i [j]
js'
    Ordering
LT -> ([],[j]
js)
    Ordering
EQ -> let 
        keep :: Bool
keep = j -> e
forall e i. Interval e i => i -> e
ub j
j e -> e -> Bool
forall a. Ord a => a -> a -> Bool
>= i -> e
forall e i. Interval e i => i -> e
ub i
i
        ([j]
block,[j]
notIntersecting) = i -> [j] -> ([j], [j])
forall e i j.
(Interval e i, Interval e j) =>
i -> [j] -> ([j], [j])
splitIntersecting i
i [j]
js'
        in (j
jj -> [j] -> [j]
forall a. a -> [a] -> [a]
:[j]
block,if Bool
keep then j
jj -> [j] -> [j]
forall a. a -> [a] -> [a]
:[j]
notIntersecting else [j]
notIntersecting)

-- | Like 'splitIntersecting' but disregards those intervals 

-- that merely touch the query. 

-- Retains overlapping intervals properly containing the 'ub' of the query. 

-- When used as a state transformer on an ascending stream @[i]@ of non-properly overlapping intervals, 

-- then one obtains the stream of blocks properly intersecting the stream of queries.

-- 

-- >>> splitProperlyIntersecting ((2,5) :: (Int,Int))  ([(0,1),(2,3),(2,2),(3,5),(5,6),(6,7)] :: [(Int,Int)])

-- ([(2,3),(3,5)],[(5,6),(6,7)])

--

-- prop> genInterval /\ \i -> genSortedIntervals /\ \js -> fst (splitProperlyIntersecting i js) == filter (properlyIntersects i) js

-- prop> genInterval /\ \i -> genSortedIntervals /\ \js -> all (not.contains i) (snd (splitProperlyIntersecting i js))

splitProperlyIntersecting :: (Interval e i, Interval e j) => i -> [j] -> ([j],[j])
splitProperlyIntersecting :: i -> [j] -> ([j], [j])
splitProperlyIntersecting i
_ [] = ([],[])
splitProperlyIntersecting i
i js :: [j]
js@(j
j:[j]
js') = case i
i i -> j -> Ordering
forall e i j. (Interval e i, Interval e j) => i -> j -> Ordering
`properOverlap` j
j of
    Ordering
GT -> i -> [j] -> ([j], [j])
forall e i j.
(Interval e i, Interval e j) =>
i -> [j] -> ([j], [j])
splitProperlyIntersecting i
i [j]
js'
    Ordering
LT -> ([],[j]
js)
    Ordering
EQ -> let 
        keep :: Bool
keep = j -> e
forall e i. Interval e i => i -> e
ub j
j e -> e -> Bool
forall a. Ord a => a -> a -> Bool
> i -> e
forall e i. Interval e i => i -> e
ub i
i
        ([j]
block,[j]
notIntersecting) = i -> [j] -> ([j], [j])
forall e i j.
(Interval e i, Interval e j) =>
i -> [j] -> ([j], [j])
splitProperlyIntersecting i
i [j]
js'
        in (j
jj -> [j] -> [j]
forall a. a -> [a] -> [a]
:[j]
block,if Bool
keep then j
jj -> [j] -> [j]
forall a. a -> [a] -> [a]
:[j]
notIntersecting else [j]
notIntersecting)

-- | Search tree of intervals.

data ITree e i = Bin (Seq i) | Split (Seq i) e e e (ITree e i) (ITree e i)
-- Internal nodes store the convex hull of its subtrees.

-- Each bin contains a sorted sequence of intervals.

-- In the node @Split top x y z left right@

-- the convex hull of @left@ is @(x,y)@,

-- the convex hull of @right@ is @(y,z)@

-- and the intervals in @top@ are those straddling the split point @y@.

instance Functor (ITree e) where
    fmap :: (a -> b) -> ITree e a -> ITree e b
fmap a -> b
f (Bin Seq a
xs) = Seq b -> ITree e b
forall e i. Seq i -> ITree e i
Bin ((a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Seq a
xs)
    fmap a -> b
f (Split Seq a
up e
x e
y e
z ITree e a
left ITree e a
right) = Seq b -> e -> e -> e -> ITree e b -> ITree e b -> ITree e b
forall e i.
Seq i -> e -> e -> e -> ITree e i -> ITree e i -> ITree e i
Split ((a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Seq a
up) e
x e
y e
z ((a -> b) -> ITree e a -> ITree e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ITree e a
left) ((a -> b) -> ITree e a -> ITree e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ITree e a
right)
instance Foldable (ITree e) where
    foldMap :: (a -> m) -> ITree e a -> m
foldMap a -> m
f (Bin Seq a
xs) = (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Seq a
xs
    foldMap a -> m
f (Split Seq a
up e
_ e
_ e
_ ITree e a
left ITree e a
right) = (a -> m) -> ITree e a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f ITree e a
left m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Seq a
up m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (a -> m) -> ITree e a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f ITree e a
right

-- | the empty 'ITree'

emptyITree :: ITree e i
emptyITree :: ITree e i
emptyITree = Seq i -> ITree e i
forall e i. Seq i -> ITree e i
Bin Seq i
forall (f :: * -> *) a. Alternative f => f a
empty

-- | smallest interval covering the entire tree. 'Nothing' if the tree is empty.

hullOfTree :: (Interval e i) => ITree e i -> Maybe (e,e)
hullOfTree :: ITree e i -> Maybe (e, e)
hullOfTree (Bin Seq i
xs) = Seq i -> Maybe (e, e)
forall e i. Interval e i => Seq i -> Maybe (e, e)
hullSeq Seq i
xs
hullOfTree (Split Seq i
_ e
x e
_ e
y ITree e i
_ ITree e i
_) = (e, e) -> Maybe (e, e)
forall a. a -> Maybe a
Just (e
x,e
y)

-- | invariant to be maintained for proper intersection queries

--

-- prop> invariant . itree 4 . fmap (\(x,y) -> (x, x + QC.getNonNegative y :: Integer))

invariant :: Interval e i => ITree e i -> Bool
invariant :: ITree e i -> Bool
invariant (Bin Seq i
_) = Bool
True
invariant (Split Seq i
up e
x e
y e
z ITree e i
left ITree e i
right) = e
x e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
y Bool -> Bool -> Bool
&& e
y e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
z Bool -> Bool -> Bool
&& Bool
invUp Bool -> Bool -> Bool
&& Bool
invLeft Bool -> Bool -> Bool
&& Bool
invRight where
    invUp :: Bool
invUp = (i -> Bool) -> Seq i -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Identity e -> i -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
intersects (e -> Identity e
forall a. a -> Identity a
Identity e
y)) Seq i
up Bool -> Bool -> Bool
&& (i -> Bool) -> Seq i -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((e, e) -> i -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
contains (e
x,e
z)) Seq i
up
    invLeft :: Bool
invLeft = (i -> Bool) -> ITree e i -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((e, e) -> i -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
contains (e
x,e
y)) ITree e i
left Bool -> Bool -> Bool
&& ITree e i -> Bool
forall e i. Interval e i => ITree e i -> Bool
invariant ITree e i
left
    invRight :: Bool
invRight = (i -> Bool) -> ITree e i -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((e, e) -> i -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
contains (e
y,e
z)) ITree e i
right Bool -> Bool -> Bool
&& ITree e i -> Bool
forall e i. Interval e i => ITree e i -> Bool
invariant ITree e i
right

-- | Intersection query. O(binsize+log(n/binsize)).

--

-- prop> genInterval /\ \i -> genIntervalSeq /\ \t -> on (==) sortByLeft (getIntersectsIT i $ itree 2 t) (i `intersecting` t)

getIntersectsIT :: (Interval e i, Interval e j) => i -> ITree e j -> Seq j
getIntersectsIT :: i -> ITree e j -> Seq j
getIntersectsIT i
i (Bin Seq j
bin) = i
i i -> Seq j -> Seq j
forall e i j. (Interval e i, Interval e j) => j -> Seq i -> Seq i
`intersecting` Seq j
bin
getIntersectsIT i
i (Split Seq j
up e
x e
y e
z ITree e j
left ITree e j
right) = let
    m :: Seq j
m = i
i i -> Seq j -> Seq j
forall e i j. (Interval e i, Interval e j) => j -> Seq i -> Seq i
`intersecting` Seq j
up
    l :: Seq j
l = if i
i i -> (e, e) -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`intersects` (e
x,e
y) then i -> ITree e j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
i -> ITree e j -> Seq j
getIntersectsIT i
i ITree e j
left else Seq j
forall (f :: * -> *) a. Alternative f => f a
empty
    r :: Seq j
r = if i
i i -> (e, e) -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`intersects` (e
y,e
z) then i -> ITree e j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
i -> ITree e j -> Seq j
getIntersectsIT i
i ITree e j
right else Seq j
forall (f :: * -> *) a. Alternative f => f a
empty
    in if i
i i -> (e, e) -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`intersects` (e
x,e
z) then Seq j
m Seq j -> Seq j -> Seq j
forall a. Seq a -> Seq a -> Seq a
>< Seq j
l Seq j -> Seq j -> Seq j
forall a. Seq a -> Seq a -> Seq a
>< Seq j
r else Seq j
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Intersection query. O(binsize+log(n/binsize)).

--

-- prop> genInterval /\ \i -> genIntervalSeq /\ \t -> on (==) sortByLeft (getProperIntersectsIT i $ itree 2 t) (i `intersectingProperly` t)

getProperIntersectsIT :: (Interval e i, Interval e j) => i -> ITree e j -> Seq j
getProperIntersectsIT :: i -> ITree e j -> Seq j
getProperIntersectsIT i
i (Bin Seq j
bin) = i
i i -> Seq j -> Seq j
forall e i j. (Interval e i, Interval e j) => j -> Seq i -> Seq i
`intersectingProperly` Seq j
bin
getProperIntersectsIT i
i (Split Seq j
up e
x e
y e
z ITree e j
left ITree e j
right) = let
    m :: Seq j
m = i
i i -> Seq j -> Seq j
forall e i j. (Interval e i, Interval e j) => j -> Seq i -> Seq i
`intersectingProperly` Seq j
up
    l :: Seq j
l = if i
i i -> (e, e) -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`properlyIntersects` (e
x,e
y) then i -> ITree e j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
i -> ITree e j -> Seq j
getProperIntersectsIT i
i ITree e j
left else Seq j
forall (f :: * -> *) a. Alternative f => f a
empty
    r :: Seq j
r = if i
i i -> (e, e) -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`properlyIntersects` (e
y,e
z) then i -> ITree e j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
i -> ITree e j -> Seq j
getProperIntersectsIT i
i ITree e j
right else Seq j
forall (f :: * -> *) a. Alternative f => f a
empty
    in if i
i i -> (e, e) -> Bool
forall e i j. (Interval e i, Interval e j) => i -> j -> Bool
`properlyIntersects` (e
x,e
z) then Seq j
m Seq j -> Seq j -> Seq j
forall a. Seq a -> Seq a -> Seq a
>< Seq j
l Seq j -> Seq j -> Seq j
forall a. Seq a -> Seq a -> Seq a
>< Seq j
r else Seq j
forall (f :: * -> *) a. Alternative f => f a
empty

-- | When the actual result of 'getIntersectsIT' is not important,

-- only whether there are intersections.

someIntersectsIT :: (Interval e i, Interval e j) => i -> ITree e j -> Bool
someIntersectsIT :: i -> ITree e j -> Bool
someIntersectsIT i
i = Bool -> Bool
not (Bool -> Bool) -> (ITree e j -> Bool) -> ITree e j -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq j -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Seq j -> Bool) -> (ITree e j -> Seq j) -> ITree e j -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> ITree e j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
i -> ITree e j -> Seq j
getIntersectsIT i
i

-- | When the actual result of 'getIntersectsIT' is not important,

-- only whether there are intersections.

someProperlyIntersectsIT :: (Interval e i, Interval e j) => i -> ITree e j -> Bool
someProperlyIntersectsIT :: i -> ITree e j -> Bool
someProperlyIntersectsIT i
i = Bool -> Bool
not (Bool -> Bool) -> (ITree e j -> Bool) -> ITree e j -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq j -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Seq j -> Bool) -> (ITree e j -> Seq j) -> ITree e j -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> ITree e j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
i -> ITree e j -> Seq j
getProperIntersectsIT i
i

-- | retrieve the left-most interval from the tree, or 'Nothing' if it is empty.

leftmostInterval :: (Interval e i) => ITree e i -> Maybe i
leftmostInterval :: ITree e i -> Maybe i
leftmostInterval (Bin Seq i
bin) = case Seq i -> ViewL i
forall a. Seq a -> ViewL a
Seq.viewl Seq i
bin of
    ViewL i
EmptyL -> Maybe i
forall a. Maybe a
Nothing
    i
i :< Seq i
_ -> i -> Maybe i
forall a. a -> Maybe a
Just i
i
leftmostInterval (Split Seq i
up e
_ e
_ e
_ ITree e i
left ITree e i
right) = let
    headl :: Seq a -> Maybe a
headl Seq a
xs = case Seq a -> ViewL a
forall a. Seq a -> ViewL a
Seq.viewl Seq a
xs of
        ViewL a
EmptyL -> Maybe a
forall a. Maybe a
Nothing
        a
i :< Seq a
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
i
    in (Seq i -> Maybe i
forall a. Seq a -> Maybe a
headl (Seq i -> Maybe i) -> ([Maybe i] -> Seq i) -> [Maybe i] -> Maybe i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq i -> Seq i
forall e i. Interval e i => Seq i -> Seq i
sortByLeft (Seq i -> Seq i) -> ([Maybe i] -> Seq i) -> [Maybe i] -> Seq i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [i] -> Seq i
forall a. [a] -> Seq a
Seq.fromList ([i] -> Seq i) -> ([Maybe i] -> [i]) -> [Maybe i] -> Seq i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe i] -> [i]
forall a. [Maybe a] -> [a]
catMaybes) [ITree e i -> Maybe i
forall e i. Interval e i => ITree e i -> Maybe i
leftmostInterval ITree e i
left,Seq i -> Maybe i
forall a. Seq a -> Maybe a
headl Seq i
up,ITree e i -> Maybe i
forall e i. Interval e i => ITree e i -> Maybe i
leftmostInterval ITree e i
right]

-- | transform the interval tree into the tree of hulls

toTree :: Interval e i => ITree e i -> Tree (e,e)
toTree :: ITree e i -> Tree (e, e)
toTree (Bin Seq i
_) = [Char] -> Tree (e, e)
forall a. HasCallStack => [Char] -> a
error [Char]
"Interval.toTree: just a bin"
toTree (Split Seq i
_ e
x e
y e
z ITree e i
left ITree e i
right) = Node :: forall a. a -> Forest a -> Tree a
Tree.Node {rootLabel :: (e, e)
Tree.rootLabel = (e
x,e
z), subForest :: Forest (e, e)
Tree.subForest = [Tree (e, e)
l,Tree (e, e)
r]} where
    l :: Tree (e, e)
l = case ITree e i
left of
        (Bin Seq i
_) -> Node :: forall a. a -> Forest a -> Tree a
Tree.Node {rootLabel :: (e, e)
Tree.rootLabel = (e
x,e
y), subForest :: Forest (e, e)
Tree.subForest = []}
        ITree e i
_ -> ITree e i -> Tree (e, e)
forall e i. Interval e i => ITree e i -> Tree (e, e)
toTree ITree e i
left
    r :: Tree (e, e)
r = case ITree e i
right of
        (Bin Seq i
_) -> Node :: forall a. a -> Forest a -> Tree a
Tree.Node {rootLabel :: (e, e)
Tree.rootLabel = (e
y,e
z), subForest :: Forest (e, e)
Tree.subForest = []}
        ITree e i
_ -> ITree e i -> Tree (e, e)
forall e i. Interval e i => ITree e i -> Tree (e, e)
toTree ITree e i
right

-- ExtPkg: non-empty allows NonEmpty Seq - makes blockstart total

newtype Block e i = Block (Seq i)
blockstart :: Interval e i => Block e i -> e
blockstart :: Block e i -> e
blockstart (Block Seq i
xs) = case Seq i -> ViewL i
forall a. Seq a -> ViewL a
Seq.viewl Seq i
xs of
    ViewL i
EmptyL -> [Char] -> e
forall a. HasCallStack => [Char] -> a
error [Char]
"empty Block"
    i
x :< Seq i
_ -> i -> e
forall e i. Interval e i => i -> e
lb i
x
blocknull :: Block e i -> Bool
blocknull :: Block e i -> Bool
blocknull (Block Seq i
xs) = Seq i -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq i
xs
instance Interval e i => Eq (Block e i) where
    == :: Block e i -> Block e i -> Bool
(==) = e -> e -> Bool
forall a. Eq a => a -> a -> Bool
(==) (e -> e -> Bool)
-> (Block e i -> e) -> Block e i -> Block e i -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Block e i -> e
forall e i. Interval e i => Block e i -> e
blockstart
instance Interval e i => Ord (Block e i) where
    compare :: Block e i -> Block e i -> Ordering
compare = e -> e -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (e -> e -> Ordering)
-> (Block e i -> e) -> Block e i -> Block e i -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Block e i -> e
forall e i. Interval e i => Block e i -> e
blockstart)
instance Functor (Block e) where
    fmap :: (a -> b) -> Block e a -> Block e b
fmap a -> b
f (Block Seq a
xs) = Seq b -> Block e b
forall e i. Seq i -> Block e i
Block ((a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Seq a
xs)
instance Foldable (Block e) where
    foldMap :: (a -> m) -> Block e a -> m
foldMap a -> m
f (Block Seq a
xs) = (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Seq a
xs
instance Semigroup (Block e i) where
    (Block Seq i
xs) <> :: Block e i -> Block e i -> Block e i
<> (Block Seq i
ys) = Seq i -> Block e i
forall e i. Seq i -> Block e i
Block (Seq i
xs Seq i -> Seq i -> Seq i
forall a. Seq a -> Seq a -> Seq a
>< Seq i
ys)
instance Monoid (Block e i) where
    mempty :: Block e i
mempty = Seq i -> Block e i
forall e i. Seq i -> Block e i
Block Seq i
forall (f :: * -> *) a. Alternative f => f a
empty
    mappend :: Block e i -> Block e i -> Block e i
mappend = Block e i -> Block e i -> Block e i
forall a. Semigroup a => a -> a -> a
(<>)
instance Show i => Show (Block e i) where
    show :: Block e i -> [Char]
show (Block Seq i
xs) = [Char]
"Block "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++([i] -> [Char]
forall a. Show a => a -> [Char]
show (Seq i -> [i]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq i
xs))

-- | generalises Control.Monad.filterM

filterM :: (Applicative f, Traversable t, Alternative m) => (a -> f Bool) -> t a -> f (m a)
filterM :: (a -> f Bool) -> t a -> f (m a)
filterM a -> f Bool
f = ((t (m a) -> m a) -> f (t (m a)) -> f (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m a -> m a -> m a) -> m a -> t (m a) -> m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) m a
forall (f :: * -> *) a. Alternative f => f a
empty)) (f (t (m a)) -> f (m a)) -> (t a -> f (t (m a))) -> t a -> f (m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (m a)) -> t a -> f (t (m a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\a
a -> (Bool -> m a) -> f Bool -> f (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
b -> if Bool
b then a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a else m a
forall (f :: * -> *) a. Alternative f => f a
empty) (a -> f Bool
f a
a))

crossesAny :: (Interval e i, Foldable f) => i -> f (Block e i) -> Bool
crossesAny :: i -> f (Block e i) -> Bool
crossesAny i
i = (Block e i -> Bool) -> f (Block e i) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (((i -> e
forall e i. Interval e i => i -> e
ub i
i) e -> e -> Bool
forall a. Ord a => a -> a -> Bool
>)(e -> Bool) -> (Block e i -> e) -> Block e i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Block e i -> e
forall e i. Interval e i => Block e i -> e
blockstart)

removeCrossers :: Interval e i => Block e i -> Seq (Block e i) -> (Seq i,Block e i)
removeCrossers :: Block e i -> Seq (Block e i) -> (Seq i, Block e i)
removeCrossers (Block Seq i
xs) Seq (Block e i)
blocks = let (Seq i
crossers,Seq i
xs') = (i -> (Seq i, Bool)) -> Seq i -> (Seq i, Seq i)
forall (f :: * -> *) (t :: * -> *) (m :: * -> *) a.
(Applicative f, Traversable t, Alternative m) =>
(a -> f Bool) -> t a -> f (m a)
filterM i -> (Seq i, Bool)
f Seq i
xs in (Seq i
crossers,Seq i -> Block e i
forall e i. Seq i -> Block e i
Block Seq i
xs') where
    f :: i -> (Seq i, Bool)
f i
i = if i
i i -> Seq (Block e i) -> Bool
forall e i (f :: * -> *).
(Interval e i, Foldable f) =>
i -> f (Block e i) -> Bool
`crossesAny` Seq (Block e i)
blocks
        then (i -> Seq i
forall a. a -> Seq a
Seq.singleton i
i,Bool
False)
        else Bool -> (Seq i, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- foldr over the list of blocks and gather all intervals

-- overlapping block boundaries. Remove blocks that are rendered empty by this.

gatherCrossers :: Interval e i => Seq (Block e i) -> (Seq i,Seq (Block e i))
gatherCrossers :: Seq (Block e i) -> (Seq i, Seq (Block e i))
gatherCrossers Seq (Block e i)
blks = case Seq (Block e i) -> ViewL (Block e i)
forall a. Seq a -> ViewL a
Seq.viewl Seq (Block e i)
blks of
    (Block e i
block :< Seq (Block e i)
blocks) -> let
        (Seq i
crossers,Seq (Block e i)
blocks') = Seq (Block e i) -> (Seq i, Seq (Block e i))
forall e i.
Interval e i =>
Seq (Block e i) -> (Seq i, Seq (Block e i))
gatherCrossers Seq (Block e i)
blocks
        (Seq i
crossers',Block e i
block') = Block e i -> Seq (Block e i) -> (Seq i, Block e i)
forall e i.
Interval e i =>
Block e i -> Seq (Block e i) -> (Seq i, Block e i)
removeCrossers Block e i
block Seq (Block e i)
blocks'
        cons :: Seq (Block e i) -> Seq (Block e i)
cons = if Block e i -> Bool
forall e a. Block e a -> Bool
blocknull Block e i
block' then Seq (Block e i) -> Seq (Block e i)
forall a. a -> a
id else (Block e i -> Seq (Block e i) -> Seq (Block e i)
forall a. a -> Seq a -> Seq a
(<|) Block e i
block')
        in (Seq i
crossers' Seq i -> Seq i -> Seq i
forall a. Seq a -> Seq a -> Seq a
>< Seq i
crossers,Seq (Block e i) -> Seq (Block e i)
cons Seq (Block e i)
blocks')
    ViewL (Block e i)
EmptyL -> (Seq i
forall (f :: * -> *) a. Alternative f => f a
empty,Seq (Block e i)
forall (f :: * -> *) a. Alternative f => f a
empty)
-- after applying gatherCrossers to a sorted list of sorted blocks,

-- all intervals within the blocks are contained in the interval

-- from the blockstart to the blockstart of the next block.

-- Hence we can use these blocks to build an interval tree,

-- where the crossers go into certain 'up' components.


blocksOf :: Int -> Seq i -> Seq (Block e i)
blocksOf :: Int -> Seq i -> Seq (Block e i)
blocksOf Int
n = (Seq i -> Block e i) -> Seq (Seq i) -> Seq (Block e i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Seq i -> Block e i
forall e i. Seq i -> Block e i
Block (Seq (Seq i) -> Seq (Block e i))
-> (Seq i -> Seq (Seq i)) -> Seq i -> Seq (Block e i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Seq i -> Seq (Seq i)
forall a. Int -> Seq a -> Seq (Seq a)
Seq.chunksOf Int
n

data SplitSeq a = EmptySeq | SingletonSeq a | TwoSeqs (Seq a) (Seq a) deriving (Int -> SplitSeq a -> ShowS
[SplitSeq a] -> ShowS
SplitSeq a -> [Char]
(Int -> SplitSeq a -> ShowS)
-> (SplitSeq a -> [Char])
-> ([SplitSeq a] -> ShowS)
-> Show (SplitSeq a)
forall a. Show a => Int -> SplitSeq a -> ShowS
forall a. Show a => [SplitSeq a] -> ShowS
forall a. Show a => SplitSeq a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SplitSeq a] -> ShowS
$cshowList :: forall a. Show a => [SplitSeq a] -> ShowS
show :: SplitSeq a -> [Char]
$cshow :: forall a. Show a => SplitSeq a -> [Char]
showsPrec :: Int -> SplitSeq a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> SplitSeq a -> ShowS
Show)

joinSeq :: SplitSeq a -> Seq a
joinSeq :: SplitSeq a -> Seq a
joinSeq SplitSeq a
EmptySeq = Seq a
forall (f :: * -> *) a. Alternative f => f a
empty
joinSeq (SingletonSeq a
a) = a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
joinSeq (TwoSeqs Seq a
xs Seq a
ys) = Seq a
xs Seq a -> Seq a -> Seq a
forall a. Semigroup a => a -> a -> a
<> Seq a
ys

-- | Split a Sequence in half, needed for the IntersectionQuery instances.  

-- prop> genIntervalSeq /\ \is -> joinSeq (splitSeq is) == is

splitSeq :: Seq a -> SplitSeq a
splitSeq :: Seq a -> SplitSeq a
splitSeq Seq a
xs = let (Seq a
l,Seq a
r) = Int -> Seq a -> (Seq a, Seq a)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt (Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq a
xs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Seq a
xs in case (Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq a
l,Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq a
r) of
    (Bool
_,Bool
True) -> SplitSeq a
forall a. SplitSeq a
EmptySeq
    (Bool
True,Bool
False) -> let (a
x :< Seq a
_) = Seq a -> ViewL a
forall a. Seq a -> ViewL a
Seq.viewl Seq a
r in a -> SplitSeq a
forall a. a -> SplitSeq a
SingletonSeq a
x
    (Bool
False,Bool
False) -> Seq a -> Seq a -> SplitSeq a
forall a. Seq a -> Seq a -> SplitSeq a
TwoSeqs Seq a
l Seq a
r

-- build a tree from a sequence of mutually non-overlapping blocks

buildFromSeq :: Interval e i => Seq (Block e i) -> ITree e i
buildFromSeq :: Seq (Block e i) -> ITree e i
buildFromSeq Seq (Block e i)
blocks = case Seq (Block e i) -> SplitSeq (Block e i)
forall a. Seq a -> SplitSeq a
splitSeq Seq (Block e i)
blocks of
    SplitSeq (Block e i)
EmptySeq -> ITree e i
forall e i. ITree e i
emptyITree
    SingletonSeq (Block Seq i
bin) -> Seq i -> ITree e i
forall e i. Seq i -> ITree e i
Bin Seq i
bin
    TwoSeqs Seq (Block e i)
lblocks Seq (Block e i)
rblocks -> let
        y :: e
y = let Block e i
b :< Seq (Block e i)
_ = Seq (Block e i) -> ViewL (Block e i)
forall a. Seq a -> ViewL a
Seq.viewl Seq (Block e i)
rblocks in Block e i -> e
forall e i. Interval e i => Block e i -> e
blockstart Block e i
b
        left :: ITree e i
left = Seq (Block e i) -> ITree e i
forall e i. Interval e i => Seq (Block e i) -> ITree e i
buildFromSeq Seq (Block e i)
lblocks
        right :: ITree e i
right = Seq (Block e i) -> ITree e i
forall e i. Interval e i => Seq (Block e i) -> ITree e i
buildFromSeq Seq (Block e i)
rblocks
        x :: e
x = e -> ((e, e) -> e) -> Maybe (e, e) -> e
forall b a. b -> (a -> b) -> Maybe a -> b
maybe e
y (e, e) -> e
forall a b. (a, b) -> a
fst (ITree e i -> Maybe (e, e)
forall e i. Interval e i => ITree e i -> Maybe (e, e)
hullOfTree ITree e i
left)
        z :: e
z = e -> ((e, e) -> e) -> Maybe (e, e) -> e
forall b a. b -> (a -> b) -> Maybe a -> b
maybe e
y (e, e) -> e
forall a b. (a, b) -> b
snd (ITree e i -> Maybe (e, e)
forall e i. Interval e i => ITree e i -> Maybe (e, e)
hullOfTree ITree e i
right)
        in Seq i -> e -> e -> e -> ITree e i -> ITree e i -> ITree e i
forall e i.
Seq i -> e -> e -> e -> ITree e i -> ITree e i -> ITree e i
Split Seq i
forall (f :: * -> *) a. Alternative f => f a
empty e
x e
y e
z ITree e i
left ITree e i
right

-- | insert the interval at the deepest possible location into the tree.

-- Does not change the overall structure, in particular no re-balancing is performed.

insert :: Interval e i => i -> ITree e i -> ITree e i
insert :: i -> ITree e i -> ITree e i
insert i
i (Bin Seq i
xs) = Seq i -> ITree e i
forall e i. Seq i -> ITree e i
Bin (i
i i -> Seq i -> Seq i
forall a. a -> Seq a -> Seq a
<| Seq i
xs)
insert i
i (Split Seq i
up e
x e
y e
z ITree e i
left ITree e i
right) = if i -> e
forall e i. Interval e i => i -> e
ub i
i e -> e -> Bool
forall a. Ord a => a -> a -> Bool
<= e
y
    then let
        left' :: ITree e i
left' = (i -> ITree e i -> ITree e i
forall e i. Interval e i => i -> ITree e i -> ITree e i
insert i
i ITree e i
left)
        x' :: e
x' = e -> ((e, e) -> e) -> Maybe (e, e) -> e
forall b a. b -> (a -> b) -> Maybe a -> b
maybe e
x (e -> e -> e
forall a. Ord a => a -> a -> a
min e
x(e -> e) -> ((e, e) -> e) -> (e, e) -> e
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(e, e) -> e
forall a b. (a, b) -> a
fst) (ITree e i -> Maybe (e, e)
forall e i. Interval e i => ITree e i -> Maybe (e, e)
hullOfTree ITree e i
left')
        in Seq i -> e -> e -> e -> ITree e i -> ITree e i -> ITree e i
forall e i.
Seq i -> e -> e -> e -> ITree e i -> ITree e i -> ITree e i
Split Seq i
up e
x' e
y e
z ITree e i
left' ITree e i
right
    else if i -> e
forall e i. Interval e i => i -> e
lb i
i e -> e -> Bool
forall a. Ord a => a -> a -> Bool
< e
y
        then Seq i -> e -> e -> e -> ITree e i -> ITree e i -> ITree e i
forall e i.
Seq i -> e -> e -> e -> ITree e i -> ITree e i -> ITree e i
Split (i
i i -> Seq i -> Seq i
forall a. a -> Seq a -> Seq a
<| Seq i
up) (e -> e -> e
forall a. Ord a => a -> a -> a
min e
x (i -> e
forall e i. Interval e i => i -> e
lb i
i)) e
y (e -> e -> e
forall a. Ord a => a -> a -> a
max e
z (i -> e
forall e i. Interval e i => i -> e
ub i
i)) ITree e i
left ITree e i
right
        else let
            right' :: ITree e i
right' = i -> ITree e i -> ITree e i
forall e i. Interval e i => i -> ITree e i -> ITree e i
insert i
i ITree e i
right
            z' :: e
z' = e -> ((e, e) -> e) -> Maybe (e, e) -> e
forall b a. b -> (a -> b) -> Maybe a -> b
maybe e
z (e -> e -> e
forall a. Ord a => a -> a -> a
max e
z(e -> e) -> ((e, e) -> e) -> (e, e) -> e
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(e, e) -> e
forall a b. (a, b) -> b
snd) (ITree e i -> Maybe (e, e)
forall e i. Interval e i => ITree e i -> Maybe (e, e)
hullOfTree ITree e i
right')
            in Seq i -> e -> e -> e -> ITree e i -> ITree e i -> ITree e i
forall e i.
Seq i -> e -> e -> e -> ITree e i -> ITree e i -> ITree e i
Split Seq i
up e
x e
y e
z' ITree e i
left ITree e i
right'

-- | Construct an interval tree with bins of maximal given size.

-- The function first sorts the intervals,

-- then splits into chunks of given size.

-- The leftmost endpoints of the chunks define boundary points.

-- Next, all intervals properly overlapping a boundary are removed

-- from the chunks and kept separately.

-- The chunks are arranged as the leaves of a binary search tree.

-- Then the intervals overlapping boundaries are placed

-- at internal nodes of the tree.

-- Hence if all intervals are mutually non-overlapping properly,

-- the resulting tree is a pure binary search tree with bins of

-- given size as leaves.

itree :: Interval e i => Int -> Seq i -> ITree e i
itree :: Int -> Seq i -> ITree e i
itree Int
n = ((ITree e i -> ITree e i) -> ITree e i -> ITree e i)
-> (ITree e i -> ITree e i, ITree e i) -> ITree e i
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ITree e i -> ITree e i) -> ITree e i -> ITree e i
forall a b. (a -> b) -> a -> b
($)((ITree e i -> ITree e i, ITree e i) -> ITree e i)
-> (Seq i -> (ITree e i -> ITree e i, ITree e i))
-> Seq i
-> ITree e i
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Seq i -> ITree e i -> ITree e i
f (Seq i -> ITree e i -> ITree e i)
-> (Seq (Block e i) -> ITree e i)
-> (Seq i, Seq (Block e i))
-> (ITree e i -> ITree e i, ITree e i)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Seq (Block e i) -> ITree e i
forall e i. Interval e i => Seq (Block e i) -> ITree e i
buildFromSeq)((Seq i, Seq (Block e i)) -> (ITree e i -> ITree e i, ITree e i))
-> (Seq i -> (Seq i, Seq (Block e i)))
-> Seq i
-> (ITree e i -> ITree e i, ITree e i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Seq (Block e i) -> (Seq i, Seq (Block e i))
forall e i.
Interval e i =>
Seq (Block e i) -> (Seq i, Seq (Block e i))
gatherCrossers(Seq (Block e i) -> (Seq i, Seq (Block e i)))
-> (Seq i -> Seq (Block e i)) -> Seq i -> (Seq i, Seq (Block e i))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Seq i -> Seq (Block e i)
forall i e. Int -> Seq i -> Seq (Block e i)
blocksOf Int
n(Seq i -> Seq (Block e i))
-> (Seq i -> Seq i) -> Seq i -> Seq (Block e i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Seq i -> Seq i
srt where
    srt :: Seq i -> Seq i
srt = (i -> i -> Ordering) -> Seq i -> Seq i
forall a. (a -> a -> Ordering) -> Seq a -> Seq a
Seq.unstableSortBy ((e, e) -> (e, e) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((e, e) -> (e, e) -> Ordering)
-> (i -> (e, e)) -> i -> i -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` i -> (e, e)
forall e i. Interval e i => i -> (e, e)
endPoints)
    f :: Seq i -> ITree e i -> ITree e i
f = (ITree e i -> Seq i -> ITree e i)
-> Seq i -> ITree e i -> ITree e i
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((i -> ITree e i -> ITree e i) -> ITree e i -> Seq i -> ITree e i
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' i -> ITree e i -> ITree e i
forall e i. Interval e i => i -> ITree e i -> ITree e i
insert)

-- * Non-overlapping intervals


-- | /O(log n)/ bounds of an ordered sequence of intervals. 'Nothing', if empty.

--

-- prop> genDisjointIntervalSeq /\ \xs -> hullSeqNonOverlap xs == hullSeq xs

hullSeqNonOverlap :: Interval e i => Seq i -> Maybe (e,e)
hullSeqNonOverlap :: Seq i -> Maybe (e, e)
hullSeqNonOverlap Seq i
xs = case Seq i -> ViewL i
forall a. Seq a -> ViewL a
Seq.viewl Seq i
xs of
    ViewL i
EmptyL -> Maybe (e, e)
forall a. Maybe a
Nothing
    i
leftmost :< Seq i
others -> (e, e) -> Maybe (e, e)
forall a. a -> Maybe a
Just (i -> e
forall e i. Interval e i => i -> e
lb i
leftmost, case Seq i -> ViewR i
forall a. Seq a -> ViewR a
Seq.viewr Seq i
others of
        Seq i
_ :> i
rightmost -> e -> (i -> e) -> Maybe i -> e
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (i -> e
forall e i. Interval e i => i -> e
ub i
rightmost) i -> e
forall e i. Interval e i => i -> e
ub ((i -> Bool) -> Seq i -> Maybe i
forall i. (i -> Bool) -> Seq i -> Maybe i
findLeftmost ((i -> e
forall e i. Interval e i => i -> e
lb i
rightmost e -> e -> Bool
forall a. Eq a => a -> a -> Bool
==)(e -> Bool) -> (i -> e) -> i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.i -> e
forall e i. Interval e i => i -> e
lb) Seq i
xs)
        ViewR i
EmptyR         -> i -> e
forall e i. Interval e i => i -> e
ub i
leftmost)

findLeftmost :: (i -> Bool) -> Seq i -> Maybe i
findLeftmost :: (i -> Bool) -> Seq i -> Maybe i
findLeftmost i -> Bool
p = Seq i -> Maybe i
go where 
    go :: Seq i -> Maybe i
go Seq i
xs = case Seq i -> SplitSeq i
forall a. Seq a -> SplitSeq a
splitSeq Seq i
xs of
        SplitSeq i
EmptySeq           -> Maybe i
forall a. Maybe a
Nothing
        SingletonSeq i
i     -> if i -> Bool
p i
i then i -> Maybe i
forall a. a -> Maybe a
Just i
i else Maybe i
forall a. Maybe a
Nothing
        TwoSeqs Seq i
left Seq i
right -> case Seq i -> Maybe i
go Seq i
left of
            foundLeftmost :: Maybe i
foundLeftmost@(Just i
_) -> Maybe i
foundLeftmost
            Maybe i
Nothing -> Seq i -> Maybe i
go Seq i
right

-- | Query an ordered 'Seq'uence of non-overlapping intervals

-- for a predicate @p@ that has the property

--

-- @

-- j `contains` k && p i k ==> p i j

-- @

--

-- and return all elements satisfying the predicate.

--

-- prop> genInterval /\ \i -> genDisjointIntervalSeq /\ \js -> findSeq intersects i js == intersecting i js

findSeq :: (Interval e i, Interval e j) => (i -> (e,e) -> Bool) -> i -> Seq j -> Seq j
findSeq :: (i -> (e, e) -> Bool) -> i -> Seq j -> Seq j
findSeq i -> (e, e) -> Bool
p i
i Seq j
js = case Seq j -> Maybe (e, e)
forall e i. Interval e i => Seq i -> Maybe (e, e)
hullSeqNonOverlap Seq j
js of
    Maybe (e, e)
Nothing -> Seq j
forall (f :: * -> *) a. Alternative f => f a
empty
    Just (e, e)
h -> if i -> (e, e) -> Bool
p i
i (e, e)
h
        then case Seq j -> SplitSeq j
forall a. Seq a -> SplitSeq a
splitSeq Seq j
js of
            SingletonSeq j
_j -> Seq j
js
            TwoSeqs Seq j
l Seq j
r -> (i -> (e, e) -> Bool) -> i -> Seq j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
(i -> (e, e) -> Bool) -> i -> Seq j -> Seq j
findSeq i -> (e, e) -> Bool
p i
i Seq j
l Seq j -> Seq j -> Seq j
forall a. Seq a -> Seq a -> Seq a
>< (i -> (e, e) -> Bool) -> i -> Seq j -> Seq j
forall e i j.
(Interval e i, Interval e j) =>
(i -> (e, e) -> Bool) -> i -> Seq j -> Seq j
findSeq i -> (e, e) -> Bool
p i
i Seq j
r
            SplitSeq j
EmptySeq -> Seq j
forall (f :: * -> *) a. Alternative f => f a
empty -- should never happen

        else Seq j
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Query an ordered 'Seq'uence of non-overlapping intervals

-- for a predicate @p@ that has the property

--

-- @

-- j `contains` k && p i k ==> p i j

-- @

existsSeq :: (Interval e i, Interval e j) => (i -> (e,e) -> Bool) -> i -> Seq j -> Bool
existsSeq :: (i -> (e, e) -> Bool) -> i -> Seq j -> Bool
existsSeq i -> (e, e) -> Bool
p i
i Seq j
js = case Seq j -> Maybe (e, e)
forall e i. Interval e i => Seq i -> Maybe (e, e)
hullSeqNonOverlap Seq j
js of
    Maybe (e, e)
Nothing -> Bool
False
    Just (e, e)
h -> if i -> (e, e) -> Bool
p i
i (e, e)
h
        then case Seq j -> SplitSeq j
forall a. Seq a -> SplitSeq a
splitSeq Seq j
js of
            SingletonSeq j
_j -> Bool
True
            TwoSeqs Seq j
l Seq j
r -> (i -> (e, e) -> Bool) -> i -> Seq j -> Bool
forall e i j.
(Interval e i, Interval e j) =>
(i -> (e, e) -> Bool) -> i -> Seq j -> Bool
existsSeq i -> (e, e) -> Bool
p i
i Seq j
l Bool -> Bool -> Bool
|| (i -> (e, e) -> Bool) -> i -> Seq j -> Bool
forall e i j.
(Interval e i, Interval e j) =>
(i -> (e, e) -> Bool) -> i -> Seq j -> Bool
existsSeq i -> (e, e) -> Bool
p i
i Seq j
r
            SplitSeq j
EmptySeq -> Bool
False -- should never happen

        else Bool
False