interval-algebra 0.1.2 → 0.2.0

raw patch · 11 files changed

+564/−263 lines, 11 filesdep +witherablesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: witherable

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−1
• README.md +10/−11
• Setup.hs +0/−2
• interval-algebra.cabal +14/−12
• src/IntervalAlgebra.hs +167/−26
• src/IntervalAlgebra/Arbitrary.hs +68/−0
• src/IntervalAlgebra/IntervalFilter.hs +0/−64
• src/IntervalAlgebra/IntervalUtilities.hs +49/−0
• test/IntervalAlgebra/IntervalUtilitiesSpec.hs +48/−0
• test/IntervalAlgebraSpec.hs +201/−147
• test/Spec.hs +1/−0

@@ -1,3 +1,8 @@ # Changelog for interval-algebra -## Unreleased changes+## 0.2.0++* Adds `IntervalSizeable` class.+* Moves `IntervalFilterable` class to main module and generalizes the container to any `Filterable` type.+* Adds `IntervalAlgebra.IntervalAlgebraUtilities` module to collect various useful functions.+* Adds `IntervalAlgebra.Arbitrary` module to provide functions for generating arbitrary intervals.

@@ -1,30 +1,29 @@ # interval-algebra -The `interval-algebra` package implements [Allen's interval algebra](https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html) in [Haskell](https://www.haskell.org). The main module provides data types and related classes for the interval-based temporal logic described in [Allen (1983)](https://doi.org/10.1145/182.358434) and axiomatized in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). +The `interval-algebra` package implements [Allen's interval algebra](https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html) in [Haskell](https://www.haskell.org). The main module provides data types and related classes for the interval-based temporal logic described in [Allen (1983)](https://doi.org/10.1145/182.358434) and axiomatized in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x).  A good primer on Allen's algebra can be [found here](https://thomasalspaugh.org/pub/fnd/allen.html). -# Design+## Design -The module is built around three typeclasses designed to separate concerns of -constructing, relating, and combining `Interval`s: +The module is built around five typeclasses designed to separate concerns of constructing, relating, and combining `Interval`s:  1. `Intervallic` provides an interface to the data structure of an `Interval`, defining how an `Interval a` (simply a pair `(a, a)`) is constructed. 2. `IntervalAlgebraic` provides an interface to the `IntervalRelation`s, the workhorse of Allen's temporal logic. 3. `IntervalCombinable` provides an interface to methods of combining multiple `Interval`s.+4. `IntervalSizeable` provides methods for measuring and modifying the size of an interval.+5. `IntervalFilterable` provides methods for filtering 'Filterable' collections of intervals. -An advantage of nested typeclass design is that developers can define an -`Interval` of type `a` with just the amount of structure that they need.+An advantage of nested typeclass design is that developers can define an `Interval` of type `a` with just the amount of structure that they need. -## Total Ordering of `Interval`s +## Total Ordering of `Interval`s -The modules makes the (opinionated) choice of a total ordering for `Intervallic` `Interval`s. Namely, the ordering is based on first ordering the `begin`s -then the `end`s.+The modules makes the (opinionated) choice of a total ordering for `Intervallic` `Interval`s. Namely, the ordering is based on first ordering the `begin`s then the `end`s. -# Axiom tests+## Axiom tests  The package [includes tests](test/IntervalAlgebraSpec.hs) that the functions of the `IntervalAlgebraic` typeclass meets the axioms for _intervals_ (not points) as laid out in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). -# Development+## Development  This module is under development and the API may change in the future.

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,13 +1,6 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.33.0.------ see: https://github.com/sol/hpack------ hash: afab50a57b38d45082f7b71f75ba5ec1cb8188302aa601326ba694aaa856a8be-+cabal-version:  2.2 name:           interval-algebra-version:        0.1.2+version:        0.2.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@@ -16,7 +9,7 @@ author:         Bradley Saul maintainer:     bsaul@novisci.com copyright:      2020 NoviSci-license:        BSD3+license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple extra-source-files:@@ -30,20 +23,29 @@ library   exposed-modules:       IntervalAlgebra-      IntervalAlgebra.IntervalFilter+      IntervalAlgebra.IntervalUtilities+      IntervalAlgebra.Arbitrary   other-modules:       Paths_interval_algebra+  autogen-modules: +      Paths_interval_algebra   hs-source-dirs:       src   build-depends:       base >=4.7 && <5     , time >=1.8 && <2+    , witherable >= 0.4+    , QuickCheck   default-language: Haskell2010  test-suite interval-algebra-test   type: exitcode-stdio-1.0-  main-is: IntervalAlgebraSpec.hs+  main-is: Spec.hs    other-modules:+      IntervalAlgebraSpec+      IntervalAlgebra.IntervalUtilitiesSpec+      Paths_interval_algebra+  autogen-modules:        Paths_interval_algebra   hs-source-dirs:       test

