diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for interval-algebra +## 1.1.2 + +* Adds an internal utility to `IntervalAlgebra.Arbitrary` to generate a `Maybe (i a)` for `Intervallic i a` from a reference interval and set of relations. `Nothing` is returned for cases in which no interval can be generated. + ## 1.1.1 * Modifies internals of `IntervalAlgebra.Arbitrary` module to give uniformity over support for `Integer` and `UTCTime` intervals, yielding better interval generators. Also bounds the `UTCTime` `utctDayTime` argument to `86399` rather than `86400` to avoid trivial and rare cases of property testing failures related to leap seconds. 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: 1.1.1 +version: 1.1.2 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at category: Algebra,Time diff --git a/src/IntervalAlgebra/Arbitrary.hs b/src/IntervalAlgebra/Arbitrary.hs --- a/src/IntervalAlgebra/Arbitrary.hs +++ b/src/IntervalAlgebra/Arbitrary.hs @@ -11,17 +11,18 @@ {-# LANGUAGE Safe #-} -module IntervalAlgebra.Arbitrary() where +module IntervalAlgebra.Arbitrary( arbitraryWithRelation ) where import Control.Applicative (liftA2, (<$>)) import Control.Monad (liftM2) import Data.Bool import Data.Fixed -import Data.Function (($), (.)) +import Data.Function (flip, ($), (.)) +import Data.Maybe (Maybe (Just, Nothing)) import Data.Ord -import Data.Time as DT (Day (ModifiedJulianDay), +import qualified Data.Set (Set, difference, null, singleton) +import Data.Time as DT (Day (ModifiedJulianDay), DiffTime, NominalDiffTime, UTCTime (..), - DiffTime, picosecondsToDiffTime, secondsToDiffTime, secondsToNominalDiffTime, @@ -30,9 +31,14 @@ import GHC.Int (Int) import GHC.Num import GHC.Real -import IntervalAlgebra (Interval, beginerval) +import IntervalAlgebra (Interval, IntervalRelation (..), + IntervalSizeable, Intervallic, beginerval, + converse, duration, moment', predicate, + strictWithinRelations) +import Prelude (Eq, (==)) import Test.QuickCheck (Arbitrary (arbitrary, shrink), Gen, - arbitrarySizedNatural, resize) + NonNegative, arbitrarySizedNatural, + elements, resize, suchThat) -- NOTE: the default size for arbitrary :: Gen Int appears to be 30 arbitrarySizedPositive :: Integral a => Gen a @@ -64,3 +70,31 @@ instance Arbitrary (Interval DT.UTCTime) where arbitrary = liftM2 beginerval arbitrary arbitrary + +-- | Conditional generation of intervals relative to a reference. If the +-- reference `iv` is of 'moment' duration, it is not possible to generate +-- intervals from the strict enclose relations StartedBy, Contains, FinishedBy. +-- If `iv` and `rs` are such that no possible relations can be generated, this +-- function returns `Nothing`. Otherwise, it returns `Just` an interval that +-- satisfies at least one of the possible relations in `rs` relative to +-- `iv`. +-- +-- >>> generate $ arbitraryWithRelation (beginerval 10 (0::Int)) (fromList [Before]) +-- Just (20, 22) +-- >>> generate $ arbitraryWithRelation (beginerval 1 (0::Int)) (fromList [StartedBy]) +-- Nothing +-- >>> generate $ arbitraryWithRelation (beginerval 1 (0::Int)) (fromList [StartedBy, Before]) +-- Just (4, 13) +arbitraryWithRelation :: (IntervalSizeable a b, Intervallic i a, Arbitrary (i a)) => + i a -- ^ reference interval + -> Data.Set.Set IntervalRelation -- ^ set of `IntervalRelation`s, of which at least one will hold for the generated interval relative to the reference + -> Gen (Maybe (i a)) +arbitraryWithRelation iv rs + | rs == Data.Set.singleton Equals = elements [Just iv] + | isEnclose && isMom = elements [Nothing] + | isMom = Just <$> arbitrary `suchThat` predicate notStrictEnclose iv + | otherwise = Just <$> arbitrary `suchThat` predicate rs iv + where + notStrictEnclose = Data.Set.difference rs (converse strictWithinRelations) + isEnclose = Data.Set.null notStrictEnclose + isMom = duration iv == moment' iv diff --git a/src/IntervalAlgebra/Core.hs b/src/IntervalAlgebra/Core.hs --- a/src/IntervalAlgebra/Core.hs +++ b/src/IntervalAlgebra/Core.hs @@ -154,6 +154,7 @@ , (<|>) , predicate, unionPredicates , disjointRelations, withinRelations + , strictWithinRelations , ComparativePredicateOf1 , ComparativePredicateOf2 , beginervalFromEnd @@ -364,6 +365,10 @@ -- | The set of @IntervalRelation@ meaning one interval is within the other. withinRelations :: Data.Set.Set IntervalRelation withinRelations = toSet [Starts, During, Finishes, Equals] + +-- | The set of @IntervalRelation@ meaning one interval is *strictly* within the other. +strictWithinRelations :: Data.Set.Set IntervalRelation +strictWithinRelations = Data.Set.difference withinRelations (toSet [Equals]) -- | Are x and y disjoint ('before', 'after', 'meets', or 'metBy')? disjoint :: (Intervallic i0 a, Intervallic i1 a)=> diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -1,92 +1,85 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} module IntervalAlgebra.IntervalUtilitiesSpec (spec) where -import Test.Hspec.QuickCheck ( modifyMaxSuccess - , modifyMaxDiscardRatio ) -import Test.Hspec ( Spec - , it - , shouldBe - , describe ) -import Test.QuickCheck ( Property - , Testable(property) - , Arbitrary(arbitrary, shrink) - , suchThat - , (===), (==>) - , Arbitrary1 (liftArbitrary) - , listOf - , resize - , orderedList - , elements) -import Data.List (sort) -import IntervalAlgebra.Arbitrary ( ) -import IntervalAlgebra ( Interval - , Intervallic(..) - , IntervalCombinable(..) - , IntervalRelation (..) - , IntervalSizeable - , beginerval - , complement - , converse - , starts - , disjointRelations - , withinRelations - , predicate ) -import IntervalAlgebra.IntervalUtilities ( gapsL - , gaps - , durations - , intersect - , relationsL - , clip - , gapsWithin - , nothingIfNone - , filterBefore - , filterMeets - , filterOverlaps - , filterFinishedBy - , filterContains - , filterStarts - , filterEquals - , filterStartedBy - , filterDuring - , filterFinishes - , filterOverlappedBy - , filterMetBy - , filterAfter - , filterDisjoint - , filterNotDisjoint - , filterConcur - , filterWithin - , filterEnclose - , filterEnclosedBy - , nothingIfAll - , nothingIfAny - , combineIntervals - , foldMeetingSafe - , formMeetingSequence ) -import IntervalAlgebra.PairedInterval ( trivialize - , makePairedInterval - , PairedInterval, getPairData ) -import Control.Monad ( liftM2 ) -import Data.Set ( Set, fromList, member ) -import Witherable ( Filterable ) -import Data.Time ( Day, UTCTime ) +import Control.Monad (liftM2) +import Data.List (sort) +import Data.Maybe (fromJust, isJust, isNothing) +import Data.Set (Set, difference, fromList, + member, toList) +import qualified Data.Set (null) +import Data.Time (Day, UTCTime) +import IntervalAlgebra (Interval, + IntervalCombinable (..), + IntervalRelation (..), + IntervalSizeable, + Intervallic (..), + beginerval, complement, + converse, disjointRelations, + duration, intervalRelations, + moment', predicate, starts, + strictWithinRelations, + withinRelations) +import IntervalAlgebra.Arbitrary (arbitraryWithRelation) +import IntervalAlgebra.IntervalUtilities (clip, combineIntervals, + durations, filterAfter, + filterBefore, filterConcur, + filterContains, + filterDisjoint, + filterDuring, filterEnclose, + filterEnclosedBy, + filterEquals, + filterFinishedBy, + filterFinishes, filterMeets, + filterMetBy, + filterNotDisjoint, + filterOverlappedBy, + filterOverlaps, + filterStartedBy, + filterStarts, filterWithin, + foldMeetingSafe, + formMeetingSequence, gaps, + gapsL, gapsWithin, + intersect, nothingIfAll, + nothingIfAny, nothingIfNone, + relationsL) +import IntervalAlgebra.PairedInterval (PairedInterval, getPairData, + makePairedInterval, + trivialize) +import Test.Hspec (Spec, describe, it, + shouldBe) +import Test.Hspec.QuickCheck (modifyMaxDiscardRatio, + modifyMaxSuccess) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), + Arbitrary1 (liftArbitrary), + Property, + Testable (property), + elements, listOf, + orderedList, resize, + sublistOf, suchThat, (===), + (==>)) +import Witherable (Filterable) -- Types for testing -- SmallInterval is just to test properties for which events of interest are so -- rare QuickCheck gives up, e.g. filterEquals -data SmallInterval = SmallInterval { unSmall :: Interval Int } deriving (Show, Eq) +newtype SmallInterval + = SmallInterval { unSmall :: Interval Int } + deriving (Eq, Show) instance Arbitrary SmallInterval where arbitrary = SmallInterval . beginerval 0 <$> elements [0..10] --- A "state" here is just used test formMeetingSequence -newtype Events a = Events {getEvents :: [PairedInterval State a]} - deriving (Eq, Show, Ord) +-- A "state" here is just used test formMeetingSequence +newtype Events a + = Events { getEvents :: [PairedInterval State a] } + deriving (Eq, Ord, Show) -newtype State = State [Bool] deriving (Show, Eq) +newtype State + = State [Bool] + deriving (Eq, Show) instance Semigroup State where State x <> State y = State $ zipWith (||) x y @@ -96,6 +89,16 @@ type StateEvent a = PairedInterval State a +-- Type for checking arbitraryWithRelation +-- A target and reference pair, where targetInterval satisfies at least one of +-- refRelations relative to refInterval +data IntervalReferenced + = IntervalReferenced + { refInterval :: Interval Int + , refRelations :: Set IntervalRelation + , targetInterval :: Maybe (Interval Int) + } + deriving (Eq, Show) readInterval :: IntervalSizeable a a => (a, a) -> Interval a readInterval (b, e) = beginerval (e - b) b @@ -115,6 +118,13 @@ instance Arbitrary (Events Int) where arbitrary = Events <$> orderedList +-- restricted refIv to decrease rareness causing quickcheck to quit +instance Arbitrary IntervalReferenced where + arbitrary = do + refIv <- liftM2 beginerval (elements [1..3]) (elements [0..3]) + rels <- fromList <$> sublistOf (toList intervalRelations) + iv <- arbitraryWithRelation refIv rels + return $ IntervalReferenced refIv rels iv -- Testing functions checkSeqStates :: (Intervallic i Int)=> [i Int] -> Bool @@ -231,6 +241,20 @@ -- Properties +-- arbitraryWithRelation props +-- 'tautology' because this repeats the logic of arbitraryWithRelation +prop_withRelation_tautology :: IntervalReferenced -> Bool +prop_withRelation_tautology ir + | isEnclose && isMom = isNothing iv + | otherwise = isJust iv && predicate rels refIv (fromJust iv) + where + refIv = refInterval ir + iv = targetInterval ir + rels = refRelations ir + isEnclose = Data.Set.null $ Data.Set.difference rels (converse strictWithinRelations) + isMom = duration refIv == moment' refIv + + -- Check that the only relation remaining after applying a function is Before prop_before:: (Ord a)=> ([Interval a] -> [Interval a]) @@ -249,13 +273,13 @@ -> Property prop_gaps1 = prop_before gapsL --- In the case that that the input is not null, then +-- In the case that that the input is not null, then -- * all relationsL should be `Meets` after formMeetingSequence prop_formMeetingSequence0:: Events Int -> Property prop_formMeetingSequence0 x = - not (null es) ==> all (==Meets) (relationsL $ formMeetingSequence es) === True + not (null es) ==> all (== Meets) (relationsL $ formMeetingSequence es) === True where es = getEvents x -- In the case that the input has @@ -263,7 +287,7 @@ -- * AND does not have any empty states -- -- THEN the number empty states in the output should smaller than or equal to --- the number before relationsL in the output +-- the number before relationsL in the output prop_formMeetingSequence1:: Events Int -> Property @@ -276,7 +300,7 @@ emptyCount = lengthWhen (\x -> getPairData x == mempty ) res lengthWhen f = length . filter f --- Check that formMeetingSequence doesn't return an empty list unless input is +-- Check that formMeetingSequence doesn't return an empty list unless input is -- empty. prop_formMeetingSequence2:: Events Int @@ -401,7 +425,7 @@ prop_small_filterEquals :: SmallInterval -> [SmallInterval] -> Property prop_small_filterEquals x l = not (null res) ==> and (fmap (predicate s i) res) === True - where + where i = unSmall x li = map unSmall l res = filterEquals i li @@ -611,3 +635,8 @@ property prop_formMeetingSequence1 it "prop_formMeetingSequence2" $ property prop_formMeetingSequence2 + + describe "arbitraryWithRelation property tests" $ + do + it "prop_withRelation_tautology" $ + property prop_withRelation_tautology