diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,12 @@ # Changelog for interval-algebra +## 0.8.5 + +* Fixes synonyms so that `before == precedes` and `after == precededBy`, rather than the incorrect `starts == precedes` and `startedBy == precededBy`. + ## 0.8.4 -* Fixes bug in `formMeetingSequence` wherein sequences of events with >2 nested events were not returning a meeting sequence. +* Fixes bug in `formMeetingSequence` wherein sequences of events with >2 nested events were not returning a meeting sequence. ## 0.8.3 diff --git a/interval-algebra.cabal b/interval-algebra.cabal --- a/interval-algebra.cabal +++ b/interval-algebra.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: interval-algebra -version: 0.8.4 +version: 0.8.5 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at category: Algebra,Time @@ -38,7 +38,7 @@ , containers >= 0.6 , witherable >= 0.4 , safe >= 0.3 - , QuickCheck + , QuickCheck == 2.14.2 default-language: Haskell2010 test-suite interval-algebra-test @@ -57,11 +57,12 @@ test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - QuickCheck + QuickCheck == 2.14.2 , base >=4.7 && <5 , hspec == 2.8.2 , containers >= 0.6 , interval-algebra , time >=1.8 && <2 + , witherable >= 0.4 , safe >= 0.3 default-language: Haskell2010 diff --git a/src/IntervalAlgebra.hs b/src/IntervalAlgebra.hs --- a/src/IntervalAlgebra.hs +++ b/src/IntervalAlgebra.hs @@ -147,10 +147,12 @@ , equals -- ** Additional predicates and utilities + , precedes, precededBy , disjoint , notDisjoint, concur , within, enclose, enclosedBy , (<|>) - , unionPredicates + , predicate, unionPredicates + , disjointRelations, withinRelations , ComparativePredicateOf1 , ComparativePredicateOf2 @@ -172,7 +174,7 @@ ) where -import Prelude ( Eq, Show, Read, Enum(..), Bounded(..) +import Prelude ( Eq, Show, Enum(..), Bounded(..) , Maybe(..), Either(..), String, Bool(..) , Integer, Int, Num , map, otherwise, show @@ -274,7 +276,7 @@ | OverlappedBy -- ^ `overlappedBy` | MetBy -- ^ `metBy` | After -- ^ `after` - deriving (Eq, Show, Read, Enum) + deriving (Eq, Show, Enum) instance Bounded IntervalRelation where minBound = Before @@ -290,11 +292,12 @@ metBy = flip meets -- | Is x before y? Is x after y? -before, after :: (Intervallic i0 a, Intervallic i1 a)=> +before, after, precedes, precededBy :: (Intervallic i0 a, Intervallic i1 a)=> ComparativePredicateOf2 (i0 a) (i1 a) before x y = end x < begin y after = flip before - +precedes = before +precededBy = after -- | Does x overlap y? Is x overlapped by y? overlaps, overlappedBy :: (Intervallic i0 a, Intervallic i1 a)=> ComparativePredicateOf2 (i0 a) (i1 a) @@ -302,12 +305,10 @@ overlappedBy = flip overlaps -- | Does x start y? Is x started by y? -starts, startedBy, precedes, precededBy :: (Intervallic i0 a, Intervallic i1 a)=> +starts, startedBy :: (Intervallic i0 a, Intervallic i1 a)=> ComparativePredicateOf2 (i0 a) (i1 a) starts x y = begin x == begin y && end x < end y startedBy = flip starts -precedes = starts -precededBy = startedBy -- | Does x finish y? Is x finished by y? finishes, finishedBy :: (Intervallic i0 a, Intervallic i1 a)=> @@ -333,9 +334,11 @@ -> ComparativePredicateOf2 (i0 a) (i1 a) (<|>) f g = unionPredicates [f, g] +-- | The set of @IntervalRelation@ meaning two intervals are disjoint. disjointRelations :: Data.Set.Set IntervalRelation disjointRelations = toSet [Before, After, Meets, MetBy] +-- | The set of @IntervalRelation@ meaning one interval is within the other. withinRelations :: Data.Set.Set IntervalRelation withinRelations = toSet [Starts, During, Finishes, Equals] diff --git a/src/IntervalAlgebra/IntervalUtilities.hs b/src/IntervalAlgebra/IntervalUtilities.hs --- a/src/IntervalAlgebra/IntervalUtilities.hs +++ b/src/IntervalAlgebra/IntervalUtilities.hs @@ -63,12 +63,11 @@ , durations ) where -import Prelude ( (<*>), seq) import GHC.Show ( Show ) import GHC.Num (xorInteger ) import GHC.Int ( Int ) import Control.Applicative - ( Applicative(pure) ) + ( Applicative(pure) , (<*>)) import Data.Bool ( Bool, otherwise, not, (||), (&&) ) import Data.Eq ( Eq((==)) ) import Data.Foldable ( Foldable(null, foldl', toList), all, any, or ) diff --git a/src/IntervalAlgebra/PairedInterval.hs b/src/IntervalAlgebra/PairedInterval.hs --- a/src/IntervalAlgebra/PairedInterval.hs +++ b/src/IntervalAlgebra/PairedInterval.hs @@ -74,8 +74,8 @@ equalPairData x y = getPairData x == getPairData y -- | Gets the intervals from a list of paired intervals. -intervals :: (Ord a) => [PairedInterval b a] -> [Interval a] -intervals = map getInterval +intervals :: (Ord a, Functor f) => f (PairedInterval b a) -> f (Interval a) +intervals = fmap getInterval -- | Empty is used to trivially lift an @Interval a@ into a @PairedInterval@. data Empty = Empty deriving (Eq, Ord, Show) diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -3,24 +3,35 @@ {-# LANGUAGE FlexibleInstances #-} module IntervalAlgebra.IntervalUtilitiesSpec (spec) where -import Test.Hspec.QuickCheck ( modifyMaxSuccess ) +import Test.Hspec.QuickCheck ( modifyMaxSuccess + , modifyMaxDiscardRatio ) import Test.Hspec ( Spec - , it, shouldBe, describe, pending, xcontext ) + , it + , shouldBe + , describe + , pending + , xcontext ) import Test.QuickCheck ( Property , Testable(property) , Arbitrary(arbitrary, shrink) , suchThat , (===), (==>) - , Arbitrary1 (liftArbitrary), listOf, orderedList) + , Arbitrary1 (liftArbitrary) + , listOf + , orderedList) import Data.List (sort) import IntervalAlgebra.Arbitrary ( ) import IntervalAlgebra ( Interval , Intervallic(..) , IntervalCombinable(..) , IntervalRelation (..) - , beginerval , IntervalSizeable - , starts ) + , beginerval + , complement + , starts + , disjointRelations + , withinRelations + , predicate ) import IntervalAlgebra.IntervalUtilities ( gaps , durations , intersect @@ -28,8 +39,25 @@ , clip , gapsWithin , nothingIfNone + , filterBefore + , filterMeets + , filterOverlaps + , filterFinishedBy + , filterContains + , filterStarts + , filterEquals + , filterStartedBy + , filterDuring + , filterFinishes + , filterOverlappedBy + , filterMetBy + , filterAfter , filterDisjoint , filterNotDisjoint + , filterConcur + , filterWithin + , filterEnclose + , filterEnclosedBy , combineIntervals , foldMeetingSafe , formMeetingSequence ) @@ -37,7 +65,8 @@ , makePairedInterval , PairedInterval, getPairData ) import Control.Monad ( liftM2 ) -import Data.Foldable +import Data.Set ( Set, fromList, member ) +import Witherable ( Filterable ) -- Types for testing @@ -237,6 +266,100 @@ prop_formMeetingSequence2 x = not (null $ getEvents x) ==> not $ null res where res = formMeetingSequence (getEvents x) +class ( Ord a ) => FiltrationProperties a where + prop_filtration :: + (Interval a -> [Interval a] -> [Interval a]) + -> Set IntervalRelation + -> Interval a + -> [Interval a] + -> Property + prop_filtration fltr s x l = + not (null res) ==> and (fmap (predicate s x) res) === True + where res = fltr x l + + prop_filterOverlaps :: Interval a + -> [Interval a] + -> Property + prop_filterOverlaps = prop_filtration filterOverlaps (fromList [Overlaps]) + + prop_filterOverlappedBy :: Interval a + -> [Interval a] + -> Property + prop_filterOverlappedBy = prop_filtration filterOverlappedBy (fromList [OverlappedBy]) + + prop_filterBefore :: Interval a + -> [Interval a] + -> Property + prop_filterBefore = prop_filtration filterBefore (fromList [Before]) + + prop_filterAfter :: Interval a + -> [Interval a] + -> Property + prop_filterAfter = prop_filtration filterAfter (fromList [After]) + + prop_filterStarts :: Interval a + -> [Interval a] + -> Property + prop_filterStarts = prop_filtration filterStarts (fromList [Starts]) + + prop_filterStartedBy :: Interval a + -> [Interval a] + -> Property + prop_filterStartedBy = prop_filtration filterStartedBy (fromList [StartedBy]) + + prop_filterFinishes :: Interval a + -> [Interval a] + -> Property + prop_filterFinishes = prop_filtration filterFinishes (fromList [Finishes]) + + prop_filterFinishedBy :: Interval a + -> [Interval a] + -> Property + prop_filterFinishedBy = prop_filtration filterFinishedBy (fromList [FinishedBy]) + + prop_filterMeets :: Interval a + -> [Interval a] + -> Property + prop_filterMeets = prop_filtration filterMeets (fromList [Meets]) + + prop_filterMetBy :: Interval a + -> [Interval a] + -> Property + prop_filterMetBy = prop_filtration filterMetBy (fromList [MetBy]) + + prop_filterDuring :: Interval a + -> [Interval a] + -> Property + prop_filterDuring = prop_filtration filterDuring (fromList [During]) + + prop_filterContains :: Interval a + -> [Interval a] + -> Property + prop_filterContains = prop_filtration filterContains (fromList [Contains]) + + prop_filterEquals :: Interval a + -> [Interval a] + -> Property + prop_filterEquals = prop_filtration filterEquals (fromList [Equals]) + + prop_filterDisjoint :: Interval a + -> [Interval a] + -> Property + prop_filterDisjoint = prop_filtration filterDisjoint disjointRelations + + prop_filterNotDisjoint :: Interval a + -> [Interval a] + -> Property + prop_filterNotDisjoint = prop_filtration filterNotDisjoint (complement disjointRelations) + + prop_filterWithin :: Interval a + -> [Interval a] + -> Property + prop_filterWithin = prop_filtration filterWithin withinRelations + +instance FiltrationProperties Int + + spec :: Spec spec = do describe "gaps tests" $ @@ -300,6 +423,7 @@ it "more emptyif tests" pending describe "filtration tests" $ + modifyMaxDiscardRatio (*2) $ do it "disjoint filter should filter out noncontainment" $ filterDisjoint containmentInt [noncontainmentInt, anotherInt] @@ -307,7 +431,24 @@ it "notDisjoint filter should keep noncontainment" $ filterNotDisjoint containmentInt [noncontainmentInt, anotherInt] `shouldBe` [noncontainmentInt] + it "filterBefore property" $ property (prop_filterBefore @Int) + it "filterAfter property" $ property (prop_filterAfter @Int) + it "filterOverlaps property" $ property (prop_filterOverlaps @Int) + it "filterOverlappedBy property" $ property (prop_filterOverlappedBy @Int) + it "filterStarts property" $ property (prop_filterStarts @Int) + it "filterStartedBy property" $ property (prop_filterStartedBy @Int) + it "filterFinishes property" $ property (prop_filterFinishes @Int) + it "filterFinishedBy property" $ property (prop_filterFinishedBy @Int) + it "filterMeets property" $ property (prop_filterMeets @Int) + it "filterMetBy property" $ property (prop_filterMetBy @Int) + it "filterDuring property" $ property (prop_filterDuring @Int) + it "filterContains property" $ property (prop_filterContains @Int) + it "filterEquals property" $ property (prop_filterEquals @Int) + it "filterDisjoint property" $ property (prop_filterDisjoint @Int) + it "filterNotDisjoint property" $ property (prop_filterNotDisjoint @Int) + it "filterWithin property" $ property (prop_filterWithin @Int) + describe "intersection tests" $ do it "intersection of (0, 2) (2, 4) should be Nothing" $ @@ -315,6 +456,15 @@ it "intersection of (0, 2) (3, 4) should be Nothing" $ intersect (iv 2 0) (iv 1 3) `shouldBe` Nothing it "intersection of (2, 4) (0, 2) should be Nothing" $ + intersect (iv 2 2) (iv 2 0) `shouldBe` Nothing + + describe "intersection tests" $ + do + it "intersection of (0, 2) (2, 4) should be Nothing" $ + intersect (iv 2 0) (iv 2 2) `shouldBe` Nothing + it "intersection of (0, 2) (3, 4) should be Nothing" $ + intersect (iv 2 0) (iv 1 3) `shouldBe` Nothing + it "intersection of (2, 4) (0, 2) should be Nothing" $ intersect (iv 2 2) (iv 2 0) `shouldBe` Nothing it "intersection of (0, 2) (1, 3) should be Just (1, 2)" $ intersect (iv 2 0) (iv 2 1) `shouldBe` Just (iv 1 1) @@ -376,6 +526,8 @@ formMeetingSequence c4in `shouldBe` c4out it "formMeetingSequence unit test 5"$ formMeetingSequence c5in `shouldBe` c5out + it "formMeetingSequence unit test 6"$ + formMeetingSequence ([] :: [StateEvent Int]) `shouldBe` [] describe "formMeetingSequence property tests" $ modifyMaxSuccess (*50) $ diff --git a/test/IntervalAlgebra/PairedIntervalSpec.hs b/test/IntervalAlgebra/PairedIntervalSpec.hs --- a/test/IntervalAlgebra/PairedIntervalSpec.hs +++ b/test/IntervalAlgebra/PairedIntervalSpec.hs @@ -1,11 +1,17 @@ module IntervalAlgebra.PairedIntervalSpec (spec) where import Test.Hspec ( it, describe, Spec, shouldBe ) -import IntervalAlgebra.PairedInterval ( PairedInterval, makePairedInterval ) +import IntervalAlgebra.PairedInterval ( PairedInterval + , makePairedInterval + , intervals ) import IntervalAlgebra ( beginerval , IntervalSizeable(duration) , equals , before ) +import Data.Bifunctor ( Bifunctor(bimap) ) +import Data.Bool +import Data.Time ( Day(ModifiedJulianDay) + , fromGregorian ) type TestPair = PairedInterval String Int @@ -21,6 +27,14 @@ spec :: Spec spec = do + describe "Basic tests of paired intervals" $ + do + it "the same pairInterval should be equal" $ t1 == t1 `shouldBe` True + it "different pairInterval should not be equal" $ t1 /= t2 `shouldBe` True + it "bimapping into a different type" $ + bimap (== "hi") ModifiedJulianDay (makePairedInterval "hi" (beginerval 5 0)) + `shouldBe `makePairedInterval True (beginerval 5 (fromGregorian 1858 11 17)) + describe "tests on paired intervals" $ do it "t1 is before t2" $ @@ -29,4 +43,9 @@ duration t1 `shouldBe` 5 it "t1 is equal to t3" $ (t1 `equals` t3) `shouldBe` True + it "t1 is LT t3" $ + (t1 < t3) `shouldBe` True + it "getintervals [t1, t2, t3]" $ + intervals [t1, t2, t3] `shouldBe` + [beginerval 5 0, beginerval 4 6, beginerval 5 0] diff --git a/test/IntervalAlgebraSpec.hs b/test/IntervalAlgebraSpec.hs --- a/test/IntervalAlgebraSpec.hs +++ b/test/IntervalAlgebraSpec.hs @@ -13,8 +13,13 @@ import Data.Maybe ( fromJust ) import Data.Either ( isRight ) import IntervalAlgebra.Arbitrary () -import Data.Time as DT ( Day ) -import Data.Set ( member ) +import Data.Time as DT ( Day(..) + , fromGregorian + ) +import Data.Set ( Set + , member + , disjointUnion + , fromList ) import IntervalAlgebra as IA ( enderval , beginerval , expandr @@ -27,6 +32,8 @@ , finishedBy , contains , starts + , precedes + , precededBy , equals , startedBy , during @@ -37,15 +44,27 @@ , relate , compose , disjoint + , within + , concur + , notDisjoint + , enclose + , enclosedBy , (<|>) , begin , end + , disjointRelations + , withinRelations + , converse + , union + , intersection + , complement , IntervalCombinable((.+.)) , IntervalSizeable(moment, diff) , ComparativePredicateOf1 , ComparativePredicateOf2 , Intervallic - , Interval ) + , Interval + , IntervalRelation (..), intervalRelations, notDisjoint ) mkIntrvl :: Int -> Int -> Interval Int mkIntrvl = beginerval @@ -167,7 +186,7 @@ \] -} -prop_IAaxiomM2 :: (IntervalSizeable a b, Show a) => +prop_IAaxiomM2 :: (IntervalSizeable a b, Show a) => M2set a -> Property prop_IAaxiomM2 x = (i `meets` j && k `meets` l) ==> @@ -245,7 +264,7 @@ b -> Interval a -> Property prop_IAaxiomM3 b i = (j `meets` i && i `meets` k) === True - where j = enderval b (begin i) + where j = enderval b (begin i) k = beginerval b (end i) prop_IAaxiomM3_Int :: Interval Int -> Property @@ -276,7 +295,7 @@ n = beginerval b (end j) k = beginerval g (end m) g = diff (begin n) (end m) - + prop_IAaxiomM4_Int :: M2set Int -> Property prop_IAaxiomM4_Int = prop_IAaxiomM4 1 @@ -320,7 +339,7 @@ ps = end (expandr (makePos b) x) -- creating l by shifting and expanding i -prop_IAaxiomM5 :: (IntervalSizeable a b) => +prop_IAaxiomM5 :: (IntervalSizeable a b) => M5set a -> Property prop_IAaxiomM5 x = ((i `meets` j && j `meets` l) && @@ -409,7 +428,58 @@ prop_exclusiveRelations x y = ( 1 == length (filter id $ map (\r -> r x y) allIArelations)) === True + -- | Given a set of interval relations and predicate function, test that the + -- predicate between two interval is equivalent to the relation of two intervals + -- being in the set of relations. + prop_predicate_unions :: Ord a => + Set IntervalRelation + -> ComparativePredicateOf2 (Interval a) (Interval a) + -> Interval a + -> Interval a + -> Property + prop_predicate_unions s pred i0 i1 = + pred i0 i1 === (relate i0 i1 `elem` s) + + prop_disjoint_predicate :: (Ord a) => + Interval a + -> Interval a + -> Property + prop_disjoint_predicate = prop_predicate_unions disjointRelations disjoint + + prop_notdisjoint_predicate :: (Ord a) => + Interval a + -> Interval a + -> Property + prop_notdisjoint_predicate = + prop_predicate_unions (complement disjointRelations) notDisjoint + + prop_concur_predicate :: (Ord a) => + Interval a + -> Interval a + -> Property + prop_concur_predicate = + prop_predicate_unions (complement disjointRelations) concur + + prop_within_predicate :: (Ord a) => + Interval a + -> Interval a + -> Property + prop_within_predicate = prop_predicate_unions withinRelations within + + prop_enclosedBy_predicate :: (Ord a) => + Interval a + -> Interval a + -> Property + prop_enclosedBy_predicate = prop_predicate_unions withinRelations enclosedBy + + prop_enclose_predicate :: (Ord a) => + Interval a + -> Interval a + -> Property + prop_enclose_predicate = prop_predicate_unions (converse withinRelations) enclose + instance IntervalRelationProperties Int Int +instance IntervalRelationProperties Day Integer allIArelations:: (Ord a) => [ComparativePredicateOf1 (Interval a)] allIArelations = [ IA.equals @@ -445,14 +515,61 @@ Interval a -> Interval a -> Interval a - -> Property + -> Property prop_compose x y z = member (relate x z) (compose (relate x y) (relate y z)) === True spec :: Spec spec = do + describe "Basic Interval unit tests of typeclass and creation methods" $ + do + it "equality works" $ beginerval 6 (1::Int) == beginerval 6 1 `shouldBe` True + it "equality works" $ beginerval 0 (1::Int) == beginerval (-1) 1 `shouldBe` True + it "equality works" $ enderval 1 (2::Int) == beginerval 1 1 `shouldBe` True + + it "parsing fails on bad inputs" $ + parseInterval 10 0 `shouldBe` Left "0<10" + it "parsing works on good inputs" $ + parseInterval 0 10 `shouldBe` Right (beginerval 10 (0::Int)) + + it "show displays intervals as expected" $ + show (beginerval 10 (0::Int)) `shouldBe` "(0, 10)" + + it "fmap can convert Interval Integer to Interval Day" $ + fmap ModifiedJulianDay (beginerval 1 0) `shouldBe` + beginerval 1 (fromGregorian 1858 11 17) + + it "(0, 2) <= (1, 3) is True" $ + beginerval 2 (0::Int) <= beginerval 2 1 `shouldBe` True + + it "(0, 2) < (1, 3) is True" $ + beginerval 2 (0::Int) < beginerval 2 1 `shouldBe` True + it "(0, 2) < (0, 3) is True" $ + beginerval 2 (0::Int) < beginerval 3 0 `shouldBe` True + + + describe "Basic IntervalRelation unit tests" $ + do + it "equality of IntervalRelations" $ Before == Before `shouldBe` True + it "equality of IntervalRelations" $ Before /= After `shouldBe` True + + it "Bounds are set correctly" $ minBound @IntervalRelation `shouldBe` Before + it "Bounds are set correctly" $ maxBound @IntervalRelation `shouldBe` After + + it "show Before is Before" $ show Before `shouldBe` "Before" + + describe "IntervalRelation algebraic operations" $ + do + it "converse of Before is After" $ converse (fromList [Before]) `shouldBe` fromList [After] + + it "union of IntervalRelations" $ union (fromList [Before]) (fromList [After]) + `shouldBe` fromList [Before, After] + it "intersection of IntervalRelations" $ intersection (fromList [Before]) (fromList [After]) + `shouldBe` fromList [] + describe "IntervalSizeable tests" $ do + it "moment is 1" $ moment @Int `shouldBe` 1 it "expandl doesn't change end" $ property (prop_expandl_end @Int) it "expandr doesn't change begin" $ property (prop_expandr_begin @Int) it "expand 0 5 Interval (0, 1) should be Interval (0, 6)" $ @@ -462,12 +579,12 @@ it "expand 5 5 Interval (0, 1) should be Interval (-5, 6)" $ expand 5 5 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (11::Int) (-5::Int) it "expand -1 5 Interval (0, 1) should be Interval (-5, 6)" $ - expand (-1) 5 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (6::Int) (0::Int) + expand (-1) 5 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (6::Int) (0::Int) it "expand 5 -5 Interval (0, 1) should be Interval (-5, 1)" $ expand 5 (-5) (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (6::Int) (-5::Int) it "expand moment 0 Interval (0, 1) should be Interval (-1, 1)" $ expand (moment @Int) 0 (beginerval (1::Int) (0::Int)) `shouldBe` - beginerval (2::Int) (-1::Int) + beginerval (2::Int) (-1::Int) it "beginerval 2 10 should be Interval (10, 12)" $ Right (beginerval (2::Int) 10) `shouldBe` parseInterval (10::Int) (12::Int) @@ -497,11 +614,18 @@ it "disjoint x y same as explicit union of predicates" $ disjoint (mkIntrvl 2 0) (mkIntrvl 2 3) `shouldBe` (before <|> after <|> meets <|> metBy) (mkIntrvl 2 0) (mkIntrvl 2 3) + it "within x y same as explicit union of predicates" $ + within (mkIntrvl 2 3) (mkIntrvl 2 3) `shouldBe` + (starts <|> during <|> finishes <|> equals) (mkIntrvl 2 3) (mkIntrvl 2 3) it "prop_compose holds" $ property (prop_compose @Int) describe "IntervalCombinable tests" $ do + it "join non-meeting intervals is Nothing" $ + beginerval 2 (0::Int) .+. beginerval 6 5 `shouldBe` Nothing + it "join meeting intervals is Just _" $ + beginerval 2 (0::Int) .+. beginerval 6 2 `shouldBe` Just (beginerval 8 0) it "" pending describe "Interval Algebra Axioms for meets properties" $ @@ -530,7 +654,6 @@ it "M4.1_Int" $ property prop_IAaxiomM4_1_Int it "M4.1_Day" $ property prop_IAaxiomM4_1_Day - describe "Interval Algebra relation properties" $ modifyMaxSuccess (*10) $ do @@ -539,8 +662,49 @@ it "finishes" $ property (prop_IAfinishes @Int) it "overlaps" $ property (prop_IAoverlaps @Int) it "during" $ property (prop_IAduring @Int) + it "before" $ property (prop_IAbefore @Day) + it "starts" $ property (prop_IAstarts @Day) + it "finishes" $ property (prop_IAfinishes @Day) + it "overlaps" $ property (prop_IAoverlaps @Day) + it "during" $ property (prop_IAduring @Day) + it "disjoint" $ property (prop_disjoint_predicate @Int) + it "disjoint" $ property (prop_disjoint_predicate @Day) + it "within" $ property (prop_within_predicate @Int) + it "within" $ property (prop_within_predicate @Day) + it "enclose" $ property (prop_enclose_predicate @Int) + it "enclose" $ property (prop_enclose_predicate @Day) + it "enclosedBy" $ property (prop_enclosedBy_predicate @Int) + it "enclosedBy" $ property (prop_enclosedBy_predicate @Day) + it "notDisjoint" $ property (prop_notdisjoint_predicate @Int) + it "notDisjoint" $ property (prop_notdisjoint_predicate @Day) + it "concur" $ property (prop_concur_predicate @Int) + it "concur" $ property (prop_concur_predicate @Day) + + describe "Interval Algebra relation unit tests for synonyms" $ + do + it "(0, 2) precedes (10, 12)" $ + beginerval 2 (0::Int) `precedes` beginerval 2 10 `shouldBe` True + it "precedes matches before" $ + beginerval 10 (0::Int) `precedes` beginerval 1 11 `shouldBe` + beginerval 10 (0::Int) `before` beginerval 1 11 + it "(10, 12) precededBy (0, 2)" $ + precededBy (beginerval 2 10) (beginerval 2 (0::Int)) `shouldBe` True + it "precededBy matches after" $ + precededBy (beginerval 1 11) (beginerval 10 (0::Int)) `shouldBe` + after (beginerval 1 11) (beginerval 10 (0::Int)) + it "concur matches notDdisjoint" $ + concur (beginerval 1 11) (beginerval 10 (0::Int)) `shouldBe` + notDisjoint (beginerval 1 11) (beginerval 10 (0::Int)) + it "concur matches notDisjoint" $ + concur (beginerval 1 0) (beginerval 10 (0::Int)) `shouldBe` + notDisjoint (beginerval 1 0) (beginerval 10 (0::Int)) + + describe "Interval Algebra relation uniqueness" $ modifyMaxSuccess (*100) $ do - it "exactly one relation must be true" $ property (prop_exclusiveRelations @Int) + it "exactly one relation must be true" $ + property (prop_exclusiveRelations @Int) + it "exactly one relation must be true" $ + property (prop_exclusiveRelations @Day)