diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,9 @@ +2.1.1 +----- + +* fix boundary comparison in `relate` (#30, thanks to marcosh) +* fix behaviour of `lattices` flag + 2.1.0 ----- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,6 @@ data-interval ============= -[![Build Status (Travis-CI)](https://travis-ci.org/msakai/data-interval.svg?branch=master)](https://travis-ci.org/msakai/data-interval) [![Build Status (GitHub Actions)](https://github.com/msakai/data-interval/actions/workflows/build.yaml/badge.svg)](https://github.com/msakai/data-interval/actions/workflows/build.yaml) [![Hackage](https://img.shields.io/hackage/v/data-interval.svg)](https://hackage.haskell.org/package/data-interval) [![Hackage Deps](https://img.shields.io/hackage-deps/v/data-interval.svg)](https://packdeps.haskellers.com/feed?needle=data-interval) diff --git a/data-interval.cabal b/data-interval.cabal --- a/data-interval.cabal +++ b/data-interval.cabal @@ -1,5 +1,5 @@ Name: data-interval -Version: 2.1.0 +Version: 2.1.1 License: BSD3 License-File: COPYING Author: Masahiro Sakai (masahiro.sakai@gmail.com) @@ -26,7 +26,9 @@ GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.4 - GHC ==8.10.2 + GHC ==8.10.7 + GHC ==9.0.1 + GHC ==9.2.1 source-repository head type: git @@ -42,7 +44,7 @@ base >=4 && <5 , containers , deepseq - , hashable >=1.1.2.5 && <1.4 + , hashable >=1.1.2.5 && <1.5 , extended-reals >=0.2 && <1.0 if impl(ghc <8.0) Build-depends: @@ -87,7 +89,6 @@ base >=4 && <5 , ChasingBottoms , containers - , lattices , deepseq , hashable , data-interval @@ -107,6 +108,9 @@ if impl(ghc <7.10) Build-depends: transformers >=0.2 + if flag(lattices) + build-depends: + lattices >=1.2.1.1 && <2.1 Default-Language: Haskell2010 Other-Extensions: TemplateHaskell diff --git a/src/Data/IntegerInterval.hs b/src/Data/IntegerInterval.hs --- a/src/Data/IntegerInterval.hs +++ b/src/Data/IntegerInterval.hs @@ -83,7 +83,7 @@ , relate ) where -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices import Algebra.Lattice #endif import Control.Exception (assert) @@ -135,7 +135,7 @@ ub@(Finite _) -> (ub, Closed) ub@_ -> (ub, Open) -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices #if MIN_VERSION_lattices(2,0,0) instance Lattice IntegerInterval where diff --git a/src/Data/Interval.hs b/src/Data/Interval.hs --- a/src/Data/Interval.hs +++ b/src/Data/Interval.hs @@ -83,7 +83,7 @@ , relate ) where -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices import Algebra.Lattice #endif import Control.Exception (assert) @@ -120,7 +120,7 @@ infix 4 >?? infix 4 /=?? -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices #if MIN_VERSION_lattices(2,0,0) instance (Ord r) => Lattice (Interval r) where @@ -857,16 +857,16 @@ -- '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 @@ (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/src/Data/IntervalRelation.hs b/src/Data/IntervalRelation.hs --- a/src/Data/IntervalRelation.hs +++ b/src/Data/IntervalRelation.hs @@ -23,25 +23,48 @@ import Data.Data import GHC.Generics (Generic) --- | describes how two intervals @x@ and @y@ can be related. +-- | Describes how two intervals @x@ and @y@ can be related. -- See [Allen's interval algebra](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra) +-- and [Intervals and their relations](http://marcosh.github.io/post/2020/05/04/intervals-and-their-relations.html). data Relation = Before + -- ^ Any element of @x@ is smaller than any element of @y@, + -- and intervals are not connected. In other words, there exists an element + -- that is bigger than any element of @x@ and smaller than any element of @y@. | JustBefore + -- ^ Any element of @x@ is smaller than any element of @y@, + -- but intervals are connected and non-empty. This implies that intersection + -- of intervals is empty, and union is a single interval. | Overlaps + -- ^ Intersection of @x@ and @y@ is non-empty, + -- @x@ start and finishes earlier than @y@. This implies that union + -- is a single interval, and @x@ finishes no earlier than @y@ starts. | Starts + -- ^ @x@ is a proper subset of @y@, + -- and they share lower bounds. | During + -- ^ @x@ is a proper subset of @y@, + -- but they share neither lower nor upper bounds. | Finishes + -- ^ @x@ is a proper subset of @y@, + -- and they share upper bounds. | Equal + -- ^ Intervals are equal. | FinishedBy + -- ^ Inverse of 'Finishes'. | Contains + -- ^ Inverse of 'During'. | StartedBy + -- ^ Inverse of 'Starts'. | OverlappedBy + -- ^ Inverse of 'Overlaps'. | JustAfter + -- ^ Inverse of 'JustBefore'. | After + -- ^ Inverse of 'Before'. deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data, Typeable) --- | inverts a relation, such that @'invert' ('Data.Interval.relate' x y) = 'Data.Interval.relate' y x@ +-- | Inverts a relation, such that @'invert' ('Data.Interval.relate' x y) = 'Data.Interval.relate' y x@ invert :: Relation -> Relation invert relation = case relation of Before -> After diff --git a/src/Data/IntervalSet.hs b/src/Data/IntervalSet.hs --- a/src/Data/IntervalSet.hs +++ b/src/Data/IntervalSet.hs @@ -62,7 +62,7 @@ where import Prelude hiding (null, span) -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices import Algebra.Lattice #endif import Control.DeepSeq @@ -133,7 +133,7 @@ instance Hashable r => Hashable (IntervalSet r) where hashWithSalt s (IntervalSet m) = hashWithSalt s (Map.toList m) -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices #if MIN_VERSION_lattices(2,0,0) instance (Ord r) => Lattice (IntervalSet r) where diff --git a/test/TestIntegerInterval.hs b/test/TestIntegerInterval.hs --- a/test/TestIntegerInterval.hs +++ b/test/TestIntegerInterval.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP, TemplateHaskell, ScopedTypeVariables #-} module TestIntegerInterval (integerIntervalTestGroup) where -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices import qualified Algebra.Lattice as L #endif import Control.DeepSeq @@ -724,7 +724,7 @@ Lattice --------------------------------------------------------------------} -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices prop_Lattice_Leq_welldefined = forAll integerIntervals $ \a b -> diff --git a/test/TestInterval.hs b/test/TestInterval.hs --- a/test/TestInterval.hs +++ b/test/TestInterval.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP, TemplateHaskell, RankNTypes, ScopedTypeVariables #-} module TestInterval (intervalTestGroup) where -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices import qualified Algebra.Lattice as L #endif import Control.DeepSeq @@ -380,6 +380,14 @@ 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 @@ -1155,7 +1163,7 @@ Lattice --------------------------------------------------------------------} -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices prop_Lattice_Leq_welldefined = forAll intervals $ \a b -> diff --git a/test/TestIntervalRelation.hs b/test/TestIntervalRelation.hs --- a/test/TestIntervalRelation.hs +++ b/test/TestIntervalRelation.hs @@ -1,11 +1,13 @@ {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} module TestIntervalRelation (intervalRelationTestGroup) where +import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Test.Tasty.TH -import Data.Interval +import Data.Interval as I import Data.IntervalRelation +import Data.Ord (Down(..)) import TestInstances @@ -14,12 +16,137 @@ --------------------------------------------------------------------} prop_invert_is_involution a = - invert (invert a) == a + invert (invert a) === a prop_invert_inverts_relation = - forAll intervals $ \a -> - forAll intervals $ \b -> - relate a b == invert (relate b a) + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + relate a b === invert (relate b a) + +------------------------------------------------------------------------ + +case_empty1 = + relate (empty :: Interval Rational) empty @?= Equal + +prop_empty2 = + forAllShrink intervals shrink $ \a -> not (I.null a) ==> + relate (empty :: Interval Rational) a === During + +prop_empty3 = + forAllShrink intervals shrink $ \a -> not (I.null a) ==> + relate a (empty :: Interval Rational) === Contains + +prop_universal_lt = + forAllShrink intervals shrink $ \a -> not (I.null a) ==> + forAllShrink intervals shrink $ \b -> not (I.null b) ==> + let r = relate a b in counterexample (show r) $ + if a not (I.null a) ==> + forAllShrink intervals shrink $ \b -> not (I.null b) ==> + let r = relate a b in counterexample (show r) $ + if a <=! b then r `elem` [Before, JustBefore, Overlaps, Starts, Equal, FinishedBy] + else r `notElem` [Before, JustBefore] + +prop_universal_eq = + forAllShrink intervals shrink $ \a -> not (I.null a) ==> + forAllShrink intervals shrink $ \b -> not (I.null b) ==> + not (a ==! b) || relate a b == Equal + +prop_universal_gt = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + (a >! b) === (b + forAllShrink intervals shrink $ \b -> + (a >=! b) === (b <=! a) + +prop_universal_ne = + forAllShrink intervals shrink $ \a -> not (I.null a) ==> + forAllShrink intervals shrink $ \b -> not (I.null b) ==> + let r = relate a b in counterexample (show r) $ + if a /=! b then r `elem` [Before, JustBefore, After, JustAfter] + else r `notElem` [Before, JustBefore, After, JustAfter] + +------------------------------------------------------------------------ + +prop_existential_lt = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + (a =! b) + +prop_existential_le = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + (a <=? b) === not (a >! b) + +prop_existential_eq = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + (a ==? b) === not (a /=! b) + +prop_existential_gt = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + (a >? b) === not (a <=! b) + +prop_existential_ge = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + (a >=? b) === not (a + forAllShrink intervals shrink $ \b -> + (a /=? b) === not (a ==! b) + +------------------------------------------------------------------------ + +prop_before = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + let r = relate a b in counterexample (show r) $ + (r == Before) === (a + forAllShrink intervals shrink $ \b -> + let r = relate a b in counterexample (show r) $ + (r == JustBefore) === (a + forAllShrink intervals shrink $ \b -> + let r = relate a b in counterexample (show r) $ + (r == Overlaps) === (not (I.null (intersection a b)) && fmap Down (lowerBound' a) < fmap Down (lowerBound' b) && upperBound' a < upperBound' b) + +prop_starts = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + let r = relate a b in counterexample (show r) $ + (r == Starts) === (isProperSubsetOf a b && lowerBound' a == lowerBound' b) + +prop_during = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + let r = relate a b in counterexample (show r) $ + (r == During) === (isProperSubsetOf a b && lowerBound' a /= lowerBound' b && upperBound' a /= upperBound' b) + +prop_finishes = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + let r = relate a b in counterexample (show r) $ + (r == Finishes) === (isProperSubsetOf a b && upperBound' a == upperBound' b) + +prop_equal = + forAllShrink intervals shrink $ \a -> + forAllShrink intervals shrink $ \b -> + let r = relate a b in counterexample (show r) $ + (r == Equal) === (a == b) ------------------------------------------------------------------------ -- Test harness diff --git a/test/TestIntervalSet.hs b/test/TestIntervalSet.hs --- a/test/TestIntervalSet.hs +++ b/test/TestIntervalSet.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP, TemplateHaskell, ScopedTypeVariables #-} module TestIntervalSet (intervalSetTestGroup) where -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices import qualified Algebra.Lattice as L #endif import Control.Applicative ((<$>)) @@ -297,7 +297,7 @@ Lattice --------------------------------------------------------------------} -#if MIN_VERSION_lattices +#ifdef MIN_VERSION_lattices prop_Lattice_Leq_welldefined = forAll arbitrary $ \(a :: IntervalSet Rational) (b :: IntervalSet Rational) ->