Merge pull request #30 from marcosh/fix-relate-boundary-comparison

msakai · Sep 3, 2021 · 227bffc · 227bffc
2 parents 2755db4 + ec800de
commit 227bffc
Show file tree

Hide file tree

Showing 2 changed files with 22 additions and 7 deletions.
diff --git a/src/Data/Interval.hs b/src/Data/Interval.hs
@@ -857,16 +857,16 @@ relate i1 i2 =
     -- 'i1' ad 'i2' are equal
     (True , True ) -> Equal
     -- 'i1' is strictly contained in `i2`
-    (True , False) | lowerBound i1 == lowerBound i2 -> Starts
-                   | upperBound i1 == upperBound i2 -> Finishes
-                   | otherwise                      -> During
+    (True , False) | compareBound (lowerBound' i1) (lowerBound' i2) == EQ -> Starts
+                   | compareBound (upperBound' i1) (upperBound' i2) == EQ -> Finishes
+                   | otherwise                                            -> During
     -- 'i2' is strictly contained in `i1`
-    (False, True ) | lowerBound i1 == lowerBound i2 -> StartedBy
-                   | upperBound i1 == upperBound i2 -> FinishedBy
-                   | otherwise                      -> Contains
+    (False, True ) | compareBound (lowerBound' i1) (lowerBound' i2) == EQ -> StartedBy
+                   | compareBound (upperBound' i1) (upperBound' i2) == EQ -> FinishedBy
+                   | otherwise                                            -> Contains
     -- neither `i1` nor `i2` is contained in the other
     (False, False) -> case ( null (i1 `intersection` i2)
-                           , upperBound' i1 <= upperBound' i2
+                           , compareBound (upperBound' i1) (upperBound' i2) <= EQ
                            , i1 `isConnected` i2
                            ) of
       (True , True , True ) -> JustBefore
@@ -875,3 +875,10 @@ relate i1 i2 =
       (True , False, False) -> After
       (False, True , _    ) -> Overlaps
       (False, False, _    ) -> OverlappedBy
+  where
+    compareBound :: Ord r => (Extended r, Boundary) -> (Extended r, Boundary) -> Ordering
+    compareBound (PosInf, _) (PosInf, _) = EQ
+    compareBound (PosInf, _) _           = GT
+    compareBound (NegInf, _) (NegInf, _) = EQ
+    compareBound (NegInf, _) _           = LT
+    compareBound a           b           = compare a b
diff --git a/test/TestInterval.hs b/test/TestInterval.hs
@@ -380,6 +380,14 @@ prop_relate_interval_contains_another =
   forAll (nonEmptyIntervalPairs (\(lb1, _) (ub1, _) (lb2, _) (ub2, _) -> lb1 < lb2 && ub1 > ub2)) $ \(a, b) ->
     Interval.relate a b == Contains
 
+prop_relate_closed_interval_contains_open_interval_with_same_boundary =
+  forAll (arbitrary `suchThat` \(lb, rb) -> lb < rb) $
+    \(lb :: Rational, rb) ->
+      Interval.relate
+        (Interval.interval (Finite lb, Interval.Closed) (Finite rb, Interval.Closed))
+        (Interval.interval (Finite lb, Interval.Open) (Finite rb, Interval.Open))
+      == Contains
+
 prop_relate_one_singleton_before_another =
   forAll (arbitrary `suchThat` uncurry (<)) $ \(r1 :: Rational, r2) ->
     Interval.relate (Interval.singleton r1) (Interval.singleton r2) == Before