@@ -1,3 +1,5 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE NoImplicitPrelude #-} {-| Module      : Interval Algebra Description : Implementation of Allen's interval algebra@@ -14,15 +16,19 @@  = Design -The module is built around three typeclasses designed to separate concerns of +The module is built around five typeclasses designed to separate concerns of  constructing, relating, and combining @'Interval'@s:   1. @'Intervallic'@ provides an interface to the data structure of an @'Interval'@,     defining how an @'Interval' a@ is constructed. 2. @'IntervalAlgebraic'@ provides an interface to the @'IntervalRelation's@,     the workhorse of Allen's temporal logic.-3. @'IntervalCombinable'@ provides an interface to methods of combining multiple+3. @'IntervalCombinable'@ provides an interface to methods of combining two    @'Interval's@.+4. @'IntervalSizeable'@ provides methods for measuring and modifying the size+   of an interval.+5. @'IntervalFilterable'@ provides methods for filtering 'Witherable.Filterable' collections+   of intervals.  An advantage of nested typeclass design is that developers can define an  @'Interval'@ of type @a@ with just the amount of structure that they need.@@ -38,21 +44,31 @@ This module is under development and the API may change in the future. -} + module IntervalAlgebra(      -- * Classes       Intervallic(..)     , IntervalAlgebraic(..)     , IntervalCombinable(..)-    -    -- * Data Types-    , Interval(..)+    , IntervalSizeable(..)+    , IntervalFilterable(..)++    -- * Types+    , Interval     , IntervalRelation     , ComparativePredicateOf- ) where -import Data.Time as DT+import Prelude (Eq, Ord, Show, Read+               , Maybe(..), Either(..), String, Integer, Int, Bool(..), Num+               , Foldable (maximum, minimum, foldMap, foldr)+               , 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 GHC.Base (Applicative(pure))+import Witherable ( Filterable(filter) )  {- | An @'Interval' a@ is a pair of @a@s \( (x, y) \text{ where } x < y\). The @'Intervallic'@ class provides a safe @'parseInterval'@ function that returns a @@ -138,8 +154,8 @@ @  -}-data IntervalRelation = -      Meets +data IntervalRelation =+      Meets     | MetBy     | Before     | After@@ -154,11 +170,18 @@     | Equals     deriving (Show, Read) +{-+Misc+-}++-- | Defines a predicate of two objects of type @a@.+type ComparativePredicateOf a = (a -> a -> Bool)+ {- |  The @'Intervallic'@ typeclass specifies how an @'Interval' a@s is constructed. It also includes functions for getting the @'begin'@ and @'end'@ of an @'Interval' a@. -}-class (Ord a, Show a) => Intervallic a where +class (Ord a, Show a) => Intervallic a where      -- | Safely parse a pair of @a@s to create an @'Interval' a@.     parseInterval :: a -> a -> Either String (Interval a)@@ -211,17 +234,17 @@      -- | Does x meet y? Is y metBy x?     meets, metBy           :: ComparativePredicateOf (Interval a)-    meets    x y  = end x == begin y +    meets    x y  = end x == begin y     metBy         = flip meets      -- | Is x before y? Is x after y?     before, after          :: ComparativePredicateOf (Interval a)     before   x y  = end x < begin y     after         = flip before-    +     -- | Does x overlap y? Is x overlapped by y?     overlaps, overlappedBy :: ComparativePredicateOf (Interval a)-    overlaps x y  = begin x < begin y && end x < end y && end x > begin y +    overlaps x y  = begin x < begin y && end x < end y && end x > begin y     overlappedBy  = flip overlaps      -- | Does x start y? Is x started by y?@@ -242,7 +265,7 @@     -- ** Interval Algebra utilities      -- | Compose a list of interval relations with _or_ to create a new-    -- @'ComparativePredicateOf' 'Interval' a@.For example, +    -- @'ComparativePredicateOf' 'Interval' a@. For example,      -- @composeRelations [before, meets]@ creates a predicate function determining     -- if one interval is either before or meets another interval.     composeRelations       :: [ComparativePredicateOf (Interval a)] ->@@ -260,16 +283,131 @@   {- |-The @'IntervalCombinable'@ typeclass provides methods combining multiple @'Interval's@.+The 'IntervalSizeable' typeclass provides functions to determine the size of+and to resize an 'Interval a'. -}+class (Intervallic a, Num b, Ord b) => IntervalSizeable a b| a -> b where++    -- | Determine the duration of an 'Interval a'.+    duration :: Interval a -> b++    -- | Sets the length of a moment for an 'Interval a'.+    moment :: a -> b+    moment x = 1+    -- TODO: The reason is function takes an argument of type @a@ is due to+    --       ambiguous types warnings. I couldn't figure out how to avoid the+    --       warnings without turning on AllowAmbiguousTypes Pragma. Is there a+    --       better way to handle this?++    -- | Shifts an @a@. Most often, the @c@ will be the same+    -- type as the @a@. But for example, if @a@ is 'Day' then @c@ would be 'Int'.+    add :: b -> a -> a++    -- | Resize an 'Interval a' to by expanding to "left" by @max l moment@ +    --   and to the "right" by @min r moment@. +    expand :: b -> b -> Interval a -> Interval a+    expand l r p = Interval (s, e)+      where s = add (negate $ max l (moment (begin p))) (begin p)+            e = add (min r (moment (end p))) (end p)++    -- | Expands an 'Interval a' to left by i.+    expandl :: b -> Interval a -> Interval a+    expandl i = expand i 0++    -- | Expands an 'Interval a' to right by i.+    expandr :: b -> Interval a -> Interval a+    expandr = expand 0++{- |+The @'IntervalCombinable'@ typeclass provides methods for (possibly) combining+two @'Interval's@.+-} class (IntervalAlgebraic a) => IntervalCombinable a where -    -- | Maybe form a new @'Interval'@ by the union of two @'Interval'@s that 'meet'.+    -- | Maybe form a new @'Interval'@ by the union of two @'Interval'@s that 'meets'.     (.+.) :: Interval a -> Interval a -> Maybe (Interval a)     (.+.) x y       | x `meets` y = Just $ Interval (begin x, end y)       | otherwise   = Nothing +    -- | Creates a new @Interval@ spanning the extent x and y+    extenterval :: Interval a -> Interval a -> Interval a+    extenterval x y = Interval (s, e)+       where s = min (begin x) (begin y)+             e = max (end x) (end y)++    -- | 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)+    (><) x y+        | x `before` y = Just $ Interval ( end x, begin y )+        | otherwise    = Nothing++    -- | 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@.+    (<+>):: (Semigroup (f (Interval a)), Applicative f) =>+            Interval a ->+            Interval a ->+            f (Interval a)+    (<+>) x y+      | x `before` y = pure x <> pure y+      | otherwise    = pure ( extenterval x y )++{- | +The @'IntervalFilterable'@ class provides functions for filtering 'Filterable's of +@'Interval'@s based on @'IntervalAlgebraic'@ relations.+-}+class (Filterable f, IntervalAlgebraic a) => IntervalFilterable f a where++    -- |Creates a function for filtering a 'Witherable.Filterable' of @Interval a@s based on a predicate+    filterMaker :: ComparativePredicateOf (Interval a) +                   -> Interval a +                   -> (f (Interval a) -> f (Interval a))+    filterMaker f p = Witherable.filter (`f` p)++    -- | Filter a 'Witherable.Filterable' of @Interval a@s to those that 'overlaps' the @Interval a@+    --   in the first argument.+    filterOverlaps :: Interval a -> f (Interval a) -> f (Interval a)+    filterOverlaps = filterMaker overlaps++    -- | Filter a 'Witherable.Filterable' of @Interval a@s to those 'overlappedBy' the @Interval a@+    --   in the first argument.+    filterOverlappedBy :: Interval a -> f (Interval a) -> f (Interval a)+    filterOverlappedBy = filterMaker overlappedBy++    -- | Filter a 'Witherable.Filterable' of Interval as to those 'before' the @Interval a@+    --   in the first argument.+    filterBefore :: Interval a -> f (Interval a) -> f (Interval a)+    filterBefore = filterMaker before++    -- | Filter a 'Witherable.Filterable' of Interval as to those 'after' the @Interval a@+    --   in the first argument.+    filterAfter :: Interval a -> f (Interval a) -> f (Interval a)+    filterAfter = filterMaker after++    -- | Filter a 'Witherable.Filterable' of Interval as to those that 'meets' the @Interval a@+    --   in the first argument.+    filterMeets :: Interval a -> f (Interval a) -> f (Interval a)+    filterMeets = filterMaker meets++    -- | Filter a 'Witherable.Filterable' of Interval as to those 'metBy' the @Interval a@+    --   in the first argument.+    filterMetBy :: Interval a -> f (Interval a) -> f (Interval a)+    filterMetBy = filterMaker metBy++    -- | Filter a 'Witherable.Filterable' of Interval as to those 'during' the @Interval a@+    --   in the first argument.+    filterDuring :: Interval a -> f (Interval a) -> f (Interval a)+    filterDuring = filterMaker during++    -- | Filter a 'Witherable.Filterable' of Interval as to those that 'contains' the @Interval a@+    --   in the first argument.+    filterContains :: Interval a -> f (Interval a) -> f (Interval a)+    filterContains = filterMaker contains+ {- Instances -}@@ -281,7 +419,7 @@       | begin x <  begin y = True       | begin x == begin y = end x <= end y       | otherwise = False-    (<)  x y +    (<)  x y       | begin x <  begin y = True       | begin x == begin y = end x < end y       | otherwise = False@@ -292,20 +430,23 @@ instance Intervallic Int instance IntervalAlgebraic Int instance IntervalCombinable Int+instance IntervalSizeable Int Int where+    add = (+)+    duration x = end x - begin x+instance IntervalFilterable [] Int  instance Intervallic Integer instance IntervalAlgebraic Integer instance IntervalCombinable Integer+instance IntervalSizeable Integer Integer where+    add = (+)+    duration x = end x - begin x+instance IntervalFilterable [] Integer  instance Intervallic DT.Day instance IntervalAlgebraic DT.Day instance IntervalCombinable DT.Day--{--Misc Utilities--}---- | Defines a predicate of two objects of type @a@.-type ComparativePredicateOf a = (a -> a -> Bool) --+instance IntervalSizeable DT.Day Integer where+    add = addDays+    duration x = diffDays (end x) (begin x)+instance IntervalFilterable [] DT.Day

