msakai / data-interval / 21

Build # 21

Build Type

push

github-actions

Committed by GitHub

Commit Message

<a href="https://github.com/msakai/data-interval/commit/<a class=hub.com/msakai/data-interval/commit/0a403d688f4cbfc381162f6a88f81233778b27d7">0a403d688<a href="https://github.com/msakai/data-interval/commit/0a403d688f4cbfc381162f6a88f81233778b27d7">">Merge </a><a class="double-link" href="https://github.com/msakai/data-interval/commit/<a class="double-link" href="https://github.com/msakai/data-interval/commit/bfd591ab936946ab1687416d4920dbc360bf55cf">bfd591ab9</a>">bfd591ab9</a><a href="https://github.com/msakai/data-interval/commit/0a403d688f4cbfc381162f6a88f81233778b27d7"> into 227bffc31">227bffc31</a>

Run Details

981 of 1132 relevant lines covered (86.66%)

0.87 hits per line

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

85.43

/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

  -- * 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
#if MIN_VERSION_lattices(2,0,0)

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

instance MeetSemiLattice IntegerInterval where
  meet = intersection

instance Lattice IntegerInterval

instance BoundedJoinSemiLattice IntegerInterval where
  bottom = empty

instance BoundedMeetSemiLattice IntegerInterval where
  top = whole

instance BoundedLattice IntegerInterval

