data-interval 1.2.0 → 1.3.0

raw patch · 15 files changed

+3234/−131 lines, 15 filesdep +ChasingBottomsdep +semigroupsdep +sybdep −test-frameworkdep −test-framework-hunitdep −test-framework-quickcheck2dep ~hashabledep ~latticesPVP ok

version bump matches the API change (PVP)

Dependencies added: ChasingBottoms, semigroups, syb, tasty, tasty-hunit, tasty-quickcheck, tasty-th, transformers

Dependencies removed: test-framework, test-framework-hunit, test-framework-quickcheck2, test-framework-th

Dependency ranges changed: hashable, lattices

API changes (from Hackage documentation)

Files

• .travis.yml +0/−56
• CHANGELOG.markdown +6/−0
• README.md +2/−2
• data-interval.cabal +40/−20
• src/Data/IntegerInterval.hs +43/−18
• src/Data/Interval.hs +77/−18
• src/Data/IntervalMap/Base.hs +562/−0
• src/Data/IntervalMap/Lazy.hs +120/−0
• src/Data/IntervalMap/Strict.hs +251/−0
• src/Data/IntervalSet.hs +422/−0
• test/TestIntegerInterval.hs +157/−9
• test/TestInterval.hs +181/−8
• test/TestIntervalMap.hs +842/−0
• test/TestIntervalSet.hs +516/−0
• test/TestSuite.hs +15/−0

@@ -1,56 +0,0 @@-# NB: don't set `language: haskell` here--# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.-env:-# - GHCVER=6.12.3-# - GHCVER=7.0.1-# - GHCVER=7.0.2-# - GHCVER=7.0.3-# - GHCVER=7.0.4-# - GHCVER=7.2.1-# - GHCVER=7.2.2-# - GHCVER=7.4.1-# - GHCVER=7.4.2-# - GHCVER=7.6.1-# - GHCVER=7.6.2- - GHCVER=7.6.3-# - GHCVER=7.8.1 # see note about Alex/Happy-# - GHCVER=7.8.2 # see note about Alex/Happy- - GHCVER=7.8.3 # see note about Alex/Happy-# - GHCVER=head  # see section about GHC HEAD snapshots--# Note: the distinction between `before_install` and `install` is not important.-before_install:- - travis_retry sudo add-apt-repository -y ppa:hvr/ghc- - travis_retry sudo apt-get update- - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER # see note about happy/alex- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH- - |-   if [ $GHCVER = "head" ] || [ ${GHCVER%.*} = "7.8" ]; then-     travis_retry sudo apt-get install happy-1.19.3 alex-3.1.3-     export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.3/bin:$PATH-   else-     travis_retry sudo apt-get install happy alex-   fi--install:- - cabal update- - cabal install --only-dependencies --enable-tests -v2  # -v2 provides useful information for debugging--# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.-script:- - cabal configure --enable-tests -v2  # -v2 provides useful information for debugging- - cabal build   # this builds all libraries and executables (including tests/benchmarks)- - cabal test- - cabal check- - cabal sdist   # tests that a source-distribution can be generated--# The following scriptlet checks that the resulting source distribution can be built & installed- - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ;-   cd dist/;-   if [ -f "$SRC_TGZ" ]; then-      cabal install "$SRC_TGZ";-   else-      echo "expected '$SRC_TGZ' not found";-      exit 1;-   fi

@@ -1,3 +1,9 @@+1.3.0+-----+* add `Data.IntervalSet`, `Data.IntervalMap.Lazy`, `Data.IntervalMap.Strict` modules+* add new function `mapMonotonic` to `Data.Interval` and `Data.IntegerInterval`+* add new function `isConnected` to `Data.Interval`.+ 1.2.0 ----- * add `Data.IntegerInterval`

