interval-algebra 1.1.1 → 1.1.2
raw patch · 5 files changed
+160/−88 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ IntervalAlgebra.Arbitrary: arbitraryWithRelation :: (IntervalSizeable a b, Intervallic i a, Arbitrary (i a)) => i a -> Set IntervalRelation -> Gen (Maybe (i a))
+ IntervalAlgebra.Core: strictWithinRelations :: Set IntervalRelation
Files
- ChangeLog.md +4/−0
- interval-algebra.cabal +1/−1
- src/IntervalAlgebra/Arbitrary.hs +40/−6
- src/IntervalAlgebra/Core.hs +5/−0
- test/IntervalAlgebra/IntervalUtilitiesSpec.hs +110/−81
ChangeLog.md view
@@ -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.
interval-algebra.cabal view
@@ -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 <https://github.com/novisci/interval-algebra> category: Algebra,Time
src/IntervalAlgebra/Arbitrary.hs view
@@ -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
src/IntervalAlgebra/Core.hs view
@@ -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)=>
test/IntervalAlgebra/IntervalUtilitiesSpec.hs view
@@ -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