closed-intervals 0.1.0.1 → 0.1.1.0

raw patch · 4 files changed

+243/−135 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

+ Data.Interval: maybeBounds :: (IntersectionQuery t e f, Interval e i) => t i -> Maybe (e, e)

+ Data.Interval: properOverlap :: (Interval e i, Interval e j) => i -> j -> Ordering

+ Data.Interval: splitIntersecting :: (Interval e i, Interval e j) => i -> [j] -> ([j], [j])

+ Data.Interval: splitProperlyIntersecting :: (Interval e i, Interval e j) => i -> [j] -> ([j], [j])

- Data.Interval: overlap :: Interval e i => i -> i -> Ordering

+ Data.Interval: overlap :: (Interval e i, Interval e j) => i -> j -> Ordering

Files

ChangeLog.md +3/−0
closed-intervals.cabal +1/−1
doctest/Test/Data/Interval.hs +166/−129
src/Data/Interval.hs +73/−5

ChangeLog.md view

@@ -1,5 +1,8 @@ # Changelog for closed-intervals +- 0.1.1.0 added properOverlap, splitIntersecting and splitProperlyIntersecting.+  Added maybeBounds to the IntersectionQuery class.+ - 0.1.0.1 bugfix in hullSeqNonOverlap which was not caught    because the QuickCheck generator generated data which    did not meet the assumptions made by hullSeqNonOverlap.

closed-intervals.cabal view

@@ -1,7 +1,7 @@ cabal-version: 1.12  name:           closed-intervals-version:        0.1.0.1+version:        0.1.1.0 synopsis:       Closed intervals of totally ordered types description:    see README.md author:         Olaf Klinke, Henning Thielemann

doctest/Test/Data/Interval.hs view

