diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,20 @@ # Changelog for interval-algebra +## 0.4.0 + +* Adds utilities `emptyIfNone`, `emptyIfAny`, and `emptyIfAll` that apply predicates to a list of inputs. If none, any, or all of the inputs meet the predicate, then the empty list is returned. Otherwise, the input is returned unmodified. These functions are generalized to `Monoid`s, so they work on structures other than lists. +* Adds `gapsWithin` function to `IntervalUtilities` module that applies `gaps` to all intervals in the input list that are non-disjoint from the interval in the first argument. +* Fixed bug in `combineIntervals` where intervals could fail to be combined properly because `foldr` was being used instead of `foldl'`. +* Adds `intersect` function to `IntervalCombinable` class that returns the (maybe) intersection of two intervals. +* Adds `relations` utility function which returns a list of the `IntervalRelations` between each consecutive pair of intervals in the input list. +* Renames `in'` predicate to `within`. Also, renames `filterIn'` to `filterWithin`. +* Adds `predicate` function to `IntervalAlgebraic` class to map an `IntervalRelation` to its corresponding predicate function. Also adds `predicates` to map a set of `IntervalRelation`s to a list of predicate functions. +* Adds `intersection`, `union`, `converse`, and `complement` methods to `IntervalAlgebraic` for taking the respective operation on `Set IntervalRelation`. +* Instantiates `Bounded`, `Enum`, and `Ord` for `IntervalRelation`, so that, for one, interval relations can be ordered and used in `Data.Set`. Uses the total ordering defined [here](https://thomasalspaugh.org/pub/fnd/allen.html), though in general, interval relations only have a partial order. +* Renames `composeRelations` to the more accurate `unionPredicates`. +* Adds `<|>` as operator for "union"ing `ComparativePredicateOf (Interval a)`, as in `starts <|> overlaps === unionPredicates [starts, overlaps]`. +* Adds a `clip x y` function which clips the interval `y` to the extent of `x`, provided `x` and `y` are not disjoint. + ## 0.3.3 * Fixes bug in `expand` function 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.3.3 +version: 0.4.0 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at category: Algebra,Time @@ -34,6 +34,7 @@ build-depends: base >=4.7 && <5 , time >=1.8 && <2 + , containers >= 0.6 , witherable >= 0.4 , QuickCheck default-language: Haskell2010 @@ -54,6 +55,7 @@ QuickCheck , base >=4.7 && <5 , hspec + , containers >= 0.6 , interval-algebra , time >=1.8 && <2 default-language: Haskell2010 diff --git a/src/IntervalAlgebra.hs b/src/IntervalAlgebra.hs --- a/src/IntervalAlgebra.hs +++ b/src/IntervalAlgebra.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -48,6 +49,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module IntervalAlgebra( -- * Classes @@ -60,17 +63,19 @@ -- * Types , Interval - , IntervalRelation + , IntervalRelation(..) , ComparativePredicateOf ) where -import Prelude (Eq, Ord, Show, Read +import Prelude (Eq, Ord, Show, Read, Enum(..), Bounded(..), Ordering (LT) , Maybe(..), Either(..), String, Integer, Int, Bool(..), Num , Foldable (maximum, minimum, foldMap, foldr) - , otherwise, flip, show, fst, snd, min, max, any, negate, not + , map, otherwise, flip, show, fst, snd, min, max, any, negate, not , (++), (==), (&&), (<), (>), (<=), ($), (+), (-), (.)) import Data.Time as DT ( Day, addDays, diffDays, addGregorianYearsClip, calendarYear ) import Data.Semigroup ( Semigroup((<>)) ) +import Data.Set(Set, fromList, difference, intersection, union, map, toList) +import Data.Ord( Ord(..), Ordering(..)) import GHC.Base (Applicative(pure)) import Witherable ( Filterable(filter) ) @@ -158,13 +163,13 @@ @ -} -data IntervalRelation = +data IntervalRelation a = Meets | MetBy | Before | After | Overlaps - | OverlappedBy + | OverlappedBy | Starts | StartedBy | Finishes @@ -172,8 +177,54 @@ | During | Contains | Equals - deriving (Show, Read) + deriving (Eq, Show, Read) +instance Bounded (IntervalRelation a) where + minBound = Before + maxBound = After + +instance Enum (IntervalRelation a) where + fromEnum r = case r of + Before -> 0 + Meets -> 1 + Overlaps -> 2 + FinishedBy -> 3 + Contains -> 4 + Starts -> 5 + Equals -> 6 + StartedBy -> 7 + During -> 8 + Finishes -> 9 + OverlappedBy -> 10 + MetBy -> 11 + After -> 12 + + toEnum i = case i of + 0 -> Before + 1 -> Meets + 2 -> Overlaps + 3 -> FinishedBy + 4 -> Contains + 5 -> Starts + 6 -> Equals + 7 -> StartedBy + 8 -> During + 9 -> Finishes + 10 -> OverlappedBy + 11 -> MetBy + 12 -> After + +instance Ord (IntervalRelation a) where + compare x y = compare (fromEnum x) (fromEnum y) + +-- | The 'Set' of all 'IntervalRelation's. +intervalRelations :: Set (IntervalRelation a) +intervalRelations = fromList (Prelude.map toEnum [0..12] ::[IntervalRelation a]) + +-- | Find the converse of a single 'IntervalRelation' +converseRelation :: IntervalRelation a -> IntervalRelation a +converseRelation x = toEnum (12 - fromEnum x) + {- Misc -} @@ -211,12 +262,12 @@ The @'IntervalAlgebraic'@ typeclass specifies the functions and relational operators for interval-based temporal logic. The typeclass defines the relational operators for intervals, plus other useful utilities such as -@'disjoint'@, @'in''@, and @'composeRelations'@. +@'disjoint'@, @'within'@, and @'unionPredicates'@. -} class (Eq a, Intervallic a) => IntervalAlgebraic a where -- | Compare two intervals to determine their 'IntervalRelation'. - relate :: Interval a -> Interval a -> IntervalRelation + relate :: Interval a -> Interval a -> IntervalRelation a relate x y | x `before` y = Before | x `after` y = After @@ -232,6 +283,62 @@ | x `contains` y = Contains | otherwise = Equals + -- | Maps an 'IntervalRelation' to its corresponding predicate function. + predicate' :: IntervalRelation a -> ComparativePredicateOf (Interval a) + predicate' r = + case r of + Before -> before + Meets -> meets + Overlaps -> overlaps + FinishedBy -> finishedBy + Contains -> contains + Starts -> starts + Equals -> equals + StartedBy -> startedBy + During -> during + Finishes -> finishes + OverlappedBy -> overlappedBy + MetBy -> metBy + After -> after + + -- | Given a set of 'IntervalRelation's return a 'List' of 'predicate' functions + -- corresponding to each relation. + predicates :: Set (IntervalRelation a) -> [ComparativePredicateOf (Interval a)] + predicates x = Prelude.map predicate' (toList x) + + -- | Forms a predicate function from the union of a set of 'IntervalRelation's. + predicate :: Set (IntervalRelation a) -> ComparativePredicateOf (Interval a) + predicate = unionPredicates.predicates + + -- ** Algebraic operations on IntervalRelations + + -- | Shortcut to creating a 'Set IntervalRelation' from a 'List'. + toSet :: [IntervalRelation a] -> Set (IntervalRelation a) + toSet = fromList + + -- | Finds the complement of a 'Set IntervalRelation'. + complement :: Set (IntervalRelation a) -> Set (IntervalRelation a) + complement = difference intervalRelations + + -- | Find the intersection of two 'Set's of 'IntervalRelation' + intersection :: Set (IntervalRelation a) + -> Set (IntervalRelation a) + -> Set (IntervalRelation a) + intersection = Data.Set.intersection + + -- | Find the union of two 'Set's of 'IntervalRelation' + union :: Set (IntervalRelation a) + -> Set (IntervalRelation a) + -> Set (IntervalRelation a) + union = Data.Set.union + + -- | Find the converse of a 'Set IntervalRelation'. + converse :: Set (IntervalRelation a) + -> Set (IntervalRelation a) + converse = Data.Set.map converseRelation + + -- ** Interval algebra predicates + -- | Does x equal y? equals :: ComparativePredicateOf (Interval a) equals x y = x == y @@ -255,6 +362,11 @@ starts, startedBy :: ComparativePredicateOf (Interval a) starts x y = begin x == begin y && (end x < end y) startedBy = flip starts + + -- | Synonyms for 'starts' and 'startedBy' + precedes, precededBy :: ComparativePredicateOf (Interval a) + precedes = starts + precededBy = startedBy -- | Does x finish y? Is x finished by y? finishes, finishedBy :: ComparativePredicateOf (Interval a) @@ -270,28 +382,36 @@ -- | Compose a list of interval relations with _or_ to create a new -- @'ComparativePredicateOf' 'Interval' a@. For example, - -- @composeRelations [before, meets]@ creates a predicate function determining + -- @unionPredicates [before, meets]@ creates a predicate function determining -- if one interval is either before or meets another interval. - composeRelations :: [ComparativePredicateOf (Interval a)] -> - ComparativePredicateOf (Interval a) - composeRelations fs x y = any (\ f -> f x y) fs + unionPredicates :: [ComparativePredicateOf (Interval a)] -> + ComparativePredicateOf (Interval a) + unionPredicates fs x y = any (\ f -> f x y) fs + -- | Operator for composing the union of two predicates + (<|>) :: ComparativePredicateOf (Interval a) + -> ComparativePredicateOf (Interval a) + -> ComparativePredicateOf (Interval a) + (<|>) f g = unionPredicates [f, g] + + disjointRelations :: Set (IntervalRelation a) + disjointRelations = toSet [Before, After, Meets, MetBy] + + withinRelations :: Set (IntervalRelation a) + withinRelations = toSet [During, Starts, Finishes, Equals] + -- | Are x and y disjoint ('before', 'after', 'meets', or 'metBy')? disjoint :: ComparativePredicateOf (Interval a) - disjoint = composeRelations [before, after, meets, metBy] + disjoint = predicate disjointRelations -- | Are x and y not disjoint; i.e. do they share any support? notDisjoint :: ComparativePredicateOf (Interval a) - notDisjoint = composeRelations [ equals - , starts, startedBy - , finishes, finishedBy - , overlaps, overlappedBy - , during, contains] + notDisjoint = predicate (complement disjointRelations) - -- | Is x contained in y in any sense ('during', 'starts', 'finishes' - -- or 'equals'? - in' :: ComparativePredicateOf (Interval a) - in' = composeRelations [during, starts, finishes, equals] + -- | Is x wholly within y (including endpoints) in any sense 'during', + -- 'starts', 'finishes', or 'equals'? + within :: ComparativePredicateOf (Interval a) + within = predicate withinRelations {- | @@ -372,8 +492,8 @@ -- | If @x@ is 'before' @y@, return @f x@ appended to @f y@. Otherwise, -- return 'extenterval' of @x@ and @y@ (wrapped in @f@). This is useful for - -- folding over an *ordered* container of @Interval@s and combining intervals - -- when @x@ is *not* 'before' @y@. + -- (left) folding over an *ordered* container of @Interval@s and combining + -- intervals when @x@ is *not* 'before' @y@. (<+>):: (Semigroup (f (Interval a)), Applicative f) => Interval a -> Interval a -> @@ -382,6 +502,15 @@ | x `before` y = pure x <> pure y | otherwise = pure ( extenterval x y ) + -- | Forms a 'Just' new interval from the intersection of two intervals, + -- provided the intervals are not disjoint. + intersect :: Interval a -> Interval a -> Maybe (Interval a) + intersect x y + | disjoint x y = Nothing + | otherwise = Just $ Interval (b, e) + where b = max (begin x) (begin y) + e = min (end x) (end y) + {- | The @'IntervalFilterable'@ class provides functions for filtering 'Filterable's of @'Interval'@s based on @'IntervalAlgebraic'@ relations. @@ -444,10 +573,10 @@ filterNotDisjoint :: Interval a -> f (Interval a) -> f (Interval a) filterNotDisjoint = filterMaker notDisjoint - -- | Filter a 'Witherable.Filterable' of Interval as to those that are 'in'' + -- | Filter a 'Witherable.Filterable' of Interval as to those that are 'within' -- the @Interval a@ in the first argument. - filterIn' :: Interval a -> f (Interval a) -> f (Interval a) - filterIn' = filterMaker disjoint + filterWithin :: Interval a -> f (Interval a) -> f (Interval a) + filterWithin = filterMaker disjoint {- Instances -} diff --git a/src/IntervalAlgebra/IntervalUtilities.hs b/src/IntervalAlgebra/IntervalUtilities.hs --- a/src/IntervalAlgebra/IntervalUtilities.hs +++ b/src/IntervalAlgebra/IntervalUtilities.hs @@ -9,21 +9,42 @@ Stability : experimental -} +{-# LANGUAGE FlexibleContexts #-} module IntervalAlgebra.IntervalUtilities ( combineIntervals , gaps , durations + , clip + , relations + , gapsWithin + , emptyIf + , emptyIfNone + , emptyIfAny + , emptyIfAll ) where import GHC.Base - ( (++), map, foldr, otherwise, ($), (.), (<*>) - , Semigroup((<>)), Functor(fmap)) -import Prelude (uncurry, zip, Num) -import IntervalAlgebra( Interval, IntervalCombinable(..), IntervalSizeable(..) ) + ( (++), map, foldr, otherwise, ($), (.), (<*>), seq, not + , Semigroup((<>)), Functor(fmap), Maybe(..) + , Int, Bool) +import GHC.Num () +import Data.Tuple ( uncurry ) +import Data.Foldable ( Foldable(null, foldl'), all, any ) +import Data.Monoid ( (<>), Monoid(mempty) ) +import IntervalAlgebra + ( Interval, Intervallic(..), IntervalAlgebraic(..) + , IntervalCombinable(..), IntervalSizeable(..) + , IntervalFilterable(..) + , IntervalRelation(..)) import Data.Maybe (mapMaybe) -import Data.List ( (++), null, any, head, init, last, tail ) +import Data.List ( (++), head, init, last, tail, zip ) +import Witherable ( Filterable ) +intInt :: Int -> Int -> Interval Int +intInt = unsafeInterval + -- | Box to avoid overlapping instances +-- TODO: avoid the head/tail footguns newtype Box a = Box { unBox :: [a] } instance (IntervalCombinable a) => Semigroup (Box (Interval a)) where Box x <> Box y @@ -36,8 +57,11 @@ -- | 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 [intInt 0 10, intInt 2 7, intInt 10 12, intInt 13 15] +-- [(0, 12),(13, 15)] combineIntervals :: (IntervalCombinable a) => [Interval a] -> [Interval a] -combineIntervals l = unBox $ foldr ((<>) . (\z -> Box [z])) (Box []) l +combineIntervals l = unBox $ foldl' (<>) (Box []) (map (\z -> Box [z]) l) -- | Returns a (possibly empty) list of intervals consisting of the gaps between -- intervals in the input list. *To work properly, the input list should be sorted*. @@ -45,5 +69,96 @@ gaps l = mapMaybe (uncurry (><)) ((zip <*> tail) l) -- | Returns the 'duration' of each 'Interval' in the 'Functor' @f@. +-- +-- >>> durations [intInt 1 10, intInt 2 12, intInt 5 6] +-- [9,10,1] durations :: (Functor f, IntervalSizeable a b) => f (Interval a) -> f b durations = fmap duration + + +-- | In the case that x y are not disjoint, clips y to the extent of x. +-- +-- >>> clip (intInt 0 5) (intInt 3 6) +-- Just (3, 5) +-- +-- >>> clip (intInt 0 3) (intInt 4 6) +-- Nothing +clip :: (IntervalAlgebraic a, IntervalSizeable a b)=> + Interval a + -> Interval a + -> Maybe (Interval a) +clip x y + | overlaps x y = Just $ enderval (diff (end x) (begin y)) (end x) + | overlappedBy x y = Just $ beginerval (diff (end y) (begin x)) (begin x) + | jx x y = Just x + | jy x y = Just y + | disjoint x y = Nothing + where jy = equals <|> startedBy <|> contains <|> finishedBy + jx = starts <|> during <|> finishes + +-- | Finds the 'IntervalRelation' between each consecutive pair of intervals. +-- +-- >>> relations [intInt 0 1, intInt 1 2] +-- [Meets] +relations :: (IntervalAlgebraic a)=> [Interval a] -> [IntervalRelation a] +-- TODO: generalize to collections besides list +relations x = map (uncurry relate) ((zip <*> tail) x) + +-- | 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@. +-- +-- >>> gapsWithin (intInt 1 10) [intInt 0 5, intInt 7 9, intInt 12 15] +-- [(5, 7),(9, 10)] +gapsWithin :: (IntervalSizeable a b, IntervalCombinable a, IntervalFilterable [] a)=> + Interval a -- ^ i + -> [Interval a] -- ^ x + -> [Interval a] +-- TODO: generalize to collections besides list +gapsWithin i x = gaps $ enderval 0 (begin i) : + mapMaybe (clip i) (filterNotDisjoint i x) ++ + [beginerval 0 (end i)] + +-- | Given a predicate combinator, a predicate, and list of intervals, returns +-- the input unchanged if the predicate combinator is 'True'. Otherwise, returns +-- an empty list. See 'emptyIfAny' and 'emptyIfNone' for examples. +emptyIf :: (Monoid (f (Interval a)), Foldable f, IntervalFilterable f a)=> + ((Interval a -> Bool) -> f (Interval a) -> Bool) -- ^ e.g. 'any' or 'all' + -> (Interval a -> Bool) -- ^ predicate to apply to each element of input list + -> f (Interval a) + -> f (Interval a) +emptyIf g f x = if g f x then mempty else x + +-- | Returns the empty monoid structure if *none* of the element of input satisfy +-- the predicate condition. +-- +-- For example, the following returns the empty list because none of the intervals +-- in the input list 'starts' (3, 5). +-- +-- >>> emptyIfNone (starts (intInt 3 5)) [intInt 3 4, intInt 5 6] +-- [] +-- +-- In the following, (3, 5) 'starts' (3, 6), so the input is returned. +-- +-- >>> emptyIfNone (starts (intInt 3 5)) [intInt 3 6, intInt 5 6] +-- [(3, 6),(5, 6)] +emptyIfNone :: (Monoid (f (Interval a)), Foldable f, IntervalFilterable f a)=> + (Interval a -> Bool) -- ^ predicate to apply to each element of input list + -> f (Interval a) + -> f (Interval a) +emptyIfNone = emptyIf (\f x -> (not.any f) x) + +-- | Returns the empty monoid structure if *any* of the element of input satisfy +-- the predicate condition +emptyIfAny :: (Monoid (f (Interval a)), Foldable f, IntervalFilterable f a)=> + (Interval a -> Bool) -- ^ predicate to apply to each element of input list + -> f (Interval a) + -> f (Interval a) +emptyIfAny = emptyIf any + +-- | Returns the empty monoid structure if *all* of the element of input satisfy +-- the predicate condition +emptyIfAll :: (Monoid (f (Interval a)), Foldable f, IntervalFilterable f a)=> + (Interval a -> Bool) -- ^ predicate to apply to each element of input list + -> f (Interval a) + -> f (Interval a) +emptyIfAll = emptyIf all diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -1,9 +1,19 @@ +{-# LANGUAGE TypeApplications #-} module IntervalAlgebra.IntervalUtilitiesSpec (spec) where -import IntervalAlgebra ( Interval, Intervallic(unsafeInterval) ) -import IntervalAlgebra.IntervalUtilities ( combineIntervals, gaps, durations ) -import Test.Hspec ( it, shouldBe, describe, Spec ) +import IntervalAlgebra ( Interval, Intervallic(unsafeInterval) + , IntervalCombinable(..) + , IntervalAlgebraic(..) + , IntervalRelation (..) ) +import IntervalAlgebra.Arbitrary () +import IntervalAlgebra.IntervalUtilities +import Test.Hspec ( it, shouldBe, describe, Spec, pending ) +import Test.QuickCheck +import Data.List(sort) +intInt :: Int -> Int -> Interval Int +intInt = unsafeInterval + containmentInt :: Interval Int containmentInt = unsafeInterval (0 :: Int) (10 :: Int) @@ -16,20 +26,43 @@ gapInt :: Interval Int gapInt = unsafeInterval (10 :: Int) (15 :: Int) +prop_combineIntervals1:: (IntervalAlgebraic a, IntervalCombinable a)=> + [Interval a] + -> Property +prop_combineIntervals1 x = + (length x > 2) ==> relations ci == replicate (length ci - 1) Before + where ci = combineIntervals (sort x) + +prop_gaps1:: (IntervalAlgebraic a, IntervalCombinable a)=> + [Interval a] + -> Property +prop_gaps1 x = + (length x > 2) ==> relations gs == replicate (length gs - 1) Before + where gs = gaps (sort x) + + spec :: Spec spec = do describe "combineIntervals unit tests" $ do it "noncontainmentInt combined into containmentInt" $ - combineIntervals [containmentInt, noncontainmentInt] `shouldBe` [containmentInt] + combineIntervals [containmentInt, noncontainmentInt] + `shouldBe` [containmentInt] it "noncontainmentInt combined into containmentInt; anotherInt unchanged" $ - combineIntervals [containmentInt, noncontainmentInt, anotherInt] `shouldBe` [containmentInt, anotherInt] + combineIntervals [containmentInt, noncontainmentInt, anotherInt] + `shouldBe` [containmentInt, anotherInt] it "idempotency of containmentInt" $ combineIntervals [containmentInt] `shouldBe` [containmentInt] it "idempotency of noncontainmentInt" $ combineIntervals [noncontainmentInt] `shouldBe` [noncontainmentInt] + it "combineIntervals [intInt 0 10, intInt 2 7, intInt 10 12, intInt 13 15]" $ + combineIntervals [intInt 0 10, intInt 2 7, intInt 10 12, intInt 13 15] + `shouldBe` [intInt 0 12, intInt 13 15] + it "after combining, only relation should be Before" $ + property (prop_combineIntervals1 @Int) + - describe "gaps unit tests" $ + describe "gaps tests" $ do it "no gaps in containmentInt and noncontainmentInt" $ gaps [containmentInt, noncontainmentInt] `shouldBe` [] @@ -37,6 +70,8 @@ gaps [containmentInt] `shouldBe` [] it "single gap between containmentInt and anotherInt" $ gaps [containmentInt, anotherInt] `shouldBe` [gapInt] + it "after gaps, only relation should be Before" $ + property (prop_gaps1 @Int) describe "durations unit tests" $ do @@ -46,3 +81,36 @@ -- durations [] `shouldBe` [] it "durations of [containmentInt, anotherInt] is [10, 5]" $ durations [containmentInt, anotherInt] `shouldBe` [10, 5] + + describe "clip tests" $ + do + it "clip disjoint should be Nothing" $ + clip containmentInt gapInt `shouldBe` Nothing + it "clip Interval (4, 10) Interval (0, 10) should be Interval (4, 10)" $ + clip noncontainmentInt containmentInt `shouldBe` + Just (unsafeInterval 4 10) + it "clip x y === intersect sort x y " pending + + describe "relations tests" $ + do + it "relations [(0, 10), (4, 10), (10, 15), (15, 20)] == [FinishedBy, Meets, Meets]" $ + relations [containmentInt, noncontainmentInt, gapInt, anotherInt] `shouldBe` + [FinishedBy, Meets, Meets] + it "more relations tests" pending + + describe "gapsWithin tests" $ + do + it "gapsWithin (1, 10) [(0,5), (7,9), (12,15)] should be [(5,7), (9,10)]" $ + gapsWithin (intInt 1 10) [intInt 0 5, intInt 7 9, intInt 12 15] + `shouldBe` [intInt 5 7, intInt 9 10] + it "more gapsWithin tests" pending + + describe "emptyIf tests" $ + do + it "emptyIfNone (starts (3, 5)) [(3,4), (5,6)] should be empty" $ + emptyIfNone (starts (intInt 3 5)) [intInt 3 4, intInt 5 6] + `shouldBe` [] + it "emptyIfNone (starts (3, 5)) [(3,6), (5,6)] shoiuld be input" $ + emptyIfNone (starts (intInt 3 5)) [intInt 3 6, intInt 5 6] + `shouldBe` [ intInt 3 6, intInt 5 6] + it "more emptyif tests" pending diff --git a/test/IntervalAlgebraSpec.hs b/test/IntervalAlgebraSpec.hs --- a/test/IntervalAlgebraSpec.hs +++ b/test/IntervalAlgebraSpec.hs @@ -12,8 +12,10 @@ import Data.Maybe import Control.Monad () import IntervalAlgebra.Arbitrary () -import Data.Time as DT +import Data.Time as DT ( Day ) +mkIntrvl = unsafeInterval + xor :: Bool -> Bool -> Bool xor a b = a /= b @@ -413,8 +415,8 @@ spec = do describe "IntervalSizeable tests" $ do - it "expandl doesn't change end" $ property (prop_expandl_end @Int) - it "expandr doesn't change begin" $ property (prop_expandr_begin @Int) + 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)" $ expand 0 5 (unsafeInterval (0::Int) (1::Int)) `shouldBe` unsafeInterval (0::Int) (6::Int) it "expand 5 0 Interval (0, 1) should be Interval (-5, 1)" $ @@ -441,6 +443,49 @@ enderval (0::Int) 10 `shouldBe` unsafeInterval (9::Int) (10::Int) it "enderval -2 10 should be Interval (9, 10)" $ enderval (-2::Int) 10 `shouldBe` unsafeInterval (9::Int) (10::Int) + + describe "IntervalAlgebraic tests" $ + do + it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 4) is True" $ + (startedBy <|> overlappedBy) (mkIntrvl (0::Int) (9::Int)) (mkIntrvl (-1::Int) (4::Int)) + `shouldBe` True + it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (0, 4) is True" $ + (startedBy <|> overlappedBy) (mkIntrvl (0::Int) (9::Int)) (mkIntrvl (0::Int) (4::Int)) + `shouldBe` True + it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 9) is False" $ + (startedBy <|> overlappedBy) (mkIntrvl (0::Int) (9::Int)) (mkIntrvl (-1::Int) (9::Int)) + `shouldBe` False + + it "disjoint x y same as explicit union of predicates" $ + disjoint (mkIntrvl (0::Int) (2::Int)) (mkIntrvl (3::Int) (5::Int)) `shouldBe` + (before <|> after <|> meets <|> metBy) (mkIntrvl (0::Int) (2::Int)) (mkIntrvl (3::Int) (5::Int)) + + describe "IntervalCombinable tests" $ + do + it "intersection of (0, 2) (2, 4) should be Nothing" $ + intersect (mkIntrvl (0::Int) (2::Int)) (mkIntrvl (2::Int) (4::Int)) + `shouldBe` Nothing + it "intersection of (0, 2) (3, 4) should be Nothing" $ + intersect (mkIntrvl (0::Int) (2::Int)) (mkIntrvl (3::Int) (4::Int)) + `shouldBe` Nothing + it "intersection of (2, 4) (0, 2) should be Nothing" $ + intersect (mkIntrvl (2::Int) (4::Int)) (mkIntrvl (0::Int) (2::Int)) + `shouldBe` Nothing + it "intersection of (0, 2) (1, 3) should be Just (1, 2)" $ + intersect (mkIntrvl (0::Int) (2::Int)) (mkIntrvl (1::Int) (3::Int)) + `shouldBe` Just (mkIntrvl 1 2) + it "intersection of (0, 2) (-1, 3) should be Just (0, 2)" $ + intersect (mkIntrvl (0::Int) (2::Int)) (mkIntrvl (-1::Int) (3::Int)) + `shouldBe` Just (mkIntrvl 0 2) + it "intersection of (0, 2) (0, 2) should be Just (0, 2)" $ + intersect (mkIntrvl (0::Int) (2::Int)) (mkIntrvl (0::Int) (2::Int)) + `shouldBe` Just (mkIntrvl 0 2) + it "intersection of (0, 2) (-1, 1) should be Just (0, 1)" $ + intersect (mkIntrvl (0::Int) (2::Int)) (mkIntrvl (-1::Int) (1::Int)) + `shouldBe` Just (mkIntrvl 0 1) + it "intersection of (0, 3) (1, 2) should be Just (1, 2)" $ + intersect (mkIntrvl (0::Int) (3::Int)) (mkIntrvl (1::Int) (2::Int)) + `shouldBe` Just (mkIntrvl 1 2) describe "Interval Algebra Axioms for meets properties" $ modifyMaxSuccess (*10) $