diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for interval-algebra +## 0.8.6 + +* Adds the `beginervalFromEnd` and `endervalFromBegin` utilities to create an interval of the provided duration from the end (respectively, begin) of another interval. +* Cleans up some of the internals in the `IntervalUtilies` using functions from the `foldl` package rather than homemade versions. + ## 0.8.5 * Fixes synonyms so that `before == precedes` and `after == precededBy`, rather than the incorrect `starts == precedes` and `startedBy == precededBy`. 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.5 +version: 0.8.6 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at category: Algebra,Time @@ -35,6 +35,7 @@ build-depends: base >=4.7 && <5 , time >=1.8 && <2 + , foldl == 1.4.12 , containers >= 0.6 , witherable >= 0.4 , safe >= 0.3 diff --git a/src/IntervalAlgebra.hs b/src/IntervalAlgebra.hs --- a/src/IntervalAlgebra.hs +++ b/src/IntervalAlgebra.hs @@ -155,6 +155,8 @@ , disjointRelations, withinRelations , ComparativePredicateOf1 , ComparativePredicateOf2 + , beginervalFromEnd + , endervalFromBegin -- ** Algebraic operations , intervalRelations @@ -615,6 +617,21 @@ -> Interval a enderval dur x = Interval (add (negate $ max (moment' i) dur) x, x) where i = Interval (x, x) + +-- | Creates a new Interval from the 'end' of an @i a@. +beginervalFromEnd :: (IntervalSizeable a b, Intervallic i a) => + b -- ^ @dur@ation to add to the 'end' + -> i a -- ^ the @i a@ from which to get the 'end' + -> Interval a +beginervalFromEnd d i = beginerval d (end i) + +-- | Creates a new Interval from the 'begin' of an @i a@. +endervalFromBegin :: (IntervalSizeable a b, Intervallic i a) => + b -- ^ @dur@ation to subtract from the 'begin' + -> i a -- ^ the @i a@ from which to get the 'begin' + -> Interval a +endervalFromBegin d i = enderval d (begin i) + -- | Creates a new @Interval@ spanning the extent x and y. -- diff --git a/src/IntervalAlgebra/IntervalUtilities.hs b/src/IntervalAlgebra/IntervalUtilities.hs --- a/src/IntervalAlgebra/IntervalUtilities.hs +++ b/src/IntervalAlgebra/IntervalUtilities.hs @@ -17,9 +17,9 @@ -- * Fold over sequential intervals combineIntervals - , combineIntervals' + , combineIntervalsL , gaps - , gaps' + , gapsL , gapsWithin -- * Operations on Meeting sequences of paired intervals @@ -57,69 +57,81 @@ -- * Misc utilities , relations - , relations' + , relationsL , intersect , clip , durations ) where -import GHC.Show ( Show ) -import GHC.Num (xorInteger ) -import GHC.Int ( Int ) -import Control.Applicative - ( Applicative(pure) , (<*>)) -import Data.Bool ( Bool, otherwise, not, (||), (&&) ) -import Data.Eq ( Eq((==)) ) -import Data.Foldable ( Foldable(null, foldl', toList), all, any, or ) -import Data.Function ( ($), (.), flip ) -import Data.Functor ( Functor(fmap) ) -import Data.Monoid ( Monoid(mempty) ) -import Data.Maybe ( Maybe(..), maybe, maybeToList, mapMaybe, catMaybes, fromMaybe ) -import Data.List ( (++) ) -import Data.Ord ( Ord(min, max) ) -import Data.Semigroup ( Semigroup((<>)) ) -import Data.Tuple ( fst ) -import Safe ( headMay, lastMay, initSafe, tailSafe) -import Witherable ( Filterable(filter) ) -import IntervalAlgebra ( (<|>), - begin, - end, - after, - before, - beginerval, - concur, - contains, - disjoint, - during, - enclose, - enclosedBy, - enderval, - equals, - extenterval, - finishedBy, - finishes, - meets, - metBy, - notDisjoint, - overlappedBy, - overlaps, - relate, - startedBy, - starts, - within, - ComparativePredicateOf1, - ComparativePredicateOf2, - Interval, - IntervalCombinable((<+>), (><)), - IntervalRelation(..), - IntervalSizeable(diff, duration), - Intervallic(..) ) -import IntervalAlgebra.PairedInterval - ( PairedInterval - , makePairedInterval - , getPairData - , equalPairData ) +import safe GHC.Show ( Show ) +import safe GHC.Int ( Int ) +import safe Control.Applicative ( Applicative(pure) + , (<*>) ) +import qualified Control.Foldl as L +import safe Control.Monad ( Functor(fmap) ) +import safe Data.Bool ( Bool, otherwise, not, (||), (&&) ) +import safe Data.Eq ( Eq((==)) ) +import safe Data.Foldable ( Foldable(null, foldl', toList) + , all + , any + , or ) +import safe Data.Function ( ($), (.), flip ) +import safe Data.Monoid ( Monoid(mempty) ) +import safe Data.Maybe ( Maybe(..) + , maybe + , maybeToList ) +import safe Data.Ord ( Ord(min, max) ) +import safe Data.Semigroup ( Semigroup((<>)) ) +import safe Data.Traversable ( Traversable(sequenceA) ) +import safe Data.Tuple ( fst ) +import safe Safe ( headMay, lastMay, initSafe, tailSafe) +import safe Witherable ( Filterable(filter) + , Witherable(..) + , mapMaybe + , catMaybes ) +import safe IntervalAlgebra ( (<|>), + begin, + end, + after, + before, + beginerval, + beginervalFromEnd, + endervalFromBegin, + concur, + contains, + disjoint, + during, + enclose, + enclosedBy, + enderval, + equals, + extenterval, + finishedBy, + finishes, + meets, + metBy, + notDisjoint, + overlappedBy, + overlaps, + relate, + startedBy, + starts, + within, + ComparativePredicateOf1, + ComparativePredicateOf2, + Interval, + IntervalCombinable((<+>), (><)), + IntervalRelation(..), + IntervalSizeable(diff, duration), + Intervallic(..) ) +import safe IntervalAlgebra.PairedInterval + ( PairedInterval + , makePairedInterval + , getPairData + , equalPairData ) + + ------------------------------------------------- -- Unexported utilties used in functions below -- ------------------------------------------------- @@ -128,30 +140,17 @@ iv :: Int -> Int -> Interval Int iv = beginerval --- TODO: does this function and applyAccume reinvent an existing foldable function? --- Fold over consecutive pairs of foldable structure and collect the results in --- a monoidal structure. -foldlAccume :: (Foldable f, Applicative m, Monoid (m a))=> - (b -> b -> a) -- ^ @f@: a function to apply to consecutive elements of @f b@ - -> f b - -> m a -foldlAccume f x = fst $ foldl' (applyAccume f) (mempty, Nothing) x - --- Apply a function and accumulate the results in a monoidal structure. -applyAccume :: (Monoid (f a), Applicative f) => - (b -> b -> a) -- ^ @f@: a function combining two @b@s to get an @a@ - -> (f a, Maybe b) -- ^ a pair (accumulating monoid for @b@s, optional @a@) - -> b -- ^ this will be the second argument to @f@ - -> (f a, Maybe b) -applyAccume f (fs, Nothing) x = (fs, Just x) -applyAccume f (fs, Just x) y = (fs <> pure (f x y), Just y) - --- Lifts a list to a foldable, applicative monoid -liftListToFoldable :: ( Applicative f - , Monoid (f a) - , Foldable f) => - [a] -> f a -liftListToFoldable = foldl' (\x y -> x <> pure y) mempty +-- An internal utility function for creating a @Fold@ that maps over a structure +-- by consecutive pairs into a new structure. +makeFolder :: (Monoid (m b), Applicative m) => + (a -> a -> b) + -> L.Fold a (m b) +makeFolder f = L.Fold step begin done + where + begin = (mempty, Nothing) + step (fs, Nothing) y = (fs, Just y) + step (fs, Just x) y = (fs <> pure (f x y), Just y) + done (fs, _) = fs -- Used to combine two lists by combining the last element of @x@ and the first -- element of @y@ by @f@. The combining function @f@ will generally return a @@ -161,31 +160,31 @@ -> [a] -- ^ x -> [a] -- ^ y -> [a] -listCombiner f x y = initSafe x ++ f (lastMay x) (headMay y) ++ tailSafe y +listCombiner f x y = initSafe x <> f (lastMay x) (headMay y) <> tailSafe y + -- | Returns a list of the 'IntervalRelation' between each consecutive pair --- of intervals. This the specialized form of 'relations'' which can return --- any 'Applicative', 'Monoid' structure. +-- of intervals. This is just a specialized 'relations' which returns a list. -- --- >>> relations [iv 1 0, iv 1 1] +-- >>> relationsL [iv 1 0, iv 1 1] -- [Meets] -relations :: (Foldable f, Intervallic i a )=> +relationsL :: (Foldable f, Intervallic i a )=> f (i a) -> [IntervalRelation] -relations = relations' +relationsL = relations -- | A generic form of 'relations' which can output any 'Applicative' and -- 'Monoid' structure. --- >>> (relations' [iv 1 0, iv 1 1]) :: [IntervalRelation (Interval Int)] +-- >>> (relations [iv 1 0, iv 1 1]) :: [IntervalRelation (Interval Int)] -- [Meets] -- -relations' :: ( Foldable f +relations :: ( Foldable f , Applicative m , Intervallic i a , Monoid (m IntervalRelation ))=> f (i a) -> m IntervalRelation -relations' = foldlAccume relate +relations = L.fold (makeFolder relate) -- | Forms a 'Just' new interval from the intersection of two intervals, -- provided the intervals are not disjoint. @@ -200,31 +199,41 @@ where b = max (begin x) (begin y) e = min (end x) (end y) --- | Returns a (possibly empty) container of intervals consisting of the gaps +-- Internal function which folds over a structure by consecutive pairs, returing +-- gaps between each pair (@Nothing@ if no such gap exists). +gapsM:: ( IntervalCombinable i a + , Traversable f + , Monoid (f (Maybe (Interval a))) + , Applicative f) => + f (i a) -> + f (Maybe (Interval a)) +gapsM = L.fold (makeFolder (\i j -> getInterval i >< getInterval j)) + +-- | Returns a @Maybe@ container of intervals consisting of the gaps -- between intervals in the input. *To work properly, the input should be --- sorted*. See 'gaps'' for a version that returns a list. +-- sorted*. See 'gapsL' for a version that always returns a list. -- -- >>> gaps [iv 4 1, iv 4 8, iv 3 11] --- [(5, 8)] -gaps :: ( IntervalCombinable i a - , Applicative f - , Monoid (f (Interval a)) - , Foldable f) => +-- +gaps:: ( IntervalCombinable i a + , Traversable f + , Monoid (f (Maybe (Interval a))) + , Applicative f) => f (i a) -> - f (Interval a) -gaps x = liftListToFoldable (gaps' x) + Maybe (f (Interval a)) +gaps = sequenceA.gapsM -- | Returns a (possibly empty) list of intervals consisting of the gaps between -- intervals in the input container. *To work properly, the input should be -- sorted*. This version outputs a list. See 'gaps' for a version that lifts -- the result to same input structure @f@. -gaps' :: ( Intervallic i a +gapsL :: ( IntervalCombinable i a , Applicative f - , Monoid (f (Interval a)) - , Foldable f) => + , Monoid (f (Maybe (Interval a))) + , Traversable f) => f (i a) -> [Interval a] -gaps' x = catMaybes (foldlAccume (\i j -> getInterval i >< getInterval j) x) +gapsL x = maybe [] toList (gaps x) -- | Returns the 'duration' of each 'Intervallic i a' in the 'Functor' @f@. -- @@ -257,31 +266,33 @@ -- | 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, then --- 'Nothing' is returned. +-- 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. -- -- >>> gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12] -- Just [(5, 7),(9, 10)] gapsWithin :: ( Applicative f - , Foldable f + , Witherable f , Monoid (f (Interval a)) + , Monoid (f (Maybe (Interval a))) , IntervalSizeable a b , IntervalCombinable i0 a , IntervalCombinable i1 a - , Filterable f )=> + ) => i0 a -- ^ i -> f (i1 a) -- ^ x -> Maybe (f (Interval a)) -gapsWithin i x - | null ivs = Nothing - | otherwise = Just $ gaps $ pure s <> ivs <> pure e - where s = enderval 0 (begin i) - e = beginerval 0 (end i) - nd = toList (filterNotDisjoint i x) - ivs = liftListToFoldable (mapMaybe (clip i) nd) +gapsWithin i x + | null x = Nothing + | null res = 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 ) -- The Box is an internal type used to hold accumulated, combined intervals in --- 'combineIntervals''. +-- 'combineIntervalsL'. newtype Box a = Box { unBox :: [a] } packIntervalBoxes :: (Intervallic i a)=> [i a] -> [Box (Interval a)] @@ -292,7 +303,7 @@ -- | Returns a container of intervals where any intervals that meet or share support -- are combined into one interval. *To work properly, the input should --- be sorted*. See 'combineIntervals'' for a version that works only on lists. +-- be sorted*. See 'combineIntervalsL' for a version that works only on lists. -- -- >>> combineIntervals [iv 10 0, iv 5 2, iv 2 10, iv 2 13] -- [(0, 12),(13, 15)] @@ -303,18 +314,20 @@ , Foldable f ) => f (i a) -> f (Interval a) -combineIntervals x = liftListToFoldable (combineIntervals' $ toList x) +combineIntervals x = + foldl' (\x y -> x <> pure y) mempty (combineIntervalsL $ toList x) + -- TODO: surely combineIntervals and combineIntervalsL could be combined -- | 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 -- be sorted*. -- --- >>> combineIntervals' [iv 10 0, iv 5 2, iv 2 10, iv 2 13] +-- >>> combineIntervalsL [iv 10 0, iv 5 2, iv 2 10, iv 2 13] -- [(0, 12),(13, 15)] -combineIntervals' :: (Intervallic i a)=> [i a] -> [Interval a] -combineIntervals' l = unBox $ foldl' (<>) (Box []) (packIntervalBoxes l) +combineIntervalsL :: (Intervallic i a)=> [i a] -> [Interval a] +combineIntervalsL l = unBox $ foldl' (<>) (Box []) (packIntervalBoxes l) --- Internal function for combining maybe intervals in the 'combineIntervals'' +-- Internal function for combining maybe intervals in the 'combineIntervalsL' -- function (<->) :: (IntervalCombinable i a) => Maybe (i a) @@ -449,7 +462,7 @@ -- Test a list of intervals to be sure they all meet; if not return Nothing. parseMeeting :: Intervallic i a => [i a] -> Maybe (Meeting [i a]) parseMeeting x - | all ( == Meets ) (relations x) = Just $ Meeting x + | all ( == Meets ) (relationsL x) = Just $ Meeting x | otherwise = Nothing -- A specific case of 'joinMeeting' for @PairedIntervals@. @@ -498,18 +511,11 @@ 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 ] + 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 @@ -536,7 +542,7 @@ ([(PairedInterval b) a ], [(PairedInterval b) a ]) -> [(PairedInterval b) a ] -> [(PairedInterval b) a ] -recurseDisjoin (acc, o:os) [] = acc ++ o:os -- the "final" pattern +recurseDisjoin (acc, o:os) [] = acc <> (o:os) -- the "final" pattern recurseDisjoin (acc, []) [] = acc -- another "final" pattern recurseDisjoin (acc, []) (e:es) = recurseDisjoin (acc, [e]) es -- the "initialize" pattern recurseDisjoin (acc, o:os) (e:es) -- the "operating" patterns @@ -549,7 +555,7 @@ is before or meets e, then we are assured that all periods up to the beginning of o are fully disjoint and subsequent input events will not overlap these in any way. -} - | (before <|> meets) o e = recurseDisjoin (acc ++ nh, recurseDisjoin ([], nt) os ) es + | (before <|> meets) o e = recurseDisjoin (acc <> nh, recurseDisjoin ([], nt) os ) es --The standard recursive operation. | otherwise = recurseDisjoin (acc, recurseDisjoin ([], n) os ) es @@ -586,7 +592,7 @@ -- There is probably a more efficient way to do this allMeet :: (Ord a) => [PairedInterval b a] -> Bool -allMeet x = all ( == Meets) ( relations x ) +allMeet x = all ( == Meets) ( relationsL x ) hasEqData :: (Eq b) => [PairedInterval b a] -> Bool -hasEqData x = or (foldlAccume (==) (fmap getPairData x) :: [Bool]) +hasEqData x = or (L.fold (makeFolder (==)) (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 @@ -32,10 +32,11 @@ , disjointRelations , withinRelations , predicate ) -import IntervalAlgebra.IntervalUtilities ( gaps +import IntervalAlgebra.IntervalUtilities ( gapsL + , gaps , durations , intersect - , relations + , relationsL , clip , gapsWithin , nothingIfNone @@ -100,7 +101,7 @@ -- Testing functions checkSeqStates :: (Intervallic i Int)=> [i Int] -> Bool -checkSeqStates x = (length x > 1) || all (== Meets) (relations x) +checkSeqStates x = (length x > 1) || all (== Meets) (relationsL x) -- Creation functions iv :: Int -> Int -> Interval Int @@ -218,7 +219,7 @@ ([Interval a] -> [Interval a]) -> [Interval a] -> Property -prop_before f x = relations ci === replicate (length ci - 1) Before +prop_before f x = relationsL ci === replicate (length ci - 1) Before where ci = f (sort x) prop_combineIntervals1:: (Ord a, Show a, Eq a)=> @@ -229,15 +230,15 @@ prop_gaps1:: (Ord a)=> [Interval a] -> Property -prop_gaps1 = prop_before gaps +prop_gaps1 = prop_before gapsL -- In the case that that the input is not null, then --- * all relations should be `Meets` after formMeetingSequence +-- * all relationsL should be `Meets` after formMeetingSequence prop_formMeetingSequence0:: Events Int -> Property prop_formMeetingSequence0 x = - not (null es) ==> all (==Meets) (relations $ formMeetingSequence es) === True + not (null es) ==> all (==Meets) (relationsL $ formMeetingSequence es) === True where es = getEvents x -- In the case that that the input has @@ -245,7 +246,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 relations in the output +-- the number before relationsL in the output prop_formMeetingSequence1:: Events Int -> Property @@ -254,7 +255,7 @@ not (any (\x -> getPairData x == State [False, False, False]) (getEvents x)) ) ==> beforeCount >= emptyCount where res = formMeetingSequence (getEvents x) - beforeCount = lengthWhen (== Before) (relations (getEvents x)) + beforeCount = lengthWhen (== Before) (relationsL (getEvents x)) emptyCount = lengthWhen (\x -> getPairData x == mempty ) res lengthWhen f x = length $ filter f x @@ -366,11 +367,11 @@ modifyMaxSuccess (*10) $ do it "no gaps in containmentInt and noncontainmentInt" $ - gaps [containmentInt, noncontainmentInt] `shouldBe` [] + gapsL [containmentInt, noncontainmentInt] `shouldBe` [] it "no gaps in containmentInt" $ - gaps [containmentInt] `shouldBe` [] + gapsL [containmentInt] `shouldBe` [] it "single gap between containmentInt and anotherInt" $ - gaps [containmentInt, anotherInt] `shouldBe` [gapInt] + gapsL [containmentInt, anotherInt] `shouldBe` [gapInt] it "after gaps, only relation should be Before" $ property (prop_gaps1 @Int) @@ -392,16 +393,16 @@ Just (iv 6 4) it "clip x y === intersect sort x y " pending - describe "relations tests" $ + describe "relationsL tests" $ do - it "relations [(0, 10), (4, 10), (10, 15), (15, 20)] == [FinishedBy, Meets, Meets]" $ - relations [containmentInt, noncontainmentInt, gapInt, anotherInt] `shouldBe` + it "relationsL [(0, 10), (4, 10), (10, 15), (15, 20)] == [FinishedBy, Meets, Meets]" $ + relationsL [containmentInt, noncontainmentInt, gapInt, anotherInt] `shouldBe` [FinishedBy, Meets, Meets] - it "relations of [] shouldBe []" $ - relations ([] :: [Interval Int]) `shouldBe` [] - it "relations of singleton shouldBe []" $ - relations [containmentInt] `shouldBe` [] - it "more relations tests" pending + it "relationsL of [] shouldBe []" $ + relationsL ([] :: [Interval Int]) `shouldBe` [] + it "relationsL of singleton shouldBe []" $ + relationsL [containmentInt] `shouldBe` [] + it "more relationsL tests" pending describe "gapsWithin tests" $ do diff --git a/test/IntervalAlgebra/PairedIntervalSpec.hs b/test/IntervalAlgebra/PairedIntervalSpec.hs --- a/test/IntervalAlgebra/PairedIntervalSpec.hs +++ b/test/IntervalAlgebra/PairedIntervalSpec.hs @@ -43,8 +43,8 @@ duration t1 `shouldBe` 5 it "t1 is equal to t3" $ (t1 `equals` t3) `shouldBe` True - it "t1 is LT t3" $ - (t1 < t3) `shouldBe` True + it "t1 is LT t2" $ + (t1 < t2) `shouldBe` True it "getintervals [t1, t2, t3]" $ intervals [t1, t2, t3] `shouldBe` [beginerval 5 0, beginerval 4 6, beginerval 5 0]