@@ -0,0 +1,68 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleInstances #-}+{-|+Module      : Generate arbitrary Intervals+Description : Functions for generating arbitrary intervals+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+Stability   : experimental+-}+module IntervalAlgebra.Arbitrary(+    makePos+    , safeInterval+    , safeInterval'+    , safeInterval''+) where++import Test.QuickCheck ( Arbitrary(arbitrary, shrink) )+import GHC.Base+    ( otherwise,+      ($),+      Eq((==)),+      Ord((<=), (<), min, max),+      Int,+      Maybe(..),+      (.), +      liftM2 )+import Control.Applicative((<$>))+import GHC.Num ( Num((+), negate) )+import IntervalAlgebra (+      Interval+    , Intervallic(unsafeInterval)+    , IntervalSizeable(add))+import Data.Time as DT ( Day(ModifiedJulianDay), toModifiedJulianDay)++instance Arbitrary (Interval Int) where+  arbitrary = liftM2 safeInterval' arbitrary arbitrary++instance Arbitrary DT.Day where+    arbitrary = DT.ModifiedJulianDay . (2000 +) <$> arbitrary+    shrink    = (DT.ModifiedJulianDay <$>) . shrink . DT.toModifiedJulianDay++instance Arbitrary (Interval DT.Day) where+  arbitrary = liftM2 safeInterval' arbitrary arbitrary++type IntervalInt = Interval Int++-- | Internal function for converting a number to a strictly positive value.+makePos :: (Ord b, Num b) => b -> b+makePos x+  | x == 0    = x + 1+  | x <  0    = negate x+  | otherwise = x++-- | A function for creating intervals when you think you know what you're doing.+safeInterval :: (Intervallic a) => a -> a -> Interval a+safeInterval x y = unsafeInterval (min x y) (max x y)++-- | Safely create a valid 'Interval a' from two @a@ by adding a positive @dur@+--   to @start@ to set the duration of the interval.+safeInterval' :: (IntervalSizeable a b) => a -> b -> Interval a+safeInterval' start dur = safeInterval start (add (makePos dur) start)++-- | Create a 'Maybe Interval a' from two @a@s.+safeInterval'' :: (Intervallic a) => a -> a -> Maybe (Interval a)+safeInterval'' x y+    | y <= x    = Nothing+    | otherwise = Just $ safeInterval x y

