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.6 +version: 0.9.0 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.hs b/src/IntervalAlgebra.hs --- a/src/IntervalAlgebra.hs +++ b/src/IntervalAlgebra.hs @@ -598,6 +598,7 @@ where i = Interval (x, x) d = max (moment' i) dur y = add d x +{-# INLINABLE beginerval #-} -- | Safely creates an 'Interval a' using @x@ as the 'end' and adding -- @negate max 'moment' dur@ to @x@ as the 'begin'. @@ -617,6 +618,7 @@ -> Interval a enderval dur x = Interval (add (negate $ max (moment' i) dur) x, x) where i = Interval (x, x) +{-# INLINABLE enderval #-} -- | Creates a new Interval from the 'end' of an @i a@. beginervalFromEnd :: (IntervalSizeable a b, Intervallic i a) => @@ -657,6 +659,7 @@ | otherwise = Nothing where b = begin x e = end y + {-# INLINABLE (.+.) #-} -- | If @x@ is 'before' @y@, then form a new @Just Interval a@ from the -- interval in the "gap" between @x@ and @y@ from the 'end' of @x@ to the @@ -706,10 +709,12 @@ (><) x y | x `before` y = Just $ Interval (end x, begin y) | otherwise = Nothing + {-# INLINABLE (><) #-} (<+>) x y | x `before` y = pure ( getInterval x ) <> pure ( getInterval y ) | otherwise = pure ( extenterval x y ) + {-# INLINABLE (<+>) #-} instance IntervalSizeable Int Int where moment = 1 diff --git a/src/IntervalAlgebra/IntervalUtilities.hs b/src/IntervalAlgebra/IntervalUtilities.hs --- a/src/IntervalAlgebra/IntervalUtilities.hs +++ b/src/IntervalAlgebra/IntervalUtilities.hs @@ -161,7 +161,7 @@ -> [a] -- ^ y -> [a] listCombiner f x y = initSafe x <> f (lastMay x) (headMay y) <> tailSafe y - +{-# INLINABLE listCombiner #-} -- | Returns a list of the 'IntervalRelation' between each consecutive pair -- of intervals. This is just a specialized 'relations' which returns a list. @@ -185,6 +185,7 @@ f (i a) -> m IntervalRelation relations = L.fold (makeFolder relate) +{-# INLINABLE relations #-} -- | Forms a 'Just' new interval from the intersection of two intervals, -- provided the intervals are not disjoint. @@ -208,6 +209,7 @@ f (i a) -> f (Maybe (Interval a)) gapsM = L.fold (makeFolder (\i j -> getInterval i >< getInterval j)) +{-# INLINABLE gapsM #-} -- | Returns a @Maybe@ container of intervals consisting of the gaps -- between intervals in the input. *To work properly, the input should be @@ -222,6 +224,7 @@ f (i a) -> Maybe (f (Interval a)) gaps = sequenceA.gapsM +{-# INLINABLE gaps #-} -- | Returns a (possibly empty) list of intervals consisting of the gaps between -- intervals in the input container. *To work properly, the input should be @@ -234,6 +237,7 @@ f (i a) -> [Interval a] gapsL x = maybe [] toList (gaps x) +{-# INLINABLE gapsL #-} -- | Returns the 'duration' of each 'Intervallic i a' in the 'Functor' @f@. -- @@ -263,11 +267,14 @@ | otherwise = Nothing {- disjoint x y case -} where jy = equals <|> startedBy <|> contains <|> finishedBy jx = starts <|> during <|> finishes +{-# INLINABLE clip #-} -- | Applies 'gaps' to all the non-disjoint intervals in @x@ that are *not* disjoint -- from @i@. Intervals that 'overlaps' or are 'overlappedBy' @i@ are 'clip'ped --- to @i@, so that all the intervals are 'within' @i@. If there are no gaps or if the --- input is empty, then 'Nothing' is returned. +-- to @i@, so that all the intervals are 'within' @i@. If all of the input intervals +-- are disjoint from the focal interval or if the input is empty, then 'Nothing' +-- is returned. When there are no gaps among the concurring intervals, then +-- `Just mempty` (e.g. `Just []`) is returned. -- -- >>> gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12] -- Just [(5, 7),(9, 10)] @@ -283,13 +290,13 @@ -> f (i1 a) -- ^ x -> Maybe (f (Interval a)) gapsWithin i x - | null x = Nothing - | null res = Nothing + | null ivs = Nothing | otherwise = Just res where s = pure (endervalFromBegin 0 i) e = pure (beginervalFromEnd 0 i) ivs = mapMaybe (clip i) (filterNotDisjoint i x) res = catMaybes $ gapsM ( s <> ivs <> e ) +{-# INLINABLE gapsWithin #-} -- The Box is an internal type used to hold accumulated, combined intervals in -- 'combineIntervalsL'. @@ -317,6 +324,7 @@ combineIntervals x = foldl' (\x y -> x <> pure y) mempty (combineIntervalsL $ toList x) -- TODO: surely combineIntervals and combineIntervalsL could be combined +{-# INLINABLE combineIntervals #-} -- | Returns a list of intervals where any intervals that meet or share support -- are combined into one interval. *To work properly, the input list should @@ -326,6 +334,7 @@ -- [(0, 12),(13, 15)] combineIntervalsL :: (Intervallic i a)=> [i a] -> [Interval a] combineIntervalsL l = unBox $ foldl' (<>) (Box []) (packIntervalBoxes l) +{-# INLINABLE combineIntervalsL #-} -- Internal function for combining maybe intervals in the 'combineIntervalsL' -- function @@ -337,6 +346,7 @@ (<->) Nothing (Just y) = [getInterval y] (<->) (Just x) Nothing = [getInterval x] (<->) (Just x) (Just y) = (<+>) (getInterval x) (getInterval y) +{-# INLINABLE (<->) #-} -- | Given a predicate combinator, a predicate, and list of intervals, returns -- the input unchanged if the predicate combinator is @True@. Otherwise, returns @@ -529,6 +539,7 @@ e2 = end y ev = flip makePairedInterval evp = \b e s -> ev (beginerval (diff e b) b) s +{-# INLINABLE disjoinPaired #-} {- | The internal function for converting a non-disjoint, ordered sequence of @@ -562,6 +573,7 @@ where n = getMeeting $ disjoinPaired o e nh = maybeToList (headMay n) nt = tailSafe n +{-# INLINABLE recurseDisjoin #-} {- | Convert an ordered sequence of @PairedInterval b a@. that may have any interval relation @@ -590,6 +602,7 @@ -- intervals that have the same data. -- -- There is probably a more efficient way to do this +{-# INLINABLE formMeetingSequence #-} allMeet :: (Ord a) => [PairedInterval b a] -> Bool allMeet x = all ( == Meets) ( relationsL x ) diff --git a/src/IntervalAlgebra/PairedInterval.hs b/src/IntervalAlgebra/PairedInterval.hs --- a/src/IntervalAlgebra/PairedInterval.hs +++ b/src/IntervalAlgebra/PairedInterval.hs @@ -13,7 +13,7 @@ module IntervalAlgebra.PairedInterval ( PairedInterval - , Empty + , Empty(..) , makePairedInterval , getPairData , intervals @@ -57,9 +57,9 @@ (<+>) x y | x `before` y = pure x <> pure y - | otherwise = pure $ makePairedInterval (getPairData x <> getPairData y) - (extenterval x y) - + | otherwise = pure $ + makePairedInterval (getPairData x <> getPairData y) + (extenterval x y) -- | Make a paired interval. makePairedInterval :: b -> Interval a -> PairedInterval b a diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -28,6 +28,7 @@ , IntervalSizeable , beginerval , complement + , converse , starts , disjointRelations , withinRelations @@ -59,6 +60,8 @@ , filterWithin , filterEnclose , filterEnclosedBy + , nothingIfAll + , nothingIfAny , combineIntervals , foldMeetingSafe , formMeetingSequence ) @@ -358,6 +361,21 @@ -> Property prop_filterWithin = prop_filtration filterWithin withinRelations + prop_filterEnclosedBy :: Interval a + -> [Interval a] + -> Property + prop_filterEnclosedBy = prop_filtration filterEnclosedBy withinRelations + + prop_filterEnclose :: Interval a + -> [Interval a] + -> Property + prop_filterEnclose = prop_filtration filterEnclose (converse withinRelations) + + prop_filterConcur :: Interval a + -> [Interval a] + -> Property + prop_filterConcur = prop_filtration filterConcur (complement disjointRelations) + instance FiltrationProperties Int @@ -409,6 +427,13 @@ it "gapsWithin (1, 10) [(0,5), (7,9), (12,15)] should be [(5,7), (9,10)]" $ gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12] `shouldBe` Just [iv 2 5, iv 1 9] + it "gapsWithin (1, 10) [(-1, 0), (12,15)] should be [(5,7), (9,10)]" $ + gapsWithin (iv 9 1) [iv 1 (-1), iv 3 12] + `shouldBe` Nothing + it "gapsWithin (0, 455) [(0, 730), (731, 762), (763, 793)]" $ + gapsWithin (readInterval (0 :: Int, 455)) + (fmap readInterval [(0, 730), (731, 762), (763, 793)]) + `shouldBe` Just [] it "gapsWithin (1, 10) [] should be []" $ gapsWithin (iv 9 1) ([] :: [Interval a]) `shouldBe` Nothing it "more gapsWithin tests" pending @@ -448,8 +473,21 @@ it "filterDisjoint property" $ property (prop_filterDisjoint @Int) it "filterNotDisjoint property" $ property (prop_filterNotDisjoint @Int) it "filterWithin property" $ property (prop_filterWithin @Int) - + it "filterConcur property" $ property (prop_filterConcur @Int) + it "filterEnclose property" $ property (prop_filterEnclose @Int) + it "filterEnclosedBy property" $ property (prop_filterEnclosedBy @Int) + describe "nothingIf unit tests" $ + do + it "nothing from nothingIfAll" $ + nothingIfAll (starts (iv 2 3)) [iv 3 3, iv 4 3] `shouldBe` Nothing + it "something from nothingIfAll" $ + nothingIfAll (starts (iv 2 3)) [iv 3 0, iv 4 3] `shouldBe` Just [iv 3 0, iv 4 3] + it "nothing from nothingIfAny" $ + nothingIfAny (starts (iv 2 3)) [iv 3 3, iv 1 5] `shouldBe` Nothing + it "something from nothingIfAny" $ + nothingIfAny (starts (iv 2 3)) [iv 3 1, iv 1 5] `shouldBe` Just [iv 3 1, iv 1 5] + describe "intersection tests" $ do it "intersection of (0, 2) (2, 4) should be Nothing" $ diff --git a/test/IntervalAlgebra/PairedIntervalSpec.hs b/test/IntervalAlgebra/PairedIntervalSpec.hs --- a/test/IntervalAlgebra/PairedIntervalSpec.hs +++ b/test/IntervalAlgebra/PairedIntervalSpec.hs @@ -3,11 +3,13 @@ import Test.Hspec ( it, describe, Spec, shouldBe ) import IntervalAlgebra.PairedInterval ( PairedInterval , makePairedInterval - , intervals ) + , intervals + , Empty(..) ) import IntervalAlgebra ( beginerval , IntervalSizeable(duration) , equals - , before ) + , before + , IntervalCombinable(..) ) import Data.Bifunctor ( Bifunctor(bimap) ) import Data.Bool import Data.Time ( Day(ModifiedJulianDay) @@ -25,15 +27,19 @@ t3 :: TestPair t3 = mkTestPr "hello" 5 0 +-- insta + 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 "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)) + it "show paired interval" $ + show t1 `shouldBe` "{(0, 5), \"hi\"}" describe "tests on paired intervals" $ do @@ -48,4 +54,19 @@ it "getintervals [t1, t2, t3]" $ intervals [t1, t2, t3] `shouldBe` [beginerval 5 0, beginerval 4 6, beginerval 5 0] - + + describe "IntervalCombinable tests" $ + do + it "" $ (t1 >< t3) `shouldBe` Nothing + it "" $ (t1 >< mkTestPr "hello" 1 6) `shouldBe` Just (mkTestPr "" 1 5) + it "" $ (t1 <+> mkTestPr "hello" 1 6) `shouldBe` [t1, mkTestPr "hello" 1 6] + it "" $ (t1 <+> mkTestPr "hello" 5 3) `shouldBe` [mkTestPr "hihello" 8 0] + + describe "tests on empty" $ + do + it "show empty" $ show Empty `shouldBe` "Empty" + it "combine emptyies" $ Empty <> Empty `shouldBe` Empty + it "monoid empty" $ (mempty :: Empty) `shouldBe` Empty + it "monoid mappend" $ mappend Empty Empty `shouldBe` Empty + it "ord empty" $ Empty < Empty `shouldBe` False + it "ord empty" $ Empty <= Empty `shouldBe` True diff --git a/test/IntervalAlgebraSpec.hs b/test/IntervalAlgebraSpec.hs --- a/test/IntervalAlgebraSpec.hs +++ b/test/IntervalAlgebraSpec.hs @@ -59,12 +59,14 @@ , intersection , complement , IntervalCombinable((.+.)) - , IntervalSizeable(moment, diff) + , IntervalSizeable(moment, moment', diff) , ComparativePredicateOf1 , ComparativePredicateOf2 , Intervallic , Interval - , IntervalRelation (..), intervalRelations, notDisjoint ) + , IntervalRelation (..) + , intervalRelations + , notDisjoint ) mkIntrvl :: Int -> Int -> Interval Int mkIntrvl = beginerval @@ -526,6 +528,7 @@ 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 "not equality works" $ enderval 5 (2::Int) /= beginerval 1 1 `shouldBe` True it "parsing fails on bad inputs" $ parseInterval 10 0 `shouldBe` Left "0<10" @@ -542,12 +545,13 @@ it "(0, 2) <= (1, 3) is True" $ beginerval 2 (0::Int) <= beginerval 2 1 `shouldBe` True + it "(1, 2) < (0, 3) is True" $ + beginerval 2 (1::Int) < beginerval 3 0 `shouldBe` False 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 @@ -558,6 +562,33 @@ it "show Before is Before" $ show Before `shouldBe` "Before" + describe "Relate unit tests" $ + do + it "relate before" $ + relate (beginerval 1 (0::Int)) (beginerval 1 2) `shouldBe` Before + it "relate after" $ + relate (beginerval 1 (2::Int)) (beginerval 1 0) `shouldBe` After + it "relate meets" $ + relate (beginerval 1 (0::Int)) (beginerval 1 1) `shouldBe` Meets + it "relate metBy" $ + relate (beginerval 1 (1::Int)) (beginerval 1 0) `shouldBe` MetBy + it "relate overlaps" $ + relate (beginerval 3 (0::Int)) (beginerval 5 2) `shouldBe` Overlaps + it "relate overlappedBy" $ + relate (beginerval 5 (2::Int)) (beginerval 3 0) `shouldBe` OverlappedBy + it "relate starts" $ + relate (beginerval 3 (0::Int)) (beginerval 5 0) `shouldBe` Starts + it "relate startedBy" $ + relate (beginerval 5 (0::Int)) (beginerval 3 0) `shouldBe` StartedBy + it "relate finishes" $ + relate (enderval 3 (0::Int)) (enderval 5 0) `shouldBe` Finishes + it "relate finishedBy" $ + relate (enderval 5 (0::Int)) (enderval 3 0) `shouldBe` FinishedBy + it "relate during" $ + relate (beginerval 1 (1::Int)) (beginerval 3 0) `shouldBe` During + it "relate Contains" $ + relate (beginerval 3 (0::Int)) (beginerval 1 1) `shouldBe` Contains + describe "IntervalRelation algebraic operations" $ do it "converse of Before is After" $ converse (fromList [Before]) `shouldBe` fromList [After] @@ -570,6 +601,7 @@ describe "IntervalSizeable tests" $ do it "moment is 1" $ moment @Int `shouldBe` 1 + it "moment' is 1" $ moment' (beginerval 1 (0::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)" $