@@ -1,5 +1,5 @@ -- Do not edit! Automatically created with doctest-extract from src/Data/Interval.hs-{-# LINE 99 "src/Data/Interval.hs" #-}+{-# LINE 107 "src/Data/Interval.hs" #-}  module Test.Data.Interval where @@ -7,7 +7,7 @@ import Test.DocTest.Base import qualified Test.DocTest.Driver as DocTest -{-# LINE 100 "src/Data/Interval.hs" #-}+{-# LINE 108 "src/Data/Interval.hs" #-} import     Data.IntervalTest import     qualified Data.Sequence as Seq import     qualified Data.List as List@@ -20,223 +20,260 @@  test :: DocTest.T () test = do- DocTest.printPrefix "Data.Interval:177: "-{-# LINE 177 "src/Data/Interval.hs" #-}- DocTest.property-{-# LINE 177 "src/Data/Interval.hs" #-}-        (genInterval /\ \i -> overlapTime i i == intervalDuration i)- DocTest.printPrefix "Data.Interval:178: "-{-# LINE 178 "src/Data/Interval.hs" #-}- DocTest.property-{-# LINE 178 "src/Data/Interval.hs" #-}-        (genInterval /\* \i j -> not (i `properlyIntersects` j) ==> overlapTime i j == 0)- DocTest.printPrefix "Data.Interval:179: "-{-# LINE 179 "src/Data/Interval.hs" #-}- DocTest.property-{-# LINE 179 "src/Data/Interval.hs" #-}-        (genInterval /\* \i j -> overlapTime i j == (sum $ fmap intervalDuration $ maybeIntersection i j))  DocTest.printPrefix "Data.Interval:189: " {-# LINE 189 "src/Data/Interval.hs" #-}  DocTest.property {-# LINE 189 "src/Data/Interval.hs" #-}-        (genInterval /\ \i c -> prevailing i (Seq.singleton (c,i)) == Just (c::Char))+        (genInterval /\ \i -> overlapTime i i == intervalDuration i)  DocTest.printPrefix "Data.Interval:190: " {-# LINE 190 "src/Data/Interval.hs" #-}  DocTest.property {-# LINE 190 "src/Data/Interval.hs" #-}-        (genInterval /\ \i -> genLabeledSeq /\ \js -> isJust (prevailing i js) == any (intersects i . snd) js)+        (genInterval /\* \i j -> not (i `properlyIntersects` j) ==> overlapTime i j == 0)  DocTest.printPrefix "Data.Interval:191: " {-# LINE 191 "src/Data/Interval.hs" #-}  DocTest.property {-# LINE 191 "src/Data/Interval.hs" #-}+        (genInterval /\* \i j -> overlapTime i j == (sum $ fmap intervalDuration $ maybeIntersection i j))+ DocTest.printPrefix "Data.Interval:201: "+{-# LINE 201 "src/Data/Interval.hs" #-}+ DocTest.property+{-# LINE 201 "src/Data/Interval.hs" #-}+        (genInterval /\ \i c -> prevailing i (Seq.singleton (c,i)) == Just (c::Char))+ DocTest.printPrefix "Data.Interval:202: "+{-# LINE 202 "src/Data/Interval.hs" #-}+ DocTest.property+{-# LINE 202 "src/Data/Interval.hs" #-}+        (genInterval /\ \i -> genLabeledSeq /\ \js -> isJust (prevailing i js) == any (intersects i . snd) js)+ DocTest.printPrefix "Data.Interval:203: "+{-# LINE 203 "src/Data/Interval.hs" #-}+ DocTest.property+{-# LINE 203 "src/Data/Interval.hs" #-}         (genInterval /\ \i -> genLabeledSeq /\* \js ks -> all (flip elem $ catMaybes [prevailing i js, prevailing i ks]) $ prevailing i (js<>ks))- DocTest.printPrefix "Data.Interval:214: "-{-# LINE 214 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:226: "+{-# LINE 226 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 214 "src/Data/Interval.hs" #-}+{-# LINE 226 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> isJust (maybeUnion i j) ==> fromJust (maybeUnion i j) `contains` i && fromJust (maybeUnion i j) `contains` j)- DocTest.printPrefix "Data.Interval:215: "-{-# LINE 215 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:227: "+{-# LINE 227 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 215 "src/Data/Interval.hs" #-}+{-# LINE 227 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> i `intersects` j ==> (maybeUnion i j >>= maybeIntersection i) == Just i)- DocTest.printPrefix "Data.Interval:223: "-{-# LINE 223 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:235: "+{-# LINE 235 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 223 "src/Data/Interval.hs" #-}+{-# LINE 235 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> i `intersects` j ==> i `contains` fromJust (maybeIntersection i j))- DocTest.printPrefix "Data.Interval:231: "-{-# LINE 231 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:243: "+{-# LINE 243 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 231 "src/Data/Interval.hs" #-}+{-# LINE 243 "src/Data/Interval.hs" #-}         (\xs -> isJust (hull xs) ==> all (\x -> fromJust (hull xs) `contains` x) (xs :: [(Int,Int)]))- DocTest.printPrefix "Data.Interval:248: "-{-# LINE 248 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:260: "+{-# LINE 260 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 248 "src/Data/Interval.hs" #-}+{-# LINE 260 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> length (i `without` j) <= 2)- DocTest.printPrefix "Data.Interval:249: "-{-# LINE 249 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:261: "+{-# LINE 261 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 249 "src/Data/Interval.hs" #-}+{-# LINE 261 "src/Data/Interval.hs" #-}         (genInterval /\ \i -> i `without` i == [])- DocTest.printPrefix "Data.Interval:250: "-{-# LINE 250 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:262: "+{-# LINE 262 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 250 "src/Data/Interval.hs" #-}+{-# LINE 262 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> all (contains i) (i `without` j))- DocTest.printPrefix "Data.Interval:251: "-{-# LINE 251 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:263: "+{-# LINE 263 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 251 "src/Data/Interval.hs" #-}+{-# LINE 263 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> not $ any (properlyIntersects j) (i `without` j))- DocTest.printPrefix "Data.Interval:239: "-{-# LINE 239 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:251: "+{-# LINE 251 "src/Data/Interval.hs" #-}  DocTest.example-{-# LINE 239 "src/Data/Interval.hs" #-}+{-# LINE 251 "src/Data/Interval.hs" #-}       (without' (1,5) (4,5))   [ExpectedLine [LineChunk "[(1,4)]"]]- DocTest.printPrefix "Data.Interval:241: "-{-# LINE 241 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:253: "+{-# LINE 253 "src/Data/Interval.hs" #-}  DocTest.example-{-# LINE 241 "src/Data/Interval.hs" #-}+{-# LINE 253 "src/Data/Interval.hs" #-}       (without' (1,5) (2,3))   [ExpectedLine [LineChunk "[(1,2),(3,5)]"]]- DocTest.printPrefix "Data.Interval:243: "-{-# LINE 243 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:255: "+{-# LINE 255 "src/Data/Interval.hs" #-}  DocTest.example-{-# LINE 243 "src/Data/Interval.hs" #-}+{-# LINE 255 "src/Data/Interval.hs" #-}       (without' (1,5) (1,5))   [ExpectedLine [LineChunk "[]"]]- DocTest.printPrefix "Data.Interval:245: "-{-# LINE 245 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:257: "+{-# LINE 257 "src/Data/Interval.hs" #-}  DocTest.example-{-# LINE 245 "src/Data/Interval.hs" #-}+{-# LINE 257 "src/Data/Interval.hs" #-}       (without' (1,5) (0,1))   [ExpectedLine [LineChunk "[(1,5)]"]]- DocTest.printPrefix "Data.Interval:267: "-{-# LINE 267 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:279: "+{-# LINE 279 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 267 "src/Data/Interval.hs" #-}+{-# LINE 279 "src/Data/Interval.hs" #-}         (genSortedIntervals /\ all (\xs -> and $ List.zipWith intersects xs (tail xs)) . contiguous)- DocTest.printPrefix "Data.Interval:282: "-{-# LINE 282 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:294: "+{-# LINE 294 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 282 "src/Data/Interval.hs" #-}+{-# LINE 294 "src/Data/Interval.hs" #-}         (genSortedIntervals /\ \xs -> all (\i -> any (flip contains i) (components xs)) xs)- DocTest.printPrefix "Data.Interval:293: "-{-# LINE 293 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:305: "+{-# LINE 305 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 293 "src/Data/Interval.hs" #-}+{-# LINE 305 "src/Data/Interval.hs" #-}         (genSortedIntervals /\ \xs -> componentsSeq (Seq.fromList xs) == Seq.fromList (components xs))- DocTest.printPrefix "Data.Interval:306: "-{-# LINE 306 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:318: "+{-# LINE 318 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 306 "src/Data/Interval.hs" #-}+{-# LINE 318 "src/Data/Interval.hs" #-}         (genInterval /\ \i -> genIntervalSeq /\ \js -> all (contains i) (covered i js))- DocTest.printPrefix "Data.Interval:307: "-{-# LINE 307 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:319: "+{-# LINE 319 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 307 "src/Data/Interval.hs" #-}+{-# LINE 319 "src/Data/Interval.hs" #-}         (genInterval /\ \i -> genIntervalSeq /\ \js -> covered i (covered i js) == covered i js)- DocTest.printPrefix "Data.Interval:315: "-{-# LINE 315 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:327: "+{-# LINE 327 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 315 "src/Data/Interval.hs" #-}+{-# LINE 327 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> j `contains` i == i `coveredBy` [j])- DocTest.printPrefix "Data.Interval:316: "-{-# LINE 316 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:328: "+{-# LINE 328 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 316 "src/Data/Interval.hs" #-}+{-# LINE 328 "src/Data/Interval.hs" #-}         (genInterval /\ \i -> genSortedIntervals /\ \js -> i `coveredBy` js ==> any (flip contains i) (components js))- DocTest.printPrefix "Data.Interval:322: "-{-# LINE 322 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:334: "+{-# LINE 334 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 322 "src/Data/Interval.hs" #-}+{-# LINE 334 "src/Data/Interval.hs" #-}         (genNonEmptyInterval /\ \i -> genIntervalSeq /\ \js -> i `coveredBy` js == (fractionCovered i js >= (1::Rational)))- DocTest.printPrefix "Data.Interval:323: "-{-# LINE 323 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:335: "+{-# LINE 335 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 323 "src/Data/Interval.hs" #-}+{-# LINE 335 "src/Data/Interval.hs" #-}         (genNonEmptyInterval /\ \i -> genNonEmptyIntervalSeq /\ \js -> any (properlyIntersects i) js == (fractionCovered i js > (0::Rational)))- DocTest.printPrefix "Data.Interval:342: "-{-# LINE 342 "src/Data/Interval.hs" #-}- DocTest.property-{-# LINE 342 "src/Data/Interval.hs" #-}-        (genInterval /\* \i j -> i `intersects` j  ==  (overlap i j == EQ))  DocTest.printPrefix "Data.Interval:354: " {-# LINE 354 "src/Data/Interval.hs" #-}  DocTest.property {-# LINE 354 "src/Data/Interval.hs" #-}+        (genInterval /\* \i j -> i `intersects` j  ==  (overlap i j == EQ))+ DocTest.printPrefix "Data.Interval:372: "+{-# LINE 372 "src/Data/Interval.hs" #-}+ DocTest.property+{-# LINE 372 "src/Data/Interval.hs" #-}+        (genInterval /\* \i j -> i `properlyIntersects` j  ==  (properOverlap i j == EQ))+ DocTest.printPrefix "Data.Interval:384: "+{-# LINE 384 "src/Data/Interval.hs" #-}+ DocTest.property+{-# LINE 384 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> (lb i <= ub i && lb j <= ub j && i `intersects` j)  ==  (max (lb i) (lb j) <= min (ub i) (ub j)))- DocTest.printPrefix "Data.Interval:351: "-{-# LINE 351 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:381: "+{-# LINE 381 "src/Data/Interval.hs" #-}  DocTest.example-{-# LINE 351 "src/Data/Interval.hs" #-}+{-# LINE 381 "src/Data/Interval.hs" #-}       (((1,2)::(Int,Int)) `intersects` ((2,3)::(Int,Int)))   [ExpectedLine [LineChunk "True"]]- DocTest.printPrefix "Data.Interval:365: "-{-# LINE 365 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:395: "+{-# LINE 395 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 365 "src/Data/Interval.hs" #-}+{-# LINE 395 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> ((i `intersects` j) && not (i `properlyIntersects` j))  ==  (ub i == lb j || ub j == lb i))- DocTest.printPrefix "Data.Interval:371: "-{-# LINE 371 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:401: "+{-# LINE 401 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 371 "src/Data/Interval.hs" #-}+{-# LINE 401 "src/Data/Interval.hs" #-}         (genInterval /\ \i -> i `contains` i)- DocTest.printPrefix "Data.Interval:372: "-{-# LINE 372 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:402: "+{-# LINE 402 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 372 "src/Data/Interval.hs" #-}+{-# LINE 402 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> (i `contains` j && j `contains` i) == (i==j))- DocTest.printPrefix "Data.Interval:373: "-{-# LINE 373 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:403: "+{-# LINE 403 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 373 "src/Data/Interval.hs" #-}+{-# LINE 403 "src/Data/Interval.hs" #-}         (genInterval /\* \i j -> i `contains` j == (maybeUnion i j == Just i))- DocTest.printPrefix "Data.Interval:385: "-{-# LINE 385 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:415: "+{-# LINE 415 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 385 "src/Data/Interval.hs" #-}+{-# LINE 415 "src/Data/Interval.hs" #-}         (genSortedList /\ \xs -> (components $ toList $ fromEndPoints xs) == if length xs < 2 then [] else [(head xs, last xs)])- DocTest.printPrefix "Data.Interval:398: "-{-# LINE 398 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:428: "+{-# LINE 428 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 398 "src/Data/Interval.hs" #-}+{-# LINE 428 "src/Data/Interval.hs" #-}         (genInterval /\ \i -> genSortedIntervalSeq /\ \js -> toList (getIntersects i js) `List.isSubsequenceOf` toList js)- DocTest.printPrefix "Data.Interval:415: "-{-# LINE 415 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:445: "+{-# LINE 445 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 415 "src/Data/Interval.hs" #-}+{-# LINE 445 "src/Data/Interval.hs" #-}         (genSortedIntervalSeq /\ \xs -> hullSeq xs == hull (toList xs))- DocTest.printPrefix "Data.Interval:447: "-{-# LINE 447 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:464: "+{-# LINE 464 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 447 "src/Data/Interval.hs" #-}+{-# LINE 464 "src/Data/Interval.hs" #-}+        (genInterval /\ \i -> genSortedIntervals /\ \js -> fst (splitIntersecting i js) == filter (intersects i) js)+ DocTest.printPrefix "Data.Interval:465: "+{-# LINE 465 "src/Data/Interval.hs" #-}+ DocTest.property+{-# LINE 465 "src/Data/Interval.hs" #-}+        (genInterval /\ \i -> genSortedIntervals /\ \js -> all (\j -> not (ub j < ub i)) (snd (splitIntersecting i js)))+ DocTest.printPrefix "Data.Interval:461: "+{-# LINE 461 "src/Data/Interval.hs" #-}+ DocTest.example+{-# LINE 461 "src/Data/Interval.hs" #-}+      (splitIntersecting ((2,5) :: (Int,Int)) ([(0,1),(2,3),(2,2),(3,6),(6,7)] :: [(Int,Int)]))+  [ExpectedLine [LineChunk "([(2,3),(2,2),(3,6)],[(3,6),(6,7)])"]]+ DocTest.printPrefix "Data.Interval:485: "+{-# LINE 485 "src/Data/Interval.hs" #-}+ DocTest.property+{-# LINE 485 "src/Data/Interval.hs" #-}+        (genInterval /\ \i -> genSortedIntervals /\ \js -> fst (splitProperlyIntersecting i js) == filter (properlyIntersects i) js)+ DocTest.printPrefix "Data.Interval:486: "+{-# LINE 486 "src/Data/Interval.hs" #-}+ DocTest.property+{-# LINE 486 "src/Data/Interval.hs" #-}+        (genInterval /\ \i -> genSortedIntervals /\ \js -> all (not.contains i) (snd (splitProperlyIntersecting i js)))+ DocTest.printPrefix "Data.Interval:482: "+{-# LINE 482 "src/Data/Interval.hs" #-}+ DocTest.example+{-# LINE 482 "src/Data/Interval.hs" #-}+      (splitProperlyIntersecting ((2,5) :: (Int,Int))  ([(0,1),(2,3),(2,2),(3,5),(5,6),(6,7)] :: [(Int,Int)]))+  [ExpectedLine [LineChunk "([(2,3),(3,5)],[(5,6),(6,7)])"]]+ DocTest.printPrefix "Data.Interval:523: "+{-# LINE 523 "src/Data/Interval.hs" #-}+ DocTest.property+{-# LINE 523 "src/Data/Interval.hs" #-}         (invariant . itree 4 . fmap (\(x,y) -> (x, x + QC.getNonNegative y :: Integer)))- DocTest.printPrefix "Data.Interval:457: "-{-# LINE 457 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:533: "+{-# LINE 533 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 457 "src/Data/Interval.hs" #-}+{-# LINE 533 "src/Data/Interval.hs" #-}         (genInterval /\ \i -> genIntervalSeq /\ \t -> on (==) sortByLeft (getIntersectsIT i $ itree 2 t) (i `intersecting` t))- DocTest.printPrefix "Data.Interval:468: "-{-# LINE 468 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:544: "+{-# LINE 544 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 468 "src/Data/Interval.hs" #-}+{-# LINE 544 "src/Data/Interval.hs" #-}         (genInterval /\ \i -> genIntervalSeq /\ \t -> on (==) sortByLeft (getProperIntersectsIT i $ itree 2 t) (i `intersectingProperly` t))- DocTest.printPrefix "Data.Interval:573: "-{-# LINE 573 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:649: "+{-# LINE 649 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 573 "src/Data/Interval.hs" #-}+{-# LINE 649 "src/Data/Interval.hs" #-}         (genIntervalSeq /\ \is -> joinSeq (splitSeq is) == is)- DocTest.printPrefix "Data.Interval:630: "-{-# LINE 630 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:706: "+{-# LINE 706 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 630 "src/Data/Interval.hs" #-}+{-# LINE 706 "src/Data/Interval.hs" #-}         (genDisjointIntervalSeq /\ \xs -> hullSeqNonOverlap xs == hullSeq xs)- DocTest.printPrefix "Data.Interval:647: "-{-# LINE 647 "src/Data/Interval.hs" #-}+ DocTest.printPrefix "Data.Interval:732: "+{-# LINE 732 "src/Data/Interval.hs" #-}  DocTest.property-{-# LINE 647 "src/Data/Interval.hs" #-}+{-# LINE 732 "src/Data/Interval.hs" #-}         (genInterval /\ \i -> genDisjointIntervalSeq /\ \js -> findSeq intersects i js == intersecting i js)

src/Data/Interval.hs view

@@ -50,6 +50,7 @@     intersects,properlyIntersects,contains,properlyContains,
     covered,coveredBy,overlapTime,prevailing,fractionCovered,
     overlap,
+    properOverlap,
     intervalDuration,
     -- * Operations on intervals
     maybeUnion,maybeIntersection,
@@ -59,6 +60,9 @@     contiguous,components,componentsSeq,
     sortByLeft,
     fromEndPoints,
+    -- * Streaming intervals
+    splitIntersecting,
+    splitProperlyIntersecting,
     -- * Interval search tree
     ITree,
     itree,
@@ -140,16 +144,20 @@     -- ^ 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 = getIntersectsIT
     getProperIntersects = getProperIntersectsIT
     someIntersects = someIntersectsIT
     someProperlyIntersects = someProperlyIntersectsIT
+    maybeBounds = hullOfTree 
 instance Ord e => IntersectionQuery Seq e Seq where
     getIntersects = findSeq intersects
     getProperIntersects = findSeq properlyIntersects
     someIntersects = existsSeq intersects
     someProperlyIntersects = existsSeq properlyIntersects
+    maybeBounds = hullSeqNonOverlap 
 
 -- | Time types supporting differences
 class TimeDifference t where
@@ -344,12 +352,30 @@ -- i.e., 'overlap' is not transitive.
 --
 -- prop> genInterval /\* \i j -> i `intersects` j  ==  (overlap i j == EQ)
-overlap :: Interval e i => i -> i -> Ordering
+overlap :: (Interval e i, Interval e j) => i -> j -> Ordering
 overlap i j = case (compare (ub i) (lb j),compare (ub j) (lb i)) of
     (LT,_) -> LT
     (_,LT) -> GT
     _      -> 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 = case ((ub i) <= (lb j),(ub j) <= (lb i)) of
+    (True,_) -> LT
+    (_,True) -> GT
+    _      -> EQ
+
 -- | intersection query.
 --
 -- >>> ((1,2)::(Int,Int)) `intersects` ((2,3)::(Int,Int))
@@ -422,6 +448,52 @@     EmptyL -> Nothing
     leftmost :< _others -> Just (lb leftmost, maximum (fmap ub 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 _ [] = ([],[])
+splitIntersecting i js@(j:js') = case i `overlap` j of
+    GT -> splitIntersecting i js'
+    LT -> ([],js)
+    EQ -> let 
+        keep = ub j >= ub i
+        (block,notIntersecting) = splitIntersecting i js'
+        in (j:block,if keep then j:notIntersecting else 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 _ [] = ([],[])
+splitProperlyIntersecting i js@(j:js') = case i `properOverlap` j of
+    GT -> splitProperlyIntersecting i js'
+    LT -> ([],js)
+    EQ -> let 
+        keep = ub j > ub i
+        (block,notIntersecting) = splitProperlyIntersecting i js'
+        in (j:block,if keep then j:notIntersecting else 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.
@@ -638,10 +710,6 @@     leftmost :< others -> Just (lb leftmost, case Seq.viewr others of
         _ :> rightmost -> maybe (ub rightmost) ub (findLeftmost ((lb rightmost ==).lb) xs)
         EmptyR         -> ub leftmost)
--- TODO: This fails e.g. for 
--- [(0,2),(0,0)] 
--- for the upper bound need to perform binary search 
--- for the left-most interval i with lb i == lb rightmost
 
 findLeftmost :: (i -> Bool) -> Seq i -> Maybe i
 findLeftmost p = go where