@@ -1,64 +0,0 @@-{-|-Module      : Interval Algebra Filtrations-Description : Offers functions for filtering list of intervals based on a -              reference interval.-Copyright   : (c) NoviSci, Inc 2020-License     : BSD3-Maintainer  : bsaul@novisci.com-Stability   : experimental--}--module IntervalAlgebra.IntervalFilter (-    -- * Classes-    IntervalFilterable(..)-) where--import IntervalAlgebra--{- | -The @'IntervalFilterable'@ class provides functions for filtering 'List's of -@'Interval'@s based on @'IntervalAlgebraic'@ relations.--}-class (IntervalAlgebraic a) => IntervalFilterable a where---- TODO: generalize the class to handle generalized "filterable" containers (not--- just lists).--    -- |Creates a function for filtering a list of Interval as based on a predicate-    filterMaker :: ComparativePredicateOf (Interval a) -                   -> Interval a -                   -> ([Interval a] -                   -> [Interval a])-    filterMaker f p = filter (`f` p)--    -- | Filter a list of Interval as to those overlapping the Interval a p-    filterOverlaps :: Interval a -> ([Interval a] -> [Interval a])-    filterOverlaps = filterMaker overlaps--    -- | Filter a list of Interval as to those overlapped by the Interval a p-    filterOverlappedBy :: Interval a -> ([Interval a] -> [Interval a])-    filterOverlappedBy = filterMaker overlappedBy--    -- | Filter a list of Interval as to those before the Interval a p-    filterBefore :: Interval a -> ([Interval a] -> [Interval a])-    filterBefore = filterMaker before--    -- | Filter a list of Interval as to those before the Interval a p-    filterAfter :: Interval a -> ([Interval a] -> [Interval a])-    filterAfter = filterMaker after--    -- | Filter a list of Interval as to those meeting the Interval a p-    filterMeets :: Interval a -> ([Interval a] -> [Interval a])-    filterMeets = filterMaker meets--    -- | Filter a list of Interval as to those meeting the Interval a p-    filterMetBy :: Interval a -> ([Interval a] -> [Interval a])-    filterMetBy = filterMaker metBy--    -- | Filter a list of Interval as to those during the Interval a p-    filterDuring :: Interval a -> ([Interval a] -> [Interval a])-    filterDuring = filterMaker during--    -- | Filter a list of Interval as to those containing the Interval a p-    filterContains :: Interval a -> ([Interval a] -> [Interval a])-    filterContains = filterMaker contains

@@ -0,0 +1,49 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleInstances #-}+{-|+Module      : Interval Algebra Utilities+Description : Functions for operating on containers of Intervals.+Copyright   : (c) NoviSci, Inc 2020+License     : BSD3+Maintainer  : bsaul@novisci.com+Stability   : experimental+-}++module IntervalAlgebra.IntervalUtilities (+      combineIntervals+    , gaps+    , durations+) where++import GHC.Base+    ( (++), map, foldr, otherwise, ($), (.), (<*>)+    , Semigroup((<>)), Functor(fmap))+import Prelude (uncurry, zip, Num)+import IntervalAlgebra( Interval, IntervalCombinable(..), IntervalSizeable(..) )+import Data.Maybe (mapMaybe)+import Data.List ( (++), null, any, head, init, last, tail )++-- | Box to avoid overlapping instances+newtype Box a = Box { unBox :: [a] }+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++-- | 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 :: (IntervalCombinable a) => [Interval a] -> [Interval a]+combineIntervals l = unBox $ foldr ((<>) . (\z -> Box [z])) (Box []) 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*.+gaps :: (IntervalCombinable a) => [Interval a] -> [Interval a]+gaps l = mapMaybe (uncurry (><)) ((zip <*> tail) l)++-- | Returns the 'duration' of each 'Interval' in the 'Functor' @f@.+durations :: (Functor f, IntervalSizeable a b) => f (Interval a) -> f b+durations = fmap duration

