diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for interval-algebra +## 0.6.3 + +* Extends the `IntervalCombinable` class to operate on general `Interval` containers. +* Removes all usage of `unsafeInterval` from the testing suite in preparation of removing this function. +* Modifies internals of the `combineIntervals` function to use safe (exception-free) functions rather than footguns like `head` and `tail`. + ## 0.6.2 * Fixes bug in `equals` which was checking for equality of the interval container, not just the interval. 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.6.2 +version: 0.6.3 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at category: Algebra,Time @@ -37,6 +37,7 @@ , time >=1.8 && <2 , containers >= 0.6 , witherable >= 0.4 + , safe >= 0.3 , QuickCheck default-language: Haskell2010 @@ -60,4 +61,5 @@ , containers >= 0.6 , interval-algebra , time >=1.8 && <2 + , safe >= 0.3 default-language: Haskell2010 diff --git a/src/IntervalAlgebra.hs b/src/IntervalAlgebra.hs --- a/src/IntervalAlgebra.hs +++ b/src/IntervalAlgebra.hs @@ -119,7 +119,7 @@ of a data structure. It also includes functions for getting the @'begin'@ and @'end'@ this data. -} -class (Ord a) => Intervallic i a where +class (Ord a, Show a) => Intervallic i a where -- | Get the interval from an @i a@ getInterval :: i a -> Interval a @@ -561,12 +561,12 @@ {- | The @'IntervalCombinable'@ typeclass provides methods for (possibly) combining -two @'Interval's@. +two @i a@s to form an @'Interval'@. -} -class (IntervalAlgebraic Interval a, Show a) => IntervalCombinable a where +class (IntervalAlgebraic i a) => IntervalCombinable i a where -- | Maybe form a new @'Interval'@ by the union of two @'Interval'@s that 'meets'. - (.+.) :: Interval a -> Interval a -> Maybe (Interval a) + (.+.) :: i a -> i a -> Maybe (Interval a) (.+.) x y | x `meets` y = Just $ Interval (begin x, end y) | otherwise = Nothing @@ -574,7 +574,7 @@ -- | 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 -- 'begin' of @y@. Otherwise, 'Nothing'. - (><) :: Interval a -> Interval a -> Maybe (Interval a) + (><) :: i a -> i a -> Maybe (Interval a) (><) x y | x `before` y = Just $ Interval ( end x, begin y ) | otherwise = Nothing @@ -583,17 +583,17 @@ -- return 'extenterval' of @x@ and @y@ (wrapped in @f@). This is useful for -- (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 -> + (<+>):: (Semigroup (f (i a)), Semigroup (f (Interval a)), Applicative f) => + i a -> + i a -> f (Interval a) (<+>) x y - | x `before` y = pure x <> pure y + | x `before` y = pure (getInterval x) <> pure (getInterval 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 :: i a -> i a -> Maybe (Interval a) intersect x y | disjoint x y = Nothing | otherwise = Just $ Interval (b, e) @@ -616,7 +616,7 @@ | begin x == begin y = end x < end y | otherwise = False -instance (Intervallic Interval a, Show a) => Show (Interval a) where +instance (Intervallic Interval a) => Show (Interval a) where show x = "(" ++ show (begin x) ++ ", " ++ show (end x) ++ ")" instance (Ord a, Show a) => Intervallic Interval a where @@ -624,21 +624,21 @@ setInterval _ x = x instance IntervalAlgebraic Interval Int -instance IntervalCombinable Int +instance IntervalCombinable Interval Int instance IntervalSizeable Int Int where moment = 1 add = (+) diff = (-) instance IntervalAlgebraic Interval Integer -instance IntervalCombinable Integer +instance IntervalCombinable Interval Integer instance IntervalSizeable Integer Integer where moment = 1 add = (+) diff = (-) instance IntervalAlgebraic Interval DT.Day -instance IntervalCombinable DT.Day +instance IntervalCombinable Interval DT.Day instance IntervalSizeable DT.Day Integer where moment = 1 add = addDays diff --git a/src/IntervalAlgebra/IntervalUtilities.hs b/src/IntervalAlgebra/IntervalUtilities.hs --- a/src/IntervalAlgebra/IntervalUtilities.hs +++ b/src/IntervalAlgebra/IntervalUtilities.hs @@ -8,6 +8,8 @@ License : BSD3 Maintainer : bsaul@novisci.com Stability : experimental + +In the examples below, @iv@ is a synonym for 'beginerval' used to save space. -} module IntervalAlgebra.IntervalUtilities ( @@ -49,36 +51,35 @@ ) where -import GHC.Base - ( otherwise, ($), (.), (<*>), seq, not - , Semigroup((<>)) - , Functor(fmap) - , Applicative(pure) - , Int, Bool, Ord) -import GHC.Show ( Show ) -import GHC.Num () -import Data.Tuple ( fst ) -import Data.Foldable ( Foldable(null, foldl', toList), all, any ) -import Data.Monoid ( (<>), Monoid(mempty) ) -import IntervalAlgebra - ( Interval, Intervallic(..), IntervalAlgebraic(..) - , IntervalCombinable(..), IntervalSizeable(..) - , IntervalRelation(..) - , ComparativePredicateOf - , unsafeInterval - , beginerval - , enderval - ) -import Data.Maybe (mapMaybe, catMaybes, fromMaybe, Maybe(..)) -import Data.List ( (++), map, head, init, last, tail ) -import Witherable ( Filterable(filter) ) +import GHC.Base ( otherwise, ($), (.), (<*>), seq, not + , Semigroup((<>)) + , Functor(fmap) + , Applicative(pure) + , Int, Bool, Ord) +import GHC.Num () +import Data.Tuple ( fst ) +import Data.Foldable ( Foldable(null, foldl', toList), all, any ) +import Data.Monoid ( (<>), Monoid(mempty) ) +import Data.Maybe (mapMaybe, catMaybes, fromMaybe, Maybe(..)) +import Data.List ( (++), map ) +import IntervalAlgebra ( Interval + , Intervallic(..) + , IntervalAlgebraic(..) + , IntervalCombinable(..) + , IntervalSizeable(..) + , IntervalRelation(..) + , ComparativePredicateOf + , beginerval + , enderval) +import Safe ( headMay, lastMay, initSafe, tailSafe) +import Witherable ( Filterable(filter) ) ------------------------------------------------- -- Unexported utilties used in functions below -- ------------------------------------------------- -intInt :: Int -> Int -> Interval Int -intInt = unsafeInterval +iv :: Int -> Int -> Interval Int +iv = beginerval -- Fold over consecutive pairs of foldable structure and collect the results in -- a monoidal structure. @@ -109,23 +110,27 @@ -- Defines how a Box of Intervals are combined. Specifically, the last element of -- x and first element of y are combined by '<+>'. -instance (IntervalCombinable a) => Semigroup (Box (Interval a)) where - Box x <> Box y - | null x = Box y - | null y = Box x - | otherwise = Box $ init x ++ (lx <+> fy) ++ tail y - where lx = last x - fy = head y +instance (IntervalCombinable Interval a) => Semigroup (Box (Interval a)) where + Box x <> Box y = Box $ initSafe x ++ lastMay x <++> headMay y ++ tailSafe y +(<++>) :: (IntervalCombinable Interval a) => + Maybe (Interval a) + -> Maybe (Interval a) + -> [Interval a] +(<++>) Nothing Nothing = [] +(<++>) Nothing (Just y) = [y] +(<++>) (Just x) Nothing = [x] +(<++>) (Just x) (Just y) = x <+> y + ------------------------------------------------- -- | 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. -- --- >>> combineIntervals [intInt 0 10, intInt 2 7, intInt 10 12, intInt 13 15] +-- >>> combineIntervals [iv 10 0, iv 5 2, iv 2 10, iv 2 13] -- [(0, 12),(13, 15)] -combineIntervals :: (IntervalCombinable a +combineIntervals :: (IntervalCombinable Interval a , Applicative f , Monoid (f (Interval a)) , Foldable f) => @@ -137,18 +142,18 @@ -- 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] +-- >>> combineIntervals' [iv 10 0, iv 5 2, iv 2 10, iv 2 13] -- [(0, 12),(13, 15)] -combineIntervals' :: (IntervalCombinable a) => [Interval a] -> [Interval a] +combineIntervals' :: (IntervalCombinable Interval a) => [Interval a] -> [Interval a] combineIntervals' l = unBox $ foldl' (<>) (Box []) (map (\z -> Box [z]) l) -- | Returns a (possibly empty) 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. -- --- >>> gaps [intInt 1 5, intInt 8 12, intInt 11 14] +-- >>> gaps [iv 4 1, iv 4 8, iv 3 11] -- [(5, 8)] -gaps :: (IntervalCombinable a +gaps :: (IntervalCombinable Interval a , Applicative f , Monoid (f (Interval a)) , Foldable f) => @@ -160,7 +165,7 @@ -- 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' :: (IntervalCombinable a +gaps' :: (IntervalCombinable Interval a , Applicative f , Monoid (f (Interval a)) , Foldable f) => @@ -170,7 +175,7 @@ -- | Returns the 'duration' of each 'Intervallic i a' in the 'Functor' @f@. -- --- >>> durations [intInt 1 10, intInt 2 12, intInt 5 6] +-- >>> durations [iv 9 1, iv 10 2, iv 1 5] -- [9,10,1] durations :: (Functor f, Intervallic i a, IntervalSizeable a b)=> f (i a) @@ -179,10 +184,10 @@ -- | In the case that x y are not disjoint, clips y to the extent of x. -- --- >>> clip (intInt 0 5) (intInt 3 6) +-- >>> clip (iv 5 0) (iv 3 3) -- Just (3, 5) -- --- >>> clip (intInt 0 3) (intInt 4 6) +-- >>> clip (iv 3 0) (iv 2 4) -- Nothing clip :: (IntervalAlgebraic Interval a, IntervalSizeable a b)=> Interval a @@ -201,7 +206,7 @@ -- of intervals. This the specialized form of 'relations'' which can return -- any 'Applicative', 'Monoid' structure. -- --- >>> relations [intInt 0 1, intInt 1 2] +-- >>> relations [iv 1 0, iv 1 1] -- [Meets] relations :: (IntervalAlgebraic i a, Foldable f)=> f (i a) @@ -210,8 +215,9 @@ -- | A generic form of 'relations' which can output any 'Applicative' and -- 'Monoid' structure. --- >>> (relations' [intInt 0 1, intInt 1 2]) :: [IntervalRelation Int] +-- >>> (relations' [iv 1 0, iv 1 1]) :: [IntervalRelation (Interval Int)] -- [Meets] +-- relations' :: ( IntervalAlgebraic i a , Foldable f , Applicative m @@ -225,26 +231,26 @@ -- to @i@, so that all the intervals are 'within' @i@. If there are no gaps, then -- 'Nothing' is returned. -- --- >>> gapsWithin (intInt 1 10) [intInt 0 5, intInt 7 9, intInt 12 15] +-- >>> gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12] -- Just [(5, 7),(9, 10)] -- gapsWithin :: ( Applicative f , Foldable f , Monoid (f (Interval a)) , IntervalSizeable a b - , IntervalCombinable a + , IntervalCombinable Interval a , Filterable f , IntervalAlgebraic Interval a)=> Interval a -- ^ i -> f (Interval a) -- ^ x -> Maybe (f (Interval a)) -gapsWithin i x - | null ivs = Nothing +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) + ivs = liftListToFoldable (mapMaybe (clip i) nd) -- | Given a predicate combinator, a predicate, and list of intervals, returns -- the input unchanged if the predicate combinator is @True@. Otherwise, returns @@ -262,12 +268,12 @@ -- For example, the following returns 'Nothing' because none of the intervals -- in the input list 'starts' (3, 5). -- --- >>> nothingIfNone (starts (intInt 3 5)) [intInt 3 4, intInt 5 6] +-- >>> nothingIfNone (starts (iv 2 3)) [iv 1 3, iv 1 5] -- Nothing -- -- In the following, (3, 5) 'starts' (3, 6), so 'Just' the input is returned. -- --- >>> nothingIfNone (starts (intInt 3 5)) [intInt 3 6, intInt 5 6] +-- >>> nothingIfNone (starts (iv 2 3)) [iv 3 3, iv 1 5] -- Just [(3, 6),(5, 6)] -- nothingIfNone :: (Monoid (f (i a)), Foldable f, Filterable f, IntervalAlgebraic i a)=> @@ -298,7 +304,7 @@ -- | Lifts a predicate to be able to compare two different 'IntervalAlgebraic' -- structure by comparing the intervals contain within each. compareIntervals :: (IntervalAlgebraic i0 a, IntervalAlgebraic i1 a) => - ComparativePredicateOf (Interval a) + ComparativePredicateOf (Interval a) -> i0 a -> i1 a -> Bool @@ -319,7 +325,7 @@ filterOverlaps :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterOverlaps = filterMaker overlaps @@ -327,7 +333,7 @@ filterOverlappedBy :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterOverlappedBy = filterMaker overlappedBy @@ -335,7 +341,7 @@ filterBefore :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterBefore = filterMaker before @@ -343,31 +349,31 @@ filterAfter :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => - i0 a -> f (i1 a) -> f (i1 a) + , IntervalAlgebraic i1 a) => + i0 a -> f (i1 a) -> f (i1 a) filterAfter = filterMaker after -- | Filter by 'starts'. filterStarts :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) -filterStarts = filterMaker starts +filterStarts = filterMaker starts -- | Filter by 'startedBy'. filterStartedBy :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) -filterStartedBy = filterMaker startedBy +filterStartedBy = filterMaker startedBy -- | Filter by 'finishes'. filterFinishes :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterFinishes = filterMaker finishes @@ -375,15 +381,15 @@ filterFinishedBy :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) -filterFinishedBy = filterMaker finishedBy +filterFinishedBy = filterMaker finishedBy -- | Filter by 'meets'. filterMeets :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterMeets = filterMaker meets @@ -391,7 +397,7 @@ filterMetBy :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterMetBy = filterMaker metBy @@ -399,7 +405,7 @@ filterDuring :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterDuring = filterMaker during @@ -407,7 +413,7 @@ filterContains :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterContains = filterMaker contains @@ -415,7 +421,7 @@ filterEquals :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterEquals = filterMaker equals @@ -423,7 +429,7 @@ filterDisjoint :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterDisjoint = filterMaker disjoint @@ -431,7 +437,7 @@ filterNotDisjoint :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterNotDisjoint = filterMaker notDisjoint @@ -439,7 +445,7 @@ filterConcur :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterConcur = filterMaker concur @@ -447,7 +453,7 @@ filterWithin :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterWithin = filterMaker within @@ -455,7 +461,7 @@ filterEnclose :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterEnclose = filterMaker enclose @@ -463,6 +469,6 @@ filterEnclosedBy :: (Filterable f , IntervalAlgebraic Interval a , IntervalAlgebraic i0 a - , IntervalAlgebraic i1 a) => + , IntervalAlgebraic i1 a) => i0 a -> f (i1 a) -> f (i1 a) filterEnclosedBy = filterMaker enclosedBy diff --git a/src/IntervalAlgebra/PairedInterval.hs b/src/IntervalAlgebra/PairedInterval.hs --- a/src/IntervalAlgebra/PairedInterval.hs +++ b/src/IntervalAlgebra/PairedInterval.hs @@ -31,7 +31,7 @@ newtype PairedInterval b a = PairedInterval (Interval a, b) deriving (Eq) -instance (Ord a) => Intervallic (PairedInterval b) a where +instance (Ord a, Show a) => Intervallic (PairedInterval b) a where getInterval (PairedInterval x) = fst x setInterval (PairedInterval (x, y)) i = PairedInterval (i, y) @@ -52,7 +52,7 @@ pairData (PairedInterval (_, y)) = y -- | Gets the intervals from a list of paired intervals. -intervals :: Ord a => [PairedInterval b a] -> [Interval a] +intervals :: (Ord a, Show a) => [PairedInterval b a] -> [Interval a] intervals = map getInterval -- | Takes a predicate of intervals and a predicate on the data part of a diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -2,42 +2,51 @@ {-# LANGUAGE FlexibleContexts #-} module IntervalAlgebra.IntervalUtilitiesSpec (spec) where -import IntervalAlgebra ( - Interval - , Intervallic(..) - , unsafeInterval - , IntervalCombinable(..) - , IntervalAlgebraic(..) - , IntervalRelation (..) ) -import IntervalAlgebra.Arbitrary () -import IntervalAlgebra.IntervalUtilities -import Test.Hspec.QuickCheck ( modifyMaxSuccess ) -import Test.Hspec ( it, shouldBe, describe, Spec, pending ) -import Test.QuickCheck -import Data.List(sort) +import Test.Hspec.QuickCheck ( modifyMaxSuccess ) +import Test.Hspec ( Spec + , it, shouldBe, describe, pending ) +import Test.QuickCheck ( Property, Testable(property) + , (===)) +import Data.List (sort) +import IntervalAlgebra.Arbitrary () +import IntervalAlgebra ( Interval + , Intervallic(..) + , IntervalCombinable(..) + , IntervalAlgebraic(..) + , IntervalRelation (..) + , beginerval) +import IntervalAlgebra.IntervalUtilities ( combineIntervals + , gaps + , durations + , clip + , relations + , gapsWithin + , nothingIfNone + , filterDisjoint + , filterNotDisjoint ) intInt :: Int -> Int -> Interval Int -intInt = unsafeInterval +intInt = beginerval containmentInt :: Interval Int -containmentInt = unsafeInterval (0 :: Int) (10 :: Int) +containmentInt = intInt (10 :: Int) (0 :: Int) noncontainmentInt :: Interval Int -noncontainmentInt = unsafeInterval (4 :: Int) (10 :: Int) +noncontainmentInt = intInt 6 4 anotherInt :: Interval Int -anotherInt = unsafeInterval (15 :: Int) (20 :: Int) +anotherInt = intInt 5 (15 :: Int) gapInt :: Interval Int -gapInt = unsafeInterval (10 :: Int) (15 :: Int) +gapInt = intInt 5 (10 :: Int) -prop_combineIntervals1:: (IntervalAlgebraic Interval a, IntervalCombinable a)=> +prop_combineIntervals1:: (IntervalAlgebraic Interval a, IntervalCombinable Interval a)=> [Interval a] -> Property prop_combineIntervals1 x = relations ci === replicate (length ci - 1) Before where ci = combineIntervals (sort x) -prop_gaps1:: (IntervalAlgebraic Interval a, IntervalCombinable a)=> +prop_gaps1:: (IntervalAlgebraic Interval a, IntervalCombinable Interval a)=> [Interval a] -> Property prop_gaps1 x = relations gs === replicate (length gs - 1) Before @@ -61,9 +70,9 @@ combineIntervals [noncontainmentInt] `shouldBe` [noncontainmentInt] it "combineIntervals [] should be []" $ combineIntervals ([] :: [Interval Int]) `shouldBe` [] - 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 "combineIntervals [(0, 10), (2, 7), (10, 12), (13, 15)]" $ + combineIntervals [intInt 10 0, intInt 5 2, intInt 2 10, intInt 2 13] + `shouldBe` [intInt 12 0, intInt 2 13] it "after combining, only relation should be Before" $ property (prop_combineIntervals1 @Int) @@ -94,7 +103,7 @@ 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) + Just (intInt 6 4) it "clip x y === intersect sort x y " pending describe "relations tests" $ @@ -111,20 +120,20 @@ 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` Just [intInt 5 7, intInt 9 10] + gapsWithin (intInt 9 1) [intInt 5 0, intInt 2 7, intInt 3 12] + `shouldBe` Just [intInt 2 5, intInt 1 9] it "gapsWithin (1, 10) [] should be []" $ - gapsWithin (intInt 1 10) [] `shouldBe` Nothing + gapsWithin (intInt 9 1) [] `shouldBe` Nothing it "more gapsWithin tests" pending describe "emptyIf tests" $ do it "emptyIfNone (starts (3, 5)) [(3,4), (5,6)] should be empty" $ - nothingIfNone (starts (intInt 3 5)) [intInt 3 4, intInt 5 6] + nothingIfNone (starts (intInt 2 3)) [intInt 1 3, intInt 1 5] `shouldBe` Nothing it "emptyIfNone (starts (3, 5)) [(3,6), (5,6)] shoiuld be input" $ - nothingIfNone (starts (intInt 3 5)) [intInt 3 6, intInt 5 6] - `shouldBe` Just [ intInt 3 6, intInt 5 6] + nothingIfNone (starts (intInt 2 3)) [intInt 3 3, intInt 1 5] + `shouldBe` Just [ intInt 3 3, intInt 1 5] it "more emptyif tests" pending describe "filtration tests" $ diff --git a/test/IntervalAlgebra/PairedIntervalSpec.hs b/test/IntervalAlgebra/PairedIntervalSpec.hs --- a/test/IntervalAlgebra/PairedIntervalSpec.hs +++ b/test/IntervalAlgebra/PairedIntervalSpec.hs @@ -1,20 +1,22 @@ module IntervalAlgebra.PairedIntervalSpec (spec) where -import Test.Hspec ( it, describe, Spec, shouldBe ) -import IntervalAlgebra.PairedInterval -import IntervalAlgebra +import Test.Hspec ( it, describe, Spec, shouldBe ) +import IntervalAlgebra.PairedInterval ( PairedInterval, mkPairedInterval ) +import IntervalAlgebra ( beginerval + , IntervalSizeable(duration) + , IntervalAlgebraic(equals, before) ) type TestPair = PairedInterval String Int mkTestPr :: String -> Int -> Int -> TestPair -mkTestPr x i j = mkPairedInterval x (unsafeInterval i j) +mkTestPr x i j = mkPairedInterval x (beginerval i j) t1 :: TestPair -t1 = mkTestPr "hi" 0 5 +t1 = mkTestPr "hi" 5 0 t2 :: TestPair -t2 = mkTestPr "bye" 6 10 +t2 = mkTestPr "bye" 4 6 t3 :: TestPair -t3 = mkTestPr "hello" 0 5 +t3 = mkTestPr "hello" 5 0 spec :: Spec spec = do diff --git a/test/IntervalAlgebraSpec.hs b/test/IntervalAlgebraSpec.hs --- a/test/IntervalAlgebraSpec.hs +++ b/test/IntervalAlgebraSpec.hs @@ -1,21 +1,43 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} --- {-# LANGUAGE AllowAmbiguousTypes #-} --- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} module IntervalAlgebraSpec (spec) where -import Test.Hspec ( hspec, describe, it, Spec, shouldBe ) -import Test.Hspec.QuickCheck ( modifyMaxSuccess, modifyMaxDiscardRatio ) -import Test.QuickCheck -import IntervalAlgebra as IA -import Data.Maybe -import Control.Monad () -import IntervalAlgebra.Arbitrary () -import Data.Time as DT ( Day ) -import Data.Set (member) +import Test.Hspec ( hspec, describe, it, Spec, shouldBe ) +import Test.Hspec.QuickCheck ( modifyMaxSuccess, modifyMaxDiscardRatio ) +import Test.QuickCheck ( (===) + , (==>) + , Arbitrary(arbitrary) + , Property + , Testable(property) ) +import Data.Maybe ( fromJust ) +import Data.Either ( isRight ) +import IntervalAlgebra.Arbitrary () +import Data.Time as DT ( Day ) +import Data.Set ( member ) +import IntervalAlgebra as IA ( enderval + , beginerval + , expandr + , expandl + , expand + , parseInterval + , IntervalCombinable(intersect, (.+.)) + , IntervalSizeable(moment, diff) + , IntervalAlgebraic( equals, starts + , finishes, finishedBy + , overlaps, during + , contains, compose + , relate, startedBy + , overlappedBy, disjoint + , before, after, meets + , metBy, (<|>)) + , ComparativePredicateOf + , Intervallic(begin, end) + , Interval ) -mkIntrvl = unsafeInterval +mkIntrvl :: Int -> Int -> Interval Int +mkIntrvl = beginerval xor :: Bool -> Bool -> Bool xor a b = a /= b @@ -27,16 +49,6 @@ | x < 0 = negate x | otherwise = x --- | A function for creating intervals when you think you know what you're doing. -safeInterval :: Ord a => a -> a -> Interval a -safeInterval x y = unsafeInterval (min x y) (max x y) - --- | Create a 'Maybe Interval a' from two @a@s. -safeInterval'' :: Ord a => a -> a -> Maybe (Interval a) -safeInterval'' x y - | y <= x = Nothing - | otherwise = Just $ safeInterval x y - -- | A set used for testing M1 defined so that the M1 condition is true. data M1set a = M1set { m11 :: Interval a @@ -66,7 +78,7 @@ where p1 = x -- interval i in prop_IAaxiomM1 p2 = beginerval a (end x) -- interval j in prop_IAaxiomM1 p3 = beginerval b (end x) -- interval k in prop_IAaxiomM1 - p4 = safeInterval (begin (expandl (makePos c) p2)) (begin p2) + p4 = enderval (makePos c) (begin p2) {- @@ -144,18 +156,18 @@ \] -} -prop_IAaxiomM2 :: (Show a, IntervalAlgebraic Interval a) => M2set a -> Property +prop_IAaxiomM2 :: (IntervalAlgebraic Interval a, IntervalSizeable a b) => M2set a -> Property prop_IAaxiomM2 x = (i `meets` j && k `meets` l) ==> (i `meets` l) `xor` - isJust m `xor` - isJust n + isRight m `xor` + isRight n where i = m21 x j = m22 x k = m23 x l = m24 x - m = safeInterval'' (end i) (begin l) - n = safeInterval'' (end k) (begin j) + m = parseInterval (end i) (begin l) + n = parseInterval (end k) (begin j) prop_IAaxiomM2_Int :: M2set Int -> Property prop_IAaxiomM2_Int = prop_IAaxiomM2 @@ -221,8 +233,8 @@ b -> Interval a -> Property prop_IAaxiomM3 b i = (j `meets` i && i `meets` k) === True - where j = safeInterval (begin (expandl b i)) (begin i) - k = safeInterval (end i) (end (expandr b i)) + where j = enderval b (begin i) + k = beginerval b (end i) prop_IAaxiomM3_Int :: Interval Int -> Property prop_IAaxiomM3_Int = prop_IAaxiomM3 1 @@ -243,15 +255,16 @@ prop_IAaxiomM4 :: (IntervalAlgebraic Interval a, IntervalSizeable a b)=> b -> M2set a -> Property -prop_IAaxiomM4 moment x = +prop_IAaxiomM4 b x = ((m `meets` i && i `meets` j && j `meets` n) && (m `meets` k && k `meets` n)) === True where i = m21 x j = m22 x - m = safeInterval (begin (expandl moment i)) (begin i) - n = safeInterval (end j) (end (expandr moment j)) - k = safeInterval (end m) (begin n) - + m = enderval b (begin i) + n = beginerval b (end j) + k = beginerval g (end m) + g = diff (begin n) (end m) + prop_IAaxiomM4_Int :: M2set Int -> Property prop_IAaxiomM4_Int = prop_IAaxiomM4 1 @@ -295,13 +308,15 @@ ps = end (expandr (makePos b) x) -- creating l by shifting and expanding i -prop_IAaxiomM5 :: (Show a, IntervalAlgebraic Interval a) => M5set a -> Property +prop_IAaxiomM5 :: (IntervalAlgebraic Interval a, IntervalSizeable a b) => + M5set a -> Property prop_IAaxiomM5 x = ((i `meets` j && j `meets` l) && (i `meets` k && k `meets` l)) === (j == k) where i = m51 x - j = safeInterval (end i) (begin l) - k = safeInterval (end i) (begin l) + j = beginerval g (end i) + k = beginerval g (end i) + g = diff (begin l) (end i) l = m52 x prop_IAaxiomM5_Int :: M5set Int -> Property @@ -321,15 +336,15 @@ \] -} -prop_IAaxiomM4_1 :: (IntervalSizeable a b, IntervalCombinable a)=> +prop_IAaxiomM4_1 :: (IntervalSizeable a b, IntervalCombinable Interval a)=> b -> M2set a -> Property prop_IAaxiomM4_1 b x = ((m `meets` i && i `meets` j && j `meets` n) && (m `meets` ij && ij `meets` n)) === True where i = m21 x j = m22 x - m = safeInterval (begin (expandl b i)) (begin i) - n = safeInterval (end j) (end (expandr b j)) + m = enderval b (begin i) + n = beginerval b (end j) ij = fromJust $ i .+. j prop_IAaxiomM4_1_Int :: M2set Int -> Property @@ -342,47 +357,50 @@ * Interval Relation property testing -} -class (IntervalAlgebraic Interval a, IntervalCombinable a)=> IntervalRelationProperties a where +class ( IntervalAlgebraic Interval a + , IntervalCombinable Interval a + , IntervalSizeable a b + ) => IntervalRelationProperties a b where prop_IAbefore :: Interval a -> Interval a -> Property prop_IAbefore i j = IA.before i j ==> (i `meets` k) && (k `meets` j) - where k = safeInterval (end i) (begin j) + where k = beginerval (diff (begin j) (end i)) (end i) prop_IAstarts:: Interval a -> Interval a -> Property prop_IAstarts i j | IA.starts i j = (j == fromJust (i .+. k)) === True | otherwise = IA.starts i j === False - where k = safeInterval (end i) (end j) + where k = beginerval (diff (end j) (end i)) (end i) prop_IAfinishes:: Interval a -> Interval a -> Property prop_IAfinishes i j | IA.finishes i j = (j == fromJust ( k .+. i)) === True | otherwise = IA.finishes i j === False - where k = safeInterval (begin j) (begin i) + where k = beginerval (diff (begin i) (begin j)) (begin j) prop_IAoverlaps:: Interval a -> Interval a -> Property prop_IAoverlaps i j | IA.overlaps i j = ((i == fromJust ( k .+. l )) && (j == fromJust ( l .+. m ))) === True | otherwise = IA.overlaps i j === False - where k = safeInterval (begin i) (begin j) - l = safeInterval (begin j) (end i) - m = safeInterval (end i) (end j) + where k = beginerval (diff (begin j) (begin i)) (begin i) + l = beginerval (diff (end i) (begin j)) (begin j) + m = beginerval (diff (end j) (end i)) (end i) prop_IAduring:: Interval a -> Interval a-> Property prop_IAduring i j | IA.during i j = (j == fromJust ( fromJust (k .+. i) .+. l)) === True | otherwise = IA.during i j === False - where k = safeInterval (begin j) (begin i) - l = safeInterval (end i) (end j) + where k = beginerval (diff (begin i) (begin j)) (begin j) + l = beginerval (diff (end j) (end i)) (end i) -- | For any two pair of intervals exactly one 'IntervalRelation' should hold prop_exclusiveRelations:: Interval a -> Interval a -> Property prop_exclusiveRelations x y = ( 1 == length (filter id $ map (\r -> r x y) allIArelations)) === True -instance IntervalRelationProperties Int +instance IntervalRelationProperties Int Int allIArelations:: IntervalAlgebraic Interval a => [ComparativePredicateOf (Interval a)] allIArelations = [ IA.equals @@ -429,76 +447,68 @@ 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) + expand 0 5 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (6::Int) (0::Int) it "expand 5 0 Interval (0, 1) should be Interval (-5, 1)" $ - expand 5 0 (unsafeInterval (0::Int) (1::Int)) `shouldBe` unsafeInterval (-5::Int) (1::Int) + expand 5 0 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (6::Int) (-5::Int) it "expand 5 5 Interval (0, 1) should be Interval (-5, 6)" $ - expand 5 5 (unsafeInterval (0::Int) (1::Int)) `shouldBe` unsafeInterval (-5::Int) (6::Int) + expand 5 5 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (11::Int) (-5::Int) it "expand -1 5 Interval (0, 1) should be Interval (-5, 6)" $ - expand (-1) 5 (unsafeInterval (0::Int) (1::Int)) `shouldBe` unsafeInterval (0::Int) (6::Int) + expand (-1) 5 (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (6::Int) (0::Int) it "expand 5 -5 Interval (0, 1) should be Interval (-5, 1)" $ - expand 5 (-5) (unsafeInterval (0::Int) (1::Int)) `shouldBe` unsafeInterval (-5::Int) (1::Int) + expand 5 (-5) (beginerval (1::Int) (0::Int)) `shouldBe` beginerval (6::Int) (-5::Int) it "expand moment 0 Interval (0, 1) should be Interval (-1, 1)" $ - expand (moment @Int) 0 (unsafeInterval (0::Int) (1::Int)) `shouldBe` - unsafeInterval (-1::Int) (1::Int) + expand (moment @Int) 0 (beginerval (1::Int) (0::Int)) `shouldBe` + beginerval (2::Int) (-1::Int) it "beginerval 2 10 should be Interval (10, 12)" $ - beginerval (2::Int) 10 `shouldBe` unsafeInterval (10::Int) (12::Int) + Right (beginerval (2::Int) 10) `shouldBe` parseInterval (10::Int) (12::Int) it "beginerval 0 10 should be Interval (10, 11)" $ - beginerval (0::Int) 10 `shouldBe` unsafeInterval (10::Int) (11::Int) + Right (beginerval (0::Int) 10) `shouldBe` parseInterval (10::Int) (11::Int) it "beginerval -2 10 should be Interval (10, 11)" $ - beginerval (-2::Int) 10 `shouldBe` unsafeInterval (10::Int) (11::Int) + Right (beginerval (-2::Int) 10) `shouldBe` parseInterval (10::Int) (11::Int) it "enderval 2 10 should be Interval (8, 10)" $ - enderval (2::Int) 10 `shouldBe` unsafeInterval (8::Int) (10::Int) + Right (enderval (2::Int) 10) `shouldBe` parseInterval (8::Int) (10::Int) it "enderval 0 10 should be Interval (9, 10)" $ - enderval (0::Int) 10 `shouldBe` unsafeInterval (9::Int) (10::Int) + Right (enderval (0::Int) 10) `shouldBe` parseInterval (9::Int) (10::Int) it "enderval -2 10 should be Interval (9, 10)" $ - enderval (-2::Int) 10 `shouldBe` unsafeInterval (9::Int) (10::Int) + Right (enderval (-2::Int) 10) `shouldBe` parseInterval (9::Int) (10::Int) describe "IntervalAlgebraic tests" $ modifyMaxSuccess (*10000) $ do it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 4) is True" $ - (startedBy <|> overlappedBy) (mkIntrvl (0::Int) (9::Int)) (mkIntrvl (-1::Int) (4::Int)) + (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 5 (-1)) `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)) + (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 4 0) `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)) + (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 10 (-1)) `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)) + disjoint (mkIntrvl 2 0) (mkIntrvl 2 3) `shouldBe` + (before <|> after <|> meets <|> metBy) (mkIntrvl 2 0) (mkIntrvl 2 3) it "prop_compose holds" $ property (prop_compose @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 + intersect (mkIntrvl 2 0) (mkIntrvl 2 2) `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 + intersect (mkIntrvl 2 0) (mkIntrvl 1 3) `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 + intersect (mkIntrvl 2 2) (mkIntrvl 2 0) `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) + intersect (mkIntrvl 2 0) (mkIntrvl 2 1) `shouldBe` Just (mkIntrvl 1 1) 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) + intersect (mkIntrvl 2 0) (mkIntrvl 4 (-1)) `shouldBe` Just (mkIntrvl 2 0) 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) + intersect (mkIntrvl 2 0) (mkIntrvl 2 0) `shouldBe` Just (mkIntrvl 2 0) 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) + intersect (mkIntrvl 2 0) (mkIntrvl 2 (-1)) `shouldBe` Just (mkIntrvl 1 0) 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) + intersect (mkIntrvl 3 0) (mkIntrvl 1 1) `shouldBe` Just (mkIntrvl 1 1) describe "Interval Algebra Axioms for meets properties" $ modifyMaxSuccess (*10) $