diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. 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.3 +version: 0.8.4 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at 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 diff --git a/src/IntervalAlgebra/IntervalUtilities.hs b/src/IntervalAlgebra/IntervalUtilities.hs --- a/src/IntervalAlgebra/IntervalUtilities.hs +++ b/src/IntervalAlgebra/IntervalUtilities.hs @@ -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]) diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -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" $