@@ -0,0 +1,48 @@+module IntervalAlgebra.IntervalUtilitiesSpec (spec) where++import IntervalAlgebra ( Interval, Intervallic(unsafeInterval) )+import IntervalAlgebra.IntervalUtilities ( combineIntervals, gaps, durations )+import Test.Hspec ( it, shouldBe, describe, Spec )++containmentInt :: Interval Int+containmentInt = unsafeInterval (0 :: Int) (10 :: Int)++noncontainmentInt :: Interval Int+noncontainmentInt = unsafeInterval (4 :: Int) (10 :: Int)++anotherInt :: Interval Int+anotherInt = unsafeInterval (15 :: Int) (20 :: Int)++gapInt :: Interval Int+gapInt = unsafeInterval (10 :: Int) (15 :: Int)++spec :: Spec+spec = do+   describe "combineIntervals unit tests" $+    do+      it "noncontainmentInt combined into containmentInt" $+         combineIntervals [containmentInt, noncontainmentInt] `shouldBe` [containmentInt]+      it "noncontainmentInt combined into containmentInt; anotherInt unchanged" $+         combineIntervals [containmentInt, noncontainmentInt, anotherInt] `shouldBe` [containmentInt, anotherInt]+      it "idempotency of containmentInt" $+         combineIntervals [containmentInt] `shouldBe` [containmentInt]+      it "idempotency of noncontainmentInt" $+         combineIntervals [noncontainmentInt] `shouldBe` [noncontainmentInt]+   +   describe "gaps unit tests" $+    do +      it "no gaps in containmentInt and noncontainmentInt" $+         gaps [containmentInt, noncontainmentInt] `shouldBe` []+      it "no gaps in containmentInt" $+         gaps [containmentInt] `shouldBe` []+      it "single gap between containmentInt and anotherInt" $+         gaps [containmentInt, anotherInt] `shouldBe` [gapInt]+  +   describe "durations unit tests" $+      do +         it "durations of containmentInt is 10" $+            durations [containmentInt] `shouldBe` [10]+         -- it "durations of empty list is empty list" $+         --    durations [] `shouldBe` []+         it "durations of [containmentInt, anotherInt] is [10, 5]" $+            durations [containmentInt, anotherInt] `shouldBe` [10, 5]