@@ -1,9 +1,9 @@ data-interval ============= -[![Build Status](https://secure.travis-ci.org/msakai/data-interval.png?branch=master)](http://travis-ci.org/msakai/data-interval) [![Hackage](https://budueba.com/hackage/data-interval)](https://hackage.haskell.org/package/data-interval)+[![Build Status](https://secure.travis-ci.org/msakai/data-interval.png?branch=master)](http://travis-ci.org/msakai/data-interval) [![Hackage](https://img.shields.io/hackage/v/data-interval.svg)](https://hackage.haskell.org/package/data-interval) [![Coverage Status](https://coveralls.io/repos/msakai/data-interval/badge.svg)](https://coveralls.io/r/msakai/data-interval) -Interval datatype and interval arithmetic for Haskell.+Interval datatype, interval arithmetic, and interval-based containers for Haskell.  Unlike the [intervals package](<http://hackage.haskell.org/package/intervals>), this package provides both open and closed intervals and is intended to be used

@@ -1,14 +1,14 @@ Name:		data-interval-Version:	1.2.0+Version:	1.3.0 License:	BSD3 License-File:	COPYING Author:		Masahiro Sakai (masahiro.sakai@gmail.com) Maintainer:	masahiro.sakai@gmail.com Category:	Data, Math Cabal-Version:	>= 1.10-Synopsis:	Interval arithmetic for both open and closed intervals+Synopsis:	Interval datatype, interval arithmetic and interval-based containers Description:-   Interval datatype and interval arithmetic for Haskell.+   Interval datatype, interval arithmetic and interval-based containers for Haskell.    Unlike the intervals package (<http://hackage.haskell.org/package/intervals>),    this package provides both open and closed intervals and is intended to be used    with exact number types such as Rational and Integer.@@ -17,7 +17,6 @@    README.md    COPYING    CHANGELOG.markdown-   .travis.yml Build-Type: Simple  source-repository head@@ -27,33 +26,54 @@ Library   Hs-source-dirs: src   Build-Depends:-     base >=4 && <5, lattices >=1.2.1.1, deepseq, hashable >=1.1.2.5 && <1.3, extended-reals >=0.2 && <1.0+       base >=4 && <5+     , containers+     , lattices >=1.2.1.1+     , deepseq+     , hashable >=1.1.2.5 && <1.3+     , extended-reals >=0.2 && <1.0+  if impl(ghc <8.0)+    Build-depends:+      semigroups   Default-Language: Haskell2010   Other-Extensions:+     CPP      ScopedTypeVariables+     TypeFamilies      DeriveDataTypeable   Exposed-Modules:      Data.Interval+     Data.IntervalMap.Lazy+     Data.IntervalMap.Strict+     Data.IntervalSet      Data.IntegerInterval--Test-suite TestInterval-  Type:              exitcode-stdio-1.0-  HS-Source-Dirs:    test-  Main-is:           TestInterval.hs-  Build-depends:     base >=4 && <5, containers, data-interval, test-framework, test-framework-th, test-framework-hunit, test-framework-quickcheck2 >=0.2.12.3, HUnit, QuickCheck >=2.5 && <3-  Default-Language: Haskell2010-  Other-Extensions:-     TemplateHaskell-     ScopedTypeVariables+  Other-Modules:+     Data.IntervalMap.Base -Test-suite TestIntegerInterval+Test-suite test-interval   Type:              exitcode-stdio-1.0   HS-Source-Dirs:    test-  Main-is:           TestIntegerInterval.hs-  Build-depends:     base >=4 && <5, containers, data-interval, test-framework, test-framework-th, test-framework-hunit, test-framework-quickcheck2 >=0.2.12.3, HUnit, QuickCheck >=2.5 && <3+  Main-is:           TestSuite.hs+  Other-Modules:     TestInterval, TestIntervalMap, TestIntervalSet, TestIntegerInterval+  Build-depends:+       base >=4 && <5+     , ChasingBottoms+     , containers+     , lattices+     , deepseq+     , hashable+     , data-interval+     , syb+     , tasty >=0.10.1+     , tasty-hunit ==0.9.*+     , tasty-quickcheck ==0.8.*+     , tasty-th+     , HUnit+     , QuickCheck >=2.5 && <3+  if impl(ghc <7.10)+    Build-depends:+      transformers >=0.2   Default-Language: Haskell2010   Other-Extensions:      TemplateHaskell      ScopedTypeVariables--

@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.IntegerInterval@@ -62,6 +63,9 @@   , hull   , hulls +  -- * Map+  , mapMonotonic+   -- * Operations   , pickup   , simplestIntegerWithin@@ -168,11 +172,11 @@  instance Show IntegerInterval where   showsPrec _ x | null x = showString "empty"-  showsPrec p x = showParen (p > appPrec) $-    showString "interval " .-    showsPrec (appPrec+1) (lowerBound' x) .-    showChar ' ' .-    showsPrec (appPrec+1) (upperBound' x)+  showsPrec p x =+    showParen (p > rangeOpPrec) $+      showsPrec (rangeOpPrec+1) (lowerBound x) . +      showString " <=..<= " .+      showsPrec (rangeOpPrec+1) (upperBound x)  instance Read IntegerInterval where   readsPrec p r =@@ -182,19 +186,33 @@       (ub,s3) <- readsPrec (appPrec+1) s2       return (interval lb ub, s3)) r     +++    (readParen (p > rangeOpPrec) $ \s0 -> do+      (do (lb,s1) <- readsPrec (rangeOpPrec+1) s0+          ("<=..<=",s2) <- lex s1+          (ub,s3) <- readsPrec (rangeOpPrec+1) s2+          return (lb <=..<= ub, s3))) r+    ++     (do ("empty", s) <- lex r         return (empty, s))  -- This instance preserves data abstraction at the cost of inefficiency.--- We omit reflection services for the sake of data abstraction.+-- We provide limited reflection services for the sake of data abstraction.  instance Data IntegerInterval where   gfoldl k z x   = z (<=..<=) `k` lowerBound x `k` upperBound x-  toConstr _     = error "toConstr"-  gunfold _ _    = error "gunfold"-  dataTypeOf _   = mkNoRepType "Data.IntegerInterval"+  toConstr _     = intervalConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (k (z (<=..<=)))+    _ -> error "gunfold"+  dataTypeOf _   = intervalDataType --- | smart constructor for 'Interval'+intervalConstr :: Constr+intervalConstr = mkConstr intervalDataType "<=..<=" [] Infix++intervalDataType :: DataType+intervalDataType = mkDataType "Data.IntegerInterval.IntegerInterval" [intervalConstr]++-- | smart constructor for 'IntegerInterval' interval   :: (Extended Integer, Bool) -- ^ lower bound and whether it is included   -> (Extended Integer, Bool) -- ^ upper bound and whether it is included@@ -252,7 +270,7 @@  -- | intersection of a list of intervals. intersections :: [IntegerInterval] -> IntegerInterval-intersections xs = foldl' intersection whole xs+intersections = foldl' intersection whole  -- | convex hull of two intervals hull :: IntegerInterval -> IntegerInterval -> IntegerInterval@@ -263,8 +281,12 @@  -- | convex hull of a list of intervals. hulls :: [IntegerInterval] -> IntegerInterval-hulls xs = foldl' hull empty xs+hulls = foldl' hull empty +-- | @mapMonotonic f i@ is the image of @i@ under @f@, where @f@ must be a strict monotone function.+mapMonotonic :: (Integer -> Integer) -> IntegerInterval -> IntegerInterval+mapMonotonic f (Interval l u) = Interval (fmap f l) (fmap f u)+ -- | Is the interval empty? null :: IntegerInterval -> Bool null (Interval l u) = u < l@@ -306,15 +328,15 @@ -- -- An integer @y@ is said to be /simpler/ than another @y'@ if ----- * @'abs' y <= 'abs' y@, and+-- * @'abs' y <= 'abs' y'@ ----- (see also 'approxRational')+-- (see also 'approxRational' and 'Interval.simplestRationalWithin') simplestIntegerWithin :: IntegerInterval -> Maybe Integer simplestIntegerWithin i   | null i    = Nothing   | 0 <! i    = Just $ let Finite x = lowerBound i in x   | i <! 0    = Just $ let Finite x = upperBound i in x-  | otherwise = assert (0 `member` i) $ Just $ 0+  | otherwise = assert (0 `member` i) $ Just 0  -- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@? (<!) :: IntegerInterval -> IntegerInterval -> Bool@@ -368,7 +390,7 @@  -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@? (<=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)-a <=?? b = do+a <=?? b =   case pickup (intersection a b) of     Just x -> return (x,x)     Nothing -> do@@ -425,6 +447,9 @@ appPrec :: Int appPrec = 10 +rangeOpPrec :: Int+rangeOpPrec = 5+ scaleInterval :: Integer -> IntegerInterval -> IntegerInterval scaleInterval _ x | null x = empty scaleInterval c (Interval lb ub) =@@ -437,11 +462,11 @@   a + b | null a || null b = empty   Interval lb1 ub1 + Interval lb2 ub2 = lb1 + lb2 <=..<= ub1 + ub2 -  negate a = scaleInterval (-1) a+  negate = scaleInterval (-1)    fromInteger i = singleton (fromInteger i) -  abs x = ((x `intersection` nonneg) `hull` (negate x `intersection` nonneg))+  abs x = (x `intersection` nonneg) `hull` (negate x `intersection` nonneg)     where       nonneg = 0 <=..< inf 

@@ -1,5 +1,9 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE Safe #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.Interval@@ -8,7 +12,7 @@ -- -- Maintainer  :  masahiro.sakai@gmail.com -- Stability   :  provisional--- Portability :  non-portable (ScopedTypeVariables, DeriveDataTypeable)+-- Portability :  non-portable (CPP, ScopedTypeVariables, DeriveDataTypeable) -- -- Interval datatype and interval arithmetic. --@@ -44,6 +48,7 @@   , notMember   , isSubsetOf   , isProperSubsetOf+  , isConnected   , lowerBound   , upperBound   , lowerBound'@@ -65,6 +70,9 @@   , hull   , hulls +  -- * Map+  , mapMonotonic+   -- * Operations   , pickup   , simplestRationalWithin@@ -110,6 +118,10 @@ data Interval r = Interval !(Extended r, Bool) !(Extended r, Bool)   deriving (Eq, Typeable) +#if __GLASGOW_HASKELL__ >= 708+type role Interval nominal+#endif+ -- | Lower endpoint (/i.e./ greatest lower bound)  of the interval. -- -- * 'lowerBound' of the empty interval is 'PosInf'.@@ -164,11 +176,13 @@  instance (Ord r, Show r) => Show (Interval r) where   showsPrec _ x | null x = showString "empty"-  showsPrec p x = showParen (p > appPrec) $-    showString "interval " .-    showsPrec (appPrec+1) (lowerBound' x) .-    showChar ' ' .-    showsPrec (appPrec+1) (upperBound' x)+  showsPrec p (Interval (lb,in1) (ub,in2)) =+    showParen (p > rangeOpPrec) $+      showsPrec (rangeOpPrec+1) lb . +      showChar ' ' . showString op . showChar ' ' .+      showsPrec (rangeOpPrec+1) ub+    where+      op = (if in1 then "<=" else "<") ++ ".." ++ (if in2 then "<=" else "<")  instance (Ord r, Read r) => Read (Interval r) where   readsPrec p r =@@ -178,19 +192,40 @@       (ub,s3) <- readsPrec (appPrec+1) s2       return (interval lb ub, s3)) r     +++    (readParen (p > rangeOpPrec) $ \s0 -> do+      (do (l,s1) <- readsPrec (rangeOpPrec+1) s0+          (op',s2) <- lex s1+          op <-+            case op' of+              "<=..<=" -> return (<=..<=)+              "<..<="  -> return (<..<=)+              "<=..<"  -> return (<=..<)+              "<..<"   -> return (<..<)+              _ -> []+          (u,s3) <- readsPrec (rangeOpPrec+1) s2+          return (op l u, s3))) r+    ++     (do ("empty", s) <- lex r         return (empty, s))  -- This instance preserves data abstraction at the cost of inefficiency.--- We omit reflection services for the sake of data abstraction.+-- We provide limited reflection services for the sake of data abstraction.  instance (Ord r, Data r) => Data (Interval r) where   gfoldl k z x   = z interval `k` lowerBound' x `k` upperBound' x-  toConstr _     = error "toConstr"-  gunfold _ _    = error "gunfold"-  dataTypeOf _   = mkNoRepType "Data.Interval.Interval"+  toConstr _     = intervalConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (k (z interval))+    _ -> error "gunfold"+  dataTypeOf _   = intervalDataType   dataCast1 f    = gcast1 f +intervalConstr :: Constr+intervalConstr = mkConstr intervalDataType "interval" [] Prefix++intervalDataType :: DataType+intervalDataType = mkDataType "Data.Interval.Interval" [intervalConstr]+ -- | smart constructor for 'Interval' interval   :: (Ord r)@@ -275,7 +310,7 @@ -- -- Since 0.6.0 intersections :: Ord r => [Interval r] -> Interval r-intersections xs = foldl' intersection whole xs+intersections = foldl' intersection whole  -- | convex hull of two intervals hull :: forall r. Ord r => Interval r -> Interval r -> Interval r@@ -305,7 +340,7 @@ -- -- Since 0.6.0 hulls :: Ord r => [Interval r] -> Interval r-hulls xs = foldl' hull empty xs+hulls = foldl' hull empty  -- | Is the interval empty? null :: Ord r => Interval r -> Bool@@ -350,6 +385,20 @@ isProperSubsetOf :: Ord r => Interval r -> Interval r -> Bool isProperSubsetOf i1 i2 = i1 /= i2 && i1 `isSubsetOf` i2 +-- | Does the union of two range form a connected set?+--+-- Since 1.3.0+isConnected :: Ord r => Interval r -> Interval r -> Bool+isConnected x y+  | null x = True+  | null y = True+  | otherwise = x ==? y || (lb1==ub2 && (lb1in || ub2in)) || (ub1==lb2 && (ub1in || lb2in))+  where+    (lb1,lb1in) = lowerBound' x+    (lb2,lb2in) = lowerBound' y+    (ub1,ub1in) = upperBound' x+    (ub2,ub2in) = upperBound' y+ -- | Width of a interval. Width of an unbounded interval is @undefined@. width :: (Num r, Ord r) => Interval r -> r width x | null x = 0@@ -384,7 +433,7 @@ simplestRationalWithin i   | 0 <! i    = Just $ go i   | i <! 0    = Just $ - go (- i)-  | otherwise = assert (0 `member` i) $ Just $ 0+  | otherwise = assert (0 `member` i) $ Just 0   where     go i       | fromInteger lb_floor       `member` i = fromInteger lb_floor@@ -394,6 +443,13 @@         Finite lb = lowerBound i         lb_floor  = floor lb +-- | @mapMonotonic f i@ is the image of @i@ under @f@, where @f@ must be a strict monotone function.+mapMonotonic :: (Ord a, Ord b) => (a -> b) -> Interval a -> Interval b+mapMonotonic f i = interval (fmap f lb, in1) (fmap f ub, in2)+  where+    (lb, in1) = lowerBound' i+    (ub, in2) = upperBound' i+ -- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@? (<!) :: Ord r => Interval r -> Interval r -> Bool a <! b =@@ -476,7 +532,7 @@ -- -- Since 1.0.0 (<=??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r)-a <=?? b = do+a <=?? b =   case pickup (intersection a b) of     Just x -> return (x,x)     Nothing -> do@@ -545,6 +601,9 @@ appPrec :: Int appPrec = 10 +rangeOpPrec :: Int+rangeOpPrec = 5+ scaleInterval :: (Num r, Ord r) => r -> Interval r -> Interval r scaleInterval _ x | null x = empty scaleInterval c (Interval lb ub) =@@ -567,11 +626,11 @@       g _ (PosInf,_) = (inf, False)       g _ _ = error "Interval.(+) should not happen" -  negate a = scaleInterval (-1) a+  negate = scaleInterval (-1)    fromInteger i = singleton (fromInteger i) -  abs x = ((x `intersection` nonneg) `hull` (negate x `intersection` nonneg))+  abs x = (x `intersection` nonneg) `hull` (negate x `intersection` nonneg)     where       nonneg = 0 <=..< inf @@ -604,7 +663,7 @@  cmpUB, cmpLB :: Ord r => (Extended r, Bool) -> (Extended r, Bool) -> Ordering cmpUB (x1,in1) (x2,in2) = compare x1 x2 `mappend` compare in1 in2-cmpLB (x1,in1) (x2,in2) = compare x1 x2 `mappend` flip compare in1 in2+cmpLB (x1,in1) (x2,in2) = compare x1 x2 `mappend` compare in2 in1  {-# DEPRECATED EndPoint "EndPoint is deprecated. Please use Extended instead." #-} -- | Endpoints of intervals

@@ -0,0 +1,562 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies, DeriveDataTypeable, MultiWayIf, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Trustworthy #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IntervalMap.Base+-- Copyright   :  (c) Masahiro Sakai 2016+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable (CPP, ScopedTypeVariables, TypeFamilies, DeriveDataTypeable, MultiWayIf, GeneralizedNewtypeDeriving)+--+-- Interval datatype and interval arithmetic.+--+-----------------------------------------------------------------------------+module Data.IntervalMap.Base+  (+  -- * IntervalMap type+    IntervalMap (..)+  , module Data.ExtendedReal+  , EndPoint++  -- * Operators+  , (!)+  , (\\)++  -- * Query+  , null+  , member+  , notMember+  , lookup+  , findWithDefault+  , span++  -- * Construction+  , whole+  , empty+  , singleton++  -- ** Insertion+  , insert+  , insertWith++  -- ** Delete\/Update+  , delete+  , adjust+  , update+  , alter++  -- * Combine+  , union+  , unionWith+  , unions+  , unionsWith+  , intersection+  , intersectionWith+  , difference++  -- * Traversal+  , map+  , mapKeysMonotonic++  -- * Conversion+  , elems+  , keys+  , assocs+  , keysSet++  -- ** List+  , fromList+  , fromListWith+  , toList++  -- ** Ordered List+  , toAscList+  , toDescList++  -- * Filter+  , filter+  , split++  -- * Submap+  , isSubmapOf+  , isSubmapOfBy+  , isProperSubmapOf+  , isProperSubmapOfBy+  )+  where++import Prelude hiding (null, lookup, map, filter, span)+import Control.Applicative hiding (empty)+import Control.DeepSeq+import Control.Monad+import Data.Data+import Data.Foldable hiding (null, foldl', and, toList)+import Data.ExtendedReal+import Data.Hashable+import Data.List (foldl')+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Semigroup (Semigroup)+import qualified Data.Semigroup as Semigroup+import Data.Traversable+import Data.Interval (Interval, EndPoint)+import qualified Data.Interval as Interval+import Data.IntervalSet (IntervalSet)+import qualified Data.IntervalSet as IntervalSet+#if __GLASGOW_HASKELL__ >= 708+import qualified GHC.Exts as GHCExts+#endif++-- ------------------------------------------------------------------------+-- The IntervalMap type++-- | A Map from non-empty, disjoint intervals over k to values a.+--+-- Unlike 'IntervalSet', 'IntervalMap' never merge adjacent mappings,+-- even if adjacent intervals are connected and mapped to the same value.+newtype IntervalMap r a = IntervalMap (Map (LB r) (Interval r, a))+  deriving (Eq, Typeable)++#if __GLASGOW_HASKELL__ >= 708+type role IntervalMap nominal representational+#endif++instance (Ord k, Show k, Show a) => Show (IntervalMap k a) where+  showsPrec p (IntervalMap m) = showParen (p > appPrec) $+    showString "fromList " .+    showsPrec (appPrec+1) (Map.elems m)++instance (Ord k, Read k, Read a) => Read (IntervalMap k a) where+  readsPrec p =+    (readParen (p > appPrec) $ \s0 -> do+      ("fromList",s1) <- lex s0+      (xs,s2) <- readsPrec (appPrec+1) s1+      return (fromList xs, s2))++appPrec :: Int+appPrec = 10++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance (Data k, Data a, Ord k) => Data (IntervalMap k a) where+  gfoldl k z x   = z fromList `k` toList x+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = mapDataType+  dataCast1 f    = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr mapDataType "fromList" [] Prefix++mapDataType :: DataType+mapDataType = mkDataType "Data.IntervalMap.Base.IntervalMap" [fromListConstr]++instance (NFData k, NFData a) => NFData (IntervalMap k a) where+  rnf (IntervalMap m) = rnf m++instance (Hashable k, Hashable a) => Hashable (IntervalMap k a) where+  hashWithSalt s m = hashWithSalt s (toList m)++instance Ord k => Monoid (IntervalMap k a) where+  mempty = empty+  mappend = union+  mconcat = unions++instance Ord k => Semigroup (IntervalMap k a) where+  (<>)   = union+#if !defined(VERSION_semigroups)+  stimes = Semigroup.stimesIdempotentMonoid+#else+#if MIN_VERSION_semigroups(0,17,0)+  stimes = Semigroup.stimesIdempotentMonoid+#else+  times1p _ a = a+#endif+#endif++#if __GLASGOW_HASKELL__ >= 708+instance Ord k => GHCExts.IsList (IntervalMap k a) where+  type Item (IntervalMap k a) = (Interval k, a)+  fromList = fromList+  toList = toList+#endif++-- ------------------------------------------------------------------------++newtype LB r = LB (Extended r, Bool)+  deriving (Eq, NFData, Typeable)++instance Ord r => Ord (LB r) where+  compare (LB (lb1, lb1in)) (LB (lb2, lb2in)) =+    -- inclusive lower endpoint shuold be considered smaller+    (lb1 `compare` lb2) `mappend` (lb2in `compare` lb1in)++-- ------------------------------------------------------------------------+-- Operators++infixl 9 !,\\ --++-- | Find the value at a key. Calls 'error' when the element can not be found.+(!) :: Ord k => IntervalMap k a -> k -> a+IntervalMap m ! k =+  case Map.lookupLE (LB (Finite k, True)) m of+    Just (_, (i, a)) | k `Interval.member` i -> a+    _ -> error "IntervalMap.!: given key is not an element in the map"++-- | Same as 'difference'.+(\\) :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a+m1 \\ m2 = difference m1 m2++-- ------------------------------------------------------------------------+-- Query++-- | Is the map empty?+null :: Ord k => IntervalMap k a -> Bool+null (IntervalMap m) = Map.null m++-- | Is the key a member of the map? See also 'notMember'.+member :: Ord k => k -> IntervalMap k a -> Bool+member k (IntervalMap m) =+  case Map.lookupLE (LB (Finite k, True)) m of+    Just (_, (i, _)) -> k `Interval.member` i+    Nothing -> False++-- | Is the key not a member of the map? See also 'member'.+notMember :: Ord k => k -> IntervalMap k a -> Bool+notMember k m = not $ member k m++-- | Lookup the value at a key in the map.+--+-- The function will return the corresponding value as @('Just' value)@,+-- or 'Nothing' if the key isn't in the map.+lookup :: Ord k => k -> IntervalMap k a -> Maybe a+lookup k (IntervalMap m) =+  case Map.lookupLE (LB (Finite k, True)) m of+    Just (_, (i, a)) | k `Interval.member` i -> Just a+    _ -> Nothing++-- | The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+findWithDefault :: Ord k => a -> k -> IntervalMap k a -> a+findWithDefault def k (IntervalMap m) =+  case Map.lookupLE (LB (Finite k, True)) m of+    Just (_, (i, a)) | k `Interval.member` i -> a+    _ -> def++lookupInterval :: Ord k => Interval k -> IntervalMap k a -> Maybe a+lookupInterval i (IntervalMap m) =+  case Map.lookupLE (LB (Interval.lowerBound' i)) m of+    Just (_, (j, a)) | i `Interval.isSubsetOf` j -> Just a+    _ -> Nothing++-- | convex hull of key intervals.+span :: Ord k => IntervalMap k a -> Interval k+span = IntervalSet.span . keysSet++-- ------------------------------------------------------------------------+-- Construction++-- | The empty map.+empty :: Ord k => IntervalMap k a+empty = IntervalMap Map.empty++-- | The map that maps whole range of k to a.+whole :: Ord k => a -> IntervalMap k a+whole a = IntervalMap $ Map.singleton (LB (Interval.lowerBound' i)) (i, a)+  where+    i = Interval.whole++-- | A map with a single interval.+singleton :: Ord k => Interval k -> a -> IntervalMap k a+singleton i a+  | Interval.null i = empty+  | otherwise = IntervalMap $ Map.singleton (LB (Interval.lowerBound' i)) (i, a)++-- ------------------------------------------------------------------------+-- Insertion++-- | insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value.+insert :: Ord k => Interval k -> a -> IntervalMap k a -> IntervalMap k a+insert i _ m | Interval.null i = m+insert i a m =+  case split i m of+    (IntervalMap m1, _, IntervalMap m2) ->+      IntervalMap $ Map.union m1 (Map.insert (LB (Interval.lowerBound' i)) (i,a) m2)+++-- | Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@ will insert the pair (interval, value) into @mp@.+-- If the interval overlaps with existing entries, the value for the entry is replace+-- with @(f new_value old_value)@.+insertWith :: Ord k => (a -> a -> a) -> Interval k -> a -> IntervalMap k a -> IntervalMap k a+insertWith _ i _ m | Interval.null i = m+insertWith f i a m = alter g i m+  where+    g Nothing = Just a+    g (Just a') = Just $ f a a'++-- ------------------------------------------------------------------------+-- Delete/Update++-- | Delete an interval and its value from the map. +-- When the interval does not overlap with the map, the original map is returned.+delete :: Ord k => Interval k -> IntervalMap k a -> IntervalMap k a+delete i m | Interval.null i = m+delete i m =+  case split i m of+    (IntervalMap m1, _, IntervalMap m2) ->+      IntervalMap $ Map.union m1 m2++-- | Update a value at a specific interval with the result of the provided function.+-- When the interval does not overlatp with the map, the original map is returned.+adjust :: Ord k => (a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a+adjust f = update (Just . f)  ++-- | The expression (@'update' f i map@) updates the value @x@+-- at @i@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @i@ is bound to the new value @y@.+update :: Ord k => (a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a+update _ i m | Interval.null i = m+update f i m =+  case split i m of+    (IntervalMap m1, IntervalMap m2, IntervalMap m3) ->+      IntervalMap $ Map.unions [m1, Map.mapMaybe (\(i,a) -> (\b -> (i,b)) <$> f a) m2, m3]++-- | The expression (@'alter' f i map@) alters the value @x@ at @i@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'IntervalMap'.+alter :: Ord k => (Maybe a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a+alter _ i m | Interval.null i = m+alter f i m =+  case split i m of+    (IntervalMap m1, IntervalMap m2, IntervalMap m3) ->+      let m2' = Map.mapMaybe (\(j,a) -> (\b -> (j,b)) <$> f (Just a)) m2+          js = IntervalSet.singleton i `IntervalSet.difference` keysSet (IntervalMap m2)+          IntervalMap m2'' =+            case f Nothing of+              Nothing -> empty+              Just a -> fromList [(j,a) | j <- IntervalSet.toList js]+      in IntervalMap $ Map.unions [m1, m2', m2'', m3]++-- ------------------------------------------------------------------------+-- Combine++-- | The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.+-- It prefers @t1@ when overlapping keys are encountered,+union :: Ord k => IntervalMap k a -> IntervalMap k a -> IntervalMap k a+union m1 m2 = +  foldl' (\m (i,a) -> insert i a m) m2 (toList m1)++-- | Union with a combining function.+unionWith :: Ord k => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a+unionWith f m1 m2 = +  foldl' (\m (i,a) -> insertWith f i a m) m2 (toList m1)++-- | The union of a list of maps:+--   (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+unions :: Ord k => [IntervalMap k a] -> IntervalMap k a+unions = foldl' union empty++-- | The union of a list of maps, with a combining operation:+--   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+unionsWith :: Ord k => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a+unionsWith f = foldl' (unionWith f) empty++-- | Return elements of the first map not existing in the second map.+difference :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a+difference m1 m2 = foldl' (\m i -> delete i m) m1 (IntervalSet.toList (keysSet m2))++-- | Intersection of two maps.+-- Return data in the first map for the keys existing in both maps.+intersection :: Ord k => IntervalMap k a -> IntervalMap k a -> IntervalMap k a+intersection = intersectionWith const++-- | Intersection with a combining function.+intersectionWith :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c +intersectionWith f im1@(IntervalMap m1) im2@(IntervalMap m2)+  | Map.size m1 >= Map.size m2 = g f im1 im2+  | otherwise = g (flip f) im2 im1+  where+    g :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c +    g f im1 (IntervalMap m2) = IntervalMap $ Map.unions $ go im1 (Map.elems m2)+      where+        go _ [] = []+        go im ((i,b) : xs) =+          case split i im of+            (_, IntervalMap m, im2) ->+              Map.map (\(j, a) -> (j, f a b)) m : go im2 xs++-- ------------------------------------------------------------------------+-- Traversal++instance Ord k => Functor (IntervalMap k) where+  fmap = map++instance Ord k => Foldable (IntervalMap k) where+  foldMap f (IntervalMap m) = foldMap (\(_,a) -> f a) m++instance Ord k => Traversable (IntervalMap k) where+  traverse f (IntervalMap m) = IntervalMap <$> traverse (\(i,a) -> (\b -> (i,b)) <$> f a) m++-- | Map a function over all values in the map.+map :: (a -> b) -> IntervalMap k a -> IntervalMap k b+map f (IntervalMap m) = IntervalMap $ Map.map (\(i, a) -> (i, f a)) m++-- | @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+-- @f@ must be strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+mapKeysMonotonic :: forall k1 k2 a. (Ord k1, Ord k2) => (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a+mapKeysMonotonic f = fromList . fmap g . toList+  where+    g :: (Interval k1, a) -> (Interval k2, a)+    g (i, a) = (Interval.mapMonotonic f i, a)++-- ------------------------------------------------------------------------++-- | Return all elements of the map in the ascending order of their keys.+elems :: IntervalMap k a -> [a]+elems (IntervalMap m) = [a | (_,a) <- Map.elems m]++-- | Return all keys of the map in ascending order. Subject to list+keys :: IntervalMap k a -> [Interval k]+keys (IntervalMap m) = [i | (i,_) <- Map.elems m]++-- | An alias for 'toAscList'. Return all key\/value pairs in the map+-- in ascending key order. +assocs :: IntervalMap k a -> [(Interval k, a)]+assocs = toAscList++-- | The set of all keys of the map.+keysSet :: Ord k => IntervalMap k a -> IntervalSet k+keysSet (IntervalMap m) = IntervalSet.fromAscList [i | (i,_) <- Map.elems m]++-- | Convert the map to a list of key\/value pairs. +toList :: IntervalMap k a -> [(Interval k, a)]+toList = toAscList++-- | Convert the map to a list of key/value pairs where the keys are in ascending order. +toAscList :: IntervalMap k a -> [(Interval k, a)]+toAscList (IntervalMap m) = Map.elems m++-- | Convert the map to a list of key/value pairs where the keys are in descending order. +toDescList :: IntervalMap k a -> [(Interval k, a)]+toDescList (IntervalMap m) = fmap snd $ Map.toDescList m++-- | Build a map from a list of key\/value pairs.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+fromList :: Ord k => [(Interval k, a)] -> IntervalMap k a+fromList = foldl' (\m (i,a) -> insert i a m) empty++-- | Build a map from a list of key\/value pairs with a combining function.+fromListWith :: Ord k => (a -> a -> a) -> [(Interval k, a)] -> IntervalMap k a+fromListWith f = foldl' (\m (i,a) -> insertWith f i a m) empty++-- ------------------------------------------------------------------------+-- Filter++-- | Filter all values that satisfy some predicate.+filter :: Ord k => (a -> Bool) -> IntervalMap k a -> IntervalMap k a+filter p (IntervalMap m) = IntervalMap $ Map.filter (\(_,a) -> p a) m++-- | The expression (@'split' i map@) is a triple @(map1,map2,map3)@ where+-- the keys in @map1@ are smaller than @i@, the keys in @map2@ are included in @i@, and the keys in @map3@ are larger than @i@.+split :: Ord k => Interval k -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a, IntervalMap k a)+split i (IntervalMap m) =+  case splitLookupLE (LB (Interval.lowerBound' i)) m of+    (smaller, m1, xs) -> +      case splitLookupLE (LB (Interval.upperBound i, True)) xs of+        (middle, m2, larger) ->+          ( IntervalMap $+              case m1 of+                Nothing -> Map.empty+                Just (j,b) ->+                  let k = Interval.intersection (upTo i) j+                  in if Interval.null k+                     then smaller+                     else Map.insert (LB (Interval.lowerBound' k)) (k,b) smaller+          , IntervalMap $ Map.unions $ middle :+              [ Map.singleton (LB (Interval.lowerBound' k)) (k, b)+              | (j, b) <- maybeToList m1 ++ maybeToList m2+              , let k = Interval.intersection i j+              , not (Interval.null k)+              ]+          , IntervalMap $ Map.unions $ larger :+              [ Map.singleton (LB (Interval.lowerBound' k)) (k, b)+              | (j, b) <- maybeToList m1 ++ maybeToList m2+              , let k = Interval.intersection (downTo i) j+              , not (Interval.null k)+              ]+          ) ++-- ------------------------------------------------------------------------+-- Submap++-- | This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+isSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool+isSubmapOf = isSubmapOfBy (==)++-- |  The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if+-- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when+-- applied to their respective values. +isSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool+isSubmapOfBy f m1 m2 = and $+  [ case lookupInterval i m2 of+      Nothing -> False+      Just b -> f a b+  | (i,a) <- toList m1 ]++-- |  Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool+isProperSubmapOf = isProperSubmapOfBy (==)++-- | Is this a proper submap? (ie. a submap but not equal).+-- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+-- @m1@ and @m2@ are not equal,+-- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+-- applied to their respective values.+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool+isProperSubmapOfBy f m1 m2 =+  isSubmapOfBy f m1 m2 &&+  keysSet m1 `IntervalSet.isProperSubsetOf` keysSet m2++-- ------------------------------------------------------------------------++splitLookupLE :: Ord k => k -> Map k v -> (Map k v, Maybe v, Map k v)+splitLookupLE k m =+  case Map.splitLookup k m of+    (smaller, Just v, larger) -> (smaller, Just v, larger)+    (smaller, Nothing, larger) ->+      case Map.maxView smaller of+        Just (v, smaller') -> (smaller', Just v, larger)+        Nothing -> (smaller, Nothing, larger)++upTo :: Ord r => Interval r -> Interval r+upTo i =+  case Interval.lowerBound' i of+    (NegInf, _) -> Interval.empty+    (PosInf, _) -> Interval.whole+    (Finite lb, incl) ->+      Interval.interval (NegInf,False) (Finite lb, not incl)++downTo :: Ord r => Interval r -> Interval r+downTo i =+  case Interval.upperBound' i of+    (PosInf, _) -> Interval.empty+    (NegInf, _) -> Interval.whole+    (Finite ub, incl) ->+      Interval.interval (Finite ub, not incl) (PosInf,False)

@@ -0,0 +1,120 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IntervalMap.Base+-- Copyright   :  (c) Masahiro Sakai 2016+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Mapping from intervals to values.+--+-- API of this module is strict in the keys, but lazy in the values.+-- If you need value-strict maps, use "Data.IntervalMap.Strict" instead.+-- The 'IntervalMap' type itself is shared between the lazy and strict modules,+-- meaning that the same 'IntervalMap' value can be passed to functions in+-- both modules (although that is rarely needed).+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- >  import Data.IntervalMap.Lazy (IntervalMap)+-- >  import qualified Data.IntervalMap.Lazy as IntervalMap+--+-----------------------------------------------------------------------------+module Data.IntervalMap.Lazy+  (+  -- * Strictness properties+  -- $strictness++  -- * IntervalMap type+    IntervalMap+  , module Data.ExtendedReal+  , EndPoint++  -- * Operators+  , (!)+  , (\\)++  -- * Query+  , null+  , member+  , notMember+  , lookup+  , findWithDefault+  , span++  -- * Construction+  , whole+  , empty+  , singleton++  -- ** Insertion+  , insert+  , insertWith++  -- ** Delete\/Update+  , delete+  , adjust+  , update+  , alter++  -- * Combine+  , union+  , unionWith+  , unions+  , unionsWith+  , intersection+  , intersectionWith+  , difference++  -- * Traversal+  , map+  , mapKeysMonotonic++  -- * Conversion+  , elems+  , keys+  , assocs+  , keysSet++  -- ** List+  , fromList+  , fromListWith+  , toList++  -- ** Ordered List+  , toAscList+  , toDescList++  -- * Filter+  , filter+  , split++  -- * Submap+  , isSubmapOf+  , isSubmapOfBy+  , isProperSubmapOf+  , isProperSubmapOfBy+  )+  where+++import Prelude hiding (null, lookup, map, filter, span)+import Data.IntervalMap.Base+import Data.ExtendedReal++-- $strictness+--+-- This module satisfies the following strictness property:+--+-- * Key arguments are evaluated to WHNF+--+-- Here are some examples that illustrate the property:+--+-- > insert undefined v m  ==  undefined+-- > insert k undefined m  ==  OK+-- > delete undefined m  ==  undefined

@@ -0,0 +1,251 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP, BangPatterns, TupleSections #-}+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IntervalMap.Base+-- Copyright   :  (c) Masahiro Sakai 2016+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable (BangPatterns, TupleSections)+--+-- Mapping from intervals to values.+--+-- API of this module is strict in both the keys and the values.+-- If you need value-lazy maps, use "Data.IntervalMap.Lazy" instead.+-- The 'IntervalMap' type itself is shared between the lazy and strict modules,+-- meaning that the same 'IntervalMap' value can be passed to functions in+-- both modules (although that is rarely needed).+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- >  import Data.IntervalMap.Strict (IntervalMap)+-- >  import qualified Data.IntervalMap.Strict as IntervalMap+--+-----------------------------------------------------------------------------+module Data.IntervalMap.Strict+  (+  -- * Strictness properties+  -- $strictness++  -- * IntervalMap type+    IntervalMap+  , module Data.ExtendedReal+  , EndPoint++  -- * Operators+  , (!)+  , (\\)++  -- * Query+  , null+  , member+  , notMember+  , lookup+  , findWithDefault+  , span++  -- * Construction+  , whole+  , empty+  , singleton++  -- ** Insertion+  , insert+  , insertWith++  -- ** Delete\/Update+  , delete+  , adjust+  , update+  , alter++  -- * Combine+  , union+  , unionWith+  , unions+  , unionsWith+  , intersection+  , intersectionWith+  , difference++  -- * Traversal+  , map+  , mapKeysMonotonic++  -- * Conversion+  , elems+  , keys+  , assocs+  , keysSet++  -- ** List+  , fromList+  , fromListWith+  , toList++  -- ** Ordered List+  , toAscList+  , toDescList++  -- * Filter+  , filter+  , split++  -- * Submap+  , isSubmapOf+  , isSubmapOfBy+  , isProperSubmapOf+  , isProperSubmapOfBy+  )+  where+++import Prelude hiding (null, lookup, map, filter, span)+import Control.Applicative hiding (empty)+import Data.ExtendedReal+import Data.Interval (Interval, EndPoint)+import qualified Data.Interval as Interval+import Data.IntervalMap.Base hiding+  ( whole+  , singleton+  , insert+  , insertWith+  , adjust+  , update+  , alter+  , unionWith+  , unionsWith+  , intersectionWith+  , map+  , fromList+  , fromListWith+  )+import qualified Data.IntervalMap.Base as B+import qualified Data.IntervalSet as IntervalSet+import Data.List (foldl')+import qualified Data.Map.Strict as Map++-- $strictness+--+-- This module satisfies the following strictness properties:+--+-- 1. Key arguments are evaluated to WHNF;+--+-- 2. Keys and values are evaluated to WHNF before they are stored in+--    the map.+--+-- Here's an example illustrating the first property:+--+-- > delete undefined m  ==  undefined+--+-- Here are some examples that illustrate the second property:+--+-- > map (\ v -> undefined) m  ==  undefined      -- m is not empty+-- > mapKeysMonotonic (\ k -> undefined) m  ==  undefined  -- m is not empty++-- | The map that maps whole range of k to a.+whole :: Ord k => a -> IntervalMap k a+whole !a = B.whole a++-- | A map with a single interval.+singleton :: Ord k => Interval k -> a -> IntervalMap k a+singleton i !a = B.singleton i a++-- | insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value.+insert :: Ord k => Interval k -> a -> IntervalMap k a -> IntervalMap k a+insert i !a m = B.insert i a m++-- | Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@ will insert the pair (interval, value) into @mp@.+-- If the interval overlaps with existing entries, the value for the entry is replace+-- with @(f new_value old_value)@.+insertWith :: Ord k => (a -> a -> a) -> Interval k -> a -> IntervalMap k a -> IntervalMap k a+insertWith _ i _ m | Interval.null i = m+insertWith f i !a m = alter g i m+  where+    g Nothing = Just a+    g (Just a') = Just $! f a a'++-- | Update a value at a specific interval with the result of the provided function.+-- When the interval does not overlatp with the map, the original map is returned.+adjust :: Ord k => (a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a+adjust f = update (Just . f)++-- | The expression (@'update' f i map@) updates the value @x@+-- at @i@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @i@ is bound to the new value @y@.+update :: Ord k => (a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a+update _ i m | Interval.null i = m+update f i m =+  case split i m of+    (IntervalMap m1, IntervalMap m2, IntervalMap m3) ->+      IntervalMap $ Map.unions [m1, Map.mapMaybe (\(i,a) -> (\b -> seq b (i,b)) <$> f a) m2, m3]++-- | The expression (@'alter' f i map@) alters the value @x@ at @i@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'IntervalMap'.+alter :: Ord k => (Maybe a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a+alter _ i m | Interval.null i = m+alter f i m =+  case split i m of+    (IntervalMap m1, IntervalMap m2, IntervalMap m3) ->+      let m2' = Map.mapMaybe (\(j,a) -> (\b -> seq b (j,b)) <$> f (Just a)) m2+          js = IntervalSet.singleton i `IntervalSet.difference` keysSet (IntervalMap m2)+          IntervalMap m2'' =+            case f Nothing of+              Nothing -> empty+              Just !a -> B.fromList [(j,a) | j <- IntervalSet.toList js]+      in seq m2' $ IntervalMap $ Map.unions [m1, m2', m2'', m3]++-- ------------------------------------------------------------------------+-- Combine++-- | Union with a combining function.+unionWith :: Ord k => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a+unionWith f m1 m2 = +  foldl' (\m (i,a) -> insertWith f i a m) m2 (toList m1)++-- | The union of a list of maps, with a combining operation:+--   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+unionsWith :: Ord k => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a+unionsWith f = foldl' (unionWith f) empty++-- | Intersection with a combining function.+intersectionWith :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c +intersectionWith f im1@(IntervalMap m1) im2@(IntervalMap m2)+  | Map.size m1 >= Map.size m2 = g f im1 im2+  | otherwise = g (flip f) im2 im1+  where+    g :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c +    g f im1 (IntervalMap m2) = IntervalMap $ Map.unions $ go im1 (Map.elems m2)+      where+        go _ [] = []+        go im ((i,b) : xs) =+          case split i im of+            (_, IntervalMap m, im2) ->+              Map.map (\(j, a) -> (j,) $! f a b) m : go im2 xs++-- ------------------------------------------------------------------------+-- Traversal++-- | Map a function over all values in the map.+map :: (a -> b) -> IntervalMap k a -> IntervalMap k b+map f (IntervalMap m) = IntervalMap $ Map.map (\(i, a) -> (i,) $! f a) m++-- ------------------------------------------------------------------------+-- Conversion++-- | Build a map from a list of key\/value pairs.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+fromList :: Ord k => [(Interval k, a)] -> IntervalMap k a+fromList = foldl' (\m (i,a) -> insert i a m) empty++-- | Build a map from a list of key\/value pairs with a combining function.+fromListWith :: Ord k => (a -> a -> a) -> [(Interval k, a)] -> IntervalMap k a+fromListWith f = foldl' (\m (i,a) -> insertWith f i a m) empty

@@ -0,0 +1,422 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies, DeriveDataTypeable, MultiWayIf #-}+{-# LANGUAGE Trustworthy #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IntervalSet+-- Copyright   :  (c) Masahiro Sakai 2016+-- License     :  BSD-style+--+-- Maintainer  :  masahiro.sakai@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable (CPP, ScopedTypeVariables, TypeFamilies, DeriveDataTypeable, MultiWayIf)+--+-- Interval datatype and interval arithmetic.+--+-----------------------------------------------------------------------------+module Data.IntervalSet+  (+  -- * IntervalSet type+    IntervalSet+  , module Data.ExtendedReal+  , EndPoint++  -- * Construction+  , whole+  , empty+  , singleton++  -- * Query+  , null+  , member+  , notMember+  , isSubsetOf+  , isProperSubsetOf+  , span++  -- * Construction+  , complement+  , insert+  , delete++  -- * Combine+  , union+  , unions+  , intersection+  , intersections+  , difference++  -- * Conversion++  -- ** List+  , fromList+  , toList++  -- ** Ordered list+  , toAscList+  , toDescList+  , fromAscList+  )+  where++import Prelude hiding (null, span)+import Algebra.Lattice+import Control.DeepSeq+import Data.Data+import Data.ExtendedReal+import Data.Function+import Data.Hashable+import Data.List (sortBy, foldl')+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Semigroup (Semigroup)+import qualified Data.Semigroup as Semigroup+import Data.Interval (Interval, EndPoint)+import qualified Data.Interval as Interval+#if __GLASGOW_HASKELL__ >= 708+import qualified GHC.Exts as GHCExts+#endif++-- | A set comprising zero or more non-empty, /disconnected/ intervals.+--+-- Any connected intervals are merged together, and empty intervals are ignored.+newtype IntervalSet r = IntervalSet (Map (Extended r) (Interval r))+  deriving (Eq, Typeable)++#if __GLASGOW_HASKELL__ >= 708+type role IntervalSet nominal+#endif++instance (Ord r, Show r) => Show (IntervalSet r) where+  showsPrec p (IntervalSet m) = showParen (p > appPrec) $+    showString "fromList " .+    showsPrec (appPrec+1) (Map.elems m)++instance (Ord r, Read r) => Read (IntervalSet r) where+  readsPrec p =+    (readParen (p > appPrec) $ \s0 -> do+      ("fromList",s1) <- lex s0+      (xs,s2) <- readsPrec (appPrec+1) s1+      return (fromList xs, s2))++appPrec :: Int+appPrec = 10++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance (Ord r, Data r) => Data (IntervalSet r) where+  gfoldl k z x   = z fromList `k` toList x+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = setDataType+  dataCast1 f    = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr setDataType "fromList" [] Prefix++setDataType :: DataType+setDataType = mkDataType "Data.IntervalSet.IntervalSet" [fromListConstr]++instance NFData r => NFData (IntervalSet r) where+  rnf (IntervalSet m) = rnf m++instance Hashable r => Hashable (IntervalSet r) where+  hashWithSalt s (IntervalSet m) = hashWithSalt s (Map.toList m)++instance (Ord r) => JoinSemiLattice (IntervalSet r) where+  join = union++instance (Ord r) => MeetSemiLattice (IntervalSet r) where+  meet = intersection++instance (Ord r) => Lattice (IntervalSet r)++instance (Ord r) => BoundedJoinSemiLattice (IntervalSet r) where+  bottom = empty++instance (Ord r) => BoundedMeetSemiLattice (IntervalSet r) where+  top = whole++instance (Ord r) => BoundedLattice (IntervalSet r)++instance Ord r => Monoid (IntervalSet r) where+  mempty = empty+  mappend = union+  mconcat = unions++instance (Ord r) => Semigroup (IntervalSet r) where+  (<>)    = union+#if !defined(VERSION_semigroups)+  stimes  = Semigroup.stimesIdempotentMonoid+#else+#if MIN_VERSION_semigroups(0,17,0)+  stimes  = Semigroup.stimesIdempotentMonoid+#else+  times1p _ a = a+#endif+#endif++lift1+  :: Ord r => (Interval r -> Interval r)+  -> IntervalSet r -> IntervalSet r+lift1 f as = fromList [f a | a <- toList as]++lift2+  :: Ord r => (Interval r -> Interval r -> Interval r)+  -> IntervalSet r -> IntervalSet r -> IntervalSet r+lift2 f as bs = fromList [f a b | a <- toList as, b <- toList bs]++instance (Num r, Ord r) => Num (IntervalSet r) where+  (+) = lift2 (+)++  (*) = lift2 (*)++  negate = lift1 negate++  abs = lift1 abs++  fromInteger i = singleton (fromInteger i)++  signum xs = fromList $ do+    x <- toList xs+    y <-+      [ if Interval.member 0 x+        then Interval.singleton 0+        else Interval.empty+      , if Interval.null ((0 Interval.<..< inf) `Interval.intersection` x)+        then Interval.empty+        else Interval.singleton 1+      , if Interval.null ((-inf Interval.<..< 0) `Interval.intersection` x)+        then Interval.empty+        else Interval.singleton (-1)+      ]+    return y++instance forall r. (Real r, Fractional r) => Fractional (IntervalSet r) where+  fromRational r = singleton (fromRational r)+  recip = lift1 recip++#if __GLASGOW_HASKELL__ >= 708+instance Ord r => GHCExts.IsList (IntervalSet r) where+  type Item (IntervalSet r) = Interval r+  fromList = fromList+  toList = toList+#endif++-- -----------------------------------------------------------------------++-- | whole real number line (-∞, ∞)+whole :: Ord r => IntervalSet r+whole = singleton $ Interval.whole++-- | empty interval set+empty :: Ord r => IntervalSet r+empty = IntervalSet Map.empty++-- | single interval+singleton :: Ord r => Interval r -> IntervalSet r+singleton i+  | Interval.null i = empty+  | otherwise = IntervalSet $ Map.singleton (Interval.lowerBound i) i++-- -----------------------------------------------------------------------++-- | Is the interval set empty?+null :: IntervalSet r -> Bool+null (IntervalSet m) = Map.null m++-- | Is the element in the interval set?+member :: Ord r => r -> IntervalSet r -> Bool+member x (IntervalSet m) =+  case Map.lookupLE (Finite x) m of+    Nothing -> False+    Just (_,i) -> Interval.member x i++-- | Is the element not in the interval set?+notMember :: Ord r => r -> IntervalSet r -> Bool+notMember x is = not $ x `member` is++-- | Is this a subset?+-- @(is1 \``isSubsetOf`\` is2)@ tells whether @is1@ is a subset of @is2@.+isSubsetOf :: Ord r => IntervalSet r -> IntervalSet r -> Bool+isSubsetOf is1 is2 = all (\i1 -> f i1 is2) (toList is1)+  where+    f i1 (IntervalSet m) =+      case Map.lookupLE (Interval.lowerBound i1) m of+        Nothing -> False+        Just (_,i2) -> Interval.isSubsetOf i1 i2++-- | Is this a proper subset? (/i.e./ a subset but not equal).+isProperSubsetOf :: Ord r => IntervalSet r -> IntervalSet r -> Bool+isProperSubsetOf is1 is2 = isSubsetOf is1 is2 && is1 /= is2++-- | convex hull of a set of intervals.+span :: Ord r => IntervalSet r -> Interval r+span (IntervalSet m) =+  case Map.minView m of+    Nothing -> Interval.empty+    Just (i1, _) ->+      case Map.maxView m of+        Nothing -> Interval.empty+        Just (i2, _) ->+          Interval.interval (Interval.lowerBound' i1) (Interval.upperBound' i2)++-- -----------------------------------------------------------------------++-- | Complement the interval set.+complement :: Ord r => IntervalSet r -> IntervalSet r+complement (IntervalSet m) = fromAscList $ f (NegInf,False) (Map.elems m)+  where+    f prev [] = [ Interval.interval prev (PosInf,False) ]+    f prev (i : is) =+      case (Interval.lowerBound' i, Interval.upperBound' i) of+        ((lb, in1), (ub, in2)) ->+          Interval.interval prev (lb, not in1) : f (ub, not in2) is++-- | Insert a new interval into the interval set.+insert :: Ord r => Interval r -> IntervalSet r -> IntervalSet r+insert i is | Interval.null i = is+insert i (IntervalSet is) = IntervalSet $+  case splitLookupLE (Interval.lowerBound i) is of+    (smaller, m1, xs) ->+      case splitLookupLE (Interval.upperBound i) xs of+        (_, m2, larger) ->+          Map.unions+          [ smaller+          , case fromList $ i : maybeToList m1 ++ maybeToList m2 of+              IntervalSet m -> m+          , larger+          ]++-- | Delete an interval from the interval set.+delete :: Ord r => Interval r -> IntervalSet r -> IntervalSet r+delete i is | Interval.null i = is+delete i (IntervalSet is) = IntervalSet $+  case splitLookupLE (Interval.lowerBound i) is of+    (smaller, m1, xs) ->+      case splitLookupLE (Interval.upperBound i) xs of+        (_, m2, larger) ->+          Map.unions+          [ smaller+          , case m1 of+              Nothing -> Map.empty+              Just j -> Map.fromList+                [ (Interval.lowerBound k, k)+                | i' <- [upTo i, downTo i], let k = i' `Interval.intersection` j, not (Interval.null k)+                ]+          , if+            | Just j <- m2, j' <- downTo i `Interval.intersection` j, not (Interval.null j') ->+                Map.singleton (Interval.lowerBound j') j'+            | otherwise -> Map.empty+          , larger+          ]++-- | union of two interval sets+union :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r+union is1@(IntervalSet m1) is2@(IntervalSet m2) =+  if Map.size m1 >= Map.size m2+  then foldl' (\is i -> insert i is) is1 (toList is2)+  else foldl' (\is i -> insert i is) is2 (toList is1)++-- | union of a list of interval sets+unions :: Ord r => [IntervalSet r] -> IntervalSet r+unions = foldl' union empty++-- | intersection of two interval sets+intersection :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r+intersection is1 is2 = difference is1 (complement is2)++-- | intersection of a list of interval sets+intersections :: Ord r => [IntervalSet r] -> IntervalSet r+intersections = foldl' intersection whole++-- | difference of two interval sets+difference :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r+difference is1 is2 =+  foldl' (\is i -> delete i is) is1 (toList is2)++-- -----------------------------------------------------------------------++-- | Build a interval set from a list of intervals.+fromList :: Ord r => [Interval r] -> IntervalSet r+fromList = IntervalSet . fromAscList' . sortBy (compareLB `on` Interval.lowerBound')++-- | Build a map from an ascending list of intervals. +-- /The precondition is not checked./+fromAscList :: Ord r => [Interval r] -> IntervalSet r+fromAscList = IntervalSet . fromAscList'++fromAscList' :: Ord r => [Interval r] -> Map (Extended r) (Interval r)+fromAscList' = Map.fromDistinctAscList . map (\i -> (Interval.lowerBound i, i)) . f+  where+    f :: Ord r => [Interval r] -> [Interval r]+    f [] = []+    f (x : xs) = g x xs+    g x [] = [x | not (Interval.null x)]+    g x (y : ys)+      | Interval.null x = g y ys+      | Interval.isConnected x y = g (x `Interval.hull` y) ys+      | otherwise = x : g y ys++-- | Convert a interval set into a list of intervals.+toList :: Ord r => IntervalSet r -> [Interval r]+toList = toAscList++-- | Convert a interval set into a list of intervals in ascending order.+toAscList :: Ord r => IntervalSet r -> [Interval r]+toAscList (IntervalSet m) = Map.elems m++-- | Convert a interval set into a list of intervals in descending order.+toDescList :: Ord r => IntervalSet r -> [Interval r]+toDescList (IntervalSet m) = fmap snd $ Map.toDescList m++-- -----------------------------------------------------------------------++splitLookupLE :: Ord k => k -> Map k v -> (Map k v, Maybe v, Map k v)+splitLookupLE k m =+  case Map.splitLookup k m of+    (smaller, Just v, larger) -> (smaller, Just v, larger)+    (smaller, Nothing, larger) ->+      case Map.maxView smaller of+        Just (v, smaller') -> (smaller', Just v, larger)+        Nothing -> (smaller, Nothing, larger)++{-+splitLookupGE :: Ord k => k -> Map k v -> (Map k v, Maybe v, Map k v)+splitLookupGE k m =+  case Map.splitLookup k m of+    (smaller, Just v, larger) -> (smaller, Just v, larger)+    (smaller, Nothing, larger) ->+      case Map.minView larger of+        Just (v, larger') -> (smaller, Just v, larger')+        Nothing -> (smaller, Nothing, larger)+-}++compareLB :: Ord r => (Extended r, Bool) -> (Extended r, Bool) -> Ordering+compareLB (lb1, lb1in) (lb2, lb2in) =+  -- inclusive lower endpoint shuold be considered smaller+  (lb1 `compare` lb2) `mappend` (lb2in `compare` lb1in)++upTo :: Ord r => Interval r -> Interval r+upTo i =+  case Interval.lowerBound' i of+    (NegInf, _) -> Interval.empty+    (PosInf, _) -> Interval.whole+    (Finite lb, incl) ->+      Interval.interval (NegInf,False) (Finite lb, not incl)++downTo :: Ord r => Interval r -> Interval r+downTo i =+  case Interval.upperBound' i of+    (PosInf, _) -> Interval.empty+    (NegInf, _) -> Interval.whole+    (Finite ub, incl) ->+      Interval.interval (Finite ub, not incl) (PosInf,False)

@@ -1,14 +1,20 @@ {-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+module TestIntegerInterval (integerIntervalTestGroup) where++import qualified Algebra.Lattice as L+import Control.DeepSeq import Control.Monad+import Data.Generics.Schemes+import Data.Hashable import Data.Maybe import Data.Ratio-import Test.HUnit hiding (Test)-import Test.QuickCheck-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.TH-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2+import Data.Typeable +import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.TH+ import Data.IntegerInterval   ( IntegerInterval, Extended (..), (<=..<=), (<=..<), (<..<=), (<..<)   , (<!), (<=!), (==!), (>=!), (>!), (/=!)@@ -49,6 +55,10 @@   singleton --------------------------------------------------------------------} +-- prop_singleton_isSingleton =+--   forAll arbitrary $ \x ->+--     IntegerInterval.isSingleton (IntegerInterval.singleton x)+ prop_singleton_member =   forAll arbitrary $ \r ->     IntegerInterval.member (r::Integer) (IntegerInterval.singleton r)@@ -178,8 +188,12 @@   forAll integerIntervals $ \a ->     IntegerInterval.member r a == IntegerInterval.isSubsetOf (IntegerInterval.singleton r) a +prop_notMember_empty =+  forAll arbitrary $ \r ->+    r `IntegerInterval.notMember` IntegerInterval.empty+ {---------------------------------------------------------------------  isSubsetOf+  isSubsetOf, isProperSubsetOf --------------------------------------------------------------------}  prop_isSubsetOf_refl =@@ -199,7 +213,57 @@ --     IntegerInterval.isSubsetOf a b && IntegerInterval.isSubsetOf b a --     ==> a == b +prop_isProperSubsetOf_not_refl =+  forAll integerIntervals $ \a ->+    not (a `IntegerInterval.isProperSubsetOf` a)++-- too slow+-- prop_isProperSubsetOf_trans =+--   forAll integerIntervals $ \a ->+--   forAll (liftM (IntegerInterval.intersection a) integerIntervals) $ \b ->+--   forAll (liftM (IntegerInterval.intersection b) integerIntervals) $ \c ->+--     IntegerInterval.isProperSubsetOf c b && IntegerInterval.isProperSubsetOf b a+--     ==> IntegerInterval.isProperSubsetOf c a++case_isProperSubsetOf =+  (0 <=..<= 1) `IntegerInterval.isProperSubsetOf` (0 <=..<= 2) @?= True+ {--------------------------------------------------------------------+  simplestIntegerWithin+--------------------------------------------------------------------}++prop_simplestIntegerWithin_member =+  forAll integerIntervals $ \a ->+    case IntegerInterval.simplestIntegerWithin a of+      Nothing -> True+      Just x -> x `IntegerInterval.member` a++prop_simplestIntegerWithin_singleton =+  forAll arbitrary $ \x ->+    IntegerInterval.simplestIntegerWithin (IntegerInterval.singleton x) == Just x++case_simplestIntegerWithin_empty =+  IntegerInterval.simplestIntegerWithin IntegerInterval.empty @?= Nothing++{--------------------------------------------------------------------+  width+--------------------------------------------------------------------}++case_width_null =+  IntegerInterval.width IntegerInterval.empty @?= 0++prop_width_singleton =+  forAll arbitrary $ \x ->+    IntegerInterval.width (IntegerInterval.singleton x) == 0++{--------------------------------------------------------------------+  map+--------------------------------------------------------------------}++case_mapMonotonic =+  IntegerInterval.mapMonotonic (+1) (0 <=..< 10) @?= ((1 <=..<11) :: IntegerInterval)++{--------------------------------------------------------------------   pickup --------------------------------------------------------------------} @@ -215,6 +279,10 @@ case_pickup_whole =   isJust (IntegerInterval.pickup (IntegerInterval.whole :: IntegerInterval)) @?= True +prop_pickup_singleton =+  forAll arbitrary $ \x ->+    IntegerInterval.pickup (IntegerInterval.singleton x) == Just x+ {--------------------------------------------------------------------   Comparison --------------------------------------------------------------------}@@ -433,6 +501,26 @@       Just (x,y) ->         IntegerInterval.member x a .&&. IntegerInterval.member y b .&&. x /= y +case_ne_some_witness_test1 = do+  let i1 = 0+      i2 = 0 <=..<= 1+  case i1 /=?? i2 of+    Nothing -> assertFailure "should not be Nothing"+    Just (a,b) -> do+      unless (a `IntegerInterval.member` i1) $ assertFailure (show a ++ "is not a member of " ++ show i1)+      unless (b `IntegerInterval.member` i2) $ assertFailure (show b ++ "is not a member of " ++ show i2)+      unless (a /= b) $ assertFailure (show a ++ " /= " ++ show b ++ " failed")++case_ne_some_witness_test2 = do+  let i1 = 0 <=..<= 1+      i2 = 1+  case i1 /=?? i2 of+    Nothing -> assertFailure "should not be Nothing"+    Just (a,b) -> do+      unless (a `IntegerInterval.member` i1) $ assertFailure (show a ++ "is not a member of " ++ show i1)+      unless (b `IntegerInterval.member` i2) $ assertFailure (show b ++ "is not a member of " ++ show i2)+      unless (a /= b) $ assertFailure (show a ++ " /= " ++ show b ++ " failed")+ prop_le_some_witness_forget =   forAll integerIntervals $ \a ->   forAll integerIntervals $ \b ->@@ -571,7 +659,31 @@     ival2 = NegInf <..< (-2)     ival3 = NegInf <..< (-8) -- * +prop_abs_signum =+  forAll integerIntervals $ \a ->+    abs (signum a) `IntegerInterval.isSubsetOf` (0 <=..<= 1)++prop_negate_negate =+  forAll integerIntervals $ \a ->+    negate (negate a) == a+ {--------------------------------------------------------------------+  Lattice+--------------------------------------------------------------------}++prop_Lattice_Leq_welldefined =+  forAll integerIntervals $ \a b ->+    a `L.meetLeq` b == a `L.joinLeq` b++prop_top =+  forAll integerIntervals $ \a ->+    a `L.joinLeq` L.top++prop_bottom =+  forAll integerIntervals $ \a ->+    L.bottom `L.joinLeq` a++{--------------------------------------------------------------------   Read --------------------------------------------------------------------} @@ -579,7 +691,38 @@   forAll integerIntervals $ \i -> do     i == read (show i) +case_read_old =+  read "interval (Finite 0, True) (PosInf, False)" @?= IntegerInterval.interval (Finite 0, True) (PosInf, False)+ {--------------------------------------------------------------------+  NFData+--------------------------------------------------------------------}++prop_rnf =+  forAll integerIntervals $ \a ->+    rnf a == ()++{--------------------------------------------------------------------+  Hashable+--------------------------------------------------------------------}++prop_hash =+  forAll integerIntervals $ \i ->+    hash i `seq` True++{- ------------------------------------------------------------------+  Data+------------------------------------------------------------------ -}++case_Data = everywhere f i @?= (1 <=..<= 2 :: IntegerInterval)+  where+    i :: IntegerInterval+    i = 0 <=..<= 1+    f x+      | Just (y :: Integer) <- cast x = fromJust $ cast (y + 1)+      | otherwise = x++{--------------------------------------------------------------------   Conversion between Interval and IntegerInterval --------------------------------------------------------------------} @@ -611,6 +754,12 @@   forAll arbitrary $ \(i :: Interval Integer) ->     IntegerInterval.toInterval (IntegerInterval.fromInterval i) `Interval.isSubsetOf` i +case_fromIntervalUnder_test1 =+  IntegerInterval.fromIntervalUnder ((0.5::Extended Rational) Interval.<=..<= 1.5) @?= IntegerInterval.singleton 1++case_fromIntervalUnder_test2 =+  IntegerInterval.fromIntervalUnder ((0::Extended Rational) Interval.<..< 2) @?= IntegerInterval.singleton 1+ {--------------------------------------------------------------------   Generators --------------------------------------------------------------------}@@ -656,5 +805,4 @@ ------------------------------------------------------------------------ -- Test harness -main :: IO ()-main = $(defaultMainGenerator)+integerIntervalTestGroup = $(testGroupGenerator)

@@ -1,15 +1,20 @@ {-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+module TestInterval (intervalTestGroup) where +import qualified Algebra.Lattice as L+import Control.DeepSeq import Control.Monad+import Data.Generics.Schemes+import Data.Hashable import Data.Maybe import Data.Ratio-import Test.HUnit hiding (Test)-import Test.QuickCheck-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.TH-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2+import Data.Typeable +import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.TH+ import Data.Interval   ( Interval, Extended (..), (<=..<=), (<=..<), (<..<=), (<..<)   , (<!), (<=!), (==!), (>=!), (>!), (/=!)@@ -48,6 +53,10 @@   singleton --------------------------------------------------------------------} +-- prop_singleton_isSingleton =+--   forAll arbitrary $ \(r::Rational) ->+--     Interval.isSingleton (Interval.singleton r)+ prop_singleton_member =   forAll arbitrary $ \r ->     Interval.member (r::Rational) (Interval.singleton r)@@ -177,6 +186,10 @@   forAll intervals $ \a ->     Interval.member r a == Interval.isSubsetOf (Interval.singleton r) a +prop_notMember_empty =+  forAll arbitrary $ \(r::Rational) ->+    r `Interval.notMember` Interval.empty+ {--------------------------------------------------------------------   isSubsetOf --------------------------------------------------------------------}@@ -198,10 +211,44 @@ --     Interval.isSubsetOf a b && Interval.isSubsetOf b a --     ==> a == b +prop_isProperSubsetOf_not_refl =+  forAll intervals $ \a ->+    not (a `Interval.isProperSubsetOf` a)++-- too slow+-- prop_isProperSubsetOf_trans =+--   forAll intervals $ \a ->+--   forAll (liftM (Interval.intersection a) intervals) $ \b ->+--   forAll (liftM (Interval.intersection b) intervals) $ \c ->+--     Interval.isProperSubsetOf c b && Interval.isProperSubsetOf b a+--     ==> Interval.isProperSubsetOf c a++case_isProperSubsetOf =+  (0 <=..<= 1) `Interval.isProperSubsetOf` (0 <=..<= 2) @?= True++{-- -----------------------------------------------------------------+  isConnected+----------------------------------------------------------------- --}++prop_isConnected_reflexive =+  forAll intervals $ \a ->+    a `Interval.isConnected` a++prop_isConnected_symmetric =+  forAll intervals $ \a ->+    forAll intervals $ \b ->+      (a `Interval.isConnected` b) == (b `Interval.isConnected` a)+ {--------------------------------------------------------------------   simplestRationalWithin --------------------------------------------------------------------} +prop_simplestRationalWithin_member =+  forAll intervals $ \a ->+    case Interval.simplestRationalWithin a of+      Nothing -> True+      Just x -> x `Interval.member` a+ prop_simplestRationalWithin_and_approxRational =   forAll arbitrary $ \(r::Rational) ->     forAll arbitrary $ \(eps::Rational) ->@@ -249,7 +296,29 @@ case_pickup_whole =   isJust (Interval.pickup (Interval.whole :: Interval Rational)) @?= True +prop_pickup_singleton =+  forAll arbitrary $ \(x::Rational) ->+    Interval.pickup (Interval.singleton x) == Just x+ {--------------------------------------------------------------------+  width+--------------------------------------------------------------------}++case_width_null =+  Interval.width Interval.empty @?= 0++prop_width_singleton =+  forAll arbitrary $ \(r::Rational) ->+    Interval.width (Interval.singleton r) == 0++{--------------------------------------------------------------------+  map+--------------------------------------------------------------------}++case_mapMonotonic =+  Interval.mapMonotonic (+1) (0 <=..< 10) @?= ((1 <=..<11) :: Interval Rational)++{--------------------------------------------------------------------   Comparison --------------------------------------------------------------------} @@ -446,6 +515,16 @@       Just (x,y) ->         Interval.member x a .&&. Interval.member y b .&&. x < y +case_lt_some_witness_test1 = do+  let i1 = 0+      i2 = 0 <=..<= 1+  case i1 <?? i2 of+    Nothing -> assertFailure "should not be Nothing"+    Just (a,b) -> do+      unless (a `Interval.member` i1) $ assertFailure (show a ++ "is not a member of " ++ show i1)+      unless (b `Interval.member` i2) $ assertFailure (show b ++ "is not a member of " ++ show i2)+      unless (a < b) $ assertFailure (show a ++ " < " ++ show b ++ " failed")+ prop_eq_some_witness =   forAll intervals $ \a ->   forAll intervals $ \b ->@@ -467,6 +546,26 @@       Just (x,y) ->         Interval.member x a .&&. Interval.member y b .&&. x /= y +case_ne_some_witness_test1 = do+  let i1 = 0+      i2 = 0 <=..<= 1+  case i1 /=?? i2 of+    Nothing -> assertFailure "should not be Nothing"+    Just (a,b) -> do+      unless (a `Interval.member` i1) $ assertFailure (show a ++ "is not a member of " ++ show i1)+      unless (b `Interval.member` i2) $ assertFailure (show b ++ "is not a member of " ++ show i2)+      unless (a /= b) $ assertFailure (show a ++ " /= " ++ show b ++ " failed")++case_ne_some_witness_test2 = do+  let i1 = 0 <=..<= 1+      i2 = 1+  case i1 /=?? i2 of+    Nothing -> assertFailure "should not be Nothing"+    Just (a,b) -> do+      unless (a `Interval.member` i1) $ assertFailure (show a ++ "is not a member of " ++ show i1)+      unless (b `Interval.member` i2) $ assertFailure (show b ++ "is not a member of " ++ show i2)+      unless (a /= b) $ assertFailure (show a ++ " /= " ++ show b ++ " failed")+ prop_le_some_witness_forget =   forAll intervals $ \a ->   forAll intervals $ \b ->@@ -605,6 +704,14 @@     ival2 = NegInf <..< (-2)     ival3 = NegInf <..< (-4) +prop_abs_signum =+  forAll intervals $ \a ->+    abs (signum a) `Interval.isSubsetOf` (0 <=..<= 1)++prop_negate_negate =+  forAll intervals $ \a ->+    negate (negate a) == a+ {--------------------------------------------------------------------   Fractional --------------------------------------------------------------------}@@ -615,6 +722,9 @@         d = fromIntegral (denominator r)     in Interval.singleton n / Interval.singleton d == Interval.singleton (r::Rational) +case_recip_empty =+  recip Interval.empty @?= Interval.empty+ case_recip_pos =   recip pos @?= pos @@ -627,7 +737,39 @@     i1 = 2 <=..< PosInf     i2 = 0 <..<= (1/2) +case_recip_test2 = recip i1 @?= i2+  where+    i1, i2 :: Interval Rational+    i1 = 0 <..<= 10+    i2 = (1/10) <=..< PosInf++case_recip_test3 = recip i1 @?= i2+  where+    i1, i2 :: Interval Rational+    i1 = -10 <=..< 0+    i2 = NegInf <..<= (-1/10)++prop_recip_zero =+  forAll intervals $ \a ->+    0 `Interval.member` a ==> recip a == Interval.whole+ {--------------------------------------------------------------------+  Lattice+--------------------------------------------------------------------}++prop_Lattice_Leq_welldefined =+  forAll intervals $ \a b ->+    a `L.meetLeq` b == a `L.joinLeq` b++prop_top =+  forAll intervals $ \a ->+    a `L.joinLeq` L.top++prop_bottom =+  forAll intervals $ \a ->+    L.bottom `L.joinLeq` a++{--------------------------------------------------------------------   Read --------------------------------------------------------------------} @@ -635,7 +777,39 @@   forAll intervals $ \i -> do     i == read (show i) +case_read_old =+  read "interval (Finite (0 % 1), True) (PosInf, False)" @?= +  (Interval.interval (Finite 0, True) (PosInf, False) :: Interval Rational)+ {--------------------------------------------------------------------+  NFData+--------------------------------------------------------------------}++prop_rnf =+  forAll intervals $ \a ->+    rnf a == ()++{--------------------------------------------------------------------+  Hashable+--------------------------------------------------------------------}++prop_hash =+  forAll intervals $ \i ->+    hash i `seq` True++{- ------------------------------------------------------------------+  Data+------------------------------------------------------------------ -}++case_Data = everywhere f i @?= (1 <=..<= 2 :: Interval Integer)+  where+    i :: Interval Integer+    i = 0 <=..<= 1+    f x+      | Just (y :: Integer) <- cast x = fromJust $ cast (y + 1)+      | otherwise = x++{--------------------------------------------------------------------   Generators --------------------------------------------------------------------} @@ -671,5 +845,4 @@ ------------------------------------------------------------------------ -- Test harness -main :: IO ()-main = $(defaultMainGenerator)+intervalTestGroup = $(testGroupGenerator)

@@ -0,0 +1,842 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+module TestIntervalMap (intervalMapTestGroup) where++import Control.Applicative ((<$>))+import Control.DeepSeq+import Control.Exception (evaluate)+import Control.Monad+import Data.Functor.Identity+import qualified Data.Foldable as F+import Data.Generics.Schemes+import Data.Hashable+import Data.Maybe+import Data.Monoid+import Data.Traversable+import Data.Typeable++import Test.ChasingBottoms.IsBottom+import Test.QuickCheck.Function+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.TH++import Data.Interval ( Interval, Extended (..), (<=..<=), (<=..<), (<..<=), (<..<), (<!))+import qualified Data.Interval as Interval+import qualified Data.IntervalSet as IntervalSet+import Data.IntervalMap.Lazy (IntervalMap)+import qualified Data.IntervalMap.Lazy as IML+import qualified Data.IntervalMap.Strict as IMS++{--------------------------------------------------------------------+  empty+--------------------------------------------------------------------}++prop_empty_is_bottom =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    IML.isSubmapOf IML.empty a++prop_null_empty =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    IML.null a == (a == IML.empty)++case_null_empty =+  IML.null (IML.empty :: IntervalMap Rational Integer) @?= True++{--------------------------------------------------------------------+  whole+--------------------------------------------------------------------}++case_nonnull_whole =+  IML.null (IML.whole 0 :: IntervalMap Rational Integer) @?= False++prop_whole_Lazy_Strict = do+  forAll arbitrary $ \(a :: Integer) ->+    (IML.whole a :: IntervalMap Rational Integer) == IMS.whole a++case_whole_nonstrict = do+  _ <- evaluate (IML.whole bottom :: IntervalMap Rational Integer)+  return ()++case_whole_strict =+  isBottom (IMS.whole bottom :: IntervalMap Rational Integer) @?= True++{--------------------------------------------------------------------+  singleton+--------------------------------------------------------------------}++prop_singleton_insert = do+  forAll arbitrary $ \(i :: Interval Rational) ->+    forAll arbitrary $ \(a :: Integer) ->+      IML.singleton i a == IML.insert i a IML.empty++prop_singleton_Lazy_Strict = do+  forAll arbitrary $ \(i :: Interval Rational) ->+    forAll arbitrary $ \(a :: Integer) ->+      IML.singleton i a == IMS.singleton i a++case_singleton_nonstrict = do+  _ <- evaluate (IML.singleton 0 bottom :: IntervalMap Rational Integer)+  return ()++case_singleton_strict =+  isBottom (IMS.singleton 0 bottom :: IntervalMap Rational Integer) @?= True++{--------------------------------------------------------------------+  insert+--------------------------------------------------------------------}++prop_insert_whole =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \a ->+      IML.insert Interval.whole a m == IML.whole a++prop_insert_empty =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \a ->+      IML.insert Interval.empty a m == m++prop_insert_comm =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \(i1,a1) ->+  forAll arbitrary $ \(i2,a2) ->+    Interval.null (Interval.intersection i1 i2)+    ==>+    (IML.insert i1 a1 (IML.insert i2 a2 m) == IML.insert i2 a2 (IML.insert i1 a1 m))++prop_insert_isSubmapOf =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \i ->+      forAll arbitrary $ \a ->+        IML.isSubmapOf (IML.singleton i a) (IML.insert i a m)++prop_insert_member =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \i ->+      forAll arbitrary $ \a ->+        case Interval.pickup i of+          Just k -> IML.member k (IML.insert i a m)+          Nothing -> True++prop_insert_lookup =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \i ->+      forAll arbitrary $ \a ->+        case Interval.pickup i of+          Just k -> IML.lookup k (IML.insert i a m) == Just a+          Nothing -> True++prop_insert_bang =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \i ->+      forAll arbitrary $ \a ->+        case Interval.pickup i of+          Just k -> IML.insert i a m IML.! k == a+          Nothing -> True++prop_insert_Lazy_Strict =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \i ->+      forAll arbitrary $ \a ->+        IML.insert i a m == IMS.insert i a m++prop_insert_nonstrict =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \i ->+      IML.insert i bottom m `seq` True++prop_insert_strict =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \i ->+      isBottom $ IMS.insert i bottom m++prop_insertWith_Lazy_Strict =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \(f :: Fun (Integer,Integer) Integer) ->+      forAll arbitrary $ \i ->+        forAll arbitrary $ \a ->+          IML.insertWith (curry (apply f)) i a m == IMS.insertWith (curry (apply f)) i a m++case_insertWith_nonstrict = evaluate (IML.insertWith (\_ _ -> bottom) (3 <=..< 7) 1 m) >> return ()+  where+    m :: IntervalMap Rational Integer+    m = IML.singleton (0 <=..< 10) 0++case_insertWith_strict = isBottom (IMS.insertWith (\_ _ -> bottom) (3 <=..< 7) 1 m) @?= True+  where+    m :: IntervalMap Rational Integer+    m = IMS.singleton (0 <=..< 10) 0++{--------------------------------------------------------------------+  delete / update+--------------------------------------------------------------------}++prop_delete_empty =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+     IML.delete Interval.empty m == m++prop_delete_whole =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+     IML.delete Interval.whole m == IML.empty++prop_delete_from_empty =+  forAll arbitrary $ \(i :: Interval Rational) ->+     IML.delete i (IML.empty :: IntervalMap Rational Integer) == IML.empty++prop_delete_comm =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \i1 ->+  forAll arbitrary $ \i2 ->+     IML.delete i1 (IML.delete i2 m) == IML.delete i2 (IML.delete i1 m)++prop_delete_notMember =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \i ->+      case Interval.pickup i of+        Just k -> IML.notMember k (IML.delete i m)+        Nothing -> True++prop_delete_lookup =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \i ->+      case Interval.pickup i of+        Just k -> IML.lookup k (IML.delete i m) == Nothing+        Nothing -> True++case_adjust = IML.adjust (+1) (3 <=..< 7) m @?= expected+  where+    m :: IntervalMap Rational Integer+    m =+      IML.fromList+      [ (0 <=..< 2, 0)+      , (2 <=..< 4, 2)+      , (4 <=..< 6, 4)+      , (6 <=..< 8, 6)+      , (8 <=..< 10, 8)+      ]+    expected =+      IML.fromList+      [ (0 <=..< 2, 0)+      , (2 <=..< 3, 2)+      , (3 <=..< 4, 3)+      , (4 <=..< 6, 5)+      , (6 <=..< 7, 7)+      , (7 <=..< 8, 6)+      , (8 <=..< 10, 8)+      ]++prop_adjust_Lazy_Strict =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \(f :: Fun Integer Integer) ->+      forAll arbitrary $ \i ->+        IML.adjust (apply f) i m == IMS.adjust (apply f) i m++case_asjust_nonstrict = do+  _ <- evaluate $ IML.adjust (\_ -> bottom) (3 <=..< 7) m+  return ()+  where+    m :: IntervalMap Rational Integer+    m = IML.singleton (0 <=..< 10) 0++case_asjust_strict = isBottom (IMS.adjust (\_ -> bottom) (3 <=..< 7) m) @?= True+  where+    m :: IntervalMap Rational Integer+    m = IMS.singleton (0 <=..< 10) 0++prop_alter =+  forAll arbitrary $ \(m :: IntervalMap Rational Int) ->+  forAll arbitrary $ \i ->+  forAll arbitrary $ \f ->+    case Interval.pickup i of+      Nothing -> True+      Just k ->+        IML.lookup k (IML.alter (apply f) i m) == apply f (IML.lookup k m)++prop_alter_Lazy_Strict =+  forAll arbitrary $ \(m :: IntervalMap Rational Int) ->+  forAll arbitrary $ \i ->+  forAll arbitrary $ \f ->+    IML.alter (apply f) i m == IMS.alter (apply f) i m++prop_alter_nonstrict =+  forAll arbitrary $ \(m :: IntervalMap Rational Int) ->+  forAll arbitrary $ \i ->+    not (Interval.null i)+    ==>+    (IML.alter (\_ -> Just bottom) i m `seq` True)++prop_alter_strict =+  forAll arbitrary $ \(m :: IntervalMap Rational Int) ->+  forAll arbitrary $ \i ->+    not (Interval.null i)+    ==>+    isBottom (IMS.alter (\_ -> Just bottom) i m)++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}++prop_union_assoc =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \b ->+  forAll arbitrary $ \c ->+    IML.union a (IML.union b c) == IML.union (IML.union a b) c++prop_union_unitL =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    IML.union IML.empty a == a++prop_union_unitR =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    IML.union a IML.empty == a++prop_union_isSubmapOf =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \b ->+    IML.isSubmapOf a (IML.union a b)++prop_union_isSubmapOf_equiv =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \b ->+    IML.isSubmapOf (IML.union a b) b+    == IML.isSubmapOf a b++case_unions_empty_list =+  IML.unions [] @?= (IML.empty :: IntervalMap Rational Integer)++prop_unions_singleton_list =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    IML.unions [a] == a++prop_unions_two_elems =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \b ->+    IML.unions [a,b] == IML.union a b++case_unionWith = actual @?= expected+  where+    actual, expected :: IntervalMap Rational Integer+    actual = IML.unionWith (+) (IML.singleton (0 <=..<= 10) 1) (IML.singleton (5 <=..<= 15) 2)+    expected = IML.fromList [(0 <=..< 5, 1), (5 <=..<= 10, 3), (10 <..<= 15, 2)]++prop_unionWith_Lazy_Strict =+  forAll arbitrary $ \(a :: IntervalMap Rational Int) ->+  forAll arbitrary $ \b ->+  forAll arbitrary $ \f ->+    IML.unionWith (curry (apply f)) a b == IMS.unionWith (curry (apply f)) a b++prop_unionWith_nonstrict =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \b ->+    IML.unionWith (\_ _ -> bottom) a b `seq` True++prop_unionWith_strict =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \b ->+    not (IntervalSet.null (IMS.keysSet a `IntervalSet.intersection` IMS.keysSet b))+    ==>+    isBottom (IMS.unionWith (\_ _ -> bottom) a b)++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}++prop_intersection_isSubmapOf =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \b ->+      IML.isSubmapOf (IML.intersection a b) a++case_intersectionWith = actual @?= expected+  where+    actual, expected :: IntervalMap Rational Integer+    actual = IML.intersectionWith (+) (IML.singleton (0 <=..< 10) 1) (IML.singleton (5 <..<= 5) 1)+    expected = IML.singleton (5 <..< 5) 2++prop_intersectionWith_Lazy_Strict =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \(b :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \(f :: Fun (Integer,Integer) Integer) ->+    IML.intersectionWith (curry (apply f)) a b == IMS.intersectionWith (curry (apply f)) a b++prop_intersectionWith_nonstrict =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \(b :: IntervalMap Rational Integer) ->+    IML.intersectionWith (\_ _ -> bottom :: Integer) a b `seq` True++prop_intersectionWith_strict =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \(b :: IntervalMap Rational Integer) ->+    not (IntervalSet.null (IMS.keysSet a `IntervalSet.intersection` IMS.keysSet b))+    ==>+    isBottom (IMS.intersectionWith (\_ _ -> bottom :: Integer) a b)++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}++prop_difference_isSubmapOf =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \(b :: IntervalMap Rational Integer) ->+      IML.isSubmapOf (a IML.\\ b) a++{--------------------------------------------------------------------+  member / lookup+--------------------------------------------------------------------}++prop_notMember_empty =+  forAll arbitrary $ \(r::Rational) ->+    r `IML.notMember` (IML.empty :: IntervalMap Rational Integer)++case_findWithDefault_case1 = IML.findWithDefault "B" 0 m @?= "A"+  where+    m :: IntervalMap Rational String+    m = IML.singleton (0 <=..<1) "A"++case_findWithDefault_case2 = IML.findWithDefault "B" 1 m @?= "B"+  where+    m :: IntervalMap Rational String+    m = IML.singleton (0 <=..<1) "A"++{--------------------------------------------------------------------+  isSubsetOf+--------------------------------------------------------------------}++prop_isSubmapOf_reflexive =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    a `IML.isSubmapOf` a++prop_isProperSubsetOf_irreflexive =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    not (a `IML.isProperSubmapOf` a)++{--------------------------------------------------------------------+  span+--------------------------------------------------------------------}++prop_span =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    IML.span a == IntervalSet.span (IML.keysSet a)++{--------------------------------------------------------------------+  map+--------------------------------------------------------------------}++case_mapKeysMonotonic = IML.mapKeysMonotonic (+1) m1 @?= m2+  where+    m1, m2 :: IntervalMap Rational String+    m1 = IML.fromList [(0 <=..< 1, "A"), (2 <..<= 3, "B")]+    m2 = IML.fromList [(1 <=..< 2, "A"), (3 <..<= 4, "B")]++prop_map_Lazy_Strict =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \(f :: Fun Integer Integer) ->+    IML.map (apply f) m == IMS.map (apply f) m++prop_map_nonstrict =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    IML.map (const (bottom :: Integer)) a `seq` True++prop_map_strict =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    not (IMS.null a)+    ==>+    isBottom (IMS.map (const (bottom :: Integer)) a)++{--------------------------------------------------------------------+  Functor / Foldable / Traversal+--------------------------------------------------------------------}++prop_Functor_identity :: Property+prop_Functor_identity =+  forAll arbitrary $ \(m :: IntervalMap Rational Int) ->+    fmap id m == m++prop_Functor_compsition :: Property+prop_Functor_compsition =+  forAll arbitrary $ \(m :: IntervalMap Rational Int) ->+    forAll arbitrary $ \(f :: Fun Int Int) ->+      forAll arbitrary $ \(g :: Fun Int Int) ->+        fmap (apply f . apply g) m == fmap (apply f) (fmap (apply g) m)++prop_Foldable_foldMap :: Property+prop_Foldable_foldMap =+  forAll arbitrary $ \(m :: IntervalMap Rational Int) ->+    forAll arbitrary $ \(f :: Fun Int String) ->+      F.foldMap (apply f) m == F.fold (fmap (apply f) m)++prop_Traversable_identity :: Property+prop_Traversable_identity =+  forAll arbitrary $ \(m :: IntervalMap Rational Int) ->+    traverse Identity m == Identity m++{--------------------------------------------------------------------+  toList / fromList+--------------------------------------------------------------------}++prop_fromList_toList_id =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    IML.fromList (IML.toList a) == a++prop_toAscList_toDescList =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    IML.toDescList a == reverse (IML.toAscList a)++case_fromList = actual @?= expected+  where+    actual, expected :: IntervalMap Rational Integer+    actual = IML.fromList [(0 <=..< 10, 1), (5 <..<= 15, 2)]+    expected = IML.fromList [(0 <=..<= 5, 1), (5 <..<= 15, 2)]++case_fromListWith = actual @?= expected+  where+    actual, expected :: IntervalMap Rational Integer+    actual = IML.fromListWith (+) [(0 <=..< 10, 1), (5 <..<= 15, 2)]+    expected = IML.fromList [(0 <=..<= 5, 1), (5 <..< 10, 3), (10 <=..<= 15, 2)]++prop_fromList_Lazy_Strict =+  forAll arbitrary $ \xs ->+    (IML.fromList xs :: IntervalMap Rational Integer) == IMS.fromList xs++case_fromList_nonstrict = evaluate m >> return ()+  where+    m :: IntervalMap Rational Integer+    m = IML.fromList [(0 <=..< 10, bottom), (5 <..<= 15, bottom)]++case_fromList_strict = isBottom m @?= True+  where+    m :: IntervalMap Rational Integer+    m = IMS.fromList [(0 <=..< 10, bottom), (5 <..<= 15, bottom)]++prop_fromListWith_Lazy_Strict =+  forAll arbitrary $ \xs ->+    forAll arbitrary $ \f ->+      (IML.fromListWith (curry (apply f)) xs :: IntervalMap Rational Integer) == IMS.fromListWith (curry (apply f))  xs++case_fromListWith_nonstrict = evaluate m >> return ()+  where+    m :: IntervalMap Rational Integer+    m = IML.fromListWith (\_ _ -> bottom) [(0 <=..< 10, 1), (5 <..<= 15, 2)]++case_fromListWith_strict = isBottom m @?= True+  where+    m :: IntervalMap Rational Integer+    m = IMS.fromListWith (\_ _ -> bottom) [(0 <=..< 10, 1), (5 <..<= 15, 2)]++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}++case_filter = actual @?= expected+  where+    m, expected, actual :: IntervalMap Rational Integer+    m =+      IML.fromList+      [ (2  <..<= 10, 1)+      , (10 <..<= 20, 2)+      , (20 <..<= 30, 3)+      , (30 <..<= 40, 4)+      ]+    expected =+      IML.fromList+      [ (10 <..<= 20, 2)+      , (30 <..<= 40, 4)+      ]+    actual = IML.filter even m++prop_split =+  forAll arbitrary $ \(m :: IntervalMap Rational Integer) ->+    forAll arbitrary $ \i ->+      not (Interval.null i)+      ==>+      (case IML.split i m of+         (m1,m2,m3) ->+           and+           [ and [j <! i | j <- IML.keys m1]+           , and [j `Interval.isSubsetOf` i | j <- IML.keys m2]+           , and [i <! j | j <- IML.keys m3]+           ])++case_split_case1 =+  IML.split (5 <=..<= 9) m @?= (smaller, middle, larger)+  where+    m :: IntervalMap Rational String+    m =+      IML.fromList+      [ (2  <..<= 10, "A")+      , (10 <..<= 20, "B")+      , (20 <..<= 30, "C")+      ]+    smaller =+      IML.fromList+      [ (2  <..< 5, "A")+      ]+    middle =+      IML.fromList+      [ (5 <=..<= 9, "A")+      ]+    larger =+      IML.fromList+      [ (9  <..<= 10, "A")+      , (10 <..<= 20, "B")+      , (20 <..<= 30, "C")+      ]++case_split_case2 =+  IML.split (5 <=..< 10) m @?= (smaller, middle, larger)+  where+    m :: IntervalMap Rational String+    m =+      IML.fromList+      [ (2  <..<= 10, "A")+      , (10 <..<= 20, "B")+      , (20 <..<= 30, "C")+      ]+    smaller =+      IML.fromList+      [ (2 <..< 5, "A")+      ]+    middle =+      IML.fromList+      [ (5 <=..< 10, "A")+      ]+    larger =+      IML.fromList+      [ (10, "A")+      , (10 <..<= 20, "B")+      , (20 <..<= 30, "C")+      ]++case_split_case3 =+  IML.split (5 <=..<= 10) m @?= (smaller, middle, larger)+  where+    m :: IntervalMap Rational String+    m =+      IML.fromList+      [ (2  <..<= 10, "A")+      , (10 <..<= 20, "B")+      , (20 <..<= 30, "C")+      ]+    smaller =+      IML.fromList+      [ (2  <..< 5, "A")+      ]+    middle =+      IML.fromList+      [ (5 <=..<= 10, "A")+      ]+    larger =+      IML.fromList+      [ (10 <..<= 20, "B")+      , (20 <..<= 30, "C")+      ]++case_split_case4 =+  IML.split (5 <=..< 10) m @?= (smaller, middle, larger)+  where+    m :: IntervalMap Rational String+    m =+      IML.fromList+      [ (2   <..<  10, "A")+      , (10 <=..<= 20, "B")+      , (20  <..<= 30, "C")+      ]+    smaller =+      IML.fromList+      [ (2  <..< 5, "A")+      ]+    middle =+      IML.fromList+      [ (5 <=..< 10, "A")+      ]+    larger =+      IML.fromList+      [ (10 <=..<= 20, "B")+      , (20  <..<= 30, "C")+      ]++case_split_case5 =+  IML.split (5 <=..<= 10) m @?= (smaller, middle, larger)+  where+    m :: IntervalMap Rational String+    m =+      IML.fromList+      [ (2   <..<  10, "A")+      , (10 <=..<= 20, "B")+      , (20  <..<= 30, "C")+      ]+    smaller =+      IML.fromList+      [ (2  <..< 5, "A")+      ]+    middle =+      IML.fromList+      [ (5 <=..< 10, "A")+      , (10, "B")+      ]+    larger =+      IML.fromList+      [ (10 <..<= 20, "B")+      , (20 <..<= 30, "C")+      ]++case_split_case6 =+  IML.split (5 <=..< 20) m @?= (smaller, middle, larger)+  where+    m :: IntervalMap Rational String+    m =+      IML.fromList+      [ (2   <..<  10, "A")+      , (10 <=..<= 20, "B")+      , (20  <..<= 30, "C")+      ]+    smaller =+      IML.fromList+      [ (2  <..< 5, "A")+      ]+    middle =+      IML.fromList+      [ (5  <=..< 10, "A")+      , (10 <=..< 20, "B")+      ]+    larger =+      IML.fromList+      [ (20, "B")+      , (20 <..<= 30, "C")+      ]++case_split_case7 =+  IML.split (5 <=..<= 20) m @?= (smaller, middle, larger)+  where+    m :: IntervalMap Rational String+    m =+      IML.fromList+      [ (2   <..<  10, "A")+      , (10 <=..<= 20, "B")+      , (20  <..<= 30, "C")+      ]+    smaller =+      IML.fromList+      [ (2  <..< 5, "A")+      ]+    middle =+      IML.fromList+      [ (5  <=..<  10, "A")+      , (10 <=..<= 20, "B")+      ]+    larger =+      IML.fromList+      [ (20 <..<= 30, "C")+      ]++case_split_case8 =+  IML.split (5 <=..< 21) m @?= (smaller, middle, larger)+  where+    m :: IntervalMap Rational String+    m =+      IML.fromList+      [ (2   <..<  10, "A")+      , (10 <=..<= 20, "B")+      , (20  <..<= 30, "C")+      ]+    smaller =+      IML.fromList+      [ (2  <..< 5, "A")+      ]+    middle =+      IML.fromList+      [ (5  <=..<  10, "A")+      , (10 <=..<= 20, "B")+      , (20  <..<  21, "C")+      ]+    larger =+      IML.fromList+      [ (21 <=..<= 30, "C")+      ]++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}++prop_Eq_reflexive =+  forAll arbitrary $ \(i :: IntervalMap Rational Integer) ->+    i == i++{--------------------------------------------------------------------+  Show / Read+--------------------------------------------------------------------}++prop_show_read_invariance =+  forAll arbitrary $ \(i :: IntervalMap Rational Integer) ->+    i == read (show i)++{--------------------------------------------------------------------+  Monoid+--------------------------------------------------------------------}++prop_monoid_assoc =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+  forAll arbitrary $ \b ->+  forAll arbitrary $ \c ->+    a <> (b <> c) == (a <> b) <> c++prop_monoid_unitL =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    mempty <> a == a++prop_monoid_unitR =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    a <> mempty == a++{--------------------------------------------------------------------+  NFData+--------------------------------------------------------------------}++prop_rnf =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    rnf a == ()++{--------------------------------------------------------------------+  Hashable+--------------------------------------------------------------------}++prop_hash =+  forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->+    hash a `seq` True++{- ------------------------------------------------------------------+  Data+------------------------------------------------------------------ -}++case_Data = everywhere f i @?= (IML.singleton (1 <=..<= 2) 3 :: IntervalMap Integer Integer)+  where+    i :: IntervalMap Integer Integer+    i = IML.singleton (0 <=..<= 1) 2+    f x+      | Just (y :: Integer) <- cast x = fromJust $ cast (y + 1)+      | otherwise = x++{--------------------------------------------------------------------+  Generators+--------------------------------------------------------------------}++instance Arbitrary r => Arbitrary (Extended r) where+  arbitrary =+    oneof+    [ return NegInf+    , return PosInf+    , liftM Finite arbitrary+    ]++instance (Arbitrary r, Ord r) => Arbitrary (Interval r) where+  arbitrary = do+    lb <- arbitrary+    ub <- arbitrary+    return $ Interval.interval lb ub++instance (Arbitrary k, Arbitrary a, Ord k) => Arbitrary (IntervalMap k a) where+  arbitrary = IML.fromList <$> listOf arbitrary++------------------------------------------------------------------------+-- Test harness++intervalMapTestGroup = $(testGroupGenerator)

