msakai / data-interval / 80

Committed 30 Aug 2025 08:23PM UTC coverage: 86.789% (+0.09%) from 86.702%

Build # 80

Build Type

push

github

Committed by

Bodigrim

Commit Message

Fix warnings

Run Details

1 of 4 new or added lines in 4 files covered. (25.0%)

87 existing lines in 4 files now uncovered.

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

84.88

/src/Data/IntegerInterval.hs

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

msakai / data-interval / 80

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