data-interval 1.3.1 → 2.1.2
raw patch · 19 files changed
Files
- CHANGELOG.markdown +38/−0
- README.md +1/−1
- data-interval.cabal +38/−24
- src/Data/IntegerInterval.hs +111/−53
- src/Data/IntegerInterval/Internal.hs +46/−12
- src/Data/Interval.hs +285/−100
- src/Data/Interval/Internal.hs +181/−29
- src/Data/IntervalMap/Base.hs +48/−56
- src/Data/IntervalMap/Lazy.hs +0/−1
- src/Data/IntervalMap/Strict.hs +9/−11
- src/Data/IntervalRelation.hs +82/−0
- src/Data/IntervalSet.hs +54/−81
- test/TestInstances.hs +47/−0
- test/TestIntegerInterval.hs +108/−7
- test/TestInterval.hs +459/−21
- test/TestIntervalMap.hs +105/−6
- test/TestIntervalRelation.hs +154/−0
- test/TestIntervalSet.hs +187/−22
- test/TestSuite.hs +2/−0
CHANGELOG.markdown view
@@ -1,3 +1,41 @@+2.1.2+-----++* fix `Data.IntegerInterval.width` (#38, thanks to ncfavier)+* add `Data.IntegerInterval.memberCount` (#44, thanks to ncfavier)+* add `instance Ord` for `Interval`, `IntervalSet` and `IntervalMap` (#41, thanks to googleson78)+* fix `Data.IntervalSet.insert` (#43)++2.1.1+-----++* fix boundary comparison in `relate` (#30, thanks to marcosh)+* fix behaviour of `lattices` flag++2.1.0+-----++* introduce operations for Allen's interval algebra (#18, thanks to marcosh)+* make `recip` precise when 0 is not an interior point (#21)+* add `instance Storable` for `Interval` (#25)+* add `instance Floating` for `Interval` (#26)++2.0.0+-----+* change internal representation of `Interval` and `IntegerInterval` to+ reduce memory footprint (#7, thanks Bodigrim)+* introduce `Boundary` type (#10, thanks Bodigrim)+* export `isSingleton` function for `Interval` and `IntegerInterval` (#13)+* remove deprecated `EndPoint` data type (#14, thanks Bodigrim)++1.3.1+-----+* support lattices-2.0 (Thanks to Bodigrim).+* move definitions of `Interval` and `IntegerInterval` data types into+ internal modules and abstract away representations from the rest of+ modules (Thanks to Bodigrim).++ 1.3.0 ----- * add `Data.IntervalSet`, `Data.IntervalMap.Lazy`, `Data.IntervalMap.Strict` modules
README.md view
@@ -1,7 +1,7 @@ data-interval ============= -[](https://travis-ci.org/msakai/data-interval)+[](https://github.com/msakai/data-interval/actions/workflows/build.yaml) [](https://hackage.haskell.org/package/data-interval) [](https://packdeps.haskellers.com/feed?needle=data-interval) [](https://coveralls.io/r/msakai/data-interval)
data-interval.cabal view
@@ -1,11 +1,11 @@ Name: data-interval-Version: 1.3.1+Version: 2.1.2 License: BSD3 License-File: COPYING Author: Masahiro Sakai (masahiro.sakai@gmail.com) Maintainer: masahiro.sakai@gmail.com Category: Data, Math-Cabal-Version: >= 1.10+Cabal-Version: 2.0 Synopsis: Interval datatype, interval arithmetic and interval-based containers Description: Interval datatype, interval arithmetic and interval-based containers for Haskell.@@ -13,47 +13,55 @@ this package provides both open and closed intervals and is intended to be used with exact number types such as Rational and Integer. Bug-Reports: https://github.com/msakai/data-interval/issues-Extra-Source-Files:+Extra-Doc-Files: README.md- COPYING CHANGELOG.markdown Build-Type: Simple Tested-With:- GHC ==7.8.4- GHC ==7.10.3- GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4- GHC ==8.6.4+ GHC ==8.6.5+ GHC ==8.8.4+ GHC ==8.10.7+ GHC ==9.0.2+ GHC ==9.2.8+ GHC ==9.4.7+ GHC ==9.6.2+ GHC ==9.8.1 source-repository head type: git- location: git://github.com/msakai/data-interval.git+ location: https://github.com/msakai/data-interval +flag lattices+ description: Derive lattice instances+ default: True+ Library Hs-source-dirs: src Build-Depends:- base >=4 && <5- , containers- , lattices >=1.2.1.1 && <2.1- , deepseq- , hashable >=1.1.2.5 && <1.4+ base >=4.10 && <5+ , containers >= 0.5.8 && < 0.8+ , deepseq < 1.6+ , hashable >=1.1.2.5 && <1.5 , extended-reals >=0.2 && <1.0- if impl(ghc <8.0)- Build-depends:- semigroups+ if flag(lattices)+ build-depends:+ lattices >=2 && <2.3 Default-Language: Haskell2010 Other-Extensions:- CPP ScopedTypeVariables TypeFamilies DeriveDataTypeable+ DeriveGeneric+ LambdaCase MultiWayIf Safe Exposed-Modules: Data.Interval Data.IntervalMap.Lazy Data.IntervalMap.Strict+ Data.IntervalRelation Data.IntervalSet Data.IntegerInterval Other-Modules:@@ -65,25 +73,31 @@ Type: exitcode-stdio-1.0 HS-Source-Dirs: test Main-is: TestSuite.hs- Other-Modules: TestInterval, TestIntervalMap, TestIntervalSet, TestIntegerInterval+ Other-Modules:+ TestInterval+ TestIntervalMap+ TestIntervalRelation+ TestIntervalSet+ TestIntegerInterval+ TestInstances Build-depends: base >=4 && <5 , ChasingBottoms , containers- , lattices , deepseq , hashable , data-interval , syb , tasty >=0.10.1 , tasty-hunit >=0.9 && <0.11- , tasty-quickcheck >=0.8 && <0.11+ , tasty-quickcheck >=0.8.1 && <0.11 , tasty-th , HUnit , QuickCheck >=2.5 && <3- if impl(ghc <7.10)- Build-depends:- transformers >=0.2+ , quickcheck-classes-base+ if flag(lattices)+ build-depends:+ lattices Default-Language: Haskell2010 Other-Extensions: TemplateHaskell
src/Data/IntegerInterval.hs view
@@ -13,7 +13,7 @@ -- -- Interval datatype and interval arithmetic over integers. ----- Since 1.2.0+-- @since 1.2.0 -- -- For the purpose of abstract interpretation, it might be convenient to use -- 'Lattice' instance. See also lattices package@@ -25,6 +25,7 @@ -- * Interval type IntegerInterval , module Data.ExtendedReal+ , Boundary(..) -- * Construction , interval@@ -38,15 +39,18 @@ -- * Query , null+ , isSingleton , member , notMember , isSubsetOf , isProperSubsetOf+ , isConnected , lowerBound , upperBound , lowerBound' , upperBound' , width+ , memberCount -- * Universal comparison operators , (<!), (<=!), (==!), (>=!), (>!), (/=!)@@ -75,17 +79,24 @@ , fromInterval , fromIntervalOver , fromIntervalUnder++ -- * Intervals relation+ , relate ) where +#ifdef MIN_VERSION_lattices import Algebra.Lattice+#endif import Control.Exception (assert) import Control.Monad hiding (join) import Data.ExtendedReal-import Data.List hiding (null)+import Data.List (foldl') import Data.Maybe import Prelude hiding (null) import Data.IntegerInterval.Internal-import qualified Data.Interval as Interval+import Data.Interval.Internal (Boundary(..))+import qualified Data.Interval.Internal as Interval+import Data.IntervalRelation infix 5 <..<= infix 5 <=..<@@ -111,22 +122,21 @@ -- | 'lowerBound' of the interval and whether it is included in the interval. -- The result is convenient to use as an argument for 'interval'.-lowerBound' :: IntegerInterval -> (Extended Integer, Bool)+lowerBound' :: IntegerInterval -> (Extended Integer, Boundary) lowerBound' x = case lowerBound x of- lb@(Finite _) -> (lb, True)- lb@_ -> (lb, False)+ lb@(Finite _) -> (lb, Closed)+ lb@_ -> (lb, Open) -- | 'upperBound' of the interval and whether it is included in the interval. -- The result is convenient to use as an argument for 'interval'.-upperBound' :: IntegerInterval -> (Extended Integer, Bool)+upperBound' :: IntegerInterval -> (Extended Integer, Boundary) upperBound' x = case upperBound x of- ub@(Finite _) -> (ub, True)- ub@_ -> (ub, False)--#if MIN_VERSION_lattices(2,0,0)+ ub@(Finite _) -> (ub, Closed)+ ub@_ -> (ub, Open) +#ifdef MIN_VERSION_lattices instance Lattice IntegerInterval where (\/) = hull (/\) = intersection@@ -136,32 +146,13 @@ instance BoundedMeetSemiLattice IntegerInterval where top = whole--#else--instance JoinSemiLattice IntegerInterval where- join = hull--instance MeetSemiLattice IntegerInterval where- meet = intersection--instance Lattice IntegerInterval--instance BoundedJoinSemiLattice IntegerInterval where- bottom = empty--instance BoundedMeetSemiLattice IntegerInterval where- top = whole--instance BoundedLattice IntegerInterval- #endif instance Show IntegerInterval where showsPrec _ x | null x = showString "empty" showsPrec p x = showParen (p > rangeOpPrec) $- showsPrec (rangeOpPrec+1) (lowerBound x) . + showsPrec (rangeOpPrec+1) (lowerBound x) . showString " <=..<= " . showsPrec (rangeOpPrec+1) (upperBound x) @@ -184,11 +175,11 @@ -- | 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+ :: (Extended Integer, Boundary) -- ^ lower bound and whether it is included+ -> (Extended Integer, Boundary) -- ^ upper bound and whether it is included -> IntegerInterval interval (x1,in1) (x2,in2) =- (if in1 then x1 else x1 + 1) <=..<= (if in2 then x2 else x2 - 1)+ (if in1 == Closed then x1 else x1 + 1) <=..<= (if in2 == Closed then x2 else x2 - 1) -- | left-open right-closed interval (@l@,@u@] (<..<=)@@ -215,7 +206,7 @@ whole :: IntegerInterval whole = NegInf <=..<= PosInf --- | singleton set \[x,x\]+-- | singleton set [x,x] singleton :: Integer -> IntegerInterval singleton x = Finite x <=..<= Finite x @@ -248,6 +239,9 @@ null :: IntegerInterval -> Bool null x = upperBound x < lowerBound x +-- | Is the interval single point?+--+-- @since 2.0.0 isSingleton :: IntegerInterval -> Bool isSingleton x = lowerBound x == upperBound x @@ -268,15 +262,43 @@ isProperSubsetOf :: IntegerInterval -> IntegerInterval -> Bool isProperSubsetOf i1 i2 = i1 /= i2 && i1 `isSubsetOf` i2 +-- | Does the union of two range form a set which is the intersection between the integers and a connected real interval?+isConnected :: IntegerInterval -> IntegerInterval -> Bool+isConnected x y = null x || null y || x ==? y || lb1nearUb2 || ub1nearLb2+ where+ lb1 = lowerBound x+ lb2 = lowerBound y+ ub1 = upperBound x+ ub2 = upperBound y++ lb1nearUb2 = case (lb1, ub2) of+ (Finite lb1Int, Finite ub2Int) -> lb1Int == ub2Int + 1+ _ -> False++ ub1nearLb2 = case (ub1, lb2) of+ (Finite ub1Int, Finite lb2Int) -> ub1Int + 1 == lb2Int+ _ -> False+ -- | Width of a interval. Width of an unbounded interval is @undefined@. width :: IntegerInterval -> Integer width x | null x = 0 | otherwise =- case (upperBound x, lowerBound x) of+ case (lowerBound x, upperBound x) of (Finite lb, Finite ub) -> ub - lb _ -> error "Data.IntegerInterval.width: unbounded interval" +-- | How many integers lie within the (bounded) interval.+-- Equal to @Just (width + 1)@ for non-empty, bounded intervals.+-- The @memberCount@ of an unbounded interval is @Nothing@.+memberCount :: IntegerInterval -> Maybe Integer+memberCount x+ | null x = Just 0+ | otherwise =+ case (lowerBound x, upperBound x) of+ (Finite lb, Finite ub) -> Just (ub - lb + 1)+ _ -> Nothing+ -- | pick up an element from the interval if the interval is not empty. pickup :: IntegerInterval -> Maybe Integer pickup x =@@ -292,7 +314,7 @@ -- -- * @'abs' y <= 'abs' y'@ ----- (see also 'approxRational' and 'Interval.simplestRationalWithin')+-- (see also 'Data.Ratio.approxRational' and 'Interval.simplestRationalWithin') simplestIntegerWithin :: IntegerInterval -> Maybe Integer simplestIntegerWithin i | null i = Nothing@@ -385,9 +407,9 @@ then f a b else liftM (\(y,x) -> (x,y)) $ f b a where- f a b = do- x <- pickup a- y <- msum [pickup (b `intersection` c) | c <- [-inf <..< Finite x, Finite x <..< inf]]+ f i j = do+ x <- pickup i+ y <- msum [pickup (j `intersection` c) | c <- [-inf <..< Finite x, Finite x <..< inf]] return (x,y) -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@?@@ -456,31 +478,67 @@ -- | Convert the interval to 'Interval.Interval' data type. toInterval :: Real r => IntegerInterval -> Interval.Interval r-toInterval x = fmap fromInteger (lowerBound x) Interval.<=..<= fmap fromInteger (upperBound x)+toInterval x = Interval.interval+ (fmap fromInteger (lowerBound x), Closed)+ (fmap fromInteger (upperBound x), Closed) -- | Conversion from 'Interval.Interval' data type. fromInterval :: Interval.Interval Integer -> IntegerInterval-fromInterval i = (if in1 then x1 else x1 + 1) <=..<= (if in2 then x2 else x2 - 1)+fromInterval i = x1' <=..<= x2' where (x1,in1) = Interval.lowerBound' i (x2,in2) = Interval.upperBound' i+ x1' = case in1 of+ Interval.Open -> x1 + 1+ Interval.Closed -> x1+ x2' = case in2 of+ Interval.Open -> x2 - 1+ Interval.Closed -> x2 -- | Given a 'Interval.Interval' @I@ over R, compute the smallest 'IntegerInterval' @J@ such that @I ⊆ J@. fromIntervalOver :: RealFrac r => Interval.Interval r -> IntegerInterval fromIntervalOver i = fmap floor lb <=..<= fmap ceiling ub where- lb = Interval.lowerBound i- ub = Interval.upperBound i+ (lb, _) = Interval.lowerBound' i+ (ub, _) = Interval.upperBound' i -- | Given a 'Interval.Interval' @I@ over R, compute the largest 'IntegerInterval' @J@ such that @J ⊆ I@. fromIntervalUnder :: RealFrac r => Interval.Interval r -> IntegerInterval-fromIntervalUnder i = fmap f lb <=..<= fmap g ub+fromIntervalUnder i = lb <=..<= ub where- lb = Interval.lowerBound i- ub = Interval.upperBound i- f x = if fromIntegral y `Interval.member` i then y else y+1- where- y = ceiling x- g x = if fromIntegral y `Interval.member` i then y else y-1- where- y = floor x+ lb = case Interval.lowerBound' i of+ (Finite x, Open)+ | fromInteger (ceiling x) == x+ -> Finite (ceiling x + 1)+ (x, _) -> fmap ceiling x+ ub = case Interval.upperBound' i of+ (Finite x, Open)+ | fromInteger (floor x) == x+ -> Finite (floor x - 1)+ (x, _) -> fmap floor x++-- | Computes how two intervals are related according to the @`Data.IntervalRelation.Relation`@ classification+relate :: IntegerInterval -> IntegerInterval -> Relation+relate i1 i2 =+ case (i1 `isSubsetOf` i2, i2 `isSubsetOf` i1) of+ -- 'i1' ad 'i2' are equal+ (True , True ) -> Equal+ -- 'i1' is strictly contained in `i2`+ (True , False) | lowerBound i1 == lowerBound i2 -> Starts+ | upperBound i1 == upperBound i2 -> Finishes+ | otherwise -> During+ -- 'i2' is strictly contained in `i1`+ (False, True ) | lowerBound i1 == lowerBound i2 -> StartedBy+ | upperBound i1 == upperBound i2 -> FinishedBy+ | otherwise -> Contains+ -- neither `i1` nor `i2` is contained in the other+ (False, False) -> case ( null (i1 `intersection` i2)+ , lowerBound i1 <= lowerBound i2+ , i1 `isConnected` i2+ ) of+ (True , True , True ) -> JustBefore+ (True , True , False) -> Before+ (True , False, True ) -> JustAfter+ (True , False, False) -> After+ (False, True , _ ) -> Overlaps+ (False, False, _ ) -> OverlappedBy
src/Data/IntegerInterval/Internal.hs view
@@ -1,9 +1,7 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, LambdaCase #-} {-# LANGUAGE Safe #-}-#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-}-#endif module Data.IntegerInterval.Internal ( IntegerInterval@@ -21,7 +19,13 @@ infix 5 <=..<= -- | The intervals (/i.e./ connected and convex subsets) over integers (__Z__).-data IntegerInterval = Interval !(Extended Integer) !(Extended Integer)+data IntegerInterval+ = Whole+ | Empty+ | Point !Integer+ | LessOrEqual !Integer+ | GreaterOrEqual !Integer+ | BothClosed !Integer !Integer deriving (Eq, Typeable) -- | Lower endpoint (/i.e./ greatest lower bound) of the interval.@@ -32,7 +36,13 @@ -- -- * 'lowerBound' of an interval may or may not be a member of the interval. lowerBound :: IntegerInterval -> Extended Integer-lowerBound (Interval lb _) = lb+lowerBound = \case+ Whole -> NegInf+ Empty -> PosInf+ Point r -> Finite r+ LessOrEqual _ -> NegInf+ GreaterOrEqual r -> Finite r+ BothClosed p _ -> Finite p -- | Upper endpoint (/i.e./ least upper bound) of the interval. --@@ -42,7 +52,13 @@ -- -- * 'upperBound' of an interval is a member of the interval. upperBound :: IntegerInterval -> Extended Integer-upperBound (Interval _ ub) = ub+upperBound = \case+ Whole -> PosInf+ Empty -> NegInf+ Point r -> Finite r+ LessOrEqual r -> Finite r+ GreaterOrEqual _ -> PosInf+ BothClosed _ p -> Finite p -- This instance preserves data abstraction at the cost of inefficiency. -- We provide limited reflection services for the sake of data abstraction.@@ -62,10 +78,22 @@ intervalDataType = mkDataType "Data.IntegerInterval.Internal.IntegerInterval" [intervalConstr] instance NFData IntegerInterval where- rnf (Interval lb ub) = rnf lb `seq` rnf ub+ rnf = \case+ Whole -> ()+ Empty -> ()+ Point r -> rnf r+ LessOrEqual r -> rnf r+ GreaterOrEqual r -> rnf r+ BothClosed p q -> rnf p `seq` rnf q instance Hashable IntegerInterval where- hashWithSalt s (Interval lb ub) = s `hashWithSalt` lb `hashWithSalt` ub+ hashWithSalt s = \case+ Whole -> s `hashWithSalt` (1 :: Int)+ Empty -> s `hashWithSalt` (2 :: Int)+ Point r -> s `hashWithSalt` (3 :: Int) `hashWithSalt` r+ LessOrEqual r -> s `hashWithSalt` (4 :: Int) `hashWithSalt` r+ GreaterOrEqual r -> s `hashWithSalt` (5 :: Int) `hashWithSalt` r+ BothClosed p q -> s `hashWithSalt` (6 :: Int) `hashWithSalt` p `hashWithSalt` q -- | closed interval [@l@,@u@] (<=..<=)@@ -74,10 +102,16 @@ -> IntegerInterval (<=..<=) PosInf _ = empty (<=..<=) _ NegInf = empty-(<=..<=) lb ub- | lb <= ub = Interval lb ub- | otherwise = empty+(<=..<=) NegInf PosInf = Whole+(<=..<=) NegInf (Finite ub) = LessOrEqual ub+(<=..<=) (Finite lb) PosInf = GreaterOrEqual lb+(<=..<=) (Finite lb) (Finite ub) =+ case compare lb ub of+ EQ -> Point lb+ LT -> BothClosed lb ub+ GT -> Empty+{-# INLINE (<=..<=) #-} -- | empty (contradicting) interval empty :: IntegerInterval-empty = Interval PosInf NegInf+empty = Empty
src/Data/Interval.hs view
@@ -1,13 +1,11 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}-{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE CPP, LambdaCase, ScopedTypeVariables #-} {-# LANGUAGE Safe #-}-#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Interval--- Copyright : (c) Masahiro Sakai 2011-2013+-- Copyright : (c) Masahiro Sakai 2011-2013, Andrew Lelechenko 2020 -- License : BSD-style -- -- Maintainer : masahiro.sakai@gmail.com@@ -30,7 +28,7 @@ -- * Interval type Interval , module Data.ExtendedReal- , EndPoint+ , Boundary(..) -- * Construction , interval@@ -44,6 +42,8 @@ -- * Query , null+ , isSingleton+ , extractSingleton , member , notMember , isSubsetOf@@ -76,14 +76,20 @@ -- * Operations , pickup , simplestRationalWithin++ -- * Intervals relation+ , relate ) where +#ifdef MIN_VERSION_lattices import Algebra.Lattice+#endif import Control.Exception (assert) import Control.Monad hiding (join) import Data.ExtendedReal import Data.Interval.Internal-import Data.List hiding (null)+import Data.IntervalRelation+import Data.List (foldl', maximumBy, minimumBy) import Data.Maybe import Data.Monoid import Data.Ratio@@ -112,8 +118,7 @@ infix 4 >?? infix 4 /=?? -#if MIN_VERSION_lattices(2,0,0)-+#ifdef MIN_VERSION_lattices instance (Ord r) => Lattice (Interval r) where (\/) = hull (/\) = intersection@@ -123,25 +128,6 @@ instance (Ord r) => BoundedMeetSemiLattice (Interval r) where top = whole--#else--instance (Ord r) => JoinSemiLattice (Interval r) where- join = hull--instance (Ord r) => MeetSemiLattice (Interval r) where- meet = intersection--instance (Ord r) => Lattice (Interval r)--instance (Ord r) => BoundedJoinSemiLattice (Interval r) where- bottom = empty--instance (Ord r) => BoundedMeetSemiLattice (Interval r) where- top = whole--instance (Ord r) => BoundedLattice (Interval r)- #endif instance (Ord r, Show r) => Show (Interval r) where@@ -154,7 +140,10 @@ where (lb, in1) = lowerBound' i (ub, in2) = upperBound' i- op = (if in1 then "<=" else "<") ++ ".." ++ (if in2 then "<=" else "<")+ op = sign in1 ++ ".." ++ sign in2+ sign = \case+ Open -> "<"+ Closed -> "<=" instance (Ord r, Read r) => Read (Interval r) where readsPrec p r =@@ -206,7 +195,7 @@ => Extended r -- ^ lower bound @l@ -> Extended r -- ^ upper bound @u@ -> Interval r-(<=..<=) lb ub = interval (lb, True) (ub, True)+(<=..<=) lb ub = interval (lb, Closed) (ub, Closed) -- | left-open right-closed interval (@l@,@u@] (<..<=)@@ -214,7 +203,7 @@ => Extended r -- ^ lower bound @l@ -> Extended r -- ^ upper bound @u@ -> Interval r-(<..<=) lb ub = interval (lb, False) (ub, True)+(<..<=) lb ub = interval (lb, Open) (ub, Closed) -- | left-closed right-open interval [@l@, @u@) (<=..<)@@ -222,7 +211,7 @@ => Extended r -- ^ lower bound @l@ -> Extended r -- ^ upper bound @u@ -> Interval r-(<=..<) lb ub = interval (lb, True) (ub, False)+(<=..<) lb ub = interval (lb, Closed) (ub, Open) -- | open interval (@l@, @u@) (<..<)@@ -230,15 +219,15 @@ => Extended r -- ^ lower bound @l@ -> Extended r -- ^ upper bound @u@ -> Interval r-(<..<) lb ub = interval (lb, False) (ub, False)+(<..<) lb ub = interval (lb, Open) (ub, Open) -- | whole real number line (-∞, ∞) whole :: Ord r => Interval r-whole = interval (NegInf, False) (PosInf, False)+whole = interval (NegInf, Open) (PosInf, Open) --- | singleton set \[x,x\]+-- | singleton set [x,x] singleton :: Ord r => r -> Interval r-singleton x = interval (Finite x, True) (Finite x, True)+singleton x = interval (Finite x, Closed) (Finite x, Closed) -- | intersection of two intervals intersection :: forall r. Ord r => Interval r -> Interval r -> Interval r@@ -246,26 +235,26 @@ (maxLB (lowerBound' i1) (lowerBound' i2)) (minUB (upperBound' i1) (upperBound' i2)) where- maxLB :: (Extended r, Bool) -> (Extended r, Bool) -> (Extended r, Bool)+ maxLB :: (Extended r, Boundary) -> (Extended r, Boundary) -> (Extended r, Boundary) maxLB (x1,in1) (x2,in2) = ( max x1 x2 , case x1 `compare` x2 of- EQ -> in1 && in2+ EQ -> in1 `min` in2 LT -> in2 GT -> in1 )- minUB :: (Extended r, Bool) -> (Extended r, Bool) -> (Extended r, Bool)+ minUB :: (Extended r, Boundary) -> (Extended r, Boundary) -> (Extended r, Boundary) minUB (x1,in1) (x2,in2) = ( min x1 x2 , case x1 `compare` x2 of- EQ -> in1 && in2+ EQ -> in1 `min` in2 LT -> in1 GT -> in2 ) -- | intersection of a list of intervals. ----- Since 0.6.0+-- @since 0.6.0 intersections :: Ord r => [Interval r] -> Interval r intersections = foldl' intersection whole @@ -278,26 +267,26 @@ (minLB (lowerBound' i1) (lowerBound' i2)) (maxUB (upperBound' i1) (upperBound' i2)) where- maxUB :: (Extended r, Bool) -> (Extended r, Bool) -> (Extended r, Bool)+ maxUB :: (Extended r, Boundary) -> (Extended r, Boundary) -> (Extended r, Boundary) maxUB (x1,in1) (x2,in2) = ( max x1 x2 , case x1 `compare` x2 of- EQ -> in1 || in2+ EQ -> in1 `max` in2 LT -> in2 GT -> in1 )- minLB :: (Extended r, Bool) -> (Extended r, Bool) -> (Extended r, Bool)+ minLB :: (Extended r, Boundary) -> (Extended r, Boundary) -> (Extended r, Boundary) minLB (x1,in1) (x2,in2) = ( min x1 x2 , case x1 `compare` x2 of- EQ -> in1 || in2+ EQ -> in1 `max` in2 LT -> in1 GT -> in2 ) -- | convex hull of a list of intervals. ----- Since 0.6.0+-- @since 0.6.0 hulls :: Ord r => [Interval r] -> Interval r hulls = foldl' hull empty @@ -305,26 +294,40 @@ null :: Ord r => Interval r -> Bool null i = case x1 `compare` x2 of- EQ -> assert (in1 && in2) False+ EQ -> assert (in1 == Closed && in2 == Closed) False LT -> False GT -> True where (x1, in1) = lowerBound' i (x2, in2) = upperBound' i +-- | Is the interval single point?+--+-- @since 2.0.0 isSingleton :: Ord r => Interval r -> Bool-isSingleton i = case (lowerBound' i, upperBound' i) of- ((Finite l, True), (Finite u, True)) -> l==u- _ -> False+isSingleton = isJust . extractSingleton +-- | If the interval is a single point, return this point.+--+-- @since 2.1.0+extractSingleton :: Ord r => Interval r -> Maybe r+extractSingleton i = case (lowerBound' i, upperBound' i) of+ ((Finite l, Closed), (Finite u, Closed))+ | l == u -> Just l+ _ -> Nothing+ -- | Is the element in the interval? member :: Ord r => r -> Interval r -> Bool member x i = condLB && condUB where (x1, in1) = lowerBound' i (x2, in2) = upperBound' i- condLB = if in1 then x1 <= Finite x else x1 < Finite x- condUB = if in2 then Finite x <= x2 else Finite x < x2+ condLB = case in1 of+ Open -> x1 < Finite x+ Closed -> x1 <= Finite x+ condUB = case in2 of+ Open -> Finite x < x2+ Closed -> Finite x <= x2 -- | Is the element not in the interval? notMember :: Ord r => r -> Interval r -> Bool@@ -339,12 +342,12 @@ case x1 `compare` x2 of GT -> True LT -> False- EQ -> not in1 || in2 -- in1 => in2+ EQ -> in1 <= in2 testUB (x1,in1) (x2,in2) = case x1 `compare` x2 of LT -> True GT -> False- EQ -> not in1 || in2 -- in1 => in2+ EQ -> in1 <= in2 -- | Is this a proper subset? (/i.e./ a subset but not equal). isProperSubsetOf :: Ord r => Interval r -> Interval r -> Bool@@ -352,12 +355,12 @@ -- | Does the union of two range form a connected set? ----- Since 1.3.0+-- @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))+ | otherwise = x ==? y || (lb1==ub2 && (lb1in == Closed || ub2in == Closed)) || (ub1==lb2 && (ub1in == Closed || lb2in == Closed)) where (lb1,lb1in) = lowerBound' x (lb2,lb2in) = lowerBound' y@@ -376,13 +379,17 @@ pickup :: (Real r, Fractional r) => Interval r -> Maybe r pickup i = case (lowerBound' i, upperBound' i) of ((NegInf,_), (PosInf,_)) -> Just 0- ((Finite x1, in1), (PosInf,_)) -> Just $ if in1 then x1 else x1+1- ((NegInf,_), (Finite x2, in2)) -> Just $ if in2 then x2 else x2-1+ ((Finite x1, in1), (PosInf,_)) -> Just $ case in1 of+ Open -> x1 + 1+ Closed -> x1+ ((NegInf,_), (Finite x2, in2)) -> Just $ case in2 of+ Open -> x2 - 1+ Closed -> x2 ((Finite x1, in1), (Finite x2, in2)) -> case x1 `compare` x2 of GT -> Nothing LT -> Just $ (x1+x2) / 2- EQ -> if in1 && in2 then Just x1 else Nothing+ EQ -> if in1 == Closed && in2 == Closed then Just x1 else Nothing _ -> Nothing -- | 'simplestRationalWithin' returns the simplest rational number within the interval.@@ -395,7 +402,7 @@ -- -- (see also 'approxRational') ----- Since 0.4.0+-- @since 0.4.0 simplestRationalWithin :: RealFrac r => Interval r -> Maybe Rational simplestRationalWithin i | null i = Nothing simplestRationalWithin i@@ -403,21 +410,30 @@ | i <! 0 = Just $ - go (- i) | otherwise = assert (0 `member` i) $ Just 0 where- go i- | fromInteger lb_floor `member` i = fromInteger lb_floor- | fromInteger (lb_floor + 1) `member` i = fromInteger (lb_floor + 1)- | otherwise = fromInteger lb_floor + recip (go (recip (i - singleton (fromInteger lb_floor))))+ go j+ | fromInteger lb_floor `member` j = fromInteger lb_floor+ | fromInteger (lb_floor + 1) `member` j = fromInteger (lb_floor + 1)+ | otherwise = fromInteger lb_floor + recip (go (recip (j - singleton (fromInteger lb_floor)))) where- Finite lb = lowerBound i+ Finite lb = lowerBound j lb_floor = floor lb --- | @mapMonotonic f i@ is the image of @i@ under @f@, where @f@ must be a strict monotone function.+-- | @mapMonotonic f i@ is the image of @i@ under @f@, where @f@ must be a strict monotone function,+-- preserving negative and positive infinities. mapMonotonic :: (Ord a, Ord b) => (a -> b) -> Interval a -> Interval b mapMonotonic f i = interval (fmap f lb, in1) (fmap f ub, in2) where (lb, in1) = lowerBound' i (ub, in2) = upperBound' i +mapAntiMonotonic :: (Ord a, Ord b) => (a -> b) -> Interval a -> Interval b+mapAntiMonotonic f i+ | null i = empty+ | otherwise = interval (fmap f ub, in2) (fmap f lb, in1)+ where+ (lb, in1) = lowerBound' i+ (ub, in2) = upperBound' i+ -- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@? (<!) :: Ord r => Interval r -> Interval r -> Bool a <! b =@@ -428,7 +444,7 @@ case ub_a of NegInf -> True -- a is empty, so it holds vacuously PosInf -> True -- b is empty, so it holds vacuously- Finite _ -> not (in1 && in2)+ Finite _ -> in1 == Open || in2 == Open where (ub_a, in1) = upperBound' a (lb_b, in2) = lowerBound' b@@ -443,7 +459,7 @@ -- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@? ----- Since 1.0.1+-- @since 1.0.1 (/=!) :: Ord r => Interval r -> Interval r -> Bool a /=! b = null $ a `intersection` b @@ -464,7 +480,7 @@ -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@? ----- Since 1.0.0+-- @since 1.0.0 (<??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) a <?? b = do guard $ lowerBound a < upperBound b@@ -491,14 +507,14 @@ case lb_a of NegInf -> False -- b is empty PosInf -> False -- a is empty- Finite _ -> in1 && in2+ Finite _ -> in1 == Closed && in2 == Closed where (lb_a, in1) = lowerBound' a (ub_b, in2) = upperBound' b -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@? ----- Since 1.0.0+-- @since 1.0.0 (<=??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) a <=?? b = case pickup (intersection a b) of@@ -511,13 +527,13 @@ -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? ----- Since 1.0.0+-- @since 1.0.0 (==?) :: Ord r => Interval r -> Interval r -> Bool a ==? b = not $ null $ intersection a b -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@? ----- Since 1.0.0+-- @since 1.0.0 (==??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) a ==?? b = do x <- pickup (intersection a b)@@ -525,13 +541,13 @@ -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? ----- Since 1.0.1+-- @since 1.0.1 (/=?) :: Ord r => Interval r -> Interval r -> Bool a /=? b = not (null a) && not (null b) && not (a == b && isSingleton a) -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@? ----- Since 1.0.1+-- @since 1.0.1 (/=??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) a /=?? b = do guard $ not $ null a@@ -541,9 +557,9 @@ then f a b else liftM (\(y,x) -> (x,y)) $ f b a where- f a b = do- x <- pickup a- y <- msum [pickup (b `intersection` c) | c <- [-inf <..< Finite x, Finite x <..< inf]]+ f i j = do+ x <- pickup i+ y <- msum [pickup (j `intersection` c) | c <- [-inf <..< Finite x, Finite x <..< inf]] return (x,y) -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@?@@ -556,13 +572,13 @@ -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@? ----- Since 1.0.0+-- @since 1.0.0 (>=??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) (>=??) = flip (<=??) -- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@? ----- Since 1.0.0+-- @since 1.0.0 (>??) :: (Real r, Fractional r) => Interval r -> Interval r -> Maybe (r,r) (>??) = flip (<??) @@ -583,19 +599,21 @@ lb = lowerBound' x ub = upperBound' x +-- | When results of 'abs' or 'signum' do not form a connected interval,+-- a convex hull is returned instead. instance (Num r, Ord r) => Num (Interval r) where a + b | null a || null b = empty | otherwise = interval (f (lowerBound' a) (lowerBound' b)) (g (upperBound' a) (upperBound' b)) where- f (Finite x1, in1) (Finite x2, in2) = (Finite (x1+x2), in1 && in2)- f (NegInf,_) _ = (-inf, False)- f _ (NegInf,_) = (-inf, False)+ f (Finite x1, in1) (Finite x2, in2) = (Finite (x1+x2), in1 `min` in2)+ f (NegInf,_) _ = (-inf, Open)+ f _ (NegInf,_) = (-inf, Open) f _ _ = error "Interval.(+) should not happen" - g (Finite x1, in1) (Finite x2, in2) = (Finite (x1+x2), in1 && in2)- g (PosInf,_) _ = (inf, False)- g _ (PosInf,_) = (inf, False)+ g (Finite x1, in1) (Finite x2, in2) = (Finite (x1+x2), in1 `min` in2)+ g (PosInf,_) _ = (inf, Open)+ g _ (PosInf,_) = (inf, Open) g _ _ = error "Interval.(+) should not happen" negate = scaleInterval (-1)@@ -624,26 +642,147 @@ ub3 = maximumBy cmpUB xs lb3 = minimumBy cmpLB xs +-- | 'recip' returns 'whole' when 0 is an interior point.+-- Otherwise @recip (recip xs)@ equals to @xs@ without 0. instance forall r. (Real r, Fractional r) => Fractional (Interval r) where fromRational r = singleton (fromRational r) recip a | null a = empty- | 0 `member` a = whole -- should be error?+ | a == 0 = empty+ | 0 `member` a && 0 /= lowerBound a && 0 /= upperBound a = whole | otherwise = interval lb3 ub3 where ub3 = maximumBy cmpUB xs lb3 = minimumBy cmpLB xs xs = [recipLB (lowerBound' a), recipUB (upperBound' a)] -cmpUB, cmpLB :: Ord r => (Extended r, Bool) -> (Extended r, Bool) -> Ordering+-- | When results of 'tan' or '**' do not form a connected interval,+-- a convex hull is returned instead.+instance (RealFrac r, Floating r) => Floating (Interval r) where+ pi = singleton pi++ exp = intersection (0 <..< PosInf) . mapMonotonic exp+ log a = interval (logB (lowerBound' b)) (logB (upperBound' b))+ where+ b = intersection (0 <..< PosInf) a++ sqrt = mapMonotonic sqrt . intersection (0 <=..< PosInf)++ a ** b = hulls (posBase : negBasePosPower : negBaseNegPower : zeroPower ++ zeroBase)+ where+ posBase = exp (log a * b)+ zeroPower = [ 1 | 0 `member` b, not (null a) ]+ zeroBase = [ 0 | 0 `member` a, not (null (b `intersection` (0 <..< PosInf))) ]+ negBasePosPower = positiveIntegralPowersOfNegativeValues+ (a `intersection` (NegInf <..< 0))+ (b `intersection` (0 <..< PosInf))+ negBaseNegPower = positiveIntegralPowersOfNegativeValues+ (recip (a `intersection` (NegInf <..< 0)))+ (negate (b `intersection` (NegInf <..< 0)))++ cos a = case lowerBound' a of+ (NegInf, _) -> -1 <=..<= 1+ (PosInf, _) -> empty+ (Finite lb, in1) -> case upperBound' a of+ (NegInf, _) -> empty+ (PosInf, _) -> -1 <=..<= 1+ (Finite ub, in2)+ | ub - lb > 2 * pi -> -1 <=..<= 1+ | clb == -1 && ub - lb == 2 * pi && in1 == Open && in2 == Open -> -1 <..<= 1+ | clb == 1 && ub - lb == 2 * pi && in1 == Open && in2 == Open -> -1 <=..< 1+ | ub - lb == 2 * pi -> -1 <=..<= 1++ | lbNorth, ubNorth, clb >= cub -> interval (cub, in2) (clb, in1)+ | lbNorth, ubNorth -> -1 <=..<= 1+ | lbNorth -> interval (-1, Closed) $ case clb `compare` cub of+ LT -> (cub, in2)+ EQ -> (cub, in1 `max` in2)+ GT -> (clb, in1)+ | ubNorth -> (`interval` (1, Closed)) $ case clb `compare` cub of+ LT -> (clb, in1)+ EQ -> (clb, in1 `max` in2)+ GT -> (cub, in2)+ | clb > cub -> -1 <=..<= 1+ | otherwise -> interval (clb, in1) (cub, in2)+ where+ mod2pi x = let y = x / (2 * pi) in y - fromInteger (floor y)+ -- is lower bound in the northern half-plane [0,pi)?+ lbNorth = (mod2pi lb, in1) < (1 / 2, Closed)+ -- is upper bound in the northern half-plane [0,pi)?+ ubNorth = (mod2pi ub, in2) < (1 / 2, Closed)+ clb = Finite (cos lb)+ cub = Finite (cos ub)++ acos = mapAntiMonotonic acos . intersection (-1 <=..<= 1)++ sin a = cos (pi / 2 - a)+ asin = mapMonotonic asin . intersection (-1 <=..<= 1)++ tan a = case lowerBound' a of+ (NegInf, _) -> whole+ (PosInf, _) -> empty+ (Finite lb, in1) -> case upperBound' a of+ (NegInf, _) -> empty+ (PosInf, _) -> whole+ (Finite ub, in2)+ | ub - lb > pi -> whole+ -- the next case corresponds to (tan lb, +inf) + (-inf, tan ub)+ -- with tan lb == tan ub, but a convex hull is returned instead+ | ub - lb == pi && in1 == Open && in2 == Open && modpi lb /= 1/2 -> whole+ | ub - lb == pi -> whole+ | tan lb <= tan ub -> interval (Finite $ tan lb, in1) (Finite $ tan ub, in2)+ -- the next case corresponds to (tan lb, +inf) + (-inf, tan ub),+ -- but a convex hull is returned instead+ | otherwise -> whole+ where+ modpi x = let y = x / pi in y - fromInteger (floor y)++ atan = intersection (Finite (-pi / 2) <=..<= Finite (pi / 2)) . mapMonotonic atan++ sinh = mapMonotonic sinh+ asinh = mapMonotonic asinh++ cosh = mapMonotonic cosh . abs+ acosh = mapMonotonic acosh . intersection (1 <=..< PosInf)++ tanh = intersection (-1 <..< 1) . mapMonotonic tanh+ atanh a = interval (atanhB (lowerBound' b)) (atanhB (upperBound' b))+ where+ b = intersection (-1 <..< 1) a++positiveIntegralPowersOfNegativeValues+ :: RealFrac r => Interval r -> Interval r -> Interval r+positiveIntegralPowersOfNegativeValues a b+ | null a || null b = empty+ | Just ub <- mub, lb > ub = empty+ | Just ub <- mub, lb == ub = a ^ lb+ -- cases below connects two intervals (a ^ k, 0) + (0, a ^ k'))+ -- into a single convex hull+ | lowerBound a >= -1 = hull (a ^ lb) (a ^ (lb + 1))+ | Just ub <- mub = hull (a ^ ub) (a ^ (ub - 1))+ | Nothing <- mub = whole+ where+ -- Similar to Data.IntegerInterval.fromIntervalUnder+ lb :: Integer+ lb = case lowerBound' b of+ (Finite x, Open)+ | fromInteger (ceiling x) == x+ -> ceiling x + 1+ (Finite x, _) -> ceiling x+ _ -> 0 -- PosInf is not expected, because b is not null+ mub :: Maybe Integer+ mub = case upperBound' b of+ (Finite x, Open)+ | fromInteger (floor x) == x+ -> Just $ floor x - 1+ (Finite x, _) -> Just $ floor x+ _ -> Nothing -- NegInf is not expected, because b is not null++cmpUB, cmpLB :: Ord r => (Extended r, Boundary) -> (Extended r, Boundary) -> Ordering cmpUB (x1,in1) (x2,in2) = compare x1 x2 `mappend` 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-type EndPoint r = Extended r--scaleInf' :: (Num r, Ord r) => r -> (Extended r, Bool) -> (Extended r, Bool)+scaleInf' :: (Num r, Ord r) => r -> (Extended r, Boundary) -> (Extended r, Boundary) scaleInf' a (x1, in1) = (scaleEndPoint a x1, in1) scaleEndPoint :: (Num r, Ord r) => r -> Extended r -> Extended r@@ -661,15 +800,61 @@ Finite b -> Finite (a*b) PosInf -> NegInf -mulInf' :: (Num r, Ord r) => (Extended r, Bool) -> (Extended r, Bool) -> (Extended r, Bool)-mulInf' (0, True) _ = (0, True)-mulInf' _ (0, True) = (0, True)-mulInf' (x1,in1) (x2,in2) = (x1*x2, in1 && in2)+mulInf' :: (Num r, Ord r) => (Extended r, Boundary) -> (Extended r, Boundary) -> (Extended r, Boundary)+mulInf' (0, Closed) _ = (0, Closed)+mulInf' _ (0, Closed) = (0, Closed)+mulInf' (x1,in1) (x2,in2) = (x1*x2, in1 `min` in2) -recipLB :: (Fractional r, Ord r) => (Extended r, Bool) -> (Extended r, Bool)-recipLB (0, _) = (PosInf, False)+recipLB :: (Fractional r, Ord r) => (Extended r, Boundary) -> (Extended r, Boundary)+recipLB (0, _) = (PosInf, Open) recipLB (x1, in1) = (recip x1, in1) -recipUB :: (Fractional r, Ord r) => (Extended r, Bool) -> (Extended r, Bool)-recipUB (0, _) = (NegInf, False)+recipUB :: (Fractional r, Ord r) => (Extended r, Boundary) -> (Extended r, Boundary)+recipUB (0, _) = (NegInf, Open) recipUB (x1, in1) = (recip x1, in1)++logB :: (Floating r, Ord r) => (Extended r, Boundary) -> (Extended r, Boundary)+logB (NegInf, in1) = (Finite $ log (log 0), in1)+logB (Finite 0, _) = (NegInf, Open)+logB (Finite x1, in1) = (Finite $ log x1, in1)+logB (PosInf, in1) = (PosInf, in1)++atanhB :: (Floating r, Ord r) => (Extended r, Boundary) -> (Extended r, Boundary)+atanhB (NegInf, in1) = (Finite $ atanh (-1/0), in1)+atanhB (Finite (-1), _) = (NegInf, Open)+atanhB (Finite 1, _) = (PosInf, Open)+atanhB (Finite x1, in1) = (Finite $ atanh x1, in1)+atanhB (PosInf, in1) = (Finite $ atanh (1/0), in1)++-- | Computes how two intervals are related according to the @`Data.IntervalRelation.Relation`@ classification+relate :: Ord r => Interval r -> Interval r -> Relation+relate i1 i2 =+ case (i1 `isSubsetOf` i2, i2 `isSubsetOf` i1) of+ -- 'i1' ad 'i2' are equal+ (True , True ) -> Equal+ -- 'i1' is strictly contained in `i2`+ (True , False) | compareBound (lowerBound' i1) (lowerBound' i2) == EQ -> Starts+ | compareBound (upperBound' i1) (upperBound' i2) == EQ -> Finishes+ | otherwise -> During+ -- 'i2' is strictly contained in `i1`+ (False, True ) | compareBound (lowerBound' i1) (lowerBound' i2) == EQ -> StartedBy+ | compareBound (upperBound' i1) (upperBound' i2) == EQ -> FinishedBy+ | otherwise -> Contains+ -- neither `i1` nor `i2` is contained in the other+ (False, False) -> case ( null (i1 `intersection` i2)+ , compareBound (upperBound' i1) (upperBound' i2) <= EQ+ , i1 `isConnected` i2+ ) of+ (True , True , True ) -> JustBefore+ (True , True , False) -> Before+ (True , False, True ) -> JustAfter+ (True , False, False) -> After+ (False, True , _ ) -> Overlaps+ (False, False, _ ) -> OverlappedBy+ where+ compareBound :: Ord r => (Extended r, Boundary) -> (Extended r, Boundary) -> Ordering+ compareBound (PosInf, _) (PosInf, _) = EQ+ compareBound (PosInf, _) _ = GT+ compareBound (NegInf, _) (NegInf, _) = EQ+ compareBound (NegInf, _) _ = LT+ compareBound a b = compare a b
src/Data/Interval/Internal.hs view
@@ -1,12 +1,11 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, LambdaCase, ScopedTypeVariables #-} {-# LANGUAGE Safe #-}-#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-}-#endif module Data.Interval.Internal- ( Interval+ ( Boundary(..)+ , Interval , lowerBound' , upperBound' , interval@@ -17,20 +16,133 @@ import Data.Data import Data.ExtendedReal import Data.Hashable+import Data.Int+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import GHC.Generics (Generic) --- | The intervals (/i.e./ connected and convex subsets) over real numbers __R__.-data Interval r = Interval- { -- | 'lowerBound' of the interval and whether it is included in the interval.- -- The result is convenient to use as an argument for 'interval'.- lowerBound' :: !(Extended r, Bool)- , -- | 'upperBound' of the interval and whether it is included in the interval.- -- The result is convenient to use as an argument for 'interval'.- upperBound' :: !(Extended r, Bool)- } deriving (Eq, Typeable)+-- | Boundary of an interval may be+-- open (excluding an endpoint) or closed (including an endpoint).+--+-- @since 2.0.0+data Boundary+ = Open+ | Closed+ deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data, Typeable) -#if __GLASGOW_HASKELL__ >= 708+instance NFData Boundary++instance Hashable Boundary++-- | The intervals (/i.e./ connected and convex subsets) over a type @r@.+data Interval r+ = Whole+ | Empty+ | Point !r+ | LessThan !r+ | LessOrEqual !r+ | GreaterThan !r+ | GreaterOrEqual !r+ -- For constructors below+ -- the first argument is strictly less than the second one+ | BothClosed !r !r+ | LeftOpen !r !r+ | RightOpen !r !r+ | BothOpen !r !r+ deriving+ ( Eq+ , Ord+ -- ^ Note that this Ord is derived and not semantically meaningful.+ -- The primary intended use case is to allow using 'Interval'+ -- in maps and sets that require ordering.+ , Typeable+ )++peekInterval :: (Applicative m, Monad m, Ord r) => m Int8 -> m r -> m r -> m (Interval r)+peekInterval tagM x y = do+ tag <- tagM+ case tag of+ 0 -> pure Whole+ 1 -> pure Empty+ 2 -> Point <$> x+ 3 -> LessThan <$> x+ 4 -> LessOrEqual <$> x+ 5 -> GreaterThan <$> x+ 6 -> GreaterOrEqual <$> x+ 7 -> wrap BothClosed <$> x <*> y+ 8 -> wrap LeftOpen <$> x <*> y+ 9 -> wrap RightOpen <$> x <*> y+ _ -> wrap BothOpen <$> x <*> y++-- | Enforce the internal invariant+-- of 'BothClosed' / 'LeftOpen' / 'RightOpen' / 'BothOpen'.+wrap :: Ord r => (r -> r -> Interval r) -> r -> r -> Interval r+wrap f x y+ | x < y = f x y+ | otherwise = Empty++pokeInterval :: Applicative m => (Int8 -> m ()) -> (r -> m ()) -> (r -> m ()) -> Interval r -> m ()+pokeInterval tag actX actY = \case+ Whole -> tag (0 :: Int8)+ Empty -> tag (1 :: Int8)+ Point x -> tag (2 :: Int8) *> actX x+ LessThan x -> tag (3 :: Int8) *> actX x+ LessOrEqual x -> tag (4 :: Int8) *> actX x+ GreaterThan x -> tag (5 :: Int8) *> actX x+ GreaterOrEqual x -> tag (6 :: Int8) *> actX x+ BothClosed x y -> tag (7 :: Int8) *> actX x *> actY y+ LeftOpen x y -> tag (8 :: Int8) *> actX x *> actY y+ RightOpen x y -> tag (9 :: Int8) *> actX x *> actY y+ BothOpen x y -> tag (10 :: Int8) *> actX x *> actY y++instance (Storable r, Ord r) => Storable (Interval r) where+ sizeOf _ = 3 * sizeOf (undefined :: r)+ alignment _ = alignment (undefined :: r)+ peek ptr = peekInterval+ (peek $ castPtr ptr)+ (peek $ castPtr ptr `advancePtr` 1)+ (peek $ castPtr ptr `advancePtr` 2)+ poke ptr = pokeInterval+ (poke $ castPtr ptr)+ (poke $ castPtr ptr `advancePtr` 1)+ (poke $ castPtr ptr `advancePtr` 2)++-- | Lower endpoint (/i.e./ greatest lower bound) of the interval,+-- together with 'Boundary' information.+-- The result is convenient to use as an argument for 'interval'.+lowerBound' :: Interval r -> (Extended r, Boundary)+lowerBound' = \case+ Whole -> (NegInf, Open)+ Empty -> (PosInf, Open)+ Point r -> (Finite r, Closed)+ LessThan{} -> (NegInf, Open)+ LessOrEqual{} -> (NegInf, Open)+ GreaterThan r -> (Finite r, Open)+ GreaterOrEqual r -> (Finite r, Closed)+ BothClosed p _ -> (Finite p, Closed)+ LeftOpen p _ -> (Finite p, Open)+ RightOpen p _ -> (Finite p, Closed)+ BothOpen p _ -> (Finite p, Open)++-- | Upper endpoint (/i.e./ least upper bound) of the interval,+-- together with 'Boundary' information.+-- The result is convenient to use as an argument for 'interval'.+upperBound' :: Interval r -> (Extended r, Boundary)+upperBound' = \case+ Whole -> (PosInf, Open)+ Empty -> (NegInf, Open)+ Point r -> (Finite r, Closed)+ LessThan r -> (Finite r, Open)+ LessOrEqual r -> (Finite r, Closed)+ GreaterThan{} -> (PosInf, Open)+ GreaterOrEqual{} -> (PosInf, Open)+ BothClosed _ q -> (Finite q, Closed)+ LeftOpen _ q -> (Finite q, Closed)+ RightOpen _ q -> (Finite q, Open)+ BothOpen _ q -> (Finite q, Open)+ type role Interval nominal-#endif instance (Ord r, Data r) => Data (Interval r) where gfoldl k z x = z interval `k` lowerBound' x `k` upperBound' x@@ -48,27 +160,67 @@ intervalDataType = mkDataType "Data.Interval.Internal.Interval" [intervalConstr] instance NFData r => NFData (Interval r) where- rnf (Interval lb ub) = rnf lb `seq` rnf ub+ rnf = \case+ Whole -> ()+ Empty -> ()+ Point r -> rnf r+ LessThan r -> rnf r+ LessOrEqual r -> rnf r+ GreaterThan r -> rnf r+ GreaterOrEqual r -> rnf r+ BothClosed p q -> rnf p `seq` rnf q+ LeftOpen p q -> rnf p `seq` rnf q+ RightOpen p q -> rnf p `seq` rnf q+ BothOpen p q -> rnf p `seq` rnf q instance Hashable r => Hashable (Interval r) where- hashWithSalt s (Interval lb ub) = s `hashWithSalt` lb `hashWithSalt` ub+ hashWithSalt s = \case+ Whole -> s `hashWithSalt` (1 :: Int)+ Empty -> s `hashWithSalt` (2 :: Int)+ Point r -> s `hashWithSalt` (3 :: Int) `hashWithSalt` r+ LessThan r -> s `hashWithSalt` (4 :: Int) `hashWithSalt` r+ LessOrEqual r -> s `hashWithSalt` (5 :: Int) `hashWithSalt` r+ GreaterThan r -> s `hashWithSalt` (6 :: Int) `hashWithSalt` r+ GreaterOrEqual r -> s `hashWithSalt` (7 :: Int) `hashWithSalt` r+ BothClosed p q -> s `hashWithSalt` (8 :: Int) `hashWithSalt` p `hashWithSalt` q+ LeftOpen p q -> s `hashWithSalt` (9 :: Int) `hashWithSalt` p `hashWithSalt` q+ RightOpen p q -> s `hashWithSalt` (10 :: Int) `hashWithSalt` p `hashWithSalt` q+ BothOpen p q -> s `hashWithSalt` (11 :: Int) `hashWithSalt` p `hashWithSalt` q -- | empty (contradicting) interval empty :: Ord r => Interval r-empty = Interval (PosInf, False) (NegInf, False)+empty = Empty -- | smart constructor for 'Interval' interval :: (Ord r)- => (Extended r, Bool) -- ^ lower bound and whether it is included- -> (Extended r, Bool) -- ^ upper bound and whether it is included+ => (Extended r, Boundary) -- ^ lower bound and whether it is included+ -> (Extended r, Boundary) -- ^ upper bound and whether it is included -> Interval r-interval lb@(x1,in1) ub@(x2,in2) =- case x1 `compare` x2 of- GT -> empty -- empty interval- LT -> Interval (normalize lb) (normalize ub)- EQ -> if in1 && in2 && isFinite x1 then Interval lb ub else empty- where- normalize x@(Finite _, _) = x- normalize (x, _) = (x, False)-+interval = \case+ (NegInf, _) -> \case+ (NegInf, _) -> Empty+ (Finite r, Open) -> LessThan r+ (Finite r, Closed) -> LessOrEqual r+ (PosInf, _) -> Whole+ (Finite p, Open) -> \case+ (NegInf, _) -> Empty+ (Finite q, Open)+ | p < q -> BothOpen p q+ | otherwise -> Empty+ (Finite q, Closed)+ | p < q -> LeftOpen p q+ | otherwise -> Empty+ (PosInf, _) -> GreaterThan p+ (Finite p, Closed) -> \case+ (NegInf, _) -> Empty+ (Finite q, Open)+ | p < q -> RightOpen p q+ | otherwise -> Empty+ (Finite q, Closed) -> case p `compare` q of+ LT -> BothClosed p q+ EQ -> Point p+ GT -> Empty+ (PosInf, _) -> GreaterOrEqual p+ (PosInf, _) -> const Empty+{-# INLINE interval #-}
src/Data/IntervalMap/Base.hs view
@@ -1,9 +1,7 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies, DeriveDataTypeable, MultiWayIf, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, LambdaCase, ScopedTypeVariables, TypeFamilies, DeriveDataTypeable, MultiWayIf, GeneralizedNewtypeDeriving #-} {-# LANGUAGE Trustworthy #-}-#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.IntervalMap.Base@@ -22,7 +20,6 @@ -- * IntervalMap type IntervalMap (..) , module Data.ExtendedReal- , EndPoint -- * Operators , (!)@@ -91,29 +88,24 @@ ) where -import Prelude hiding (null, lookup, map, filter, span)-import Control.Applicative hiding (empty)+import Prelude hiding (null, lookup, map, filter, span, and) 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.Foldable hiding (null, toList) 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 Data.Interval (Interval) 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+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid (Monoid(..)) #endif+import qualified GHC.Exts as GHCExts -- ------------------------------------------------------------------------ -- The IntervalMap type@@ -123,11 +115,16 @@ -- 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)+ deriving+ ( Eq+ , Ord+ -- ^ Note that this Ord is derived and not semantically meaningful.+ -- The primary intended use case is to allow using 'IntervalSet'+ -- in maps and sets that require ordering.+ , 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) $@@ -170,31 +167,21 @@ instance Ord k => Monoid (IntervalMap k a) where mempty = empty- mappend = union+ mappend = (Semigroup.<>) mconcat = unions -instance Ord k => Semigroup (IntervalMap k a) where+instance Ord k => Semigroup.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)+newtype LB r = LB (Extended r, Interval.Boundary) deriving (Eq, NFData, Typeable) instance Ord r => Ord (LB r) where@@ -210,7 +197,7 @@ -- | 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+ case Map.lookupLE (LB (Finite k, Interval.Closed)) m of Just (_, (i, a)) | k `Interval.member` i -> a _ -> error "IntervalMap.!: given key is not an element in the map" @@ -228,7 +215,7 @@ -- | 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+ case Map.lookupLE (LB (Finite k, Interval.Closed)) m of Just (_, (i, _)) -> k `Interval.member` i Nothing -> False @@ -242,7 +229,7 @@ -- 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+ case Map.lookupLE (LB (Finite k, Interval.Closed)) m of Just (_, (i, a)) | k `Interval.member` i -> Just a _ -> Nothing @@ -251,7 +238,7 @@ -- 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+ case Map.lookupLE (LB (Finite k, Interval.Closed)) m of Just (_, (i, a)) | k `Interval.member` i -> a _ -> def @@ -312,7 +299,7 @@ -- ------------------------------------------------------------------------ -- Delete/Update --- | Delete an interval and its value from the map. +-- | 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@@ -324,7 +311,7 @@ -- | 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) +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@@ -334,7 +321,7 @@ 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]+ IntervalMap $ Map.unions [m1, Map.mapMaybe (\(j,a) -> (\b -> (j,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'.@@ -357,12 +344,12 @@ -- | 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 = +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 = +unionWith f m1 m2 = foldl' (\m (i,a) -> insertWith f i a m) m2 (toList m1) -- | The union of a list of maps:@@ -385,19 +372,19 @@ intersection = intersectionWith const -- | Intersection with a combining function.-intersectionWith :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c +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)+ g :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c+ g h jm1 (IntervalMap m3) = IntervalMap $ Map.unions $ go jm1 (Map.elems m3) 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+ (_, IntervalMap m, jm2) ->+ Map.map (\(j, a) -> (j, h a b)) m : go jm2 xs -- ------------------------------------------------------------------------ -- Traversal@@ -415,7 +402,7 @@ 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@.+-- | @'mapKeysMonotonic' 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@@ -435,7 +422,7 @@ keys (IntervalMap m) = [i | (i,_) <- Map.elems m] -- | An alias for 'toAscList'. Return all key\/value pairs in the map--- in ascending key order. +-- in ascending key order. assocs :: IntervalMap k a -> [(Interval k, a)] assocs = toAscList @@ -443,15 +430,15 @@ 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. +-- | 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. +-- | 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. +-- | 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 @@ -477,8 +464,8 @@ 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+ (smaller, m1, xs) ->+ case splitLookupLE (LB (Interval.upperBound i, Interval.Closed)) xs of (middle, m2, larger) -> ( IntervalMap $ case m1 of@@ -500,7 +487,7 @@ , let k = Interval.intersection (downTo i) j , not (Interval.null k) ]- ) + ) -- ------------------------------------------------------------------------ -- Submap@@ -511,7 +498,7 @@ -- | 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. +-- 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@@ -551,7 +538,7 @@ (NegInf, _) -> Interval.empty (PosInf, _) -> Interval.whole (Finite lb, incl) ->- Interval.interval (NegInf,False) (Finite lb, not incl)+ Interval.interval (NegInf, Interval.Open) (Finite lb, notB incl) downTo :: Ord r => Interval r -> Interval r downTo i =@@ -559,4 +546,9 @@ (PosInf, _) -> Interval.empty (NegInf, _) -> Interval.whole (Finite ub, incl) ->- Interval.interval (Finite ub, not incl) (PosInf,False)+ Interval.interval (Finite ub, notB incl) (PosInf, Interval.Open)++notB :: Interval.Boundary -> Interval.Boundary+notB = \case+ Interval.Open -> Interval.Closed+ Interval.Closed -> Interval.Open
src/Data/IntervalMap/Lazy.hs view
@@ -33,7 +33,6 @@ -- * IntervalMap type IntervalMap , module Data.ExtendedReal- , EndPoint -- * Operators , (!)
src/Data/IntervalMap/Strict.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE CPP, BangPatterns, TupleSections #-}+{-# LANGUAGE BangPatterns, TupleSections #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- |@@ -34,7 +34,6 @@ -- * IntervalMap type IntervalMap , module Data.ExtendedReal- , EndPoint -- * Operators , (!)@@ -105,9 +104,8 @@ import Prelude hiding (null, lookup, map, filter, span)-import Control.Applicative hiding (empty) import Data.ExtendedReal-import Data.Interval (Interval, EndPoint)+import Data.Interval (Interval) import qualified Data.Interval as Interval import Data.IntervalMap.Base hiding ( whole@@ -185,7 +183,7 @@ 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]+ IntervalMap $ Map.unions [m1, Map.mapMaybe (\(j,a) -> (\b -> seq b (j,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'.@@ -207,7 +205,7 @@ -- | Union with a combining function. unionWith :: Ord k => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a-unionWith f m1 m2 = +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:@@ -216,19 +214,19 @@ 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 :: 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)+ g :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c+ g h jm1 (IntervalMap m3) = IntervalMap $ Map.unions $ go jm1 (Map.elems m3) 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+ (_, IntervalMap m, jm2) ->+ Map.map (\(j, a) -> (j,) $! h a b) m : go jm2 xs -- ------------------------------------------------------------------------ -- Traversal
+ src/Data/IntervalRelation.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE Safe #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.IntervalRelation+-- Copyright : (c) Masahiro Sakai 2016+-- License : BSD-style+--+-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : non-portable (CPP, DeriveDataTypeable, DeriveGeneric)+--+-- Interval relations and their algebra.+--+-----------------------------------------------------------------------------+module Data.IntervalRelation+ ( Relation(..)+ , invert+ )+ where++import Data.Data+import GHC.Generics (Generic)++-- | Describes how two intervals @x@ and @y@ can be related.+-- See [Allen's interval algebra](https://en.wikipedia.org/wiki/Allen%27s_interval_algebra)+-- and [Intervals and their relations](http://marcosh.github.io/post/2020/05/04/intervals-and-their-relations.html).+data Relation+ = Before+ -- ^ Any element of @x@ is smaller than any element of @y@,+ -- and intervals are not connected. In other words, there exists an element+ -- that is bigger than any element of @x@ and smaller than any element of @y@.+ | JustBefore+ -- ^ Any element of @x@ is smaller than any element of @y@,+ -- but intervals are connected and non-empty. This implies that intersection+ -- of intervals is empty, and union is a single interval.+ | Overlaps+ -- ^ Intersection of @x@ and @y@ is non-empty,+ -- @x@ start and finishes earlier than @y@. This implies that union+ -- is a single interval, and @x@ finishes no earlier than @y@ starts.+ | Starts+ -- ^ @x@ is a proper subset of @y@,+ -- and they share lower bounds.+ | During+ -- ^ @x@ is a proper subset of @y@,+ -- but they share neither lower nor upper bounds.+ | Finishes+ -- ^ @x@ is a proper subset of @y@,+ -- and they share upper bounds.+ | Equal+ -- ^ Intervals are equal.+ | FinishedBy+ -- ^ Inverse of 'Finishes'.+ | Contains+ -- ^ Inverse of 'During'.+ | StartedBy+ -- ^ Inverse of 'Starts'.+ | OverlappedBy+ -- ^ Inverse of 'Overlaps'.+ | JustAfter+ -- ^ Inverse of 'JustBefore'.+ | After+ -- ^ Inverse of 'Before'.+ deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data, Typeable)++-- | Inverts a relation, such that @'invert' ('Data.Interval.relate' x y) = 'Data.Interval.relate' y x@+invert :: Relation -> Relation+invert relation = case relation of+ Before -> After+ JustBefore -> JustAfter+ Overlaps -> OverlappedBy+ Starts -> StartedBy+ During -> Contains+ Finishes -> FinishedBy+ Equal -> Equal+ FinishedBy -> Finishes+ Contains -> During+ StartedBy -> Starts+ OverlappedBy -> Overlaps+ JustAfter -> JustBefore+ After -> Before
src/Data/IntervalSet.hs view
@@ -1,9 +1,7 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies, DeriveDataTypeable, MultiWayIf #-}+{-# LANGUAGE CPP, LambdaCase, ScopedTypeVariables, TypeFamilies, DeriveDataTypeable, MultiWayIf #-} {-# LANGUAGE Trustworthy #-}-#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.IntervalSet@@ -22,7 +20,6 @@ -- * IntervalSet type IntervalSet , module Data.ExtendedReal- , EndPoint -- * Construction , whole@@ -63,7 +60,9 @@ where import Prelude hiding (null, span)+#ifdef MIN_VERSION_lattices import Algebra.Lattice+#endif import Control.DeepSeq import Data.Data import Data.ExtendedReal@@ -73,24 +72,28 @@ 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 Data.Interval (Interval, Boundary(..)) import qualified Data.Interval as Interval-#if __GLASGOW_HASKELL__ >= 708-import qualified GHC.Exts as GHCExts+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid (Monoid(..)) #endif+import qualified GHC.Exts as GHCExts -- | 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)+ deriving+ ( Eq+ , Ord+ -- ^ Note that this Ord is derived and not semantically meaningful.+ -- The primary intended use case is to allow using 'IntervalSet'+ -- in maps and sets that require ordering.+ , 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) $@@ -131,8 +134,7 @@ instance Hashable r => Hashable (IntervalSet r) where hashWithSalt s (IntervalSet m) = hashWithSalt s (Map.toList m) -#if MIN_VERSION_lattices(2,0,0)-+#ifdef MIN_VERSION_lattices instance (Ord r) => Lattice (IntervalSet r) where (\/) = union (/\) = intersection@@ -142,43 +144,16 @@ instance (Ord r) => BoundedMeetSemiLattice (IntervalSet r) where top = whole--#else--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)- #endif instance Ord r => Monoid (IntervalSet r) where mempty = empty- mappend = union+ mappend = (Semigroup.<>) mconcat = unions -instance (Ord r) => Semigroup (IntervalSet r) where+instance (Ord r) => Semigroup.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)@@ -216,16 +191,15 @@ ] return y +-- | @recip (recip xs) == delete 0 xs@ instance forall r. (Real r, Fractional r) => Fractional (IntervalSet r) where fromRational r = singleton (fromRational r)- recip = lift1 recip+ recip xs = lift1 recip (delete (Interval.singleton 0) xs) -#if __GLASGOW_HASKELL__ >= 708 instance Ord r => GHCExts.IsList (IntervalSet r) where type Item (IntervalSet r) = Interval r fromList = fromList toList = toList-#endif -- ----------------------------------------------------------------------- @@ -289,29 +263,35 @@ -- | Complement the interval set. complement :: Ord r => IntervalSet r -> IntervalSet r-complement (IntervalSet m) = fromAscList $ f (NegInf,False) (Map.elems m)+complement (IntervalSet m) = fromAscList $ f (NegInf,Open) (Map.elems m) where- f prev [] = [ Interval.interval prev (PosInf,False) ]+ f prev [] = [ Interval.interval prev (PosInf,Open) ] 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+ Interval.interval prev (lb, notB in1) : f (ub, notB 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- ]+insert i (IntervalSet is) = IntervalSet $ Map.unions+ [ smaller'+ , case fromList $ i : maybeToList m0 ++ maybeToList m1 ++ maybeToList m2 of+ IntervalSet m -> m+ , larger+ ]+ where+ (smaller, m1, xs) = splitLookupLE (Interval.lowerBound i) is+ (_, m2, larger) = splitLookupLE (Interval.upperBound i) xs + -- A tricky case is when an interval @i@ connects two adjacent+ -- members of IntervalSet, e. g., inserting {0} into (whole \\ {0}).+ (smaller', m0) = case Map.maxView smaller of+ Nothing -> (smaller, Nothing)+ Just (v, rest)+ | Interval.isConnected v i -> (rest, Just v)+ _ -> (smaller, Nothing)+ -- | Delete an interval from the interval set. delete :: Ord r => Interval r -> IntervalSet r -> IntervalSet r delete i is | Interval.null i = is@@ -365,7 +345,7 @@ fromList :: Ord r => [Interval r] -> IntervalSet r fromList = IntervalSet . fromAscList' . sortBy (compareLB `on` Interval.lowerBound') --- | Build a map from an ascending list of intervals. +-- | Build a map from an ascending list of intervals. -- /The precondition is not checked./ fromAscList :: Ord r => [Interval r] -> IntervalSet r fromAscList = IntervalSet . fromAscList'@@ -398,25 +378,13 @@ 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)--}+ case Map.spanAntitone (<= k) m of+ (lessOrEqual, greaterThan) ->+ case Map.maxView lessOrEqual of+ Just (v, lessOrEqual') -> (lessOrEqual', Just v, greaterThan)+ Nothing -> (lessOrEqual, Nothing, greaterThan) -compareLB :: Ord r => (Extended r, Bool) -> (Extended r, Bool) -> Ordering+compareLB :: Ord r => (Extended r, Boundary) -> (Extended r, Boundary) -> Ordering compareLB (lb1, lb1in) (lb2, lb2in) = -- inclusive lower endpoint shuold be considered smaller (lb1 `compare` lb2) `mappend` (lb2in `compare` lb1in)@@ -427,7 +395,7 @@ (NegInf, _) -> Interval.empty (PosInf, _) -> Interval.whole (Finite lb, incl) ->- Interval.interval (NegInf,False) (Finite lb, not incl)+ Interval.interval (NegInf, Open) (Finite lb, notB incl) downTo :: Ord r => Interval r -> Interval r downTo i =@@ -435,4 +403,9 @@ (PosInf, _) -> Interval.empty (NegInf, _) -> Interval.whole (Finite ub, incl) ->- Interval.interval (Finite ub, not incl) (PosInf,False)+ Interval.interval (Finite ub, notB incl) (PosInf, Open)++notB :: Boundary -> Boundary+notB = \case+ Open -> Closed+ Closed -> Open
+ test/TestInstances.hs view
@@ -0,0 +1,47 @@+module TestInstances where++import Control.Monad++import Test.Tasty.QuickCheck++import Data.Interval+import Data.IntervalRelation++instance Arbitrary Boundary where+ arbitrary = arbitraryBoundedEnum++instance Arbitrary r => Arbitrary (Extended r) where+ arbitrary = frequency+ [ (1, return NegInf)+ , (1, return PosInf)+ , (3, liftM Finite arbitrary)+ ]+ shrink NegInf = []+ shrink (Finite x) = NegInf : PosInf : map Finite (shrink x)+ shrink PosInf = []++instance (Arbitrary r, Ord r) => Arbitrary (Interval r) where+ arbitrary = do+ x <- arbitrary+ y <- arbitrary+ frequency+ [ (1, return $ interval x y)+ , (3, return $ interval (min x y) (max x y))+ ]+ shrink a+ | isSingleton a = case lowerBound a of+ Finite x -> map singleton $ shrink x+ _ -> []+ | otherwise = mkPoint lb ++ mkPoint ub ++ map (lb `interval`) (shrink ub) ++ map (`interval` ub) (shrink lb)+ where+ lb = lowerBound' a+ ub = upperBound' a++ mkPoint (Finite x, _) = [singleton x]+ mkPoint _ = []++intervals :: Gen (Interval Rational)+intervals = arbitrary++instance Arbitrary Relation where+ arbitrary = arbitraryBoundedEnum
test/TestIntegerInterval.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE CPP, TemplateHaskell, ScopedTypeVariables #-} module TestIntegerInterval (integerIntervalTestGroup) where +#ifdef MIN_VERSION_lattices import qualified Algebra.Lattice as L+#endif import Control.DeepSeq import Control.Monad import Data.Generics.Schemes@@ -24,6 +26,7 @@ import qualified Data.IntegerInterval as IntegerInterval import Data.Interval (Interval) import qualified Data.Interval as Interval+import Data.IntervalRelation {-------------------------------------------------------------------- empty@@ -228,6 +231,19 @@ case_isProperSubsetOf = (0 <=..<= 1) `IntegerInterval.isProperSubsetOf` (0 <=..<= 2) @?= True +{-- -----------------------------------------------------------------+ isConnected+----------------------------------------------------------------- --}++prop_isConnected_reflexive =+ forAll integerIntervals $ \a ->+ a `IntegerInterval.isConnected` a++prop_isConnected_symmetric =+ forAll integerIntervals $ \a ->+ forAll integerIntervals $ \b ->+ (a `IntegerInterval.isConnected` b) == (b `IntegerInterval.isConnected` a)+ {-------------------------------------------------------------------- simplestIntegerWithin --------------------------------------------------------------------}@@ -252,11 +268,28 @@ case_width_null = IntegerInterval.width IntegerInterval.empty @?= 0 +case_width_positive =+ IntegerInterval.width (0 <=..< 10) @?= 9+ prop_width_singleton = forAll arbitrary $ \x -> IntegerInterval.width (IntegerInterval.singleton x) == 0 {--------------------------------------------------------------------+ memberCount+--------------------------------------------------------------------}++case_memberCount_null =+ IntegerInterval.memberCount IntegerInterval.empty @?= Just 0++case_memberCount_positive =+ IntegerInterval.memberCount (0 <=..< 10) @?= Just 10++prop_memberCount_singleton =+ forAll arbitrary $ \x ->+ IntegerInterval.memberCount (IntegerInterval.singleton x) == Just 1++{-------------------------------------------------------------------- map --------------------------------------------------------------------} @@ -284,6 +317,43 @@ IntegerInterval.pickup (IntegerInterval.singleton x) == Just x {--------------------------------------------------------------------+ relate+--------------------------------------------------------------------}++prop_relate_equals =+ forAll integerIntervals $ \a ->+ IntegerInterval.relate a a == Equal++prop_relate_empty_contained_in_non_empty =+ forAll (integerIntervals `suchThat` (not . IntegerInterval.null)) $ \a ->+ IntegerInterval.relate a IntegerInterval.empty == Contains++prop_relate_detects_before =+ forAll (nonEmptyIntegerIntervalPairs (\_ ub1 lb2 _ -> ub1 < lb2 - 1)) $ \(a, b) ->+ IntegerInterval.relate a b == Before++prop_relate_detects_just_before =+ forAll (arbitrary `suchThat` \(b1, b2, i) -> b1 <= Finite i && Finite (i + 1) <= b2) $+ \(b1, b2, i) ->+ IntegerInterval.relate (b1 <=..<= Finite i) (Finite (i + 1) <=..<= b2) == JustBefore++prop_relate_two_intervals_overlap =+ forAll (nonEmptyIntegerIntervalPairs (\lb1 ub1 lb2 ub2 -> lb1 < lb2 && lb2 < ub1 && ub1 < ub2)) $ \(a, b) ->+ IntegerInterval.relate a b == Overlaps++prop_relate_interval_starts_another =+ forAll (nonEmptyIntegerIntervalPairs (\lb1 ub1 lb2 ub2 -> lb1 == lb2 && ub1 < ub2)) $ \(a, b) ->+ IntegerInterval.relate a b == Starts++prop_relate_interval_finishes_another =+ forAll (nonEmptyIntegerIntervalPairs (\lb1 ub1 lb2 ub2 -> lb1 > lb2 && ub1 == ub2)) $ \(a, b) ->+ IntegerInterval.relate a b == Finishes++prop_relate_interval_contains_another =+ forAll (nonEmptyIntegerIntervalPairs (\lb1 ub1 lb2 ub2 -> lb1 < lb2 && ub1 > ub2)) $ \(a, b) ->+ IntegerInterval.relate a b == Contains++{-------------------------------------------------------------------- Comparison --------------------------------------------------------------------} @@ -629,35 +699,35 @@ ival1 :: IntegerInterval ival1 = 1 <=..<= 2 ival2 = 1 <..< 2- ival3 = IntegerInterval.empty -- *+ ival3 = IntegerInterval.empty case_mult_test3 = ival1 * ival2 @?= ival3 where ival1 :: IntegerInterval ival1 = 1 <..< 2 ival2 = 1 <..< 2- ival3 = IntegerInterval.empty -- *+ ival3 = IntegerInterval.empty case_mult_test4 = ival1 * ival2 @?= ival3 where ival1 :: IntegerInterval ival1 = 2 <..< PosInf ival2 = 3 <..< PosInf- ival3 = 11 <..< PosInf -- *+ ival3 = 11 <..< PosInf case_mult_test5 = ival1 * ival2 @?= ival3 where ival1 :: IntegerInterval ival1 = NegInf <..< (-3) ival2 = NegInf <..< (-2)- ival3 = 11 <..< PosInf -- *+ ival3 = 11 <..< PosInf case_mult_test6 = ival1 * ival2 @?= ival3 where ival1 :: IntegerInterval ival1 = 2 <..< PosInf ival2 = NegInf <..< (-2)- ival3 = NegInf <..< (-8) -- *+ ival3 = NegInf <..< (-8) prop_abs_signum = forAll integerIntervals $ \a ->@@ -671,6 +741,8 @@ Lattice --------------------------------------------------------------------} +#ifdef MIN_VERSION_lattices+ prop_Lattice_Leq_welldefined = forAll integerIntervals $ \a b -> a `L.meetLeq` b == a `L.joinLeq` b@@ -683,6 +755,14 @@ forAll integerIntervals $ \a -> L.bottom `L.joinLeq` a +#else++prop_Lattice_Leq_welldefined = True+prop_top = True+prop_bottom = True++#endif+ {-------------------------------------------------------------------- Read --------------------------------------------------------------------}@@ -692,7 +772,7 @@ i == read (show i) case_read_old =- read "interval (Finite 0, True) (PosInf, False)" @?= IntegerInterval.interval (Finite 0, True) (PosInf, False)+ read "interval (Finite 0, Closed) (PosInf, Open)" @?= IntegerInterval.interval (Finite 0, Interval.Closed) (PosInf, Interval.Open) {-------------------------------------------------------------------- NFData@@ -764,6 +844,9 @@ Generators --------------------------------------------------------------------} +instance Arbitrary Interval.Boundary where+ arbitrary = arbitraryBoundedEnum+ instance Arbitrary r => Arbitrary (Extended r) where arbitrary = oneof@@ -786,6 +869,24 @@ integerIntervals :: Gen IntegerInterval integerIntervals = arbitrary++nonEmptyIntegerIntervalPairs+ :: ( Extended Integer+ -> Extended Integer+ -> Extended Integer+ -> Extended Integer+ -> Bool)+ -> Gen (IntegerInterval, IntegerInterval)+nonEmptyIntegerIntervalPairs boundariesComparer = ap (fmap (,) integerIntervals) integerIntervals `suchThat`+ (\(i1, i2) ->+ (not . IntegerInterval.null $ i1) &&+ (not . IntegerInterval.null $ i2) &&+ boundariesComparer+ (IntegerInterval.lowerBound i1)+ (IntegerInterval.upperBound i1)+ (IntegerInterval.lowerBound i2)+ (IntegerInterval.upperBound i2)+ ) intervals :: Gen (Interval.Interval Rational) intervals = arbitrary
test/TestInterval.hs view
@@ -1,11 +1,15 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE CPP, TemplateHaskell, RankNTypes, ScopedTypeVariables #-} module TestInterval (intervalTestGroup) where +#ifdef MIN_VERSION_lattices import qualified Algebra.Lattice as L+#endif import Control.DeepSeq+import Control.Exception import Control.Monad import Data.Generics.Schemes import Data.Hashable+import Data.Int import Data.Maybe import Data.Ratio import Data.Typeable@@ -13,7 +17,11 @@ import Test.Tasty import Test.Tasty.QuickCheck import Test.Tasty.HUnit+import Test.Tasty.Options import Test.Tasty.TH+#ifdef MIN_VERSION_quickcheck_classes_base+import Test.QuickCheck.Classes.Base+#endif import Data.Interval ( Interval, Extended (..), (<=..<=), (<=..<), (<..<=), (<..<)@@ -22,7 +30,10 @@ , (<??), (<=??), (==??), (>=??), (>??), (/=??) ) import qualified Data.Interval as Interval+import Data.IntervalRelation +import TestInstances+ {-------------------------------------------------------------------- empty --------------------------------------------------------------------}@@ -198,7 +209,11 @@ forAll intervals $ \a -> Interval.isSubsetOf a a -prop_isSubsetOf_trans =+test_isSubsetOf_trans :: [TestTree]+test_isSubsetOf_trans =+ (: []) $+ adjustOption (\(QuickCheckMaxRatio r) -> QuickCheckMaxRatio (r * 10)) $+ testProperty "isSubsetOf trans" $ forAll intervals $ \a -> forAll intervals $ \b -> forAll intervals $ \c ->@@ -307,6 +322,9 @@ case_width_null = Interval.width Interval.empty @?= 0 +case_width_positive =+ Interval.width (0 <=..< 10) @?= 10+ prop_width_singleton = forAll arbitrary $ \(r::Rational) -> Interval.width (Interval.singleton r) == 0@@ -319,6 +337,81 @@ Interval.mapMonotonic (+1) (0 <=..< 10) @?= ((1 <=..<11) :: Interval Rational) {--------------------------------------------------------------------+ relate+--------------------------------------------------------------------}++prop_relate_equals =+ forAll intervals $ \a ->+ Interval.relate a a == Equal++prop_relate_empty_contained_in_non_empty =+ forAll (intervals `suchThat` (not . Interval.null)) $ \a ->+ Interval.relate a Interval.empty == Contains++prop_relate_detects_before =+ forAll (nonEmptyIntervalPairs (\_ (ub1, _) (lb2, _) _ -> ub1 < lb2)) $ \(a, b) ->+ Interval.relate a b == Before++prop_relate_open_intervals_with_common_boundary_are_before =+ forAll (arbitrary `suchThat` \(b1, b2, i) -> fst b1 < i && i < fst b2) $+ \(b1 :: (Extended Rational, Interval.Boundary), b2, i :: Extended Rational) ->+ Interval.relate (Interval.interval b1 (i, Interval.Open)) (Interval.interval (i, Interval.Open) b2) == Before++prop_relate_right_closed_interval_just_before =+ forAll (arbitrary `suchThat` \(b1, b2, i) -> fst b1 < i && i < fst b2) $+ \(b1 :: (Extended Rational, Interval.Boundary), b2, i :: Extended Rational) ->+ Interval.relate (Interval.interval b1 (i, Interval.Closed)) (Interval.interval (i, Interval.Open) b2) == JustBefore++prop_relate_right_open_interval_just_before =+ forAll (arbitrary `suchThat` \(b1, b2, i) -> fst b1 < i && i < fst b2) $+ \(b1 :: (Extended Rational, Interval.Boundary), b2, i :: Extended Rational) ->+ Interval.relate (Interval.interval b1 (i, Interval.Open)) (Interval.interval (i, Interval.Closed) b2) == JustBefore++prop_relate_two_intervals_overlap =+ forAll (nonEmptyIntervalPairs (\(lb1, _) (ub1, _) (lb2, _) (ub2, _) -> lb1 < lb2 && lb2 < ub1 && ub1 < ub2)) $ \(a, b) ->+ Interval.relate a b == Overlaps++prop_relate_interval_starts_another =+ forAll (nonEmptyIntervalPairs (\lb1 (ub1, _) lb2 (ub2, _) -> lb1 == lb2 && ub1 < ub2)) $ \(a, b) ->+ Interval.relate a b == Starts++prop_relate_interval_finishes_another =+ forAll (nonEmptyIntervalPairs (\(lb1, _) ub1 (lb2, _) ub2 -> lb1 > lb2 && ub1 == ub2)) $ \(a, b) ->+ Interval.relate a b == Finishes++prop_relate_interval_contains_another =+ forAll (nonEmptyIntervalPairs (\(lb1, _) (ub1, _) (lb2, _) (ub2, _) -> lb1 < lb2 && ub1 > ub2)) $ \(a, b) ->+ Interval.relate a b == Contains++prop_relate_closed_interval_contains_open_interval_with_same_boundary =+ forAll (arbitrary `suchThat` \(lb, rb) -> lb < rb) $+ \(lb :: Rational, rb) ->+ Interval.relate+ (Interval.interval (Finite lb, Interval.Closed) (Finite rb, Interval.Closed))+ (Interval.interval (Finite lb, Interval.Open) (Finite rb, Interval.Open))+ == Contains++prop_relate_one_singleton_before_another =+ forAll (arbitrary `suchThat` uncurry (<)) $ \(r1 :: Rational, r2) ->+ Interval.relate (Interval.singleton r1) (Interval.singleton r2) == Before++prop_relate_singleton_starts_interval =+ forAll (arbitrary `suchThat` uncurry (<)) $ \(r1 :: Rational, r2) b ->+ Interval.relate (Interval.singleton r1) (Interval.interval (Finite r1, Interval.Closed) (Finite r2, b)) == Starts++prop_relate_singleton_just_before_interval =+ forAll (arbitrary `suchThat` uncurry (<)) $ \(r1 :: Rational, r2) b ->+ Interval.relate (Interval.singleton r1) (Interval.interval (Finite r1, Interval.Open) (Finite r2, b)) == JustBefore++prop_relate_singleton_finishes_interval =+ forAll (arbitrary `suchThat` uncurry (<)) $ \(r1 :: Rational, r2) b ->+ Interval.relate (Interval.singleton r2) (Interval.interval (Finite r1, b) (Finite r2, Interval.Closed)) == Finishes++prop_relate_singleton_just_after_interval =+ forAll (arbitrary `suchThat` uncurry (<)) $ \(r1 :: Rational, r2) b ->+ Interval.relate (Interval.singleton r2) (Interval.interval (Finite r1, b) (Finite r2, Interval.Open)) == JustAfter++{-------------------------------------------------------------------- Comparison --------------------------------------------------------------------} @@ -749,14 +842,332 @@ i1 = -10 <=..< 0 i2 = NegInf <..<= (-1/10) -prop_recip_zero =+case_recip_test4 = recip i1 @?= i2+ where+ i1, i2 :: Interval Rational+ i1 = 0 <=..<= 10+ i2 = (1/10) <=..< PosInf++case_recip_test5 = recip i1 @?= i2+ where+ i1, i2 :: Interval Rational+ i1 = -10 <=..<= 0+ i2 = NegInf <..<= (-1/10)++case_recip_test6 = recip i1 @?= i2+ where+ i1, i2 :: Interval Rational+ i1 = 0 <=..<= 0+ i2 = Interval.empty++prop_recip = forAll intervals $ \a ->- 0 `Interval.member` a ==> recip a == Interval.whole+ if 0 `isInteriorPoint` a+ then recip a === Interval.whole+ else recip (recip a) === without0 a +isInteriorPoint :: (Ord a, Show a) => a -> Interval a -> Bool+isInteriorPoint x xs+ = x `Interval.member` xs+ && Finite x /= Interval.lowerBound xs+ && Finite x /= Interval.upperBound xs++without0 :: (Ord a, Num a) => Interval a -> Interval a+without0 xs = case Interval.lowerBound' xs of+ (0, Interval.Closed) ->+ Interval.interval (0, Interval.Open) (Interval.upperBound' xs)+ _ -> case Interval.upperBound' xs of+ (0, Interval.Closed) ->+ Interval.interval (Interval.lowerBound' xs) (0, Interval.Open)+ _ -> xs+ {--------------------------------------------------------------------+ Floating+--------------------------------------------------------------------}++prop_exp_singleton = floatingSingleton exp++prop_exp_mid_point = floatingMidPoint exp++case_exp_whole = exp Interval.whole @?= 0 <..< PosInf++case_exp_empty = exp Interval.empty @?= Interval.empty++prop_log_singleton a = a > 0 ==>+ floatingSingleton log a++prop_log_mid_point = floatingMidPoint log . Interval.intersection (0 <..< PosInf)++case_log_whole = log Interval.whole @?= Interval.whole+case_log_half1 = log (0 <=..< PosInf) @?= Interval.whole+case_log_half2 = log (0 <..< PosInf) @?= Interval.whole+case_log_zero = log (0 :: Interval Double) @?= Interval.empty++case_log_empty = log Interval.empty @?= Interval.empty++prop_log_exp a = log (exp a) =~= a++prop_exp_log a = exp (log a) =~= a `Interval.intersection` (0 <..< PosInf)++-------------------------------------------------------------------------------++prop_sqrt_singleton = floatingSingleton sqrt++prop_sqrt_mid_point = floatingMidPoint sqrt . Interval.intersection (0 <=..< PosInf)++case_sqrt_whole = sqrt Interval.whole @?= 0 <=..< PosInf++case_sqrt_empty = sqrt Interval.empty @?= Interval.empty++prop_sqr_sqrt a = sqrt a * sqrt a =~= a `Interval.intersection` (0 <=..< PosInf)++prop_sqrt_sqr a = sqrt (a * a) =~= abs a++-------------------------------------------------------------------------------++prop_pow_singleton_Double_Double a' b' =+ not (isInfinite c || isNaN c) ==>+ Interval.singleton a ** Interval.singleton b =~= Interval.singleton c+ where+ a = min 5 $ max (-5) a'+ b = min 5 $ max (-5) b'+ c = a ** b++prop_pow_singleton_Double_Integer 0 b'+ | b' < 0 = discard+prop_pow_singleton_Double_Integer a' b' =+ Interval.singleton a ** Interval.singleton b =~= Interval.singleton (a ** b)+ where+ a = min 5 $ max (-5) a'+ b = min 5 $ max (-5) $ fromInteger b'++prop_pow_singleton_Integer_Double a' b =+ not (isInfinite c || isNaN c) ==>+ Interval.singleton a ** Interval.singleton b =~= Interval.singleton (a ** b)+ where+ a = fromInteger a'+ c = a ** b++prop_pow_mid_point a' b' = case (Interval.pickup a, Interval.pickup b) of+ (Nothing, _) -> discard+ (_, Nothing) -> discard+ (Just x, Just y) -> let z = x ** y :: Double in not (isInfinite z || isNaN z) ==>+ ioProperty $ do+ x <- try (evaluate (a ** b))+ return $ case x of+ Left LossOfPrecision -> discard+ Right c -> distance z c < Finite (1e-10 * (1 `max` abs z))+ where+ -- for larger intervals the loss of precision becomes exponentially huge+ a = Interval.mapMonotonic (min 5 . max (-5)) a'+ b = Interval.mapMonotonic (min 5 . max (-5)) b'++prop_pow_empty_1 :: Interval Double -> Bool+prop_pow_empty_1 x = Interval.null (Interval.empty ** x)++prop_pow_empty_2 :: Interval Double -> Bool+prop_pow_empty_2 x = Interval.null (x ** Interval.empty)++-------------------------------------------------------------------------------++prop_sin_singleton a =+ distance (sin a :: Double) (sin (Interval.singleton a)) <= 1e-10++prop_sin_mid_point a+ | Interval.isSingleton a = discard+ | otherwise = floatingMidPoint sin a++case_sin_whole = sin Interval.whole @?= -1 <=..<= 1++case_sin_empty = sin Interval.empty @?= Interval.empty++prop_asin_singleton a = floatingSingleton asin (if abs a < 1 then a else recip a)++prop_asin_mid_point = floatingMidPoint asin . Interval.intersection (-1 <=..<= 1)++case_asin_whole = asin Interval.whole @?= Finite (-pi / 2) <=..<= Finite (pi / 2)++case_asin_empty = asin Interval.empty @?= Interval.empty++prop_sin_asin a = sin (asin a) =~= a `Interval.intersection` (-1 <=..<= 1)++-------------------------------------------------------------------------------++prop_cos_singleton a =+ distance (cos a :: Double) (cos (Interval.singleton a)) <= 1e-10++prop_cos_mid_point a+ | Interval.isSingleton a = discard+ | otherwise = floatingMidPoint cos a++case_cos_whole = cos Interval.whole @?= -1 <=..<= 1++case_cos_empty = cos Interval.empty @?= Interval.empty++prop_acos_singleton a = floatingSingleton acos (if abs a < 1 then a else recip a)++prop_acos_mid_point = floatingMidPoint acos . Interval.intersection (-1 <=..<= 1)++case_acos_whole = acos Interval.whole @?= 0 <=..<= Finite pi++case_acos_empty = acos Interval.empty @?= Interval.empty++prop_cos_acos a = cos (acos a) =~= a `Interval.intersection` (-1 <=..<= 1)++-------------------------------------------------------------------------------++prop_tan_singleton a =+ distance (tan a :: Double) (tan (Interval.singleton a)) <= 1e-10++prop_tan_mid_point a = case Interval.pickup a of+ Nothing -> discard+ Just x -> let z = tan x :: Double in not (isInfinite z || isNaN z) ==>+ ioProperty $ do+ x <- try (evaluate (tan a))+ return $ case x of+ Left LossOfPrecision -> discard+ Right c -> distance z c < Finite (1e-10 * (1 `max` abs z))++case_tan_whole = tan Interval.whole @?= Interval.whole++case_tan_empty = tan Interval.empty @?= Interval.empty++prop_atan_singleton = floatingSingleton atan++prop_atan_mid_point = floatingMidPoint atan++case_atan_whole = atan Interval.whole @?= Finite (-pi / 2) <=..<= Finite (pi / 2)++case_atan_empty = atan Interval.empty @?= Interval.empty++prop_tan_atan a = case (Interval.lowerBound a, Interval.upperBound a) of+ (Finite{}, Finite{}) -> tan (atan a) =~= a+ _ -> discard++-------------------------------------------------------------------------------++prop_sinh_singleton = floatingSingleton sinh++prop_sinh_mid_point = floatingMidPoint sinh++case_sinh_whole = sinh Interval.whole @?= Interval.whole++case_sinh_empty = sinh Interval.empty @?= Interval.empty++prop_asinh_singleton = floatingSingleton asinh++prop_asinh_mid_point = floatingMidPoint asinh++case_asinh_whole = asinh Interval.whole @?= Interval.whole++case_asinh_empty = asinh Interval.empty @?= Interval.empty++prop_asinh_sinh a' = asinh (sinh a) =~= a+ where+ -- for larger intervals the loss of precision becomes exponentially huge+ a = Interval.mapMonotonic (min 5 . max (-5)) a'++prop_sinh_asinh a = sinh (asinh a) =~= a++-------------------------------------------------------------------------------++prop_cosh_singleton = floatingSingleton cosh++prop_cosh_mid_point = floatingMidPoint cosh++case_cosh_whole = cosh Interval.whole @?= 1 <=..< PosInf++case_cosh_empty = cosh Interval.empty @?= Interval.empty++prop_acosh_singleton = floatingSingleton acosh++prop_acosh_mid_point = floatingMidPoint acosh . Interval.intersection (1 <=..< PosInf)++case_acosh_whole = acosh Interval.whole @?= 0 <=..< PosInf++case_acosh_empty = acosh Interval.empty @?= Interval.empty++prop_acosh_cosh a' = acosh (cosh a) =~= abs a+ where+ -- for larger intervals the loss of precision becomes exponentially huge+ a = Interval.mapMonotonic (min 5 . max (-5)) a'++prop_cosh_acosh a = cosh (acosh a) =~= a `Interval.intersection` (1 <=..< PosInf)++-------------------------------------------------------------------------------++prop_tanh_singleton a = abs a <= 10 ==>+ floatingSingleton tanh a++prop_tanh_mid_point = floatingMidPoint tanh . Interval.intersection (-5 <=..<= 5)++case_tanh_whole = tanh Interval.whole @?= -1 <..< 1++case_tanh_empty = tanh Interval.empty @?= Interval.empty++prop_atanh_singleton 1 = atanh 1 === Interval.empty+prop_atanh_singleton (-1) = atanh (-1) === Interval.empty+prop_atanh_singleton a = floatingSingleton atanh (if abs a < 1 then a else recip a)++prop_atanh_mid_point = floatingMidPoint atanh . Interval.intersection (-1 <..< 1)++case_atanh_whole = atanh Interval.whole @?= Interval.whole++case_atanh_empty = atanh Interval.empty @?= Interval.empty++prop_atanh_tanh a' = atanh (tanh a) =~= a+ where+ -- for larger intervals the loss of precision becomes exponentially huge+ a = Interval.mapMonotonic (min 5 . max (-5)) a'++prop_tanh_atanh = uncurry (=~=) . tanhAtanh++case_tanh_atanh_1 = uncurry (@?=) $ tanhAtanh (-1 <=..<= 1)+case_tanh_atanh_2 = uncurry (@?=) $ tanhAtanh (-1 <=..< 1)+case_tanh_atanh_3 = uncurry (@?=) $ tanhAtanh (-1 <..<= 1)+case_tanh_atanh_4 = uncurry (@?=) $ tanhAtanh (-1 <..< 1)++tanhAtanh :: Interval Double -> (Interval Double, Interval Double)+tanhAtanh a = (tanh (atanh a), a `Interval.intersection` (-1 <..< 1))++-------------------------------------------------------------------------------++floatingSingleton :: (forall a. Floating a => a -> a) -> Double -> Property+floatingSingleton f a = Interval.singleton (f a) === f (Interval.singleton a)++distance :: (Ord r, Num r) => r -> Interval r -> Extended r+distance x xs+ | Interval.member x xs = 0+ | otherwise+ = abs (Finite x - Interval.lowerBound xs) `min`+ abs (Finite x - Interval.upperBound xs)++floatingMidPoint :: (forall a. Floating a => a -> a) -> Interval Double -> Property+floatingMidPoint f a = case Interval.pickup a of+ Nothing -> discard+ Just x -> property $ f x `Interval.member` f a++infix 4 =~=+(=~=) :: Interval Double -> Interval Double -> Property+a =~= b+ | eqPair (Interval.lowerBound' a) (Interval.lowerBound' b)+ , eqPair (Interval.upperBound' a) (Interval.upperBound' b)+ = property True+ | otherwise+ = a === b+ where+ eqPair (x, a) (y, b) = eqExt x y && a == b++ eqExt (Finite x) (Finite y) =+ abs (x - y) < 1e-10 * (1 `max` abs x `max` abs y)+ eqExt x y = x == y++{-------------------------------------------------------------------- Lattice --------------------------------------------------------------------} +#ifdef MIN_VERSION_lattices+ prop_Lattice_Leq_welldefined = forAll intervals $ \a b -> a `L.meetLeq` b == a `L.joinLeq` b@@ -769,6 +1180,14 @@ forAll intervals $ \a -> L.bottom `L.joinLeq` a +#else++prop_Lattice_Leq_welldefined = True+prop_top = True+prop_bottom = True++#endif+ {-------------------------------------------------------------------- Read --------------------------------------------------------------------}@@ -778,8 +1197,8 @@ i == read (show i) case_read_old =- read "interval (Finite (0 % 1), True) (PosInf, False)" @?= - (Interval.interval (Finite 0, True) (PosInf, False) :: Interval Rational)+ read "interval (Finite (0 % 1), Closed) (PosInf, Open)" @?=+ (Interval.interval (Finite 0, Interval.Closed) (PosInf, Interval.Open) :: Interval Rational) {-------------------------------------------------------------------- NFData@@ -810,25 +1229,44 @@ | otherwise = x {--------------------------------------------------------------------- Generators+ Storable --------------------------------------------------------------------} -instance Arbitrary r => Arbitrary (Extended r) where- arbitrary =- oneof- [ return NegInf- , return PosInf- , liftM Finite arbitrary- ]+#ifdef MIN_VERSION_quickcheck_classes_base+test_Storable_Int8 = map (uncurry testProperty) $ lawsProperties $+ storableLaws (Proxy :: Proxy (Interval Int8))+test_Storable_Int = map (uncurry testProperty) $ lawsProperties $+ storableLaws (Proxy :: Proxy (Interval Int))+#else+test_Storable_Int8 = []+test_Storable_Int = []+#endif -instance (Arbitrary r, Ord r) => Arbitrary (Interval r) where- arbitrary = do- lb <- arbitrary- ub <- arbitrary- return $ Interval.interval lb ub+{--------------------------------------------------------------------+ Generators+--------------------------------------------------------------------} -intervals :: Gen (Interval Rational)-intervals = arbitrary+nonEmptyIntervalPairs+ :: ( (Extended Rational, Interval.Boundary)+ -> (Extended Rational, Interval.Boundary)+ -> (Extended Rational, Interval.Boundary)+ -> (Extended Rational, Interval.Boundary)+ -> Bool)+ -> Gen (Interval Rational, Interval Rational)+nonEmptyIntervalPairs boundariesComparer = ap (fmap (,) intervals) intervals `suchThat`+ (\(i1, i2) ->+ (not . Interval.null $ i1) &&+ (not . Interval.null $ i2) &&+ boundariesComparer+ (Interval.lowerBound' i1)+ (Interval.upperBound' i1)+ (Interval.lowerBound' i2)+ (Interval.upperBound' i2)+ )++{--------------------------------------------------------------------+ Test intervals+--------------------------------------------------------------------} pos :: Interval Rational pos = 0 <..< PosInf
test/TestIntervalMap.hs view
@@ -1,8 +1,7 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE CPP, TemplateHaskell, ScopedTypeVariables #-} module TestIntervalMap (intervalMapTestGroup) where -import Control.Applicative ((<$>)) import Control.DeepSeq import Control.Exception (evaluate) import Control.Monad@@ -11,12 +10,14 @@ import Data.Generics.Schemes import Data.Hashable import Data.Maybe-import Data.Monoid-import Data.Traversable+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup ((<>))+#endif import Data.Typeable import Test.ChasingBottoms.IsBottom import Test.QuickCheck.Function+import Test.Tasty import Test.Tasty.QuickCheck import Test.Tasty.HUnit import Test.Tasty.TH@@ -32,14 +33,17 @@ empty --------------------------------------------------------------------} +prop_empty_is_bottom :: Property prop_empty_is_bottom = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> IML.isSubmapOf IML.empty a +prop_null_empty :: Property prop_null_empty = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> IML.null a == (a == IML.empty) +case_null_empty :: Assertion case_null_empty = IML.null (IML.empty :: IntervalMap Rational Integer) @?= True @@ -47,17 +51,21 @@ whole --------------------------------------------------------------------} +case_nonnull_whole :: Assertion case_nonnull_whole = IML.null (IML.whole 0 :: IntervalMap Rational Integer) @?= False +prop_whole_Lazy_Strict :: Property prop_whole_Lazy_Strict = do forAll arbitrary $ \(a :: Integer) -> (IML.whole a :: IntervalMap Rational Integer) == IMS.whole a +case_whole_nonstrict :: Assertion case_whole_nonstrict = do _ <- evaluate (IML.whole bottom :: IntervalMap Rational Integer) return () +case_whole_strict :: Assertion case_whole_strict = isBottom (IMS.whole bottom :: IntervalMap Rational Integer) @?= True @@ -65,20 +73,24 @@ singleton --------------------------------------------------------------------} +prop_singleton_insert :: Property 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 :: Property 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 :: Assertion case_singleton_nonstrict = do _ <- evaluate (IML.singleton 0 bottom :: IntervalMap Rational Integer) return () +case_singleton_strict :: Assertion case_singleton_strict = isBottom (IMS.singleton 0 bottom :: IntervalMap Rational Integer) @?= True @@ -86,16 +98,19 @@ insert --------------------------------------------------------------------} +prop_insert_whole :: Property prop_insert_whole = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \a -> IML.insert Interval.whole a m == IML.whole a +prop_insert_empty :: Property prop_insert_empty = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \a -> IML.insert Interval.empty a m == m +prop_insert_comm :: Property prop_insert_comm = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \(i1,a1) ->@@ -104,12 +119,14 @@ ==> (IML.insert i1 a1 (IML.insert i2 a2 m) == IML.insert i2 a2 (IML.insert i1 a1 m)) +prop_insert_isSubmapOf :: Property 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 :: Property prop_insert_member = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \i ->@@ -118,6 +135,7 @@ Just k -> IML.member k (IML.insert i a m) Nothing -> True +prop_insert_lookup :: Property prop_insert_lookup = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \i ->@@ -126,6 +144,7 @@ Just k -> IML.lookup k (IML.insert i a m) == Just a Nothing -> True +prop_insert_bang :: Property prop_insert_bang = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \i ->@@ -134,22 +153,26 @@ Just k -> IML.insert i a m IML.! k == a Nothing -> True +prop_insert_Lazy_Strict :: Property 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 :: Property prop_insert_nonstrict = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \i -> IML.insert i bottom m `seq` True +prop_insert_strict :: Property prop_insert_strict = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \i -> isBottom $ IMS.insert i bottom m +prop_insertWith_Lazy_Strict :: Property prop_insertWith_Lazy_Strict = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \(f :: Fun (Integer,Integer) Integer) ->@@ -157,11 +180,13 @@ forAll arbitrary $ \a -> IML.insertWith (curry (apply f)) i a m == IMS.insertWith (curry (apply f)) i a m +case_insertWith_nonstrict :: Assertion 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 :: Assertion case_insertWith_strict = isBottom (IMS.insertWith (\_ _ -> bottom) (3 <=..< 7) 1 m) @?= True where m :: IntervalMap Rational Integer@@ -171,24 +196,29 @@ delete / update --------------------------------------------------------------------} +prop_delete_empty :: Property prop_delete_empty = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> IML.delete Interval.empty m == m +prop_delete_whole :: Property prop_delete_whole = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> IML.delete Interval.whole m == IML.empty +prop_delete_from_empty :: Property prop_delete_from_empty = forAll arbitrary $ \(i :: Interval Rational) -> IML.delete i (IML.empty :: IntervalMap Rational Integer) == IML.empty +prop_delete_comm :: Property 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 :: Property prop_delete_notMember = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \i ->@@ -196,6 +226,7 @@ Just k -> IML.notMember k (IML.delete i m) Nothing -> True +prop_delete_lookup :: Property prop_delete_lookup = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \i ->@@ -203,6 +234,7 @@ Just k -> IML.lookup k (IML.delete i m) == Nothing Nothing -> True +case_adjust :: Assertion case_adjust = IML.adjust (+1) (3 <=..< 7) m @?= expected where m :: IntervalMap Rational Integer@@ -225,12 +257,14 @@ , (8 <=..< 10, 8) ] +prop_adjust_Lazy_Strict :: Property 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 :: Assertion case_asjust_nonstrict = do _ <- evaluate $ IML.adjust (\_ -> bottom) (3 <=..< 7) m return ()@@ -238,11 +272,13 @@ m :: IntervalMap Rational Integer m = IML.singleton (0 <=..< 10) 0 +case_asjust_strict :: Assertion case_asjust_strict = isBottom (IMS.adjust (\_ -> bottom) (3 <=..< 7) m) @?= True where m :: IntervalMap Rational Integer m = IMS.singleton (0 <=..< 10) 0 +prop_alter :: Property prop_alter = forAll arbitrary $ \(m :: IntervalMap Rational Int) -> forAll arbitrary $ \i ->@@ -252,12 +288,14 @@ Just k -> IML.lookup k (IML.alter (apply f) i m) == apply f (IML.lookup k m) +prop_alter_Lazy_Strict :: Property 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 :: Property prop_alter_nonstrict = forAll arbitrary $ \(m :: IntervalMap Rational Int) -> forAll arbitrary $ \i ->@@ -265,6 +303,7 @@ ==> (IML.alter (\_ -> Just bottom) i m `seq` True) +prop_alter_strict :: Property prop_alter_strict = forAll arbitrary $ \(m :: IntervalMap Rational Int) -> forAll arbitrary $ \i ->@@ -276,60 +315,72 @@ Union --------------------------------------------------------------------} +prop_union_assoc :: Property 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 :: Property prop_union_unitL = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> IML.union IML.empty a == a +prop_union_unitR :: Property prop_union_unitR = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> IML.union a IML.empty == a +prop_union_isSubmapOf :: Property prop_union_isSubmapOf = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> forAll arbitrary $ \b -> IML.isSubmapOf a (IML.union a b) +prop_union_isSubmapOf_equiv :: Property 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 :: Assertion case_unions_empty_list = IML.unions [] @?= (IML.empty :: IntervalMap Rational Integer) +prop_unions_singleton_list :: Property prop_unions_singleton_list = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> IML.unions [a] == a +prop_unions_two_elems :: Property prop_unions_two_elems = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> forAll arbitrary $ \b -> IML.unions [a,b] == IML.union a b +case_unionWith :: Assertion 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 :: Property 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 :: Property prop_unionWith_nonstrict = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> forAll arbitrary $ \b -> IML.unionWith (\_ _ -> bottom) a b `seq` True +prop_unionWith_strict :: Property prop_unionWith_strict = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> forAll arbitrary $ \b ->@@ -341,28 +392,33 @@ Intersection --------------------------------------------------------------------} +prop_intersection_isSubmapOf :: Property prop_intersection_isSubmapOf = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> forAll arbitrary $ \b -> IML.isSubmapOf (IML.intersection a b) a +case_intersectionWith :: Assertion 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 :: Property 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 :: Property 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 :: Property prop_intersectionWith_strict = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> forAll arbitrary $ \(b :: IntervalMap Rational Integer) ->@@ -374,6 +430,7 @@ Difference --------------------------------------------------------------------} +prop_difference_isSubmapOf :: Property prop_difference_isSubmapOf = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> forAll arbitrary $ \(b :: IntervalMap Rational Integer) ->@@ -383,15 +440,18 @@ member / lookup --------------------------------------------------------------------} +prop_notMember_empty :: Property prop_notMember_empty = forAll arbitrary $ \(r::Rational) -> r `IML.notMember` (IML.empty :: IntervalMap Rational Integer) +case_findWithDefault_case1 :: Assertion case_findWithDefault_case1 = IML.findWithDefault "B" 0 m @?= "A" where m :: IntervalMap Rational String m = IML.singleton (0 <=..<1) "A" +case_findWithDefault_case2 :: Assertion case_findWithDefault_case2 = IML.findWithDefault "B" 1 m @?= "B" where m :: IntervalMap Rational String@@ -401,10 +461,12 @@ isSubsetOf --------------------------------------------------------------------} +prop_isSubmapOf_reflexive :: Property prop_isSubmapOf_reflexive = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> a `IML.isSubmapOf` a +prop_isProperSubsetOf_irreflexive :: Property prop_isProperSubsetOf_irreflexive = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> not (a `IML.isProperSubmapOf` a)@@ -413,6 +475,7 @@ span --------------------------------------------------------------------} +prop_span :: Property prop_span = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> IML.span a == IntervalSet.span (IML.keysSet a)@@ -421,21 +484,25 @@ map --------------------------------------------------------------------} +case_mapKeysMonotonic :: Assertion 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 :: Property 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 :: Property prop_map_nonstrict = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> IML.map (const (bottom :: Integer)) a `seq` True +prop_map_strict :: Property prop_map_strict = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> not (IMS.null a)@@ -473,50 +540,60 @@ toList / fromList --------------------------------------------------------------------} +prop_fromList_toList_id :: Property prop_fromList_toList_id = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> IML.fromList (IML.toList a) == a +prop_toAscList_toDescList :: Property prop_toAscList_toDescList = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> IML.toDescList a == reverse (IML.toAscList a) +case_fromList :: Assertion 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 :: Assertion 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 :: Property prop_fromList_Lazy_Strict = forAll arbitrary $ \xs -> (IML.fromList xs :: IntervalMap Rational Integer) == IMS.fromList xs +case_fromList_nonstrict :: Assertion case_fromList_nonstrict = evaluate m >> return () where m :: IntervalMap Rational Integer m = IML.fromList [(0 <=..< 10, bottom), (5 <..<= 15, bottom)] +case_fromList_strict :: Assertion case_fromList_strict = isBottom m @?= True where m :: IntervalMap Rational Integer m = IMS.fromList [(0 <=..< 10, bottom), (5 <..<= 15, bottom)] +prop_fromListWith_Lazy_Strict :: Property 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 :: Assertion case_fromListWith_nonstrict = evaluate m >> return () where m :: IntervalMap Rational Integer m = IML.fromListWith (\_ _ -> bottom) [(0 <=..< 10, 1), (5 <..<= 15, 2)] +case_fromListWith_strict :: Assertion case_fromListWith_strict = isBottom m @?= True where m :: IntervalMap Rational Integer@@ -526,6 +603,7 @@ Filter --------------------------------------------------------------------} +case_filter :: Assertion case_filter = actual @?= expected where m, expected, actual :: IntervalMap Rational Integer@@ -543,6 +621,7 @@ ] actual = IML.filter even m +prop_split :: Property prop_split = forAll arbitrary $ \(m :: IntervalMap Rational Integer) -> forAll arbitrary $ \i ->@@ -556,6 +635,7 @@ , and [i <! j | j <- IML.keys m3] ]) +case_split_case1 :: Assertion case_split_case1 = IML.split (5 <=..<= 9) m @?= (smaller, middle, larger) where@@ -581,6 +661,7 @@ , (20 <..<= 30, "C") ] +case_split_case2 :: Assertion case_split_case2 = IML.split (5 <=..< 10) m @?= (smaller, middle, larger) where@@ -606,6 +687,7 @@ , (20 <..<= 30, "C") ] +case_split_case3 :: Assertion case_split_case3 = IML.split (5 <=..<= 10) m @?= (smaller, middle, larger) where@@ -630,6 +712,7 @@ , (20 <..<= 30, "C") ] +case_split_case4 :: Assertion case_split_case4 = IML.split (5 <=..< 10) m @?= (smaller, middle, larger) where@@ -654,6 +737,7 @@ , (20 <..<= 30, "C") ] +case_split_case5 :: Assertion case_split_case5 = IML.split (5 <=..<= 10) m @?= (smaller, middle, larger) where@@ -679,6 +763,7 @@ , (20 <..<= 30, "C") ] +case_split_case6 :: Assertion case_split_case6 = IML.split (5 <=..< 20) m @?= (smaller, middle, larger) where@@ -704,6 +789,7 @@ , (20 <..<= 30, "C") ] +case_split_case7 :: Assertion case_split_case7 = IML.split (5 <=..<= 20) m @?= (smaller, middle, larger) where@@ -728,6 +814,7 @@ [ (20 <..<= 30, "C") ] +case_split_case8 :: Assertion case_split_case8 = IML.split (5 <=..< 21) m @?= (smaller, middle, larger) where@@ -757,6 +844,7 @@ Eq --------------------------------------------------------------------} +prop_Eq_reflexive :: Property prop_Eq_reflexive = forAll arbitrary $ \(i :: IntervalMap Rational Integer) -> i == i@@ -765,6 +853,7 @@ Show / Read --------------------------------------------------------------------} +prop_show_read_invariance :: Property prop_show_read_invariance = forAll arbitrary $ \(i :: IntervalMap Rational Integer) -> i == read (show i)@@ -773,24 +862,28 @@ Monoid --------------------------------------------------------------------} +prop_monoid_assoc :: Property prop_monoid_assoc = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> forAll arbitrary $ \b -> forAll arbitrary $ \c -> a <> (b <> c) == (a <> b) <> c +prop_monoid_unitL :: Property prop_monoid_unitL = forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->- mempty <> a == a+ IML.empty <> a == a +prop_monoid_unitR :: Property prop_monoid_unitR = forAll arbitrary $ \(a :: IntervalMap Rational Integer) ->- a <> mempty == a+ a <> IML.empty == a {-------------------------------------------------------------------- NFData --------------------------------------------------------------------} +prop_rnf :: Property prop_rnf = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> rnf a == ()@@ -799,6 +892,7 @@ Hashable --------------------------------------------------------------------} +prop_hash :: Property prop_hash = forAll arbitrary $ \(a :: IntervalMap Rational Integer) -> hash a `seq` True@@ -807,6 +901,7 @@ Data ------------------------------------------------------------------ -} +case_Data :: Assertion case_Data = everywhere f i @?= (IML.singleton (1 <=..<= 2) 3 :: IntervalMap Integer Integer) where i :: IntervalMap Integer Integer@@ -819,6 +914,9 @@ Generators --------------------------------------------------------------------} +instance Arbitrary Interval.Boundary where+ arbitrary = arbitraryBoundedEnum+ instance Arbitrary r => Arbitrary (Extended r) where arbitrary = oneof@@ -839,4 +937,5 @@ ------------------------------------------------------------------------ -- Test harness +intervalMapTestGroup :: TestTree intervalMapTestGroup = $(testGroupGenerator)
+ test/TestIntervalRelation.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-}+module TestIntervalRelation (intervalRelationTestGroup) where++import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Test.Tasty.TH++import Data.Interval as I+import Data.IntervalRelation+import Data.Ord (Down(..))++import TestInstances++{--------------------------------------------------------------------+ invert+--------------------------------------------------------------------}++prop_invert_is_involution a =+ invert (invert a) === a++prop_invert_inverts_relation =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ relate a b === invert (relate b a)++------------------------------------------------------------------------++case_empty1 =+ relate (empty :: Interval Rational) empty @?= Equal++prop_empty2 =+ forAllShrink intervals shrink $ \a -> not (I.null a) ==>+ relate (empty :: Interval Rational) a === During++prop_empty3 =+ forAllShrink intervals shrink $ \a -> not (I.null a) ==>+ relate a (empty :: Interval Rational) === Contains++prop_universal_lt =+ forAllShrink intervals shrink $ \a -> not (I.null a) ==>+ forAllShrink intervals shrink $ \b -> not (I.null b) ==>+ let r = relate a b in counterexample (show r) $+ if a <! b then r `elem` [Before, JustBefore]+ else r `notElem` [Before, JustBefore]++prop_universal_le =+ forAllShrink intervals shrink $ \a -> not (I.null a) ==>+ forAllShrink intervals shrink $ \b -> not (I.null b) ==>+ let r = relate a b in counterexample (show r) $+ if a <=! b then r `elem` [Before, JustBefore, Overlaps, Starts, Equal, FinishedBy]+ else r `notElem` [Before, JustBefore]++prop_universal_eq =+ forAllShrink intervals shrink $ \a -> not (I.null a) ==>+ forAllShrink intervals shrink $ \b -> not (I.null b) ==>+ not (a ==! b) || relate a b == Equal++prop_universal_gt =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ (a >! b) === (b <! a)++prop_universal_ge =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ (a >=! b) === (b <=! a)++prop_universal_ne =+ forAllShrink intervals shrink $ \a -> not (I.null a) ==>+ forAllShrink intervals shrink $ \b -> not (I.null b) ==>+ let r = relate a b in counterexample (show r) $+ if a /=! b then r `elem` [Before, JustBefore, After, JustAfter]+ else r `notElem` [Before, JustBefore, After, JustAfter]++------------------------------------------------------------------------++prop_existential_lt =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ (a <? b) === not (a >=! b)++prop_existential_le =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ (a <=? b) === not (a >! b)++prop_existential_eq =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ (a ==? b) === not (a /=! b)++prop_existential_gt =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ (a >? b) === not (a <=! b)++prop_existential_ge =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ (a >=? b) === not (a <! b)++prop_existential_ne =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ (a /=? b) === not (a ==! b)++------------------------------------------------------------------------++prop_before =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ let r = relate a b in counterexample (show r) $+ (r == Before) === (a <! b && not (isConnected a b))++prop_just_before =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ let r = relate a b in counterexample (show r) $+ (r == JustBefore) === (a <! b && isConnected a b && not (I.null a) && not (I.null b))++prop_overlaps =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ let r = relate a b in counterexample (show r) $+ (r == Overlaps) === (not (I.null (intersection a b)) && fmap Down (lowerBound' a) < fmap Down (lowerBound' b) && upperBound' a < upperBound' b)++prop_starts =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ let r = relate a b in counterexample (show r) $+ (r == Starts) === (isProperSubsetOf a b && lowerBound' a == lowerBound' b)++prop_during =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ let r = relate a b in counterexample (show r) $+ (r == During) === (isProperSubsetOf a b && lowerBound' a /= lowerBound' b && upperBound' a /= upperBound' b)++prop_finishes =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ let r = relate a b in counterexample (show r) $+ (r == Finishes) === (isProperSubsetOf a b && upperBound' a == upperBound' b)++prop_equal =+ forAllShrink intervals shrink $ \a ->+ forAllShrink intervals shrink $ \b ->+ let r = relate a b in counterexample (show r) $+ (r == Equal) === (a == b)++------------------------------------------------------------------------+-- Test harness++intervalRelationTestGroup = $(testGroupGenerator)
test/TestIntervalSet.hs view
@@ -1,12 +1,16 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE CPP, TemplateHaskell, ScopedTypeVariables #-} module TestIntervalSet (intervalSetTestGroup) where +#ifdef MIN_VERSION_lattices import qualified Algebra.Lattice as L+#endif import Control.Applicative ((<$>))+import Control.Arrow (first) import Control.DeepSeq import Control.Monad import Data.Generics.Schemes import Data.Hashable+import qualified Data.List as L import Data.Maybe import Data.Monoid import Data.Ratio@@ -60,6 +64,9 @@ forAll arbitrary $ \r1 -> not $ IntervalSet.null $ fromRational (r1::Rational) +case_singleton_1 =+ IntervalSet.singleton Interval.empty @?= (IntervalSet.empty :: IntervalSet Rational)+ {-------------------------------------------------------------------- complement --------------------------------------------------------------------}@@ -80,6 +87,10 @@ fromList --------------------------------------------------------------------} +case_fromList_minus_one_to_one_without_zero = xs @?= xs+ where+ xs = show (IntervalSet.fromList [ (-1 <..< 0 :: Interval Rational), 0 <..<1 ])+ case_fromList_connected = IntervalSet.fromList [ (0 <=..< 1 :: Interval Rational), 1 <=..<2 ] @?= IntervalSet.fromList [ 0 <=..<2 ]@@ -108,6 +119,22 @@ IntervalSet.insert (1 <=..< 2 :: Interval Rational) (IntervalSet.fromList [ 0 <=..< 1, 2 <=..< 3 ]) @?= IntervalSet.singleton (0 <=..< 3) +case_insert_zero =+ IntervalSet.insert zero (IntervalSet.complement $ IntervalSet.singleton zero) @?= IntervalSet.whole+ where+ zero :: Interval Rational+ zero = 0 <=..<= 0++case_insert_zero_negative =+ IntervalSet.insert zero negative @?= nonPositive+ where+ zero :: Interval Rational+ zero = 0 <=..<= 0+ negative :: IntervalSet Rational+ negative = IntervalSet.singleton $ NegInf <..< 0+ nonPositive :: IntervalSet Rational+ nonPositive = IntervalSet.singleton $ NegInf <..<= 0+ {-------------------------------------------------------------------- delete --------------------------------------------------------------------}@@ -160,11 +187,22 @@ forAll arbitrary $ \(a :: IntervalSet Rational) -> IntervalSet.intersection a IntervalSet.empty == IntervalSet.empty +prop_intersection_isSubsetOf_integer =+ forAll arbitrary $ \(a :: IntervalSet Integer) ->+ forAll arbitrary $ \b ->+ IntervalSet.isSubsetOf (IntervalSet.intersection a b) a+ prop_intersection_isSubsetOf = forAll arbitrary $ \(a :: IntervalSet Rational) -> forAll arbitrary $ \b -> IntervalSet.isSubsetOf (IntervalSet.intersection a b) a +prop_intersection_isSubsetOf_equiv_integer =+ forAll arbitrary $ \(a :: IntervalSet Integer) ->+ forAll arbitrary $ \b ->+ (IntervalSet.intersection a b == a)+ == IntervalSet.isSubsetOf a b+ prop_intersection_isSubsetOf_equiv = forAll arbitrary $ \(a :: IntervalSet Rational) -> forAll arbitrary $ \b ->@@ -211,11 +249,22 @@ forAll arbitrary $ \(a :: IntervalSet Rational) -> IntervalSet.union a IntervalSet.whole == IntervalSet.whole +prop_union_isSubsetOf_integer =+ forAll arbitrary $ \(a :: IntervalSet Integer) ->+ forAll arbitrary $ \b ->+ IntervalSet.isSubsetOf a (IntervalSet.union a b)+ prop_union_isSubsetOf = forAll arbitrary $ \(a :: IntervalSet Rational) -> forAll arbitrary $ \b -> IntervalSet.isSubsetOf a (IntervalSet.union a b) +prop_union_isSubsetOf_equiv_integer =+ forAll arbitrary $ \(a :: IntervalSet Integer) ->+ forAll arbitrary $ \b ->+ (IntervalSet.union a b == b)+ == IntervalSet.isSubsetOf a b+ prop_union_isSubsetOf_equiv = forAll arbitrary $ \(a :: IntervalSet Rational) -> forAll arbitrary $ \b ->@@ -244,6 +293,10 @@ span --------------------------------------------------------------------} +prop_span_integer =+ forAll arbitrary $ \(a :: IntervalSet Integer) ->+ a `IntervalSet.isSubsetOf` IntervalSet.singleton (IntervalSet.span a)+ prop_span = forAll arbitrary $ \(a :: IntervalSet Rational) -> a `IntervalSet.isSubsetOf` IntervalSet.singleton (IntervalSet.span a)@@ -251,18 +304,98 @@ case_span_empty = IntervalSet.span IntervalSet.empty @?= (Interval.empty :: Interval Rational) +case_span_whole =+ IntervalSet.span IntervalSet.whole @?= (Interval.whole :: Interval Rational)++case_span_without_zero =+ IntervalSet.span (IntervalSet.complement $ IntervalSet.singleton $ 0 <=..<= 0) @?=+ (Interval.whole :: Interval Rational)++case_span_1 =+ IntervalSet.span (IntervalSet.fromList [0 <=..< 10, 20 <..< PosInf]) @?=+ 0 <=..< PosInf+ {-------------------------------------------------------------------- member --------------------------------------------------------------------} +prop_member =+ forAll arbitrary $ \(r :: Rational) (is :: IntervalSet Rational) ->+ r `IntervalSet.member` is ==+ any (r `Interval.member`) (IntervalSet.toList is)++prop_member_empty =+ forAll arbitrary $ \(r :: Rational) ->+ not (r `IntervalSet.member` IntervalSet.empty)++prop_member_singleton =+ forAll arbitrary $ \(r1 :: Rational) (r2 :: Rational) ->+ r1 `IntervalSet.member` IntervalSet.singleton (Interval.singleton r2) ==+ (r1 == r2)+ prop_notMember_empty =- forAll arbitrary $ \(r::Rational) ->+ forAll arbitrary $ \(r :: Rational) -> r `IntervalSet.notMember` IntervalSet.empty {-------------------------------------------------------------------- isSubsetOf --------------------------------------------------------------------} +case_isSubsetOf_1 = IntervalSet.isSubsetOf a b @?= False+ where+ a = IntervalSet.singleton (NegInf <..<= 2)+ b = IntervalSet.singleton (NegInf <..<= 1)++case_isSubsetOf_2 = IntervalSet.isSubsetOf a b @?= False+ where+ a = IntervalSet.singleton (1 <=..< PosInf)+ b = IntervalSet.singleton (2 <=..< PosInf)++case_isSubsetOf_3 = IntervalSet.isSubsetOf a b @?= False+ where+ a = IntervalSet.singleton (0 <=..< 1)+ b = IntervalSet.singleton (2 <..< PosInf)++case_isSubsetOf_4 = IntervalSet.isSubsetOf a b @?= False+ where+ a = IntervalSet.singleton (0 <=..<= 1)+ b = IntervalSet.singleton (2 <..< PosInf)++case_isSubsetOf_5 = IntervalSet.isSubsetOf a b @?= False+ where+ a = IntervalSet.singleton (0 <..< 1)+ b = IntervalSet.singleton (2 <=..< PosInf)++case_isSubsetOf_6 = IntervalSet.isSubsetOf a b @?= False+ where+ a = IntervalSet.singleton (0 <..< 1)+ b = IntervalSet.singleton (2 <..< PosInf)++case_isSubsetOf_7 = IntervalSet.isSubsetOf a b @?= False+ where+ a = IntervalSet.singleton (0 <..<= 1)+ b = IntervalSet.fromList [NegInf <..<= 0, 1 <=..< PosInf]++case_isSubsetOf_8 = IntervalSet.isSubsetOf a b @?= False+ where+ a = IntervalSet.singleton (0 <..< 1)+ b = IntervalSet.fromList [NegInf <..< 0, 1 <=..< PosInf]++case_isSubsetOf_9 = IntervalSet.isSubsetOf a b @?= True+ where+ a = IntervalSet.singleton (-3 <..< 1)+ b = IntervalSet.singleton (-4 <..< 2)++case_isSubsetOf_10 = IntervalSet.isSubsetOf a b @?= True+ where+ a = IntervalSet.singleton (14 <=..<= 16)+ b = IntervalSet.singleton (-8 <=..< PosInf)++case_isSubsetOf_11 = IntervalSet.isSubsetOf a b @?= False+ where+ a = IntervalSet.singleton (0 <=..<= 1)+ b = IntervalSet.fromList [0 <=..<= 0, 1 <=..< PosInf]+ prop_isSubsetOf_reflexive = forAll arbitrary $ \(a :: IntervalSet Rational) -> a `IntervalSet.isSubsetOf` a@@ -271,6 +404,14 @@ forAll arbitrary $ \(a :: IntervalSet Rational) -> not (a `IntervalSet.isProperSubsetOf` a) +prop_isSubsetOf_empty =+ forAll arbitrary $ \(a :: IntervalSet Rational) ->+ IntervalSet.empty `IntervalSet.isSubsetOf` a++prop_isSubsetOf_whole =+ forAll arbitrary $ \(a :: IntervalSet Rational) ->+ a `IntervalSet.isSubsetOf` IntervalSet.whole+ {-------------------------------------------------------------------- toList / fromList --------------------------------------------------------------------}@@ -279,6 +420,15 @@ forAll arbitrary $ \(a :: IntervalSet Rational) -> IntervalSet.fromList (IntervalSet.toList a) == a +prop_fromAscList_toAscList_id =+ forAll arbitrary $ \(a :: IntervalSet Rational) ->+ IntervalSet.fromAscList (IntervalSet.toAscList a) == a++case_toDescList_simple = xs @?= xs+ where+ xs = IntervalSet.toDescList $+ IntervalSet.fromList [NegInf <..< Finite (-1), Finite 1 <..< PosInf]+ prop_toAscList_toDescList = forAll arbitrary $ \(a :: IntervalSet Rational) -> IntervalSet.toDescList a == reverse (IntervalSet.toAscList a)@@ -295,6 +445,8 @@ Lattice --------------------------------------------------------------------} +#ifdef MIN_VERSION_lattices+ prop_Lattice_Leq_welldefined = forAll arbitrary $ \(a :: IntervalSet Rational) (b :: IntervalSet Rational) -> a `L.meetLeq` b == a `L.joinLeq` b@@ -307,6 +459,14 @@ forAll arbitrary $ \(a :: IntervalSet Rational) -> L.bottom `L.joinLeq` a +#else++prop_Lattice_Leq_welldefined = True+prop_top = True+prop_bottom = True++#endif+ {-------------------------------------------------------------------- Show / Read --------------------------------------------------------------------}@@ -443,9 +603,8 @@ 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+prop_recip (a :: IntervalSet Rational) =+ recip (recip a) === IntervalSet.delete (Interval.singleton 0) a {- ------------------------------------------------------------------ Data@@ -463,32 +622,38 @@ Generators --------------------------------------------------------------------} +instance Arbitrary Interval.Boundary where+ arbitrary = arbitraryBoundedEnum+ instance Arbitrary r => Arbitrary (Extended r) where arbitrary = oneof- [ return NegInf- , return PosInf- , liftM Finite arbitrary+ [ pure NegInf+ , pure PosInf+ , fmap Finite arbitrary ] instance (Arbitrary r, Ord r) => Arbitrary (Interval r) where- arbitrary = do- lb <- arbitrary- ub <- arbitrary- return $ Interval.interval lb ub+ arbitrary =+ Interval.interval <$> arbitrary <*> arbitrary instance (Arbitrary r, Ord r) => Arbitrary (IntervalSet r) where- arbitrary = do+ arbitrary = do+ tabStops <- L.sort <$> arbitrary+ let is = IntervalSet.fromList $ go tabStops 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+ pure $ if b then is else IntervalSet.complement is+ where+ go [] = []+ go [(x, LT)] = [Finite x <..< PosInf]+ go [(x, GT)] = [Finite x <=..< PosInf]+ go ((x, EQ) : rest) = Interval.singleton x : go rest+ go ((x, LT) : (y, LT) : rest) = (Finite x <..< Finite y) : go rest+ go ((x, LT) : (y, GT) : rest) = (Finite x <..<= Finite y) : go rest+ go ((x, GT) : (y, LT) : rest) = (Finite x <=..< Finite y) : go rest+ go ((x, GT) : (y, GT) : rest) = (Finite x <=..<= Finite y) : go rest+ go ((x, LT) : (y, EQ) : rest) = (Finite x <..< Finite y) : go ((y, LT) : rest)+ go ((x, GT) : (y, EQ) : rest) = (Finite x <=..< Finite y) : go ((y, LT) : rest) intervals :: Gen (Interval Rational) intervals = arbitrary
test/TestSuite.hs view
@@ -2,6 +2,7 @@ import TestInterval import TestIntervalMap+import TestIntervalRelation import TestIntervalSet import TestIntegerInterval import Test.Tasty@@ -10,6 +11,7 @@ main = defaultMain $ testGroup "data-interval test suite" [ intervalTestGroup , intervalMapTestGroup+ , intervalRelationTestGroup , intervalSetTestGroup , integerIntervalTestGroup ]