@@ -0,0 +1,516 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+module TestIntervalSet (intervalSetTestGroup) where++import qualified Algebra.Lattice as L+import Control.Applicative ((<$>))+import Control.DeepSeq+import Control.Monad+import Data.Generics.Schemes+import Data.Hashable+import Data.Maybe+import Data.Monoid+import Data.Ratio+import Data.Typeable++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.TH++import Data.Interval ( Interval, Extended (..), (<=..<=), (<=..<), (<..<=), (<..<) )+import qualified Data.Interval as Interval+import Data.IntervalSet (IntervalSet)+import qualified Data.IntervalSet as IntervalSet++{--------------------------------------------------------------------+  empty+--------------------------------------------------------------------}++prop_empty_is_bottom =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.isSubsetOf IntervalSet.empty a++prop_null_empty =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.null a == (a == IntervalSet.empty)++case_null_empty =+  IntervalSet.null (IntervalSet.empty :: IntervalSet Rational) @?= True++{--------------------------------------------------------------------+  whole+--------------------------------------------------------------------}++prop_whole_is_top =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.isSubsetOf a IntervalSet.whole++case_nonnull_top =+  IntervalSet.null (IntervalSet.whole :: IntervalSet Rational) @?= False++{--------------------------------------------------------------------+  singleton+--------------------------------------------------------------------}++prop_singleton_member =+  forAll arbitrary $ \r ->+    IntervalSet.member (r::Rational) (fromRational r)++prop_singleton_nonnull =+  forAll arbitrary $ \r1 ->+    not $ IntervalSet.null $ fromRational (r1::Rational)++{--------------------------------------------------------------------+  complement+--------------------------------------------------------------------}++prop_complement_involution =+  forAll arbitrary $ \(s :: IntervalSet Rational) ->+    IntervalSet.complement (IntervalSet.complement s) == s++prop_complement_union =+  forAll arbitrary $ \(is :: IntervalSet Rational) ->+    IntervalSet.union is (IntervalSet.complement is) == IntervalSet.whole++prop_complement_intersection =+  forAll arbitrary $ \(is :: IntervalSet Rational) ->+    IntervalSet.intersection is (IntervalSet.complement is) == IntervalSet.empty++{--------------------------------------------------------------------+  fromList+--------------------------------------------------------------------}++case_fromList_connected =+  IntervalSet.fromList [ (0 <=..< 1 :: Interval Rational), 1 <=..<2 ]+  @?= IntervalSet.fromList [ 0 <=..<2 ]++{--------------------------------------------------------------------+  insert+--------------------------------------------------------------------}++prop_insert_Interval_whole =+  forAll arbitrary $ \(i :: Interval Rational) ->+     IntervalSet.insert i IntervalSet.whole == IntervalSet.whole++prop_insert_whole_IntervalSet =+  forAll arbitrary $ \(is :: IntervalSet Rational) ->+     IntervalSet.insert Interval.whole is == IntervalSet.whole++prop_insert_comm =+  forAll arbitrary $ \(is :: IntervalSet Rational) ->+  forAll arbitrary $ \(i1 :: Interval Rational) ->+  forAll arbitrary $ \(i2 :: Interval Rational) ->+     IntervalSet.insert i1 (IntervalSet.insert i2 is)+     ==+     IntervalSet.insert i2 (IntervalSet.insert i1 is)++case_insert_connected =+  IntervalSet.insert (1 <=..< 2 :: Interval Rational) (IntervalSet.fromList [ 0 <=..< 1, 2 <=..< 3 ])+  @?= IntervalSet.singleton (0 <=..< 3)++{--------------------------------------------------------------------+  delete+--------------------------------------------------------------------}++prop_delete_Interval_empty =+  forAll arbitrary $ \(i :: Interval Rational) ->+     IntervalSet.delete i IntervalSet.empty == IntervalSet.empty++prop_delete_empty_IntervalSet =+  forAll arbitrary $ \(is :: IntervalSet Rational) ->+     IntervalSet.delete Interval.empty is == is++prop_delete_comm =+  forAll arbitrary $ \(is :: IntervalSet Rational) ->+  forAll arbitrary $ \(i1 :: Interval Rational) ->+  forAll arbitrary $ \(i2 :: Interval Rational) ->+     IntervalSet.delete i1 (IntervalSet.delete i2 is)+     ==+     IntervalSet.delete i2 (IntervalSet.delete i1 is)++case_delete_connected =+  IntervalSet.delete (1 <=..< 2) (IntervalSet.fromList [ 0 <=..< 3 :: Interval Rational ])+  @?=  (IntervalSet.fromList [ 0 <=..< 1, 2 <=..< 3 ])++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}++prop_intersection_comm =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    IntervalSet.intersection a b == IntervalSet.intersection b a++prop_intersection_assoc =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+  forAll arbitrary $ \c ->+    IntervalSet.intersection a (IntervalSet.intersection b c) ==+    IntervalSet.intersection (IntervalSet.intersection a b) c++prop_intersection_unitL =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.intersection IntervalSet.whole a == a++prop_intersection_unitR =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.intersection a IntervalSet.whole == a++prop_intersection_empty =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.intersection a IntervalSet.empty == IntervalSet.empty++prop_intersection_isSubsetOf =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    IntervalSet.isSubsetOf (IntervalSet.intersection a b) a++prop_intersection_isSubsetOf_equiv =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    (IntervalSet.intersection a b == a)+    == IntervalSet.isSubsetOf a b++case_intersections_empty_list =+  IntervalSet.intersections [] @?= (IntervalSet.whole :: IntervalSet Rational)++prop_intersections_singleton_list =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.intersections [a] == a++prop_intersections_two_elems =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    IntervalSet.intersections [a,b] == IntervalSet.intersection a b++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}++prop_union_comm =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    IntervalSet.union a b == IntervalSet.union b a++prop_union_assoc =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+  forAll arbitrary $ \c ->+    IntervalSet.union a (IntervalSet.union b c) ==+    IntervalSet.union (IntervalSet.union a b) c++prop_union_unitL =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.union IntervalSet.empty a == a++prop_union_unitR =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.union a IntervalSet.empty == a++prop_union_whole =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.union a IntervalSet.whole == IntervalSet.whole++prop_union_isSubsetOf =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    IntervalSet.isSubsetOf a (IntervalSet.union a b)++prop_union_isSubsetOf_equiv =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    (IntervalSet.union a b == b)+    == IntervalSet.isSubsetOf a b++case_unions_empty_list =+  IntervalSet.unions [] @?= (IntervalSet.empty :: IntervalSet Rational)++prop_unions_singleton_list =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.unions [a] == a++prop_unions_two_elems =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    IntervalSet.unions [a,b] == IntervalSet.union a b++prop_union_intersection_duality =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    IntervalSet.complement (IntervalSet.union a b) ==+    IntervalSet.intersection (IntervalSet.complement a) (IntervalSet.complement b)++{--------------------------------------------------------------------+  span+--------------------------------------------------------------------}++prop_span =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    a `IntervalSet.isSubsetOf` IntervalSet.singleton (IntervalSet.span a)++case_span_empty =+  IntervalSet.span IntervalSet.empty @?= (Interval.empty :: Interval Rational)++{--------------------------------------------------------------------+  member+--------------------------------------------------------------------}++prop_notMember_empty =+  forAll arbitrary $ \(r::Rational) ->+    r `IntervalSet.notMember` IntervalSet.empty++{--------------------------------------------------------------------+  isSubsetOf+--------------------------------------------------------------------}++prop_isSubsetOf_reflexive =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    a `IntervalSet.isSubsetOf` a++prop_isProperSubsetOf_irreflexive =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    not (a `IntervalSet.isProperSubsetOf` a)++{--------------------------------------------------------------------+  toList / fromList+--------------------------------------------------------------------}++prop_fromList_toList_id =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.fromList (IntervalSet.toList a) == a++prop_toAscList_toDescList =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.toDescList a == reverse (IntervalSet.toAscList a)++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}++prop_Eq_reflexive =+  forAll arbitrary $ \(i :: IntervalSet Rational) ->+    i == i++{--------------------------------------------------------------------+  Lattice+--------------------------------------------------------------------}++prop_Lattice_Leq_welldefined =+  forAll arbitrary $ \(a :: IntervalSet Rational) (b :: IntervalSet Rational) ->+    a `L.meetLeq` b == a `L.joinLeq` b++prop_top =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    a `L.joinLeq` L.top++prop_bottom =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    L.bottom `L.joinLeq` a++{--------------------------------------------------------------------+  Show / Read+--------------------------------------------------------------------}++prop_show_read_invariance =+  forAll arbitrary $ \(i :: IntervalSet Rational) ->+    i == read (show i)++{--------------------------------------------------------------------+  NFData+--------------------------------------------------------------------}++prop_rnf =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    rnf a == ()++{--------------------------------------------------------------------+  Hashable+--------------------------------------------------------------------}++prop_hash =+  forAll arbitrary $ \(i :: IntervalSet Rational) ->+    hash i `seq` True++{--------------------------------------------------------------------+  Monoid+--------------------------------------------------------------------}++prop_monoid_assoc =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+  forAll arbitrary $ \c ->+    a <> (b <> c) == (a <> b) <> c++prop_monoid_unitL =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    mempty <> a == a++prop_monoid_unitR =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    a <> mempty == a++{--------------------------------------------------------------------+  Num+--------------------------------------------------------------------}++prop_scale_empty =+  forAll arbitrary $ \r ->+    fromRational (r::Rational) * IntervalSet.empty == IntervalSet.empty++prop_add_comm =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    a + b == b + a++prop_add_assoc =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+  forAll arbitrary $ \c ->+    a + (b + c) == (a + b) + c++prop_add_unitL =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.singleton 0 + a == a++prop_add_unitR =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    a + IntervalSet.singleton 0 == a++prop_add_member =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    and [ (x+y) `IntervalSet.member` (a+b)+        | x <- maybeToList $ pickup a+        , y <- maybeToList $ pickup b+        ]++prop_mult_comm =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    a * b == b * a++prop_mult_assoc =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+  forAll arbitrary $ \c ->+    a * (b * c) == (a * b) * c++prop_mult_unitL =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.singleton 1 * a == a++prop_mult_unitR =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    a * IntervalSet.singleton 1 == a++prop_mult_dist =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+  forAll arbitrary $ \c ->+    (a * (b + c)) `IntervalSet.isSubsetOf` (a * b + a * c)++prop_mult_empty =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    IntervalSet.empty * a == IntervalSet.empty++prop_mult_zero =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    not (IntervalSet.null a) ==> IntervalSet.singleton 0 * a ==  IntervalSet.singleton 0++prop_mult_member =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+  forAll arbitrary $ \b ->+    and [ (x*y) `IntervalSet.member` (a*b)+        | x <- maybeToList $ pickup a+        , y <- maybeToList $ pickup b+        ]++prop_abs_signum =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    abs (signum a) `IntervalSet.isSubsetOf` IntervalSet.singleton (0 <=..<= 1)++prop_negate_negate =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    negate (negate a) == a++{--------------------------------------------------------------------+  Fractional+--------------------------------------------------------------------}++prop_recip_singleton =+  forAll arbitrary $ \r ->+    let n = fromIntegral (numerator r)+        d = fromIntegral (denominator r)+    in fromRational n / fromRational d == (fromRational (r::Rational) :: IntervalSet Rational)++prop_recip_zero =+  forAll arbitrary $ \(a :: IntervalSet Rational) ->+    0 `IntervalSet.member` a ==> recip a == IntervalSet.whole++{- ------------------------------------------------------------------+  Data+------------------------------------------------------------------ -}++case_Data = everywhere f i @?= (IntervalSet.singleton (1 <=..<= 2) :: IntervalSet Integer)+  where+    i :: IntervalSet Integer+    i = IntervalSet.singleton (0 <=..<= 1)+    f x+      | Just (y :: Integer) <- cast x = fromJust $ cast (y + 1)+      | otherwise = x++{--------------------------------------------------------------------+  Generators+--------------------------------------------------------------------}++instance Arbitrary r => Arbitrary (Extended r) where+  arbitrary =+    oneof+    [ return NegInf+    , return PosInf+    , liftM Finite arbitrary+    ]++instance (Arbitrary r, Ord r) => Arbitrary (Interval r) where+  arbitrary = do+    lb <- arbitrary+    ub <- arbitrary+    return $ Interval.interval lb ub++instance (Arbitrary r, Ord r) => Arbitrary (IntervalSet r) where+  arbitrary =  do+    b <- arbitrary+    if b then+      return IntervalSet.whole+    else do+      xs <- IntervalSet.fromList <$> listOf arbitrary+      b2 <- arbitrary+      if b2 then+        return xs+      else+        return $ IntervalSet.complement xs++intervals :: Gen (Interval Rational)+intervals = arbitrary++pos :: Interval Rational+pos = 0 <..< PosInf++neg :: Interval Rational+neg = NegInf <..< 0++nonpos :: Interval Rational+nonpos = NegInf <..<= 0++nonneg :: Interval Rational+nonneg = 0 <=..< PosInf++pickup :: (Ord r, Real r, Fractional r) => IntervalSet r -> Maybe r+pickup xs = do+  x <- listToMaybe (IntervalSet.toList xs)+  Interval.pickup x++------------------------------------------------------------------------+-- Test harness++intervalSetTestGroup = $(testGroupGenerator)

@@ -0,0 +1,15 @@+module Main where++import TestInterval+import TestIntervalMap+import TestIntervalSet+import TestIntegerInterval+import Test.Tasty++main :: IO ()+main = defaultMain $ testGroup "data-interval test suite"+  [ intervalTestGroup+  , intervalMapTestGroup+  , intervalSetTestGroup+  , integerIntervalTestGroup+  ]