interval-algebra 0.8.6 → 0.9.0
raw patch · 7 files changed
+133/−24 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ IntervalAlgebra.PairedInterval: Empty :: Empty
Files
- interval-algebra.cabal +1/−1
- src/IntervalAlgebra.hs +5/−0
- src/IntervalAlgebra/IntervalUtilities.hs +18/−5
- src/IntervalAlgebra/PairedInterval.hs +4/−4
- test/IntervalAlgebra/IntervalUtilitiesSpec.hs +39/−1
- test/IntervalAlgebra/PairedIntervalSpec.hs +31/−10
- test/IntervalAlgebraSpec.hs +35/−3
interval-algebra.cabal view
@@ -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 <https://github.com/novisci/interval-algebra> category: Algebra,Time
src/IntervalAlgebra.hs view
@@ -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
src/IntervalAlgebra/IntervalUtilities.hs view
@@ -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 )
src/IntervalAlgebra/PairedInterval.hs view
@@ -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
test/IntervalAlgebra/IntervalUtilitiesSpec.hs view
@@ -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" $
test/IntervalAlgebra/PairedIntervalSpec.hs view
@@ -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
test/IntervalAlgebraSpec.hs view
@@ -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)" $