interval-algebra 0.8.3 → 0.8.4
raw patch · 4 files changed
+92/−28 lines, 4 filesdep ~hspecPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: hspec
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- interval-algebra.cabal +5/−3
- src/IntervalAlgebra/IntervalUtilities.hs +38/−20
- test/IntervalAlgebra/IntervalUtilitiesSpec.hs +45/−5
ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog for interval-algebra +## 0.8.4++* Fixes bug in `formMeetingSequence` wherein sequences of events with >2 nested events were not returning a meeting sequence. + ## 0.8.3 * Moves `begin` and `end` out of the `Intervallic` class.
interval-algebra.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: interval-algebra-version: 0.8.3+version: 0.8.4 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@@ -42,7 +42,9 @@ default-language: Haskell2010 test-suite interval-algebra-test- type: exitcode-stdio-1.0+ type: exitcode-stdio-1.0 + -- this type means successful test run returns the zero exit code, + -- and a failed test run returns a non-zero exit code main-is: Spec.hs other-modules: IntervalAlgebraSpec@@ -57,7 +59,7 @@ build-depends: QuickCheck , base >=4.7 && <5- , hspec+ , hspec == 2.8.2 , containers >= 0.6 , interval-algebra , time >=1.8 && <2
src/IntervalAlgebra/IntervalUtilities.hs view
@@ -65,13 +65,13 @@ import Prelude ( (<*>), seq) import GHC.Show ( Show )-import GHC.Num ( )+import GHC.Num (xorInteger ) import GHC.Int ( Int ) import Control.Applicative ( Applicative(pure) )-import Data.Bool ( Bool, otherwise, not )+import Data.Bool ( Bool, otherwise, not, (||), (&&) ) import Data.Eq ( Eq((==)) )-import Data.Foldable ( Foldable(null, foldl', toList), all, any )+import Data.Foldable ( Foldable(null, foldl', toList), all, any, or ) import Data.Function ( ($), (.), flip ) import Data.Functor ( Functor(fmap) ) import Data.Monoid ( Monoid(mempty) )@@ -83,7 +83,7 @@ import Safe ( headMay, lastMay, initSafe, tailSafe) import Witherable ( Filterable(filter) ) import IntervalAlgebra ( (<|>),- begin, + begin, end, after, before,@@ -112,7 +112,7 @@ ComparativePredicateOf2, Interval, IntervalCombinable((<+>), (><)),- IntervalRelation(Meets),+ IntervalRelation(..), IntervalSizeable(diff, duration), Intervallic(..) ) import IntervalAlgebra.PairedInterval@@ -496,14 +496,21 @@ (PairedInterval b) a -> (PairedInterval b) a -> Meeting [(PairedInterval b) a]-disjoinPaired o e- | x `before` y = Meeting [ x, evp e1 b2 mempty, y ]- | x `meets` y = foldMeeting $ Meeting [ x, y ]- | x `overlaps` y = foldMeeting $ Meeting [ evp b1 b2 s1, evp b2 e1 sc, evp e1 e2 s2 ]- | x `finishedBy` y = foldMeeting $ Meeting [ evp b1 b2 s1, ev i2 sc ]- | x `contains` y = foldMeeting $ Meeting [ evp b1 b2 s1, evp b2 e2 sc, evp e2 e1 s1 ]- | x `starts` y = foldMeeting $ Meeting [ ev i1 sc, evp e1 e2 s2 ]- | otherwise = Meeting [ ev i1 sc ] {- x `equals` y case -}+disjoinPaired o e = case relate x y of+ Before -> Meeting [ x, evp e1 b2 mempty, y ]+ Meets -> foldMeeting $ Meeting [ x, y ]+ Overlaps -> foldMeeting $ Meeting [ evp b1 b2 s1, evp b2 e1 sc, evp e1 e2 s2 ]+ FinishedBy -> foldMeeting $ Meeting [ evp b1 b2 s1, ev i2 sc ]+ Contains -> foldMeeting $ Meeting [ evp b1 b2 s1, evp b2 e2 sc, evp e2 e1 s1 ]+ Starts -> foldMeeting $ Meeting [ ev i1 sc, evp e1 e2 s2 ]+ _ -> Meeting [ ev i1 sc ] {- Equals case -}+ -- | x `before` y = Meeting [ x, evp e1 b2 mempty, y ]+ -- | x `meets` y = foldMeeting $ Meeting [ x, y ]+ -- | x `overlaps` y = foldMeeting $ Meeting [ evp b1 b2 s1, evp b2 e1 sc, evp e1 e2 s2 ]+ -- | x `finishedBy` y = foldMeeting $ Meeting [ evp b1 b2 s1, ev i2 sc ]+ -- | x `contains` y = foldMeeting $ Meeting [ evp b1 b2 s1, evp b2 e2 sc, evp e2 e1 s1 ]+ -- | x `starts` y = foldMeeting $ Meeting [ ev i1 sc, evp e1 e2 s2 ]+ -- | otherwise = Meeting [ ev i1 sc ] {- x `equals` y case -} where x = min o e y = max o e i1 = getInterval x@@ -537,7 +544,7 @@ -- If input event is equal to the first comparator, skip the comparison. | e == o = recurseDisjoin (acc, o:os) es - {- If the period of o is either before or meets the period of e, then + {- If o is either before or meets e, then the first of the combined events can be put into the accumulator. That is, since the inputs events are ordered, once the beginning of o is before or meets e, then we are assured that all periods up to the @@ -565,11 +572,22 @@ , IntervalSizeable a c) => [ PairedInterval b a ] -> [ PairedInterval b a ]-formMeetingSequence x = recurseDisjoin ([], []) (recurseDisjoin ([], []) x)- -- the second pass of recurseDisjoin is to handle the situation where the first pass- -- disjoins all the events correctly into a meeting sequence but -- due to - -- nesting of intervals in the input -- some of the sequential pairs have- -- the same data after the first pass. The second pass merges any sequential+formMeetingSequence x+ | null x = []+ | allMeet x && not (hasEqData x) = x+ | otherwise = formMeetingSequence (recurseDisjoin ([], []) x)+ -- recurseDisjoin ([], []) (recurseDisjoin ([], []) (recurseDisjoin ([], []) x))++ -- the multiple passes of recurseDisjoin is to handle the situation where the + -- initial passes almost disjoins all the events correctly into a meeting sequence+ -- but due to nesting of intervals in the input -- some of the sequential pairs have+ -- the same data after the first pass. The recursive passes merges any sequential -- intervals that have the same data. --- -- There is probably a more efficient way to do this.+ -- There is probably a more efficient way to do this++allMeet :: (Ord a) => [PairedInterval b a] -> Bool+allMeet x = all ( == Meets) ( relations x )++hasEqData :: (Eq b) => [PairedInterval b a] -> Bool+hasEqData x = or (foldlAccume (==) (fmap getPairData x) :: [Bool])
test/IntervalAlgebra/IntervalUtilitiesSpec.hs view
@@ -51,6 +51,14 @@ mempty = State [False, False, False] type StateEvent a = PairedInterval State a ++readInterval :: IntervalSizeable a a => (a, a) -> Interval a+readInterval (b, e) = beginerval (e - b) b++mkEv :: IntervalSizeable a a => (a, a) -> b -> PairedInterval b a+mkEv i s = makePairedInterval s (readInterval i)++ instance Arbitrary State where arbitrary = State <$> suchThat (listOf arbitrary) (\x -> length x == 3) @@ -156,6 +164,24 @@ , evpi 3 0 [False, False, False] , evpi 1 3 [True, False, True ]] +++c5in :: [StateEvent Int]+c5in = [+ mkEv (-63, 21) (State [False,True,True])+ , mkEv (-56, 20) (State [True,True,True])+ , mkEv (1, 41) (State [False,True,False])+ , mkEv (11, 34) (State [True,False,True])+ , mkEv (27, 28) (State [False,True,True])+ ]++c5out :: [StateEvent Int]+c5out = [+ mkEv (-63, -56) (State [False,True,True])+ , mkEv (-56, 34) (State [True,True,True])+ , mkEv (34, 41) (State [False,True,False])+ ]+ -- Properties -- Check that the only relation remaining after applying a function is Before@@ -176,6 +202,15 @@ -> Property prop_gaps1 = prop_before gaps +-- In the case that that the input is not null, then +-- * all relations should be `Meets` after formMeetingSequence+prop_formMeetingSequence0::+ Events Int+ -> Property+prop_formMeetingSequence0 x =+ not (null es) ==> all (==Meets) (relations $ formMeetingSequence es) === True+ where es = getEvents x+ -- In the case that that the input has -- * at least one Before relation between consequent pairs -- * AND does not have any empty states@@ -329,19 +364,24 @@ describe "formMeetingSequence unit tests" $ do- it "formMeetingSequence 0" $+ it "formMeetingSequence unit test 0" $ formMeetingSequence c0in `shouldBe` c0out- it "formMeetingSequence 1"$+ it "formMeetingSequence unit test 1"$ formMeetingSequence c1in `shouldBe` c1out- it "formMeetingSequence 2"$+ it "formMeetingSequence unit test 2"$ formMeetingSequence c2in `shouldBe` c2out- it "formMeetingSequence 3"$+ it "formMeetingSequence unit test 3"$ formMeetingSequence c3in `shouldBe` c3out- it "formMeetingSequence 4"$+ it "formMeetingSequence unit test 4"$ formMeetingSequence c4in `shouldBe` c4out+ it "formMeetingSequence unit test 5"$+ formMeetingSequence c5in `shouldBe` c5out describe "formMeetingSequence property tests" $+ modifyMaxSuccess (*50) $ do+ it "prop_formMeetingSequence0" $+ property prop_formMeetingSequence0 it "prop_formMeetingSequence1" $ property prop_formMeetingSequence1 it "prop_formMeetingSequence2" $