msakai / data-interval / 74

Committed 07 Jun 2025 02:12PM UTC coverage: 86.789% (-0.05%) from 86.837%

Build # 74

Build Type

push

github

Committed by

web-flow

Commit Message

Merge 0e36d5686 into 8f4ec0ead

Run Details

992 of 1143 relevant lines covered (86.79%)

0.87 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

85.85

/src/Data/IntegerInterval.hs

{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.IntegerInterval
-- Copyright   :  (c) Masahiro Sakai 2011-2014
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable (ScopedTypeVariables, DeriveDataTypeable)
--
-- Interval datatype and interval arithmetic over integers.
--
-- @since 1.2.0
--
-- For the purpose of abstract interpretation, it might be convenient to use
-- 'Lattice' instance. See also lattices package
-- (<http://hackage.haskell.org/package/lattices>).
--
-----------------------------------------------------------------------------
module Data.IntegerInterval
  (
  -- * Interval type
    IntegerInterval
  , module Data.ExtendedReal
  , Boundary(..)

  -- * Construction
  , interval
  , (<=..<=)
  , (<..<=)
  , (<=..<)
  , (<..<)
  , whole
  , empty
  , singleton

  -- * Query
  , null
  , isSingleton
  , member
  , notMember
  , isSubsetOf
  , isProperSubsetOf
  , isConnected
  , lowerBound
  , upperBound
  , lowerBound'
  , upperBound'
  , width
  , memberCount

  -- * Universal comparison operators
  , (<!), (<=!), (==!), (>=!), (>!), (/=!)

  -- * Existential comparison operators
  , (<?), (<=?), (==?), (>=?), (>?), (/=?)

  -- * Existential comparison operators that produce witnesses (experimental)
  , (<??), (<=??), (==??), (>=??), (>??), (/=??)

  -- * Combine
  , intersection
  , intersections
  , hull
  , hulls

  -- * Map
  , mapMonotonic

  -- * Operations
  , pickup
  , simplestIntegerWithin

  -- * Conversion
  , toInterval
  , 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 (foldl')
import Data.Maybe
import Prelude hiding (null)
import Data.IntegerInterval.Internal
import Data.Interval.Internal (Boundary(..))
import qualified Data.Interval.Internal as Interval
import Data.IntervalRelation

infix 5 <..<=
infix 5 <=..<
infix 5 <..<
infix 4 <!
infix 4 <=!
infix 4 ==!
infix 4 >=!
infix 4 >!
infix 4 /=!
infix 4 <?
infix 4 <=?
infix 4 ==?
infix 4 >=?
infix 4 >?
infix 4 /=?
infix 4 <??
infix 4 <=??
infix 4 ==??
infix 4 >=??
infix 4 >??
infix 4 /=??

-- | '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, Boundary)
lowerBound' x =
  case lowerBound x of
    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, Boundary)
upperBound' x =
  case upperBound x of
    ub@(Finite _) -> (ub, Closed)
    ub@_ -> (ub, Open)

#ifdef MIN_VERSION_lattices
instance Lattice IntegerInterval where
  (\/) = hull
  (/\) = intersection

instance BoundedJoinSemiLattice IntegerInterval where
  bottom = empty

instance BoundedMeetSemiLattice IntegerInterval where
  top = whole
#endif

instance Show IntegerInterval where
  showsPrec _ x | null x = showString "empty"
  showsPrec p x =
    showParen (p > rangeOpPrec) $
      showsPrec (rangeOpPrec+1) (lowerBound x) .
      showString " <=..<= " .
      showsPrec (rangeOpPrec+1) (upperBound x)

instance Read IntegerInterval where
  readsPrec p r =
    (readParen (p > appPrec) $ \s0 -> do
      ("interval",s1) <- lex s0
      (lb,s2) <- readsPrec (appPrec+1) s1
      (ub,s3) <- readsPrec (appPrec+1) s2
      return (interval lb ub, s3)) r
    ++
    (readParen (p > rangeOpPrec) $ \s0 -> do
      (do (lb,s1) <- readsPrec (rangeOpPrec+1) s0
          ("<=..<=",s2) <- lex s1
          (ub,s3) <- readsPrec (rangeOpPrec+1) s2
          return (lb <=..<= ub, s3))) r
    ++
    (do ("empty", s) <- lex r
        return (empty, s))

-- | smart constructor for 'IntegerInterval'
interval
  :: (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 == Closed then x1 else x1 + 1) <=..<= (if in2 == Closed then x2 else x2 - 1)

-- | left-open right-closed interval (@l@,@u@]
(<..<=)
  :: Extended Integer -- ^ lower bound @l@
  -> Extended Integer -- ^ upper bound @u@
  -> IntegerInterval
(<..<=) lb ub = (lb+1) <=..<= ub

-- | left-closed right-open interval [@l@, @u@)
(<=..<)
  :: Extended Integer -- ^ lower bound @l@
  -> Extended Integer -- ^ upper bound @u@
  -> IntegerInterval
(<=..<) lb ub = lb <=..<= ub-1

-- | open interval (@l@, @u@)
(<..<)
  :: Extended Integer -- ^ lower bound @l@
  -> Extended Integer -- ^ upper bound @u@
  -> IntegerInterval
(<..<) lb ub = lb+1 <=..<= ub-1

-- | whole real number line (-∞, ∞)
whole :: IntegerInterval
whole = NegInf <=..<= PosInf

-- | singleton set [x,x]
singleton :: Integer -> IntegerInterval
singleton x = Finite x <=..<= Finite x

-- | intersection of two intervals
intersection :: IntegerInterval -> IntegerInterval -> IntegerInterval
intersection x1 x2 =
  max (lowerBound x1) (lowerBound x2) <=..<= min (upperBound x1) (upperBound x2)

-- | intersection of a list of intervals.
intersections :: [IntegerInterval] -> IntegerInterval
intersections = foldl' intersection whole

-- | convex hull of two intervals
hull :: IntegerInterval -> IntegerInterval -> IntegerInterval
hull x1 x2
  | null x1 = x2
  | null x2 = x1
hull x1 x2 =
  min (lowerBound x1) (lowerBound x2) <=..<= max (upperBound x1) (upperBound x2)

-- | convex hull of a list of intervals.
hulls :: [IntegerInterval] -> IntegerInterval
hulls = foldl' hull empty

-- | @mapMonotonic f i@ is the image of @i@ under @f@, where @f@ must be a strict monotone function.
mapMonotonic :: (Integer -> Integer) -> IntegerInterval -> IntegerInterval
mapMonotonic f x = fmap f (lowerBound x) <=..<= fmap f (upperBound x)

-- | Is the interval empty?
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

-- | Is the element in the interval?
member :: Integer -> IntegerInterval -> Bool
member x i = lowerBound i <= Finite x && Finite x <= upperBound i

-- | Is the element not in the interval?
notMember :: Integer -> IntegerInterval -> Bool
notMember a i = not $ member a i

-- | Is this a subset?
-- @(i1 \``isSubsetOf`\` i2)@ tells whether @i1@ is a subset of @i2@.
isSubsetOf :: IntegerInterval -> IntegerInterval -> Bool
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
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 (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 =
  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.
--
-- An integer @y@ is said to be /simpler/ than another @y'@ if
--
-- * @'abs' y <= 'abs' y'@
--
-- (see also 'Data.Ratio.approxRational' and 'Interval.simplestRationalWithin')
simplestIntegerWithin :: IntegerInterval -> Maybe Integer
simplestIntegerWithin i
  | null i    = Nothing
  | 0 <! i    = Just $ let Finite x = lowerBound i in x
  | i <! 0    = Just $ let Finite x = upperBound i in x
  | otherwise = assert (0 `member` i) $ Just 0

-- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@?
(<!) :: IntegerInterval -> IntegerInterval -> Bool
--a <! b = upperBound a < lowerBound b
a <! b = a+1 <=! b

-- | For all @x@ in @X@, @y@ in @Y@. @x '<=' y@?
(<=!) :: IntegerInterval -> IntegerInterval -> Bool
a <=! b = upperBound a <= lowerBound b

-- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@?
(==!) :: IntegerInterval -> IntegerInterval -> Bool
a ==! b = a <=! b && a >=! b

-- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@?
(/=!) :: IntegerInterval -> IntegerInterval -> Bool
a /=! b = null $ a `intersection` b

-- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@?
(>=!) :: IntegerInterval -> IntegerInterval -> Bool
(>=!) = flip (<=!)

-- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@?
(>!) :: IntegerInterval -> IntegerInterval -> Bool
(>!) = flip (<!)

-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@?
(<?) :: IntegerInterval -> IntegerInterval -> Bool
a <? b = lowerBound a < upperBound b

-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@?
(<??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
a <?? b = do
  (x,y) <- a+1 <=?? b
  return (x-1,y)

-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@?
(<=?) :: IntegerInterval -> IntegerInterval -> Bool
a <=? b =
  case lb_a `compare` ub_b of
    LT -> True
    GT -> False
    EQ ->
      case lb_a of
        NegInf -> False -- b is empty
        PosInf -> False -- a is empty
        Finite _ -> True
  where
    lb_a = lowerBound a
    ub_b = upperBound b

-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@?
(<=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
a <=?? b =
  case pickup (intersection a b) of
    Just x -> return (x,x)
    Nothing -> do
      guard $ upperBound a <= lowerBound b
      x <- pickup a
      y <- pickup b
      return (x,y)

-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@?
(==?) :: IntegerInterval -> IntegerInterval -> Bool
a ==? b = not $ null $ intersection a b

-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@?
(==??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
a ==?? b = do
  x <- pickup (intersection a b)
  return (x,x)

-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@?
(/=?) :: IntegerInterval -> IntegerInterval -> 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@?
(/=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
a /=?? b = do
  guard $ not $ null a
  guard $ not $ null b
  guard $ not $ a == b && isSingleton a
  if not (isSingleton b)
    then f a b
    else liftM (\(y,x) -> (x,y)) $ f b a
  where
    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@?
(>=?) :: IntegerInterval -> IntegerInterval -> Bool
(>=?) = flip (<=?)

-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@?
(>?) :: IntegerInterval -> IntegerInterval -> Bool
(>?) = flip (<?)

-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@?
(>=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
(>=??) = flip (<=??)

-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@?
(>??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
(>??) = flip (<??)

appPrec :: Int
appPrec = 10

rangeOpPrec :: Int
rangeOpPrec = 5

scaleInterval :: Integer -> IntegerInterval -> IntegerInterval
scaleInterval _ x | null x = empty
scaleInterval c x =
  case compare c 0 of
    EQ -> singleton 0
    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
      | otherwise = lowerBound a + lowerBound b <=..<= upperBound a + upperBound b

  negate = scaleInterval (-1)

  fromInteger i = singleton (fromInteger i)

  abs x = (x `intersection` nonneg) `hull` (negate x `intersection` nonneg)
    where
      nonneg = 0 <=..< inf

  signum x = zero `hull` pos `hull` neg
    where
      zero = if member 0 x then singleton 0 else empty
      pos = if null $ (0 <..< inf) `intersection` x
            then empty
            else singleton 1
      neg = if null $ (-inf <..< 0) `intersection` x
            then empty
            else singleton (-1)

  a * b
    | null a || null b = empty
    | otherwise = minimum xs <=..<= maximum xs
    where
      xs = [ mul x1 x2 | x1 <- [lowerBound a, upperBound a], x2 <- [lowerBound b, upperBound b] ]

      mul :: Extended Integer -> Extended Integer -> Extended Integer
      mul 0 _ = 0
      mul _ 0 = 0
      mul x1 x2 = x1*x2

-- | Convert the interval to 'Interval.Interval' data type.
toInterval :: Real r => IntegerInterval -> Interval.Interval r
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 = 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

-- | 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 = lb <=..<= ub
  where
    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

1	{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
2	{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}
3	{-# LANGUAGE Safe #-}
4	-----------------------------------------------------------------------------
5	-- \|
6	-- Module : Data.IntegerInterval
7	-- Copyright : (c) Masahiro Sakai 2011-2014
8	-- License : BSD-style
9	--
10	-- Maintainer : masahiro.sakai@gmail.com
11	-- Stability : provisional
12	-- Portability : non-portable (ScopedTypeVariables, DeriveDataTypeable)
13	--
14	-- Interval datatype and interval arithmetic over integers.
15	--
16	-- @since 1.2.0
17	--
18	-- For the purpose of abstract interpretation, it might be convenient to use
19	-- 'Lattice' instance. See also lattices package
20	-- (<http://hackage.haskell.org/package/lattices>).
21	--
22	-----------------------------------------------------------------------------
23	module Data.IntegerInterval
24	(
25	-- * Interval type
26	IntegerInterval
27	, module Data.ExtendedReal
28	, Boundary(..)
29
30	-- * Construction
31	, interval
32	, (<=..<=)
33	, (<..<=)
34	, (<=..<)
35	, (<..<)
36	, whole
37	, empty
38	, singleton
39
40	-- * Query
41	, null
42	, isSingleton
43	, member
44	, notMember
45	, isSubsetOf
46	, isProperSubsetOf
47	, isConnected
48	, lowerBound
49	, upperBound
50	, lowerBound'
51	, upperBound'
52	, width
53	, memberCount
54
55	-- * Universal comparison operators
56	, (<!), (<=!), (==!), (>=!), (>!), (/=!)
57
58	-- * Existential comparison operators
59	, (<?), (<=?), (==?), (>=?), (>?), (/=?)
60
61	-- * Existential comparison operators that produce witnesses (experimental)
62	, (<??), (<=??), (==??), (>=??), (>??), (/=??)
63
64	-- * Combine
65	, intersection
66	, intersections
67	, hull
68	, hulls
69
70	-- * Map
71	, mapMonotonic
72
73	-- * Operations
74	, pickup
75	, simplestIntegerWithin
76
77	-- * Conversion
78	, toInterval
79	, fromInterval
80	, fromIntervalOver
81	, fromIntervalUnder
82
83	-- * Intervals relation
84	, relate
85	) where
86
87	#ifdef MIN_VERSION_lattices
88	import Algebra.Lattice
89	#endif
90	import Control.Exception (assert)
91	import Control.Monad hiding (join)
92	import Data.ExtendedReal
93	import Data.List (foldl')
94	import Data.Maybe
95	import Prelude hiding (null)
96	import Data.IntegerInterval.Internal
97	import Data.Interval.Internal (Boundary(..))
98	import qualified Data.Interval.Internal as Interval
99	import Data.IntervalRelation
100
101	infix 5 <..<=
102	infix 5 <=..<
103	infix 5 <..<
104	infix 4 <!
105	infix 4 <=!
106	infix 4 ==!
107	infix 4 >=!
108	infix 4 >!
109	infix 4 /=!
110	infix 4 <?
111	infix 4 <=?
112	infix 4 ==?
113	infix 4 >=?
114	infix 4 >?
115	infix 4 /=?
116	infix 4 <??
117	infix 4 <=??
118	infix 4 ==??
119	infix 4 >=??
120	infix 4 >??
121	infix 4 /=??
122
123	-- \| 'lowerBound' of the interval and whether it is included in the interval.
124	-- The result is convenient to use as an argument for 'interval'.
125	lowerBound' :: IntegerInterval -> (Extended Integer, Boundary)
126	lowerBound' x =	×
127	case lowerBound x of	×
128	lb@(Finite _) -> (lb, Closed)	×
129	lb@_ -> (lb, Open)	×
130
131	-- \| 'upperBound' of the interval and whether it is included in the interval.
132	-- The result is convenient to use as an argument for 'interval'.
133	upperBound' :: IntegerInterval -> (Extended Integer, Boundary)
134	upperBound' x =	×
135	case upperBound x of	×
136	ub@(Finite _) -> (ub, Closed)	×
137	ub@_ -> (ub, Open)	×
138
139	#ifdef MIN_VERSION_lattices
140	instance Lattice IntegerInterval where
141	(\/) = hull	1✔
142	(/\) = intersection	1✔
143
144	instance BoundedJoinSemiLattice IntegerInterval where
145	bottom = empty	1✔
146
147	instance BoundedMeetSemiLattice IntegerInterval where
148	top = whole	1✔
149	#endif
150
151	instance Show IntegerInterval where
152	showsPrec _ x \| null x = showString "empty"	1✔
153	showsPrec p x =
154	showParen (p > rangeOpPrec) $	1✔
155	showsPrec (rangeOpPrec+1) (lowerBound x) .	1✔
156	showString " <=..<= " .	1✔
157	showsPrec (rangeOpPrec+1) (upperBound x)	1✔
158
159	instance Read IntegerInterval where
160	readsPrec p r =	1✔
161	(readParen (p > appPrec) $ \s0 -> do	1✔
162	("interval",s1) <- lex s0	1✔
163	(lb,s2) <- readsPrec (appPrec+1) s1	×
164	(ub,s3) <- readsPrec (appPrec+1) s2	×
165	return (interval lb ub, s3)) r	1✔
166	++
167	(readParen (p > rangeOpPrec) $ \s0 -> do	1✔
168	(do (lb,s1) <- readsPrec (rangeOpPrec+1) s0	1✔
169	("<=..<=",s2) <- lex s1	1✔
170	(ub,s3) <- readsPrec (rangeOpPrec+1) s2	1✔
171	return (lb <=..<= ub, s3))) r	1✔
172	++
173	(do ("empty", s) <- lex r	1✔
174	return (empty, s))	1✔
175
176	-- \| smart constructor for 'IntegerInterval'
177	interval
178	:: (Extended Integer, Boundary) -- ^ lower bound and whether it is included
179	-> (Extended Integer, Boundary) -- ^ upper bound and whether it is included
180	-> IntegerInterval
181	interval (x1,in1) (x2,in2) =	1✔
182	(if in1 == Closed then x1 else x1 + 1) <=..<= (if in2 == Closed then x2 else x2 - 1)	1✔
183
184	-- \| left-open right-closed interval (@l@,@u@]
185	(<..<=)
186	:: Extended Integer -- ^ lower bound @l@
187	-> Extended Integer -- ^ upper bound @u@
188	-> IntegerInterval
189	(<..<=) lb ub = (lb+1) <=..<= ub	1✔
190
191	-- \| left-closed right-open interval [@l@, @u@)
192	(<=..<)
193	:: Extended Integer -- ^ lower bound @l@
194	-> Extended Integer -- ^ upper bound @u@
195	-> IntegerInterval
196	(<=..<) lb ub = lb <=..<= ub-1	1✔
197
198	-- \| open interval (@l@, @u@)
199	(<..<)
200	:: Extended Integer -- ^ lower bound @l@
201	-> Extended Integer -- ^ upper bound @u@
202	-> IntegerInterval
203	(<..<) lb ub = lb+1 <=..<= ub-1	1✔
204
205	-- \| whole real number line (-∞, ∞)
206	whole :: IntegerInterval
207	whole = NegInf <=..<= PosInf	1✔
208
209	-- \| singleton set [x,x]
210	singleton :: Integer -> IntegerInterval
211	singleton x = Finite x <=..<= Finite x	1✔
212
213	-- \| intersection of two intervals
214	intersection :: IntegerInterval -> IntegerInterval -> IntegerInterval
215	intersection x1 x2 =	1✔
216	max (lowerBound x1) (lowerBound x2) <=..<= min (upperBound x1) (upperBound x2)	1✔
217
218	-- \| intersection of a list of intervals.
219	intersections :: [IntegerInterval] -> IntegerInterval
220	intersections = foldl' intersection whole	1✔
221
222	-- \| convex hull of two intervals
223	hull :: IntegerInterval -> IntegerInterval -> IntegerInterval
224	hull x1 x2	1✔
225	\| null x1 = x2	1✔
226	\| null x2 = x1	1✔
227	hull x1 x2 =
228	min (lowerBound x1) (lowerBound x2) <=..<= max (upperBound x1) (upperBound x2)	1✔
229
230	-- \| convex hull of a list of intervals.
231	hulls :: [IntegerInterval] -> IntegerInterval
232	hulls = foldl' hull empty	1✔
233
234	-- \| @mapMonotonic f i@ is the image of @i@ under @f@, where @f@ must be a strict monotone function.
235	mapMonotonic :: (Integer -> Integer) -> IntegerInterval -> IntegerInterval
236	mapMonotonic f x = fmap f (lowerBound x) <=..<= fmap f (upperBound x)	1✔
237
238	-- \| Is the interval empty?
239	null :: IntegerInterval -> Bool
240	null x = upperBound x < lowerBound x	1✔
241
242	-- \| Is the interval single point?
243	--
244	-- @since 2.0.0
245	isSingleton :: IntegerInterval -> Bool
246	isSingleton x = lowerBound x == upperBound x	1✔
247
248	-- \| Is the element in the interval?
249	member :: Integer -> IntegerInterval -> Bool
250	member x i = lowerBound i <= Finite x && Finite x <= upperBound i	1✔
251
252	-- \| Is the element not in the interval?
253	notMember :: Integer -> IntegerInterval -> Bool
254	notMember a i = not $ member a i	1✔
255
256	-- \| Is this a subset?
257	-- @(i1 \``isSubsetOf`\` i2)@ tells whether @i1@ is a subset of @i2@.
258	isSubsetOf :: IntegerInterval -> IntegerInterval -> Bool
259	isSubsetOf i1 i2 = lowerBound i2 <= lowerBound i1 && upperBound i1 <= upperBound i2	1✔
260
261	-- \| Is this a proper subset? (/i.e./ a subset but not equal).
262	isProperSubsetOf :: IntegerInterval -> IntegerInterval -> Bool
263	isProperSubsetOf i1 i2 = i1 /= i2 && i1 `isSubsetOf` i2	1✔
264
265	-- \| Does the union of two range form a set which is the intersection between the integers and a connected real interval?
266	isConnected :: IntegerInterval -> IntegerInterval -> Bool
267	isConnected x y = null x \|\| null y \|\| x ==? y \|\| lb1nearUb2 \|\| ub1nearLb2	1✔
268	where
269	lb1 = lowerBound x	1✔
270	lb2 = lowerBound y	1✔
271	ub1 = upperBound x	1✔
272	ub2 = upperBound y	1✔
273
274	lb1nearUb2 = case (lb1, ub2) of	1✔
275	(Finite lb1Int, Finite ub2Int) -> lb1Int == ub2Int + 1	1✔
276	_ -> False	1✔
277
278	ub1nearLb2 = case (ub1, lb2) of	1✔
279	(Finite ub1Int, Finite lb2Int) -> ub1Int + 1 == lb2Int	1✔
280	_ -> False	1✔
281
282	-- \| Width of a interval. Width of an unbounded interval is @undefined@.
283	width :: IntegerInterval -> Integer
284	width x	1✔
285	\| null x = 0	1✔
286	\| otherwise =	1✔
287	case (lowerBound x, upperBound x) of	1✔
288	(Finite lb, Finite ub) -> ub - lb	1✔
289	_ -> error "Data.IntegerInterval.width: unbounded interval"	×
290
291	-- \| How many integers lie within the (bounded) interval.
292	-- Equal to @Just (width + 1)@ for non-empty, bounded intervals.
293	-- The @memberCount@ of an unbounded interval is @Nothing@.
294	memberCount :: IntegerInterval -> Maybe Integer
295	memberCount x	1✔
296	\| null x = Just 0	1✔
297	\| otherwise =	1✔
298	case (lowerBound x, upperBound x) of	1✔
299	(Finite lb, Finite ub) -> Just (ub - lb + 1)	1✔
300	_ -> Nothing	×
301
302	-- \| pick up an element from the interval if the interval is not empty.
303	pickup :: IntegerInterval -> Maybe Integer
304	pickup x =	1✔
305	case (lowerBound x, upperBound x) of	1✔
306	(NegInf, PosInf) -> Just 0	1✔
307	(Finite l, _) -> Just l	1✔
308	(_, Finite u) -> Just u	1✔
309	_ -> Nothing	1✔
310
311	-- \| 'simplestIntegerWithin' returns the simplest rational number within the interval.
312	--
313	-- An integer @y@ is said to be /simpler/ than another @y'@ if
314	--
315	-- * @'abs' y <= 'abs' y'@
316	--
317	-- (see also 'Data.Ratio.approxRational' and 'Interval.simplestRationalWithin')
318	simplestIntegerWithin :: IntegerInterval -> Maybe Integer
319	simplestIntegerWithin i	1✔
320	\| null i = Nothing	1✔
321	\| 0 <! i = Just $ let Finite x = lowerBound i in x	1✔
322	\| i <! 0 = Just $ let Finite x = upperBound i in x	1✔
323	\| otherwise = assert (0 `member` i) $ Just 0	×
324
325	-- \| For all @x@ in @X@, @y@ in @Y@. @x '<' y@?
326	(<!) :: IntegerInterval -> IntegerInterval -> Bool
327	--a <! b = upperBound a < lowerBound b
328	a <! b = a+1 <=! b	1✔
329
330	-- \| For all @x@ in @X@, @y@ in @Y@. @x '<=' y@?
331	(<=!) :: IntegerInterval -> IntegerInterval -> Bool
332	a <=! b = upperBound a <= lowerBound b	1✔
333
334	-- \| For all @x@ in @X@, @y@ in @Y@. @x '==' y@?
335	(==!) :: IntegerInterval -> IntegerInterval -> Bool
336	a ==! b = a <=! b && a >=! b	1✔
337
338	-- \| For all @x@ in @X@, @y@ in @Y@. @x '/=' y@?
339	(/=!) :: IntegerInterval -> IntegerInterval -> Bool
340	a /=! b = null $ a `intersection` b	1✔
341
342	-- \| For all @x@ in @X@, @y@ in @Y@. @x '>=' y@?
343	(>=!) :: IntegerInterval -> IntegerInterval -> Bool
344	(>=!) = flip (<=!)	1✔
345
346	-- \| For all @x@ in @X@, @y@ in @Y@. @x '>' y@?
347	(>!) :: IntegerInterval -> IntegerInterval -> Bool
348	(>!) = flip (<!)	×
349
350	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@?
351	(<?) :: IntegerInterval -> IntegerInterval -> Bool
352	a <? b = lowerBound a < upperBound b	1✔
353
354	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@?
355	(<??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
356	a <?? b = do	1✔
357	(x,y) <- a+1 <=?? b	1✔
358	return (x-1,y)	1✔
359
360	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@?
361	(<=?) :: IntegerInterval -> IntegerInterval -> Bool
362	a <=? b =	1✔
363	case lb_a `compare` ub_b of	1✔
364	LT -> True	1✔
365	GT -> False	1✔
366	EQ ->
367	case lb_a of	1✔
368	NegInf -> False -- b is empty	1✔
369	PosInf -> False -- a is empty	1✔
370	Finite _ -> True	1✔
371	where
372	lb_a = lowerBound a	1✔
373	ub_b = upperBound b	1✔
374
375	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@?
376	(<=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
377	a <=?? b =	1✔
378	case pickup (intersection a b) of	1✔
379	Just x -> return (x,x)	1✔
380	Nothing -> do	1✔
381	guard $ upperBound a <= lowerBound b	1✔
382	x <- pickup a	1✔
383	y <- pickup b	1✔
384	return (x,y)	1✔
385
386	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@?
387	(==?) :: IntegerInterval -> IntegerInterval -> Bool
388	a ==? b = not $ null $ intersection a b	1✔
389
390	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@?
391	(==??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
392	a ==?? b = do	1✔
393	x <- pickup (intersection a b)	1✔
394	return (x,x)	1✔
395
396	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@?
397	(/=?) :: IntegerInterval -> IntegerInterval -> Bool
398	a /=? b = not (null a) && not (null b) && not (a == b && isSingleton a)	1✔
399
400	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@?
401	(/=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
402	a /=?? b = do	1✔
403	guard $ not $ null a	1✔
404	guard $ not $ null b	1✔
405	guard $ not $ a == b && isSingleton a	1✔
406	if not (isSingleton b)	1✔
407	then f a b	1✔
408	else liftM (\(y,x) -> (x,y)) $ f b a	1✔
409	where
410	f i j = do	1✔
411	x <- pickup i	1✔
412	y <- msum [pickup (j `intersection` c) \| c <- [-inf <..< Finite x, Finite x <..< inf]]	1✔
413	return (x,y)	1✔
414
415	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@?
416	(>=?) :: IntegerInterval -> IntegerInterval -> Bool
417	(>=?) = flip (<=?)	×
418
419	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@?
420	(>?) :: IntegerInterval -> IntegerInterval -> Bool
421	(>?) = flip (<?)	×
422
423	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@?
424	(>=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
425	(>=??) = flip (<=??)	×
426
427	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@?
428	(>??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
429	(>??) = flip (<??)	×
430
431	appPrec :: Int
432	appPrec = 10	1✔
433
434	rangeOpPrec :: Int
435	rangeOpPrec = 5	1✔
436
437	scaleInterval :: Integer -> IntegerInterval -> IntegerInterval
438	scaleInterval _ x \| null x = empty	1✔
439	scaleInterval c x =
440	case compare c 0 of	1✔
441	EQ -> singleton 0	×
442	LT -> Finite c * upperBound x <=..<= Finite c * lowerBound x	1✔
443	GT -> Finite c * lowerBound x <=..<= Finite c * upperBound x	×
444
445	instance Num IntegerInterval where
446	a + b	1✔
447	\| null a \|\| null b = empty	1✔
448	\| otherwise = lowerBound a + lowerBound b <=..<= upperBound a + upperBound b	1✔
449
450	negate = scaleInterval (-1)	×
451
452	fromInteger i = singleton (fromInteger i)	1✔
453
454	abs x = (x `intersection` nonneg) `hull` (negate x `intersection` nonneg)	1✔
455	where
456	nonneg = 0 <=..< inf	1✔
457
458	signum x = zero `hull` pos `hull` neg	1✔
459	where
460	zero = if member 0 x then singleton 0 else empty	1✔
461	pos = if null $ (0 <..< inf) `intersection` x	1✔
462	then empty	1✔
463	else singleton 1	1✔
464	neg = if null $ (-inf <..< 0) `intersection` x	1✔
465	then empty	1✔
466	else singleton (-1)	×
467
468	a * b	1✔
469	\| null a \|\| null b = empty	1✔
470	\| otherwise = minimum xs <=..<= maximum xs	1✔
471	where
472	xs = [ mul x1 x2 \| x1 <- [lowerBound a, upperBound a], x2 <- [lowerBound b, upperBound b] ]	1✔
473
474	mul :: Extended Integer -> Extended Integer -> Extended Integer
475	mul 0 _ = 0	1✔
476	mul _ 0 = 0	1✔
477	mul x1 x2 = x1*x2	1✔
478
479	-- \| Convert the interval to 'Interval.Interval' data type.
480	toInterval :: Real r => IntegerInterval -> Interval.Interval r
481	toInterval x = Interval.interval	1✔
482	(fmap fromInteger (lowerBound x), Closed)	1✔
483	(fmap fromInteger (upperBound x), Closed)	1✔
484
485	-- \| Conversion from 'Interval.Interval' data type.
486	fromInterval :: Interval.Interval Integer -> IntegerInterval
487	fromInterval i = x1' <=..<= x2'	1✔
488	where
489	(x1,in1) = Interval.lowerBound' i	1✔
490	(x2,in2) = Interval.upperBound' i	1✔
491	x1' = case in1 of	1✔
492	Interval.Open -> x1 + 1	1✔
493	Interval.Closed -> x1	1✔
494	x2' = case in2 of	1✔
495	Interval.Open -> x2 - 1	1✔
496	Interval.Closed -> x2	1✔
497
498	-- \| Given a 'Interval.Interval' @I@ over R, compute the smallest 'IntegerInterval' @J@ such that @I ⊆ J@.
499	fromIntervalOver :: RealFrac r => Interval.Interval r -> IntegerInterval
500	fromIntervalOver i = fmap floor lb <=..<= fmap ceiling ub	1✔
501	where
502	(lb, _) = Interval.lowerBound' i	1✔
503	(ub, _) = Interval.upperBound' i	1✔
504
505	-- \| Given a 'Interval.Interval' @I@ over R, compute the largest 'IntegerInterval' @J@ such that @J ⊆ I@.
506	fromIntervalUnder :: RealFrac r => Interval.Interval r -> IntegerInterval
507	fromIntervalUnder i = lb <=..<= ub	1✔
508	where
509	lb = case Interval.lowerBound' i of	1✔
510	(Finite x, Open)
511	\| fromInteger (ceiling x) == x	1✔
512	-> Finite (ceiling x + 1)	1✔
513	(x, _) -> fmap ceiling x	1✔
514	ub = case Interval.upperBound' i of	1✔
515	(Finite x, Open)
516	\| fromInteger (floor x) == x	1✔
517	-> Finite (floor x - 1)	1✔
518	(x, _) -> fmap floor x	1✔
519
520	-- \| Computes how two intervals are related according to the @`Data.IntervalRelation.Relation`@ classification
521	relate :: IntegerInterval -> IntegerInterval -> Relation
522	relate i1 i2 =	1✔
523	case (i1 `isSubsetOf` i2, i2 `isSubsetOf` i1) of	1✔
524	-- 'i1' ad 'i2' are equal
525	(True , True ) -> Equal	1✔
526	-- 'i1' is strictly contained in `i2`
527	(True , False) \| lowerBound i1 == lowerBound i2 -> Starts	1✔
528	\| upperBound i1 == upperBound i2 -> Finishes	×
529	\| otherwise -> During	×
530	-- 'i2' is strictly contained in `i1`
531	(False, True ) \| lowerBound i1 == lowerBound i2 -> StartedBy	×
532	\| upperBound i1 == upperBound i2 -> FinishedBy	×
533	\| otherwise -> Contains	1✔
534	-- neither `i1` nor `i2` is contained in the other
535	(False, False) -> case ( null (i1 `intersection` i2)	1✔
536	, lowerBound i1 <= lowerBound i2	1✔
537	, i1 `isConnected` i2	1✔
538	) of
539	(True , True , True ) -> JustBefore	1✔
540	(True , True , False) -> Before	1✔
541	(True , False, True ) -> JustAfter	×
542	(True , False, False) -> After	×
543	(False, True , _ ) -> Overlaps	1✔
544	(False, False, _ ) -> OverlappedBy	×

msakai / data-interval / 74

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous