diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -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 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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](), this package provides both open and closed intervals and is intended to be used diff --git a/data-interval.cabal b/data-interval.cabal --- a/data-interval.cabal +++ b/data-interval.cabal @@ -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 (), 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 - - diff --git a/src/Data/IntegerInterval.hs b/src/Data/IntegerInterval.hs --- a/src/Data/IntegerInterval.hs +++ b/src/Data/IntegerInterval.hs @@ -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 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 diff --git a/src/Data/Interval.hs b/src/Data/Interval.hs --- a/src/Data/Interval.hs +++ b/src/Data/Interval.hs @@ -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 (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@? ( Interval r -> Interval r -> Bool a 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 diff --git a/src/Data/IntervalMap/Base.hs b/src/Data/IntervalMap/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntervalMap/Base.hs @@ -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) diff --git a/src/Data/IntervalMap/Lazy.hs b/src/Data/IntervalMap/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntervalMap/Lazy.hs @@ -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 diff --git a/src/Data/IntervalMap/Strict.hs b/src/Data/IntervalMap/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntervalMap/Strict.hs @@ -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 diff --git a/src/Data/IntervalSet.hs b/src/Data/IntervalSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntervalSet.hs @@ -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) diff --git a/test/TestIntegerInterval.hs b/test/TestIntegerInterval.hs --- a/test/TestIntegerInterval.hs +++ b/test/TestIntegerInterval.hs @@ -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) diff --git a/test/TestInterval.hs b/test/TestInterval.hs --- a/test/TestInterval.hs +++ b/test/TestInterval.hs @@ -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 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) diff --git a/test/TestIntervalMap.hs b/test/TestIntervalMap.hs new file mode 100644 --- /dev/null +++ b/test/TestIntervalMap.hs @@ -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 (..), (<=..<=), (<=..<), (<..<=), (<..<), ( + 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 == 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) diff --git a/test/TestIntervalSet.hs b/test/TestIntervalSet.hs new file mode 100644 --- /dev/null +++ b/test/TestIntervalSet.hs @@ -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) diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -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 + ]