#endif
#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 (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 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
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.List (foldl')
93	import Data.Maybe
94	import Prelude hiding (null)
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)
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)
133	upperBound' x =	×
134	case upperBound x of	×
135	ub@(Finite _) -> (ub, Closed)	×
136	ub@_ -> (ub, Open)	×
137
138	#ifdef MIN_VERSION_lattices
139	#if MIN_VERSION_lattices(2,0,0)
140
141	instance Lattice IntegerInterval where
142	(\/) = hull	1✔
143	(/\) = intersection	1✔
144
145	instance BoundedJoinSemiLattice IntegerInterval where
146	bottom = empty	1✔
147
148	instance BoundedMeetSemiLattice IntegerInterval where
149	top = whole	1✔
150
151	#else
152
153	instance JoinSemiLattice IntegerInterval where
154	join = hull
155
156	instance MeetSemiLattice IntegerInterval where
157	meet = intersection
158
159	instance Lattice IntegerInterval
160
161	instance BoundedJoinSemiLattice IntegerInterval where
162	bottom = empty
163
164	instance BoundedMeetSemiLattice IntegerInterval where
165	top = whole
166
167	instance BoundedLattice IntegerInterval
168
169	#endif
170	#endif
171
172	instance Show IntegerInterval where
173	showsPrec _ x \| null x = showString "empty"	1✔
174	showsPrec p x =
175	showParen (p > rangeOpPrec) $	1✔
176	showsPrec (rangeOpPrec+1) (lowerBound x) .	1✔
177	showString " <=..<= " .	1✔
178	showsPrec (rangeOpPrec+1) (upperBound x)	1✔
179
180	instance Read IntegerInterval where
181	readsPrec p r =	1✔
182	(readParen (p > appPrec) $ \s0 -> do	1✔
183	("interval",s1) <- lex s0	1✔
184	(lb,s2) <- readsPrec (appPrec+1) s1	×
185	(ub,s3) <- readsPrec (appPrec+1) s2	×
186	return (interval lb ub, s3)) r	1✔
187	++
188	(readParen (p > rangeOpPrec) $ \s0 -> do	1✔
189	(do (lb,s1) <- readsPrec (rangeOpPrec+1) s0	1✔
190	("<=..<=",s2) <- lex s1	1✔
191	(ub,s3) <- readsPrec (rangeOpPrec+1) s2	1✔
192	return (lb <=..<= ub, s3))) r	1✔
193	++
194	(do ("empty", s) <- lex r	1✔
195	return (empty, s))	1✔
196
197	-- \| smart constructor for 'IntegerInterval'
198	interval
199	:: (Extended Integer, Boundary) -- ^ lower bound and whether it is included
200	-> (Extended Integer, Boundary) -- ^ upper bound and whether it is included
201	-> IntegerInterval
202	interval (x1,in1) (x2,in2) =	1✔
203	(if in1 == Closed then x1 else x1 + 1) <=..<= (if in2 == Closed then x2 else x2 - 1)	1✔
204
205	-- \| left-open right-closed interval (@l@,@u@]
206	(<..<=)
207	:: Extended Integer -- ^ lower bound @l@
208	-> Extended Integer -- ^ upper bound @u@
209	-> IntegerInterval
210	(<..<=) lb ub = (lb+1) <=..<= ub	1✔
211
212	-- \| left-closed right-open interval [@l@, @u@)
213	(<=..<)
214	:: Extended Integer -- ^ lower bound @l@
215	-> Extended Integer -- ^ upper bound @u@
216	-> IntegerInterval
217	(<=..<) lb ub = lb <=..<= ub-1	1✔
218
219	-- \| open interval (@l@, @u@)
220	(<..<)
221	:: Extended Integer -- ^ lower bound @l@
222	-> Extended Integer -- ^ upper bound @u@
223	-> IntegerInterval
224	(<..<) lb ub = lb+1 <=..<= ub-1	1✔
225
226	-- \| whole real number line (-∞, ∞)
227	whole :: IntegerInterval
228	whole = NegInf <=..<= PosInf	1✔
229
230	-- \| singleton set [x,x]
231	singleton :: Integer -> IntegerInterval
232	singleton x = Finite x <=..<= Finite x	1✔
233
234	-- \| intersection of two intervals
235	intersection :: IntegerInterval -> IntegerInterval -> IntegerInterval
236	intersection x1 x2 =	1✔
237	max (lowerBound x1) (lowerBound x2) <=..<= min (upperBound x1) (upperBound x2)	1✔
238
239	-- \| intersection of a list of intervals.
240	intersections :: [IntegerInterval] -> IntegerInterval
241	intersections = foldl' intersection whole	1✔
242
243	-- \| convex hull of two intervals
244	hull :: IntegerInterval -> IntegerInterval -> IntegerInterval
245	hull x1 x2	1✔
246	\| null x1 = x2	1✔
247	\| null x2 = x1	1✔
248	hull x1 x2 =
249	min (lowerBound x1) (lowerBound x2) <=..<= max (upperBound x1) (upperBound x2)	1✔
250
251	-- \| convex hull of a list of intervals.
252	hulls :: [IntegerInterval] -> IntegerInterval
253	hulls = foldl' hull empty	1✔
254
255	-- \| @mapMonotonic f i@ is the image of @i@ under @f@, where @f@ must be a strict monotone function.
256	mapMonotonic :: (Integer -> Integer) -> IntegerInterval -> IntegerInterval
257	mapMonotonic f x = fmap f (lowerBound x) <=..<= fmap f (upperBound x)	1✔
258
259	-- \| Is the interval empty?
260	null :: IntegerInterval -> Bool
261	null x = upperBound x < lowerBound x	1✔
262
263	-- \| Is the interval single point?
264	--
265	-- @since 2.0.0
266	isSingleton :: IntegerInterval -> Bool
267	isSingleton x = lowerBound x == upperBound x	1✔
268
269	-- \| Is the element in the interval?
270	member :: Integer -> IntegerInterval -> Bool
271	member x i = lowerBound i <= Finite x && Finite x <= upperBound i	1✔
272
273	-- \| Is the element not in the interval?
274	notMember :: Integer -> IntegerInterval -> Bool
275	notMember a i = not $ member a i	1✔
276
277	-- \| Is this a subset?
278	-- @(i1 \``isSubsetOf`\` i2)@ tells whether @i1@ is a subset of @i2@.
279	isSubsetOf :: IntegerInterval -> IntegerInterval -> Bool
280	isSubsetOf i1 i2 = lowerBound i2 <= lowerBound i1 && upperBound i1 <= upperBound i2	1✔
281
282	-- \| Is this a proper subset? (/i.e./ a subset but not equal).
283	isProperSubsetOf :: IntegerInterval -> IntegerInterval -> Bool
284	isProperSubsetOf i1 i2 = i1 /= i2 && i1 `isSubsetOf` i2	1✔
285
286	-- \| Does the union of two range form a set which is the intersection between the integers and a connected real interval?
287	isConnected :: IntegerInterval -> IntegerInterval -> Bool
288	isConnected x y = null x \|\| null y \|\| x ==? y \|\| lb1nearUb2 \|\| ub1nearLb2	1✔
289	where
290	lb1 = lowerBound x	1✔
291	lb2 = lowerBound y	1✔
292	ub1 = upperBound x	1✔
293	ub2 = upperBound y	1✔
294
295	lb1nearUb2 = case (lb1, ub2) of	1✔
296	(Finite lb1Int, Finite ub2Int) -> lb1Int == ub2Int + 1	1✔
297	_ -> False	1✔
298
299	ub1nearLb2 = case (ub1, lb2) of	1✔
300	(Finite ub1Int, Finite lb2Int) -> ub1Int + 1 == lb2Int	1✔
301	_ -> False	×
302
303	-- \| Width of a interval. Width of an unbounded interval is @undefined@.
304	width :: IntegerInterval -> Integer
305	width x	1✔
306	\| null x = 0	1✔
307	\| otherwise =	1✔
308	case (upperBound x, lowerBound x) of	1✔
309	(Finite lb, Finite ub) -> ub - lb	1✔
310	_ -> error "Data.IntegerInterval.width: unbounded interval"	×
311
312	-- \| pick up an element from the interval if the interval is not empty.
313	pickup :: IntegerInterval -> Maybe Integer
314	pickup x =	1✔
315	case (lowerBound x, upperBound x) of	1✔
316	(NegInf, PosInf) -> Just 0	1✔
317	(Finite l, _) -> Just l	1✔
318	(_, Finite u) -> Just u	1✔
319	_ -> Nothing	1✔
320
321	-- \| 'simplestIntegerWithin' returns the simplest rational number within the interval.
322	--
323	-- An integer @y@ is said to be /simpler/ than another @y'@ if
324	--
325	-- * @'abs' y <= 'abs' y'@
326	--
327	-- (see also 'Data.Ratio.approxRational' and 'Interval.simplestRationalWithin')
328	simplestIntegerWithin :: IntegerInterval -> Maybe Integer
329	simplestIntegerWithin i	1✔
330	\| null i = Nothing	1✔
331	\| 0 <! i = Just $ let Finite x = lowerBound i in x	1✔
332	\| i <! 0 = Just $ let Finite x = upperBound i in x	1✔
333	\| otherwise = assert (0 `member` i) $ Just 0	×
334
335	-- \| For all @x@ in @X@, @y@ in @Y@. @x '<' y@?
336	(<!) :: IntegerInterval -> IntegerInterval -> Bool
337	--a <! b = upperBound a < lowerBound b
338	a <! b = a+1 <=! b	1✔
339
340	-- \| For all @x@ in @X@, @y@ in @Y@. @x '<=' y@?
341	(<=!) :: IntegerInterval -> IntegerInterval -> Bool
342	a <=! b = upperBound a <= lowerBound b	1✔
343
344	-- \| For all @x@ in @X@, @y@ in @Y@. @x '==' y@?
345	(==!) :: IntegerInterval -> IntegerInterval -> Bool
346	a ==! b = a <=! b && a >=! b	1✔
347
348	-- \| For all @x@ in @X@, @y@ in @Y@. @x '/=' y@?
349	(/=!) :: IntegerInterval -> IntegerInterval -> Bool
350	a /=! b = null $ a `intersection` b	1✔
351
352	-- \| For all @x@ in @X@, @y@ in @Y@. @x '>=' y@?
353	(>=!) :: IntegerInterval -> IntegerInterval -> Bool
354	(>=!) = flip (<=!)	1✔
355
356	-- \| For all @x@ in @X@, @y@ in @Y@. @x '>' y@?
357	(>!) :: IntegerInterval -> IntegerInterval -> Bool
358	(>!) = flip (<!)	×
359
360	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@?
361	(<?) :: IntegerInterval -> IntegerInterval -> Bool
362	a <? b = lowerBound a < upperBound b	1✔
363
364	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@?
365	(<??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
366	a <?? b = do	1✔
367	(x,y) <- a+1 <=?? b	1✔
368	return (x-1,y)	1✔
369
370	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@?
371	(<=?) :: IntegerInterval -> IntegerInterval -> Bool
372	a <=? b =	1✔
373	case lb_a `compare` ub_b of	1✔
374	LT -> True	1✔
375	GT -> False	1✔
376	EQ ->
377	case lb_a of	1✔
378	NegInf -> False -- b is empty	1✔
379	PosInf -> False -- a is empty	1✔
380	Finite _ -> True	1✔
381	where
382	lb_a = lowerBound a	1✔
383	ub_b = upperBound b	1✔
384
385	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@?
386	(<=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
387	a <=?? b =	1✔
388	case pickup (intersection a b) of	1✔
389	Just x -> return (x,x)	1✔
390	Nothing -> do	1✔
391	guard $ upperBound a <= lowerBound b	1✔
392	x <- pickup a	1✔
393	y <- pickup b	1✔
394	return (x,y)	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 $ intersection a b	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	x <- pickup (intersection a b)	1✔
404	return (x,x)	1✔
405
406	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@?
407	(/=?) :: IntegerInterval -> IntegerInterval -> Bool
408	a /=? b = not (null a) && not (null b) && not (a == b && isSingleton a)	1✔
409
410	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@?
411	(/=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer,Integer)
412	a /=?? b = do	1✔
413	guard $ not $ null a	1✔
414	guard $ not $ null b	1✔
415	guard $ not $ a == b && isSingleton a	1✔
416	if not (isSingleton b)	1✔
417	then f a b	1✔
418	else liftM (\(y,x) -> (x,y)) $ f b a	1✔
419	where
420	f i j = do	1✔
421	x <- pickup i	1✔
422	y <- msum [pickup (j `intersection` c) \| c <- [-inf <..< Finite x, Finite x <..< inf]]	1✔
423	return (x,y)	1✔
424
425	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@?
426	(>=?) :: IntegerInterval -> IntegerInterval -> Bool
427	(>=?) = flip (<=?)	×
428
429	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@?
430	(>?) :: IntegerInterval -> IntegerInterval -> Bool
431	(>?) = flip (<?)	×
432
433	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@?
434	(>=??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
435	(>=??) = flip (<=??)	×
436
437	-- \| Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@?
438	(>??) :: IntegerInterval -> IntegerInterval -> Maybe (Integer, Integer)
439	(>??) = flip (<??)	×
440
441	appPrec :: Int
442	appPrec = 10	1✔
443
444	rangeOpPrec :: Int
445	rangeOpPrec = 5	1✔
446
447	scaleInterval :: Integer -> IntegerInterval -> IntegerInterval
448	scaleInterval _ x \| null x = empty	1✔
449	scaleInterval c x =
450	case compare c 0 of	1✔
451	EQ -> singleton 0	×
452	LT -> Finite c * upperBound x <=..<= Finite c * lowerBound x	1✔
453	GT -> Finite c * lowerBound x <=..<= Finite c * upperBound x	×
454
455	instance Num IntegerInterval where
456	a + b	1✔
457	\| null a \|\| null b = empty	1✔
458	\| otherwise = lowerBound a + lowerBound b <=..<= upperBound a + upperBound b	1✔
459
460	negate = scaleInterval (-1)	×
461
462	fromInteger i = singleton (fromInteger i)	1✔
463
464	abs x = (x `intersection` nonneg) `hull` (negate x `intersection` nonneg)	1✔
465	where
466	nonneg = 0 <=..< inf	1✔
467
468	signum x = zero `hull` pos `hull` neg	1✔
469	where
470	zero = if member 0 x then singleton 0 else empty	1✔
471	pos = if null $ (0 <..< inf) `intersection` x	1✔
472	then empty	1✔
473	else singleton 1	1✔
474	neg = if null $ (-inf <..< 0) `intersection` x	1✔
475	then empty	1✔
476	else singleton (-1)	×
477
478	a * b	1✔
479	\| null a \|\| null b = empty	1✔
480	\| otherwise = minimum xs <=..<= maximum xs	1✔
481	where
482	xs = [ mul x1 x2 \| x1 <- [lowerBound a, upperBound a], x2 <- [lowerBound b, upperBound b] ]	1✔
483
484	mul :: Extended Integer -> Extended Integer -> Extended Integer
485	mul 0 _ = 0	1✔
486	mul _ 0 = 0	1✔
487	mul x1 x2 = x1*x2	1✔
488
489	-- \| Convert the interval to 'Interval.Interval' data type.
490	toInterval :: Real r => IntegerInterval -> Interval.Interval r
491	toInterval x = Interval.interval	1✔
492	(fmap fromInteger (lowerBound x), Closed)	1✔
493	(fmap fromInteger (upperBound x), Closed)	1✔
494
495	-- \| Conversion from 'Interval.Interval' data type.
496	fromInterval :: Interval.Interval Integer -> IntegerInterval
497	fromInterval i = x1' <=..<= x2'	1✔
498	where
499	(x1,in1) = Interval.lowerBound' i	1✔
500	(x2,in2) = Interval.upperBound' i	1✔
501	x1' = case in1 of	1✔
502	Interval.Open -> x1 + 1	1✔
503	Interval.Closed -> x1	1✔
504	x2' = case in2 of	1✔
505	Interval.Open -> x2 - 1	1✔
506	Interval.Closed -> x2	1✔
507
508	-- \| Given a 'Interval.Interval' @I@ over R, compute the smallest 'IntegerInterval' @J@ such that @I ⊆ J@.
509	fromIntervalOver :: RealFrac r => Interval.Interval r -> IntegerInterval
510	fromIntervalOver i = fmap floor lb <=..<= fmap ceiling ub	1✔
511	where
512	(lb, _) = Interval.lowerBound' i	1✔
513	(ub, _) = Interval.upperBound' i	1✔
514
515	-- \| Given a 'Interval.Interval' @I@ over R, compute the largest 'IntegerInterval' @J@ such that @J ⊆ I@.
516	fromIntervalUnder :: RealFrac r => Interval.Interval r -> IntegerInterval
517	fromIntervalUnder i = lb <=..<= ub	1✔
518	where
519	lb = case Interval.lowerBound' i of	1✔
520	(Finite x, Open)
521	\| fromInteger (ceiling x) == x	1✔
522	-> Finite (ceiling x + 1)	1✔
523	(x, _) -> fmap ceiling x	1✔
524	ub = case Interval.upperBound' i of	1✔
525	(Finite x, Open)
526	\| fromInteger (floor x) == x	1✔
527	-> Finite (floor x - 1)	1✔
528	(x, _) -> fmap floor x	1✔
529
530	-- \| Computes how two intervals are related according to the @`Data.IntervalRelation.Relation`@ classification
531	relate :: IntegerInterval -> IntegerInterval -> Relation
532	relate i1 i2 =	1✔
533	case (i1 `isSubsetOf` i2, i2 `isSubsetOf` i1) of	1✔
534	-- 'i1' ad 'i2' are equal
535	(True , True ) -> Equal	1✔
536	-- 'i1' is strictly contained in `i2`
537	(True , False) \| lowerBound i1 == lowerBound i2 -> Starts	1✔
538	\| upperBound i1 == upperBound i2 -> Finishes	×
539	\| otherwise -> During	×
540	-- 'i2' is strictly contained in `i1`
541	(False, True ) \| lowerBound i1 == lowerBound i2 -> StartedBy	×
542	\| upperBound i1 == upperBound i2 -> FinishedBy	×
543	\| otherwise -> Contains	1✔
544	-- neither `i1` nor `i2` is contained in the other
545	(False, False) -> case ( null (i1 `intersection` i2)	1✔
546	, lowerBound i1 <= lowerBound i2	1✔
547	, i1 `isConnected` i2	1✔
548	) of
549	(True , True , True ) -> JustBefore	1✔
550	(True , True , False) -> Before	1✔
551	(True , False, True ) -> JustAfter	×
552	(True , False, False) -> After	×
553	(False, True , _ ) -> Overlaps	1✔
554	(False, False, _ ) -> OverlappedBy	×

msakai / data-interval / 21

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