@@ -1,64 +1,50 @@ {-# LANGUAGE FlexibleInstances #-}-import Test.Hspec-import Test.Hspec.QuickCheck+{-# LANGUAGE TypeApplications #-}++module IntervalAlgebraSpec (spec) where++import Test.Hspec ( hspec, describe, it, Spec )+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    xor :: Bool -> Bool -> Bool xor a b = a /= b -instance Arbitrary IntervalInt where-  arbitrary = liftM2 safeInterval' arbitrary arbitrary--type IntervalInt = Interval Int--makePos :: Int -> Int-makePos x-  | x == 0    = x + 1-  | x <  0    = negate x-  | otherwise = x---- | A function for creating intervals when you think you know what you're doing.-safeInterval :: Int -> Int -> IntervalInt-safeInterval x y = unsafeInterval (min x y) (max x y)---- | Safely create a valid 'IntervalInt' from two Ints by adding 'makepos' @dur@---   to @start@ to set the duration of the interval.-safeInterval' :: Int -> Int -> IntervalInt-safeInterval' start dur = safeInterval start (start + makePos dur)---- | Create a 'Maybe IntervalInt' from two Ints.-safeInterval'' :: Int -> Int -> Maybe IntervalInt-safeInterval'' a b -    | b <= a    = Nothing-    | otherwise = Just $ safeInterval a b-- -- | A set used for testing M1 defined so that the M1 condition is true.-data M1set = M1set { -     m11 :: IntervalInt-   , m12 :: IntervalInt-   , m13 :: IntervalInt-   , m14 :: IntervalInt }+data M1set a = M1set {+     m11 :: Interval a+   , m12 :: Interval a+   , m13 :: Interval a+   , m14 :: Interval a }    deriving (Show) -instance Arbitrary M1set where+-- TODO: remove duplication like this:+instance Arbitrary (M1set Int) where   arbitrary = do     x <- arbitrary     a <- arbitrary     b <- arbitrary-    c <- arbitrary-    return $ m1set x a b c+    m1set x a b <$> arbitrary +instance Arbitrary (M1set DT.Day) where+  arbitrary = do+    x <- arbitrary+    a <- arbitrary+    b <- arbitrary+    m1set x a b <$> arbitrary+ -- | Smart constructor of 'M1set'.-m1set :: IntervalInt -> Int -> Int -> Int -> M1set+m1set :: (IntervalSizeable a b) => Interval a -> b -> b -> b -> M1set a m1set x a b c = M1set p1 p2 p3 p4   where p1 = x                          -- interval i in prop_IAaxiomM1         p2 = safeInterval' (end x) a    -- interval j in prop_IAaxiomM1         p3 = safeInterval' (end x) b    -- interval k in prop_IAaxiomM1-        p4 = safeInterval  (begin p2 - (makePos c)) (begin p2)+        p4 = safeInterval  (begin (expandl (makePos c) p2)) (begin p2)  {- @@ -72,32 +58,44 @@    \forall i,j,k,l s.t. (i:j & i:k & l:j) \implies l:k  \]  -}-prop_IAaxiomM1 :: M1set -> Property-prop_IAaxiomM1 x = +prop_IAaxiomM1 :: (IntervalAlgebraic a) => M1set a -> Property+prop_IAaxiomM1 x =   (i `meets` j && i `meets` k && l `meets` j) ==> (l `meets` k)   where i = m11 x         j = m12 x         k = m13 x         l = m14 x +prop_IAaxiomM1_Int :: M1set Int -> Property +prop_IAaxiomM1_Int = prop_IAaxiomM1++prop_IAaxiomM1_Day :: M1set DT.Day -> Property +prop_IAaxiomM1_Day = prop_IAaxiomM1+ -- | A set used for testing M2 defined so that the M2 condition is true.-data M2set = M2set {-    m21 :: IntervalInt-  , m22 :: IntervalInt-  , m23 :: IntervalInt-  , m24 :: IntervalInt }+data M2set a = M2set {+    m21 :: Interval a+  , m22 :: Interval a+  , m23 :: Interval a+  , m24 :: Interval a }   deriving (Show) -instance Arbitrary M2set where+instance Arbitrary (M2set Int) where   arbitrary = do     x <- arbitrary     a <- arbitrary     b <- arbitrary-    c <- arbitrary-    return $ m2set x a b c+    m2set x a b <$> arbitrary +instance Arbitrary (M2set DT.Day) where+  arbitrary = do+    x <- arbitrary+    a <- arbitrary+    b <- arbitrary+    m2set x a b <$> arbitrary+ -- | Smart constructor of 'M2set'.-m2set :: IntervalInt -> IntervalInt -> Int -> Int -> M2set+m2set :: (IntervalSizeable a b)=> Interval a -> Interval a -> b -> b -> M2set a m2set x y a b = M2set p1 p2 p3 p4   where p1 = x                          -- interval i in prop_IAaxiomM2         p2 = safeInterval' (end x) a     -- interval j in prop_IAaxiomM2@@ -124,19 +122,25 @@  \]  -} -prop_IAaxiomM2 :: M2set -> Property+prop_IAaxiomM2 :: (IntervalAlgebraic a) => M2set a -> Property prop_IAaxiomM2 x =-  (i `meets` j && k `meets` l) ==> -    (i `meets` l)  `xor`  -    (not $ isNothing m) `xor`-    (not $ isNothing n)+  (i `meets` j && k `meets` l) ==>+    (i `meets` l)  `xor`+    isJust m `xor`+    isJust 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 = safeInterval'' (end i) (begin l)+          n = safeInterval'' (end k) (begin j) +prop_IAaxiomM2_Int :: M2set Int -> Property+prop_IAaxiomM2_Int = prop_IAaxiomM2++prop_IAaxiomM2_Day :: M2set DT.Day -> Property+prop_IAaxiomM2_Day = prop_IAaxiomM2+ {-   ** Axiom ML1@@ -148,9 +152,15 @@  \]  -} -prop_IAaxiomML1 :: IntervalInt -> Property+prop_IAaxiomML1 :: (IntervalAlgebraic a) => Interval a -> Property prop_IAaxiomML1 x = not (x `meets` x) === True +prop_IAaxiomML1_Int :: Interval Int -> Property+prop_IAaxiomML1_Int = prop_IAaxiomML1++prop_IAaxiomML1_Day :: Interval DT.Day -> Property+prop_IAaxiomML1_Day = prop_IAaxiomML1+ {-  ** Axiom ML2@@ -162,13 +172,18 @@ \]  -} -prop_IAaxiomML2 :: M2set -> Property+prop_IAaxiomML2 :: (IntervalAlgebraic a)=> M2set a -> Property prop_IAaxiomML2 x =   (i `meets` j) ==> not (j `meets` i)   where i = m21 x         j = m22 x +prop_IAaxiomML2_Int :: M2set Int -> Property+prop_IAaxiomML2_Int = prop_IAaxiomML2 +prop_IAaxiomML2_Day :: M2set DT.Day -> Property+prop_IAaxiomML2_Day = prop_IAaxiomML2+ {-  ** Axiom M3@@ -180,12 +195,19 @@ \]  -} -prop_IAaxiomM3 :: IntervalInt -> Property-prop_IAaxiomM3 i = +prop_IAaxiomM3 :: (IntervalAlgebraic a, IntervalSizeable a b)=> +      b -> Interval a -> Property+prop_IAaxiomM3 b i =    (j `meets` i && i `meets` k) === True-   where j = safeInterval (begin i - 1) (begin i)-         k = safeInterval (end i) (end i + 1)+   where j = safeInterval (begin (expandl b i)) (begin i)+         k = safeInterval (end i) (end (expandr b i)) +prop_IAaxiomM3_Int :: Interval Int -> Property +prop_IAaxiomM3_Int = prop_IAaxiomM3 1++prop_IAaxiomM3_Day :: Interval Day -> Property +prop_IAaxiomM3_Day = prop_IAaxiomM3 1+ {-  ** Axiom M4@@ -197,17 +219,23 @@ \]  -} -prop_IAaxiomM4 :: M2set -> Property-prop_IAaxiomM4 x = +prop_IAaxiomM4 :: (IntervalAlgebraic a, IntervalSizeable a b)=>+     b -> M2set a -> Property+prop_IAaxiomM4 moment 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 i - 1) (begin i)-         n = safeInterval (end j) (end j + 1)+         m = safeInterval (begin (expandl moment i)) (begin i)+         n = safeInterval (end j) (end (expandr moment j))          k = safeInterval (end m) (begin n) +prop_IAaxiomM4_Int :: M2set Int -> Property +prop_IAaxiomM4_Int = prop_IAaxiomM4 1 +prop_IAaxiomM4_Day :: M2set DT.Day -> Property +prop_IAaxiomM4_Day = prop_IAaxiomM4 1+ {-  ** Axiom M5@@ -220,28 +248,33 @@ -}  -- | A set used for testing M5.-data M5set = M5set { -     m51 :: IntervalInt-   , m52 :: IntervalInt }+data M5set a = M5set {+     m51 :: Interval a+   , m52 :: Interval a }    deriving (Show) -instance Arbitrary M5set where+instance Arbitrary (M5set Int) where   arbitrary = do     x <- arbitrary     a <- arbitrary-    b <- arbitrary-    return $ m5set x a b+    m5set x a <$> arbitrary +instance Arbitrary (M5set DT.Day) where+  arbitrary = do+    x <- arbitrary+    a <- arbitrary+    m5set x a <$> arbitrary+ -- | Smart constructor of 'M5set'.-m5set :: IntervalInt -> Int -> Int -> M5set-m5set x a b = M5set p1 p2 +m5set :: (IntervalSizeable a b)=> Interval a -> b -> b -> M5set a+m5set x a b = M5set p1 p2   where p1 = x                     -- interval i in prop_IAaxiomM5         p2 = safeInterval' ps a    -- interval l in prop_IAaxiomM5-        ps = (makePos b) + (end x) -- creating l by shifting and expanding i+        ps = end (expandr (makePos b) x) -- creating l by shifting and expanding i  -prop_IAaxiomM5 :: M5set -> Property-prop_IAaxiomM5 x = +prop_IAaxiomM5 :: (IntervalAlgebraic a) => M5set a -> Property+prop_IAaxiomM5 x =    ((i `meets` j && j `meets` l) &&     (i `meets` k && k `meets` l))  === (j == k)    where i = m51 x@@ -249,6 +282,12 @@          k = safeInterval (end i) (begin l)          l = m52 x +prop_IAaxiomM5_Int :: M5set Int -> Property +prop_IAaxiomM5_Int = prop_IAaxiomM5++prop_IAaxiomM5_Day :: M5set DT.Day -> Property +prop_IAaxiomM5_Day = prop_IAaxiomM5+ {-  ** Axiom M4.1@@ -260,69 +299,78 @@ \]  -} -prop_IAaxiomM4_1 :: M2set -> Property-prop_IAaxiomM4_1 x = +prop_IAaxiomM4_1 :: (IntervalSizeable a b, IntervalCombinable 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 i - 1) (begin i)-         n = safeInterval (end j) (end j + 1)+         m = safeInterval (begin (expandl b i)) (begin i)+         n = safeInterval (end j) (end (expandr b j))          ij = fromJust $ i .+. j +prop_IAaxiomM4_1_Int :: M2set Int -> Property+prop_IAaxiomM4_1_Int = prop_IAaxiomM4_1 1 +prop_IAaxiomM4_1_Day :: M2set DT.Day -> Property+prop_IAaxiomM4_1_Day = prop_IAaxiomM4_1 1+ {- * Interval Relation property testing  -} -prop_IAbefore :: IntervalInt -> IntervalInt -> Property-prop_IAbefore i j = -  IA.before i j ==> (i `meets` k) && (k `meets` j)-    where k = safeInterval (end i) (begin j)+class (IntervalAlgebraic a, IntervalCombinable a)=> IntervalRelationProperties a 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) -prop_IAstarts:: IntervalInt -> IntervalInt -> Property-prop_IAstarts i j-  | ((IA.starts i j) == True) =-    let k = safeInterval (end i) (end j)-    in -     (j == (fromJust $ i .+. k)) === True-  | otherwise = IA.starts i j === False+    prop_IAstarts:: Interval a -> Interval a -> Property+    prop_IAstarts i j+      | IA.starts i j =+        let k = safeInterval (end i) (end j)+        in+        (j == (fromJust $ i .+. k)) === True+      | otherwise = IA.starts i j === False +    prop_IAfinishes:: Interval a -> Interval a -> Property+    prop_IAfinishes i j+      | IA.finishes i j =+        let k = safeInterval (begin j) (begin i)+        in+        (j == (fromJust $ k .+. i)) === True+      | otherwise = IA.finishes i j === False -prop_IAfinishes:: IntervalInt -> IntervalInt -> Property-prop_IAfinishes i j-  | ((IA.finishes i j) == True) =-    let k = safeInterval (begin j) (begin i)-    in -     (j == (fromJust $ k .+. i)) === True-  | otherwise = IA.finishes i j === False+    prop_IAoverlaps:: Interval a -> Interval a -> Property+    prop_IAoverlaps i j+      | IA.overlaps i j =+        let k = safeInterval (begin i) (begin j)+            l = safeInterval (begin j) (end i)+            m = safeInterval (end i)   (end j)+        in+        ((i == (fromJust $ k .+. l )) &&+          (j == (fromJust $ l .+. m ))) === True+      | otherwise  = IA.overlaps i j === False -prop_IAoverlaps:: IntervalInt -> IntervalInt -> Property-prop_IAoverlaps i j-  | ((IA.overlaps i j) == True) = -    let k = safeInterval (begin i) (begin j)-        l = safeInterval (begin j) (end i)-        m = safeInterval (end i)   (end j)-    in -     ((i == (fromJust $ k .+. l )) &&-      (j == (fromJust $ l .+. m ))) === True-  | otherwise  = IA.overlaps i j === False +    prop_IAduring:: Interval a -> Interval a-> Property+    prop_IAduring i j+      | IA.during i j =+        let k = safeInterval (begin j) (begin i)+            l = safeInterval (end i) (end j)+        in+        (j == (fromJust $ (fromJust $ k .+. i) .+. l)) === True+      | otherwise  = IA.during i j === False -prop_IAduring:: IntervalInt -> IntervalInt -> Property-prop_IAduring i j-  | ((IA.during i j) == True) = -    let k = safeInterval (begin j) (begin i)-        l = safeInterval (end i) (end j)-    in -     (j == (fromJust $ (fromJust $ k .+. i) .+. l)) === True-  | otherwise  = IA.during i j === False +    -- | 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 -{--For any two pair of intervals exactly one 'IntervalRelation' should hold.--}+instance IntervalRelationProperties Int -allIArelations:: [(ComparativePredicateOf (IntervalInt))]+allIArelations:: IntervalAlgebraic a => [ComparativePredicateOf (Interval a)] allIArelations =   [  IA.equals                     , IA.meets                     , IA.metBy@@ -337,42 +385,48 @@                     , IA.during                     , IA.contains ] -prop_exclusiveRelations::  IntervalInt -> IntervalInt -> Property -prop_exclusiveRelations x y =-  (  1 == length (filter id $ map (\r -> r x y) allIArelations)) === True -main :: IO ()-main = hspec $ do-  describe "Interval Algebra Axioms for meets property" $ -  --modifyMaxDiscardRatio (* 10) $-    do -      it "M1" $ property prop_IAaxiomM1    -      it "M2" $ property prop_IAaxiomM2-      it "ML1" $ property prop_IAaxiomML1-      it "ML2" $ property prop_IAaxiomML2++spec :: Spec+spec = do+  describe "Interval Algebra Axioms for meets property" $+    modifyMaxSuccess (*10) $+    do+      it "M1 Int" $ property prop_IAaxiomM1_Int+      it "M1 Day" $ property prop_IAaxiomM1_Day+      it "M2_Int" $ property prop_IAaxiomM2_Int+      it "M2_Day" $ property prop_IAaxiomM2_Day+      it "ML1_Int" $ property prop_IAaxiomML1_Int+      it "ML1_Day" $ property prop_IAaxiomML1_Day+      it "ML2_Int" $ property prop_IAaxiomML2_Int+      it "ML2_Day" $ property prop_IAaxiomML2_Day       {-         ML3 says that For all i, there does not exist m such that i meets m and         m meet i. Not testing that this axiom holds, as I'm not sure how I would         test the lack of existence.       -}       --it "ML3" $ property prop_IAaxiomML3-      it "M3" $ property prop_IAaxiomM3-      it "M4" $ property prop_IAaxiomM4-      it "M5" $ property prop_IAaxiomM5 -      it "M4.1" $ property prop_IAaxiomM4_1- +      it "M3_Int" $ property prop_IAaxiomM3_Int+      it "M3_Day" $ property prop_IAaxiomM3_Day+      it "M4_Int" $ property prop_IAaxiomM4_Int+      it "M4_Day" $ property prop_IAaxiomM4_Day+      it "M5_Int" $ property prop_IAaxiomM5_Int+      it "M5_Day" $ property prop_IAaxiomM5_Day+      it "M4.1_Int" $ property prop_IAaxiomM4_1_Int+      it "M4.1_Day" $ property prop_IAaxiomM4_1_Day -  describe "Interval Algebra relation properties" $ ++  describe "Interval Algebra relation properties" $       modifyMaxSuccess (*10) $     do-      it "before"   $ property prop_IAbefore-      it "starts"   $ property prop_IAstarts-      it "finishes" $ property prop_IAfinishes-      it "overlaps" $ property prop_IAoverlaps-      it "during"   $ property prop_IAduring+      it "before"   $ property (prop_IAbefore @Int)+      it "starts"   $ property (prop_IAstarts @Int)+      it "finishes" $ property (prop_IAfinishes @Int)+      it "overlaps" $ property (prop_IAoverlaps @Int)+      it "during"   $ property (prop_IAduring @Int) -  describe "Interval Algebra relation uniqueness" $ +  describe "Interval Algebra relation uniqueness" $       modifyMaxSuccess (*100) $     do-      it "exactly one relation must be true" $ property prop_exclusiveRelations+      it "exactly one relation must be true" $ property (prop_exclusiveRelations @Int) 

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}