data-interval 1.3.0 → 1.3.1

raw patch · 7 files changed

+339/−213 lines, 7 filesdep ~basedep ~hashabledep ~latticesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, hashable, lattices

API changes (from Hackage documentation)

Files

• README.md +5/−1
• data-interval.cabal +16/−5
• src/Data/IntegerInterval.hs +58/−94
• src/Data/IntegerInterval/Internal.hs +83/−0
• src/Data/Interval.hs +87/−113
• src/Data/Interval/Internal.hs +74/−0
• src/Data/IntervalSet.hs +16/−0

@@ -1,7 +1,11 @@ data-interval ============= -[![Build Status](https://secure.travis-ci.org/msakai/data-interval.png?branch=master)](http://travis-ci.org/msakai/data-interval) [![Hackage](https://img.shields.io/hackage/v/data-interval.svg)](https://hackage.haskell.org/package/data-interval) [![Coverage Status](https://coveralls.io/repos/msakai/data-interval/badge.svg)](https://coveralls.io/r/msakai/data-interval)+[![Build Status](https://travis-ci.org/msakai/data-interval.svg?branch=master)](https://travis-ci.org/msakai/data-interval)+[![Hackage](https://img.shields.io/hackage/v/data-interval.svg)](https://hackage.haskell.org/package/data-interval)+[![Hackage Deps](https://img.shields.io/hackage-deps/v/data-interval.svg)](https://packdeps.haskellers.com/feed?needle=data-interval)+[![Coverage Status](https://coveralls.io/repos/msakai/data-interval/badge.svg)](https://coveralls.io/r/msakai/data-interval)+[![License](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause)  Interval datatype, interval arithmetic, and interval-based containers for Haskell. 

@@ -1,5 +1,5 @@ Name:		data-interval-Version:	1.3.0+Version:	1.3.1 License:	BSD3 License-File:	COPYING Author:		Masahiro Sakai (masahiro.sakai@gmail.com)@@ -18,6 +18,13 @@    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  source-repository head   type:     git@@ -28,9 +35,9 @@   Build-Depends:        base >=4 && <5      , containers-     , lattices >=1.2.1.1+     , lattices >=1.2.1.1 && <2.1      , deepseq-     , hashable >=1.1.2.5 && <1.3+     , hashable >=1.1.2.5 && <1.4      , extended-reals >=0.2 && <1.0   if impl(ghc <8.0)     Build-depends:@@ -41,6 +48,8 @@      ScopedTypeVariables      TypeFamilies      DeriveDataTypeable+     MultiWayIf+     Safe   Exposed-Modules:      Data.Interval      Data.IntervalMap.Lazy@@ -48,6 +57,8 @@      Data.IntervalSet      Data.IntegerInterval   Other-Modules:+     Data.Interval.Internal+     Data.IntegerInterval.Internal      Data.IntervalMap.Base  Test-suite test-interval@@ -65,8 +76,8 @@      , data-interval      , syb      , tasty >=0.10.1-     , tasty-hunit ==0.9.*-     , tasty-quickcheck ==0.8.*+     , tasty-hunit >=0.9 && <0.11+     , tasty-quickcheck >=0.8 && <0.11      , tasty-th      , HUnit      , QuickCheck >=2.5 && <3

@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-} {-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- |@@ -78,18 +78,15 @@   ) where  import Algebra.Lattice-import Control.DeepSeq import Control.Exception (assert) import Control.Monad hiding (join)-import Data.Data import Data.ExtendedReal-import Data.Hashable import Data.List hiding (null) import Data.Maybe import Prelude hiding (null)+import Data.IntegerInterval.Internal import qualified Data.Interval as Interval -infix 5 <=..<= infix 5 <..<= infix 5 <=..< infix 5 <..<@@ -112,48 +109,36 @@ infix 4 >?? infix 4 /=?? --- | The intervals (/i.e./ connected and convex subsets) over integers (__Z__).-data IntegerInterval = Interval !(Extended Integer) !(Extended Integer)-  deriving (Eq, Typeable)---- | Lower endpoint (/i.e./ greatest lower bound)  of the interval.------ * 'lowerBound' of the empty interval is 'PosInf'.------ * 'lowerBound' of a left unbounded interval is 'NegInf'.------ * 'lowerBound' of an interval may or may not be a member of the interval.-lowerBound :: IntegerInterval -> Extended Integer-lowerBound (Interval lb _) = lb---- | Upper endpoint (/i.e./ least upper bound) of the interval.------ * 'upperBound' of the empty interval is 'NegInf'.------ * 'upperBound' of a right unbounded interval is 'PosInf'.------ * 'upperBound' of an interval is a member of the interval.-upperBound :: IntegerInterval -> Extended Integer-upperBound (Interval _ ub) = ub- -- | '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' (Interval lb@(Finite _)  _) = (lb, True)-lowerBound' (Interval lb  _) = (lb, False)+lowerBound' x =+  case lowerBound x of+    lb@(Finite _) -> (lb, True)+    lb@_ -> (lb, False)  -- | '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' (Interval _ ub@(Finite _)) = (ub, True)-upperBound' (Interval _ ub) = (ub, False)+upperBound' x =+  case upperBound x of+    ub@(Finite _) -> (ub, True)+    ub@_ -> (ub, False) -instance NFData IntegerInterval where-  rnf (Interval lb ub) = rnf lb `seq` rnf ub+#if MIN_VERSION_lattices(2,0,0) -instance Hashable IntegerInterval where-  hashWithSalt s (Interval lb ub) = s `hashWithSalt` lb `hashWithSalt` ub+instance Lattice IntegerInterval where+  (\/) = hull+  (/\) = intersection +instance BoundedJoinSemiLattice IntegerInterval where+  bottom = empty++instance BoundedMeetSemiLattice IntegerInterval where+  top = whole++#else+ instance JoinSemiLattice IntegerInterval where   join = hull @@ -170,6 +155,8 @@  instance BoundedLattice IntegerInterval +#endif+ instance Show IntegerInterval where   showsPrec _ x | null x = showString "empty"   showsPrec p x =@@ -195,23 +182,6 @@     (do ("empty", s) <- lex r         return (empty, s)) --- This instance preserves data abstraction at the cost of inefficiency.--- We provide limited reflection services for the sake of data abstraction.--instance Data IntegerInterval where-  gfoldl k z x   = z (<=..<=) `k` lowerBound x `k` upperBound x-  toConstr _     = intervalConstr-  gunfold k z c  = case constrIndex c of-    1 -> k (k (z (<=..<=)))-    _ -> error "gunfold"-  dataTypeOf _   = intervalDataType--intervalConstr :: Constr-intervalConstr = mkConstr intervalDataType "<=..<=" [] Infix--intervalDataType :: DataType-intervalDataType = mkDataType "Data.IntegerInterval.IntegerInterval" [intervalConstr]- -- | smart constructor for 'IntegerInterval' interval   :: (Extended Integer, Bool) -- ^ lower bound and whether it is included@@ -220,17 +190,6 @@ interval (x1,in1) (x2,in2) =   (if in1 then x1 else x1 + 1) <=..<= (if in2 then x2 else x2 - 1) --- | closed interval [@l@,@u@]-(<=..<=)-  :: Extended Integer -- ^ lower bound @l@-  -> Extended Integer -- ^ upper bound @u@-  -> IntegerInterval-(<=..<=) PosInf _ = empty-(<=..<=) _ NegInf = empty-(<=..<=) lb ub-  | lb <= ub  = Interval lb ub-  | otherwise = empty- -- | left-open right-closed interval (@l@,@u@] (<..<=)   :: Extended Integer -- ^ lower bound @l@@@ -254,11 +213,7 @@  -- | whole real number line (-∞, ∞) whole :: IntegerInterval-whole = Interval NegInf PosInf---- | empty (contradicting) interval-empty :: IntegerInterval-empty = Interval PosInf NegInf+whole = NegInf <=..<= PosInf  -- | singleton set \[x,x\] singleton :: Integer -> IntegerInterval@@ -266,7 +221,8 @@  -- | intersection of two intervals intersection :: IntegerInterval -> IntegerInterval -> IntegerInterval-intersection (Interval l1 u1) (Interval l2 u2) = max l1 l2 <=..<= min u1 u2+intersection x1 x2 =+  max (lowerBound x1) (lowerBound x2) <=..<= min (upperBound x1) (upperBound x2)  -- | intersection of a list of intervals. intersections :: [IntegerInterval] -> IntegerInterval@@ -277,7 +233,8 @@ hull x1 x2   | null x1 = x2   | null x2 = x1-hull (Interval l1 u1) (Interval l2 u2) = min l1 l2 <=..<= max u1 u2+hull x1 x2 =+  min (lowerBound x1) (lowerBound x2) <=..<= max (upperBound x1) (upperBound x2)  -- | convex hull of a list of intervals. hulls :: [IntegerInterval] -> IntegerInterval@@ -285,18 +242,18 @@  -- | @mapMonotonic f i@ is the image of @i@ under @f@, where @f@ must be a strict monotone function. mapMonotonic :: (Integer -> Integer) -> IntegerInterval -> IntegerInterval-mapMonotonic f (Interval l u) = Interval (fmap f l) (fmap f u)+mapMonotonic f x = fmap f (lowerBound x) <=..<= fmap f (upperBound x)  -- | Is the interval empty? null :: IntegerInterval -> Bool-null (Interval l u) = u < l+null x = upperBound x < lowerBound x  isSingleton :: IntegerInterval -> Bool-isSingleton (Interval l u) = l==u+isSingleton x = lowerBound x == upperBound x  -- | Is the element in the interval? member :: Integer -> IntegerInterval -> Bool-member x (Interval l u) = l <= Finite x && Finite x <= u+member x i = lowerBound i <= Finite x && Finite x <= upperBound i  -- | Is the element not in the interval? notMember :: Integer -> IntegerInterval -> Bool@@ -305,7 +262,7 @@ -- | Is this a subset? -- @(i1 \``isSubsetOf`\` i2)@ tells whether @i1@ is a subset of @i2@. isSubsetOf :: IntegerInterval -> IntegerInterval -> Bool-isSubsetOf (Interval lb1 ub1) (Interval lb2 ub2) = lb2 <= lb1 && ub1 <= ub2+isSubsetOf i1 i2 = lowerBound i2 <= lowerBound i1 && upperBound i1 <= upperBound i2  -- | Is this a proper subset? (/i.e./ a subset but not equal). isProperSubsetOf :: IntegerInterval -> IntegerInterval -> Bool@@ -313,16 +270,21 @@  -- | Width of a interval. Width of an unbounded interval is @undefined@. width :: IntegerInterval -> Integer-width x | null x = 0-width (Interval (Finite l) (Finite u)) = u - l-width _ = error "Data.IntegerInterval.width: unbounded interval"+width x+  | null x = 0+  | otherwise =+      case (upperBound x, lowerBound x) of+        (Finite lb, Finite ub) -> ub - lb+        _ -> error "Data.IntegerInterval.width: unbounded interval"  -- | pick up an element from the interval if the interval is not empty. pickup :: IntegerInterval -> Maybe Integer-pickup (Interval NegInf PosInf) = Just 0-pickup (Interval (Finite l) _) = Just l-pickup (Interval _ (Finite u)) = Just u-pickup _ = Nothing+pickup x =+  case (lowerBound x, upperBound x) of+    (NegInf, PosInf) -> Just 0+    (Finite l, _) -> Just l+    (_, Finite u) -> Just u+    _ -> Nothing  -- | 'simplestIntegerWithin' returns the simplest rational number within the interval. --@@ -452,15 +414,16 @@  scaleInterval :: Integer -> IntegerInterval -> IntegerInterval scaleInterval _ x | null x = empty-scaleInterval c (Interval lb ub) =+scaleInterval c x =   case compare c 0 of     EQ -> singleton 0-    LT -> Finite c * ub <=..<= Finite c * lb-    GT -> Finite c * lb <=..<= Finite c * ub+    LT -> Finite c * upperBound x <=..<= Finite c * lowerBound x+    GT -> Finite c * lowerBound x <=..<= Finite c * upperBound x  instance Num IntegerInterval where-  a + b | null a || null b = empty-  Interval lb1 ub1 + Interval lb2 ub2 = lb1 + lb2 <=..<= ub1 + ub2+  a + b+      | null a || null b = empty+      | otherwise = lowerBound a + lowerBound b <=..<= upperBound a + upperBound b    negate = scaleInterval (-1) @@ -480,10 +443,11 @@             then empty             else singleton (-1) -  a * b | null a || null b = empty-  Interval lb1 ub1 * Interval lb2 ub2 = minimum xs <=..<= maximum xs+  a * b+    | null a || null b = empty+    | otherwise = minimum xs <=..<= maximum xs     where-      xs = [ mul x1 x2 | x1 <- [lb1, ub1], x2 <- [lb2, ub2] ]+      xs = [ mul x1 x2 | x1 <- [lowerBound a, upperBound a], x2 <- [lowerBound b, upperBound b] ]        mul :: Extended Integer -> Extended Integer -> Extended Integer       mul 0 _ = 0@@ -492,7 +456,7 @@  -- | Convert the interval to 'Interval.Interval' data type. toInterval :: Real r => IntegerInterval -> Interval.Interval r-toInterval (Interval l u) = fmap fromInteger l Interval.<=..<= fmap fromInteger u+toInterval x = fmap fromInteger (lowerBound x) Interval.<=..<= fmap fromInteger (upperBound x)  -- | Conversion from 'Interval.Interval' data type. fromInterval :: Interval.Interval Integer -> IntegerInterval

@@ -0,0 +1,83 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE Safe #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations #-}+#endif++module Data.IntegerInterval.Internal+  ( IntegerInterval+  , lowerBound+  , upperBound+  , (<=..<=)+  , empty+  ) where++import Control.DeepSeq+import Data.Data+import Data.ExtendedReal+import Data.Hashable++infix 5 <=..<=++-- | The intervals (/i.e./ connected and convex subsets) over integers (__Z__).+data IntegerInterval = Interval !(Extended Integer) !(Extended Integer)+  deriving (Eq, Typeable)++-- | Lower endpoint (/i.e./ greatest lower bound)  of the interval.+--+-- * 'lowerBound' of the empty interval is 'PosInf'.+--+-- * 'lowerBound' of a left unbounded interval is 'NegInf'.+--+-- * 'lowerBound' of an interval may or may not be a member of the interval.+lowerBound :: IntegerInterval -> Extended Integer+lowerBound (Interval lb _) = lb++-- | Upper endpoint (/i.e./ least upper bound) of the interval.+--+-- * 'upperBound' of the empty interval is 'NegInf'.+--+-- * 'upperBound' of a right unbounded interval is 'PosInf'.+--+-- * 'upperBound' of an interval is a member of the interval.+upperBound :: IntegerInterval -> Extended Integer+upperBound (Interval _ ub) = ub++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data IntegerInterval where+  gfoldl k z x   = z (<=..<=) `k` lowerBound x `k` upperBound x+  toConstr _     = intervalConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (k (z (<=..<=)))+    _ -> error "gunfold"+  dataTypeOf _   = intervalDataType++intervalConstr :: Constr+intervalConstr = mkConstr intervalDataType "<=..<=" [] Infix++intervalDataType :: DataType+intervalDataType = mkDataType "Data.IntegerInterval.Internal.IntegerInterval" [intervalConstr]++instance NFData IntegerInterval where+  rnf (Interval lb ub) = rnf lb `seq` rnf ub++instance Hashable IntegerInterval where+  hashWithSalt s (Interval lb ub) = s `hashWithSalt` lb `hashWithSalt` ub++-- | closed interval [@l@,@u@]+(<=..<=)+  :: Extended Integer -- ^ lower bound @l@+  -> Extended Integer -- ^ upper bound @u@+  -> IntegerInterval+(<=..<=) PosInf _ = empty+(<=..<=) _ NegInf = empty+(<=..<=) lb ub+  | lb <= ub  = Interval lb ub+  | otherwise = empty++-- | empty (contradicting) interval+empty :: IntegerInterval+empty = Interval PosInf NegInf

@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE Safe #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-}@@ -79,12 +79,10 @@   ) where  import Algebra.Lattice-import Control.DeepSeq import Control.Exception (assert) import Control.Monad hiding (join)-import Data.Data import Data.ExtendedReal-import Data.Hashable+import Data.Interval.Internal import Data.List hiding (null) import Data.Maybe import Data.Monoid@@ -114,49 +112,19 @@ infix 4 >?? infix 4 /=?? --- | The intervals (/i.e./ connected and convex subsets) over real numbers __R__.-data Interval r = Interval !(Extended r, Bool) !(Extended r, Bool)-  deriving (Eq, Typeable)--#if __GLASGOW_HASKELL__ >= 708-type role Interval nominal-#endif---- | Lower endpoint (/i.e./ greatest lower bound)  of the interval.------ * 'lowerBound' of the empty interval is 'PosInf'.------ * 'lowerBound' of a left unbounded interval is 'NegInf'.------ * 'lowerBound' of an interval may or may not be a member of the interval.-lowerBound :: Interval r -> Extended r-lowerBound (Interval (lb,_) _) = lb---- | Upper endpoint (/i.e./ least upper bound) of the interval.------ * 'upperBound' of the empty interval is 'NegInf'.------ * 'upperBound' of a right unbounded interval is 'PosInf'.------ * 'upperBound' of an interval may or may not be a member of the interval.-upperBound :: Interval r -> Extended r-upperBound (Interval _ (ub,_)) = ub+#if MIN_VERSION_lattices(2,0,0) --- | 'lowerBound' of the interval and whether it is included in the interval.--- The result is convenient to use as an argument for 'interval'.-lowerBound' :: Interval r -> (Extended r, Bool)-lowerBound' (Interval lb _) = lb+instance (Ord r) => Lattice (Interval r) where+  (\/) = hull+  (/\) = intersection --- | 'upperBound' of the interval and whether it is included in the interval.--- The result is convenient to use as an argument for 'interval'.-upperBound' :: Interval r -> (Extended r, Bool)-upperBound' (Interval _ ub) = ub+instance (Ord r) => BoundedJoinSemiLattice (Interval r) where+  bottom = empty -instance NFData r => NFData (Interval r) where-  rnf (Interval lb ub) = rnf lb `seq` rnf ub+instance (Ord r) => BoundedMeetSemiLattice (Interval r) where+  top = whole -instance Hashable r => Hashable (Interval r) where-  hashWithSalt s (Interval lb ub) = s `hashWithSalt` lb `hashWithSalt` ub+#else  instance (Ord r) => JoinSemiLattice (Interval r) where   join = hull@@ -174,14 +142,18 @@  instance (Ord r) => BoundedLattice (Interval r) +#endif+ instance (Ord r, Show r) => Show (Interval r) where   showsPrec _ x | null x = showString "empty"-  showsPrec p (Interval (lb,in1) (ub,in2)) =+  showsPrec p i =     showParen (p > rangeOpPrec) $-      showsPrec (rangeOpPrec+1) lb . +      showsPrec (rangeOpPrec+1) lb .       showChar ' ' . showString op . showChar ' ' .       showsPrec (rangeOpPrec+1) ub     where+      (lb, in1) = lowerBound' i+      (ub, in2) = upperBound' i       op = (if in1 then "<=" else "<") ++ ".." ++ (if in2 then "<=" else "<")  instance (Ord r, Read r) => Read (Interval r) where@@ -208,38 +180,25 @@     (do ("empty", s) <- lex r         return (empty, s)) --- This instance preserves data abstraction at the cost of inefficiency.--- We provide limited reflection services for the sake of data abstraction.--instance (Ord r, Data r) => Data (Interval r) where-  gfoldl k z x   = z interval `k` lowerBound' x `k` upperBound' x-  toConstr _     = intervalConstr-  gunfold k z c  = case constrIndex c of-    1 -> k (k (z interval))-    _ -> error "gunfold"-  dataTypeOf _   = intervalDataType-  dataCast1 f    = gcast1 f--intervalConstr :: Constr-intervalConstr = mkConstr intervalDataType "interval" [] Prefix--intervalDataType :: DataType-intervalDataType = mkDataType "Data.Interval.Interval" [intervalConstr]+-- | Lower endpoint (/i.e./ greatest lower bound)  of the interval.+--+-- * 'lowerBound' of the empty interval is 'PosInf'.+--+-- * 'lowerBound' of a left unbounded interval is 'NegInf'.+--+-- * 'lowerBound' of an interval may or may not be a member of the interval.+lowerBound :: Interval r -> Extended r+lowerBound = fst . lowerBound' --- | 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-  -> 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)+-- | Upper endpoint (/i.e./ least upper bound) of the interval.+--+-- * 'upperBound' of the empty interval is 'NegInf'.+--+-- * 'upperBound' of a right unbounded interval is 'PosInf'.+--+-- * 'upperBound' of an interval may or may not be a member of the interval.+upperBound :: Interval r -> Extended r+upperBound = fst . upperBound'  -- | closed interval [@l@,@u@] (<=..<=)@@ -275,11 +234,7 @@  -- | whole real number line (-∞, ∞) whole :: Ord r => Interval r-whole = Interval (NegInf, False) (PosInf, False)---- | empty (contradicting) interval-empty :: Ord r => Interval r-empty = Interval (PosInf, False) (NegInf, False)+whole = interval (NegInf, False) (PosInf, False)  -- | singleton set \[x,x\] singleton :: Ord r => r -> Interval r@@ -287,7 +242,9 @@  -- | intersection of two intervals intersection :: forall r. Ord r => Interval r -> Interval r -> Interval r-intersection (Interval l1 u1) (Interval l2 u2) = interval (maxLB l1 l2) (minUB u1 u2)+intersection i1 i2 = interval+  (maxLB (lowerBound' i1) (lowerBound' i2))+  (minUB (upperBound' i1) (upperBound' i2))   where     maxLB :: (Extended r, Bool) -> (Extended r, Bool) -> (Extended r, Bool)     maxLB (x1,in1) (x2,in2) =@@ -317,7 +274,9 @@ hull x1 x2   | null x1 = x2   | null x2 = x1-hull (Interval l1 u1) (Interval l2 u2) = interval (minLB l1 l2) (maxUB u1 u2)+hull i1 i2 = interval+  (minLB (lowerBound' i1) (lowerBound' i2))+  (maxUB (upperBound' i1) (upperBound' i2))   where     maxUB :: (Extended r, Bool) -> (Extended r, Bool) -> (Extended r, Bool)     maxUB (x1,in1) (x2,in2) =@@ -344,20 +303,26 @@  -- | Is the interval empty? null :: Ord r => Interval r -> Bool-null (Interval (x1,in1) (x2,in2)) =+null i =   case x1 `compare` x2 of     EQ -> assert (in1 && in2) False     LT -> False     GT -> True+  where+    (x1, in1) = lowerBound' i+    (x2, in2) = upperBound' i  isSingleton :: Ord r => Interval r -> Bool-isSingleton (Interval (Finite l, True) (Finite u, True)) = l==u-isSingleton _ = False+isSingleton i = case (lowerBound' i, upperBound' i) of+  ((Finite l, True), (Finite u, True)) -> l==u+  _ -> False  -- | Is the element in the interval? member :: Ord r => r -> Interval r -> Bool-member x (Interval (x1,in1) (x2,in2)) = condLB && condUB+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 @@ -368,7 +333,7 @@ -- | Is this a subset? -- @(i1 \``isSubsetOf`\` i2)@ tells whether @i1@ is a subset of @i2@. isSubsetOf :: Ord r => Interval r -> Interval r -> Bool-isSubsetOf (Interval lb1 ub1) (Interval lb2 ub2) = testLB lb1 lb2 && testUB ub1 ub2+isSubsetOf i1 i2 = testLB (lowerBound' i1) (lowerBound' i2) && testUB (upperBound' i1) (upperBound' i2)   where     testLB (x1,in1) (x2,in2) =       case x1 `compare` x2 of@@ -401,21 +366,24 @@  -- | Width of a interval. Width of an unbounded interval is @undefined@. width :: (Num r, Ord r) => Interval r -> r-width x | null x = 0-width (Interval (Finite l, _) (Finite u, _)) = u - l-width _ = error "Data.Interval.width: unbounded interval"+width x+  | null x = 0+  | otherwise = case (fst (lowerBound' x), fst (upperBound' x)) of+    (Finite l, Finite u) -> u - l+    _ -> error "Data.Interval.width: unbounded interval"  -- | pick up an element from the interval if the interval is not empty. pickup :: (Real r, Fractional r) => Interval r -> Maybe r-pickup (Interval (NegInf,_) (PosInf,_))   = Just 0-pickup (Interval (Finite x1, in1) (PosInf,_)) = Just $ if in1 then x1 else x1+1-pickup (Interval (NegInf,_) (Finite x2, in2)) = Just $ if in2 then x2 else x2-1-pickup (Interval (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-pickup _ = Nothing+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), (Finite x2, in2)) ->+    case x1 `compare` x2 of+      GT -> Nothing+      LT -> Just $ (x1+x2) / 2+      EQ -> if in1 && in2 then Just x1 else Nothing+  _ -> Nothing  -- | 'simplestRationalWithin' returns the simplest rational number within the interval. --@@ -605,16 +573,20 @@ rangeOpPrec = 5  scaleInterval :: (Num r, Ord r) => r -> Interval r -> Interval r-scaleInterval _ x | null x = empty-scaleInterval c (Interval lb ub) =-  case compare c 0 of+scaleInterval c x+  | null x = empty+  | otherwise = case compare c 0 of     EQ -> singleton 0     LT -> interval (scaleInf' c ub) (scaleInf' c lb)     GT -> interval (scaleInf' c lb) (scaleInf' c ub)+  where+    lb = lowerBound' x+    ub = upperBound' x  instance (Num r, Ord r) => Num (Interval r) where-  a + b | null a || null b = empty-  Interval lb1 ub1 + Interval lb2 ub2 = interval (f lb1 lb2) (g ub1 ub2)+  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)@@ -644,22 +616,24 @@             then empty             else singleton (-1) -  a * b | null a || null b = empty-  Interval lb1 ub1 * Interval lb2 ub2 = interval lb3 ub3+  a * b+    | null a || null b = empty+    | otherwise = interval lb3 ub3     where-      xs = [ mulInf' x1 x2 | x1 <- [lb1, ub1], x2 <- [lb2, ub2] ]+      xs = [ mulInf' x1 x2 | x1 <- [lowerBound' a, upperBound' a], x2 <- [lowerBound' b, upperBound' b] ]       ub3 = maximumBy cmpUB xs       lb3 = minimumBy cmpLB xs  instance forall r. (Real r, Fractional r) => Fractional (Interval r) where   fromRational r = singleton (fromRational r)-  recip a | null a = empty-  recip i | 0 `member` i = whole -- should be error?-  recip (Interval lb ub) = interval lb3 ub3+  recip a+    | null a = empty+    | 0 `member` a = whole -- should be error?+    | otherwise = interval lb3 ub3     where       ub3 = maximumBy cmpUB xs       lb3 = minimumBy cmpLB xs-      xs = [recipLB lb, recipUB ub]+      xs = [recipLB (lowerBound' a), recipUB (upperBound' a)]  cmpUB, cmpLB :: Ord r => (Extended r, Bool) -> (Extended r, Bool) -> Ordering cmpUB (x1,in1) (x2,in2) = compare x1 x2 `mappend` compare in1 in2

@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE Safe #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations #-}+#endif++module Data.Interval.Internal+  ( Interval+  , lowerBound'+  , upperBound'+  , interval+  , empty+  ) where++import Control.DeepSeq+import Data.Data+import Data.ExtendedReal+import Data.Hashable++-- | 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)++#if __GLASGOW_HASKELL__ >= 708+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+  toConstr _     = intervalConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (k (z interval))+    _ -> error "gunfold"+  dataTypeOf _   = intervalDataType+  dataCast1 f    = gcast1 f++intervalConstr :: Constr+intervalConstr = mkConstr intervalDataType "interval" [] Prefix++intervalDataType :: DataType+intervalDataType = mkDataType "Data.Interval.Internal.Interval" [intervalConstr]++instance NFData r => NFData (Interval r) where+  rnf (Interval lb ub) = rnf lb `seq` rnf ub++instance Hashable r => Hashable (Interval r) where+  hashWithSalt s (Interval lb ub) = s `hashWithSalt` lb `hashWithSalt` ub++-- | empty (contradicting) interval+empty :: Ord r => Interval r+empty = Interval (PosInf, False) (NegInf, False)++-- | 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+  -> 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)+

@@ -131,6 +131,20 @@ instance Hashable r => Hashable (IntervalSet r) where   hashWithSalt s (IntervalSet m) = hashWithSalt s (Map.toList m) +#if MIN_VERSION_lattices(2,0,0)++instance (Ord r) => Lattice (IntervalSet r) where+  (\/) = union+  (/\) = intersection++instance (Ord r) => BoundedJoinSemiLattice (IntervalSet r) where+  bottom = empty++instance (Ord r) => BoundedMeetSemiLattice (IntervalSet r) where+  top = whole++#else+ instance (Ord r) => JoinSemiLattice (IntervalSet r) where   join = union @@ -146,6 +160,8 @@   top = whole  instance (Ord r) => BoundedLattice (IntervalSet r)++#endif  instance Ord r => Monoid (IntervalSet r) where   mempty = empty