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.0

/src/Data/IntervalSet.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE CPP, LambdaCase, ScopedTypeVariables, TypeFamilies, MultiWayIf #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE RoleAnnotations #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.IntervalSet
-- Copyright   :  (c) Masahiro Sakai 2016
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
--
-- Interval datatype and interval arithmetic.
--
-----------------------------------------------------------------------------
module Data.IntervalSet
  (
  -- * IntervalSet type
    IntervalSet
  , module Data.ExtendedReal

  -- * Construction
  , whole
  , empty
  , singleton

  -- * Query
  , null
  , member
  , notMember
  , isSubsetOf
  , isProperSubsetOf
  , span

  -- * Construction
  , complement
  , insert
  , delete

  -- * Combine
  , union
  , unions
  , intersection
  , intersections
  , difference

  -- * Conversion

  -- ** List
  , fromList
  , toList

  -- ** Ordered list
  , toAscList
  , toDescList
  , fromAscList
  )
  where

import Prelude hiding (Foldable(..), span)
#ifdef MIN_VERSION_lattices
import Algebra.Lattice
#endif
import Control.DeepSeq
import Data.Data
import Data.ExtendedReal
import Data.Foldable hiding (null, toList)
import Data.Function
import Data.Hashable
import Data.List (sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Semigroup as Semigroup
import Data.Interval (Interval, Boundary(..))
import qualified Data.Interval as Interval
import qualified GHC.Exts as GHCExts

-- | A set comprising zero or more non-empty, /disconnected/ intervals.
--
-- Any connected intervals are merged together, and empty intervals are ignored.
newtype IntervalSet r = IntervalSet (Map (Extended r) (Interval r))
  deriving
    ( Eq
    , Ord
      -- ^ Note that this Ord is derived and not semantically meaningful.
      -- The primary intended use case is to allow using 'IntervalSet'
      -- in maps and sets that require ordering.
    )

type role IntervalSet nominal

instance (Ord r, Show r) => Show (IntervalSet r) where
  showsPrec p (IntervalSet m) = showParen (p > appPrec) $
    showString "fromList " .
    showsPrec (appPrec+1) (Map.elems m)

instance (Ord r, Read r) => Read (IntervalSet r) where
  readsPrec p =
    (readParen (p > appPrec) $ \s0 -> do
      ("fromList",s1) <- lex s0
      (xs,s2) <- readsPrec (appPrec+1) s1
      return (fromList xs, s2))

appPrec :: Int
appPrec = 10

-- This instance preserves data abstraction at the cost of inefficiency.
-- We provide limited reflection services for the sake of data abstraction.

instance (Ord r, Data r) => Data (IntervalSet r) where
  gfoldl k z x   = z fromList `k` toList x
  toConstr _     = fromListConstr
  gunfold k z c  = case constrIndex c of
    1 -> k (z fromList)
    _ -> error "gunfold"
  dataTypeOf _   = setDataType
  dataCast1 f    = gcast1 f

fromListConstr :: Constr
fromListConstr = mkConstr setDataType "fromList" [] Prefix

setDataType :: DataType
setDataType = mkDataType "Data.IntervalSet.IntervalSet" [fromListConstr]

instance NFData r => NFData (IntervalSet r) where
  rnf (IntervalSet m) = rnf m

instance Hashable r => Hashable (IntervalSet r) where
  hashWithSalt s (IntervalSet m) = hashWithSalt s (Map.toList m)

#ifdef MIN_VERSION_lattices
instance (Ord r) => Lattice (IntervalSet r) where
  (\/) = union
  (/\) = intersection

instance (Ord r) => BoundedJoinSemiLattice (IntervalSet r) where
  bottom = empty

instance (Ord r) => BoundedMeetSemiLattice (IntervalSet r) where
  top = whole
#endif

instance Ord r => Monoid (IntervalSet r) where
  mempty = empty
  mappend = (Semigroup.<>)
  mconcat = unions

instance (Ord r) => Semigroup.Semigroup (IntervalSet r) where
  (<>)    = union
  stimes  = Semigroup.stimesIdempotentMonoid

lift1
  :: Ord r => (Interval r -> Interval r)
  -> IntervalSet r -> IntervalSet r
lift1 f as = fromList [f a | a <- toList as]

lift2
  :: Ord r => (Interval r -> Interval r -> Interval r)
  -> IntervalSet r -> IntervalSet r -> IntervalSet r
lift2 f as bs = fromList [f a b | a <- toList as, b <- toList bs]

instance (Num r, Ord r) => Num (IntervalSet r) where
  (+) = lift2 (+)

  (*) = lift2 (*)

  negate = lift1 negate

  abs = lift1 abs

  fromInteger i = singleton (fromInteger i)

  signum xs = fromList $ do
    x <- toList xs
    y <-
      [ if Interval.member 0 x
        then Interval.singleton 0
        else Interval.empty
      , if Interval.null ((0 Interval.<..< inf) `Interval.intersection` x)
        then Interval.empty
        else Interval.singleton 1
      , if Interval.null ((-inf Interval.<..< 0) `Interval.intersection` x)
        then Interval.empty
        else Interval.singleton (-1)
      ]
    return y

-- | @recip (recip xs) == delete 0 xs@
instance forall r. (Real r, Fractional r) => Fractional (IntervalSet r) where
  fromRational r = singleton (fromRational r)
  recip xs = lift1 recip (delete (Interval.singleton 0) xs)

instance Ord r => GHCExts.IsList (IntervalSet r) where
  type Item (IntervalSet r) = Interval r
  fromList = fromList
  toList = toList

-- -----------------------------------------------------------------------

-- | whole real number line (-∞, ∞)
whole :: Ord r => IntervalSet r
whole = singleton $ Interval.whole

-- | empty interval set
empty :: Ord r => IntervalSet r
empty = IntervalSet Map.empty

-- | single interval
singleton :: Ord r => Interval r -> IntervalSet r
singleton i
  | Interval.null i = empty
  | otherwise = IntervalSet $ Map.singleton (Interval.lowerBound i) i

-- -----------------------------------------------------------------------

-- | Is the interval set empty?
null :: IntervalSet r -> Bool
null (IntervalSet m) = Map.null m

-- | Is the element in the interval set?
member :: Ord r => r -> IntervalSet r -> Bool
member x (IntervalSet m) =
  case Map.lookupLE (Finite x) m of
    Nothing -> False
    Just (_,i) -> Interval.member x i

-- | Is the element not in the interval set?
notMember :: Ord r => r -> IntervalSet r -> Bool
notMember x is = not $ x `member` is

-- | Is this a subset?
-- @(is1 \``isSubsetOf`\` is2)@ tells whether @is1@ is a subset of @is2@.
isSubsetOf :: Ord r => IntervalSet r -> IntervalSet r -> Bool
isSubsetOf is1 is2 = all (\i1 -> f i1 is2) (toList is1)
  where
    f i1 (IntervalSet m) =
      case Map.lookupLE (Interval.lowerBound i1) m of
        Nothing -> False
        Just (_,i2) -> Interval.isSubsetOf i1 i2

-- | Is this a proper subset? (/i.e./ a subset but not equal).
isProperSubsetOf :: Ord r => IntervalSet r -> IntervalSet r -> Bool
isProperSubsetOf is1 is2 = isSubsetOf is1 is2 && is1 /= is2

-- | convex hull of a set of intervals.
span :: Ord r => IntervalSet r -> Interval r
span (IntervalSet m) =
  case Map.minView m of
    Nothing -> Interval.empty
    Just (i1, _) ->
      case Map.maxView m of
        Nothing -> Interval.empty
        Just (i2, _) ->
          Interval.interval (Interval.lowerBound' i1) (Interval.upperBound' i2)

-- -----------------------------------------------------------------------

-- | Complement the interval set.
complement :: Ord r => IntervalSet r -> IntervalSet r
complement (IntervalSet m) = fromAscList $ f (NegInf,Open) (Map.elems m)
  where
    f prev [] = [ Interval.interval prev (PosInf,Open) ]
    f prev (i : is) =
      case (Interval.lowerBound' i, Interval.upperBound' i) of
        ((lb, in1), (ub, in2)) ->
          Interval.interval prev (lb, notB in1) : f (ub, notB in2) is

-- | Insert a new interval into the interval set.
insert :: Ord r => Interval r -> IntervalSet r -> IntervalSet r
insert i is | Interval.null i = is
insert i (IntervalSet is) = IntervalSet $ Map.unions
  [ smaller'
  , case fromList $ i : maybeToList m0 ++ maybeToList m1 ++ maybeToList m2 of
      IntervalSet m -> m
  , larger
  ]
  where
    (smaller, m1, xs) = splitLookupLE (Interval.lowerBound i) is
    (_, m2, larger) = splitLookupLE (Interval.upperBound i) xs

    -- A tricky case is when an interval @i@ connects two adjacent
    -- members of IntervalSet, e. g., inserting {0} into (whole \\ {0}).
    (smaller', m0) = case Map.maxView smaller of
      Nothing -> (smaller, Nothing)
      Just (v, rest)
        | Interval.isConnected v i -> (rest, Just v)
      _ -> (smaller, Nothing)

-- | Delete an interval from the interval set.
delete :: Ord r => Interval r -> IntervalSet r -> IntervalSet r
delete i is | Interval.null i = is
delete i (IntervalSet is) = IntervalSet $
  case splitLookupLE (Interval.lowerBound i) is of
    (smaller, m1, xs) ->
      case splitLookupLE (Interval.upperBound i) xs of
        (_, m2, larger) ->
          Map.unions
          [ smaller
          , case m1 of
              Nothing -> Map.empty
              Just j -> Map.fromList
                [ (Interval.lowerBound k, k)
                | i' <- [upTo i, downTo i], let k = i' `Interval.intersection` j, not (Interval.null k)
                ]
          , if
            | Just j <- m2, j' <- downTo i `Interval.intersection` j, not (Interval.null j') ->
                Map.singleton (Interval.lowerBound j') j'
            | otherwise -> Map.empty
          , larger
          ]

-- | union of two interval sets
union :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r
union is1@(IntervalSet m1) is2@(IntervalSet m2) =
  if Map.size m1 >= Map.size m2
  then foldl' (\is i -> insert i is) is1 (toList is2)
  else foldl' (\is i -> insert i is) is2 (toList is1)

-- | union of a list of interval sets
unions :: Ord r => [IntervalSet r] -> IntervalSet r
unions = foldl' union empty

-- | intersection of two interval sets
intersection :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r
intersection is1 is2 = difference is1 (complement is2)

-- | intersection of a list of interval sets
intersections :: Ord r => [IntervalSet r] -> IntervalSet r
intersections = foldl' intersection whole

-- | difference of two interval sets
difference :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r
difference is1 is2 =
  foldl' (\is i -> delete i is) is1 (toList is2)

-- -----------------------------------------------------------------------

-- | Build a interval set from a list of intervals.
fromList :: Ord r => [Interval r] -> IntervalSet r
fromList = IntervalSet . fromAscList' . sortBy (compareLB `on` Interval.lowerBound')

-- | Build a map from an ascending list of intervals.
-- /The precondition is not checked./
fromAscList :: Ord r => [Interval r] -> IntervalSet r
fromAscList = IntervalSet . fromAscList'

fromAscList' :: Ord r => [Interval r] -> Map (Extended r) (Interval r)
fromAscList' = Map.fromDistinctAscList . map (\i -> (Interval.lowerBound i, i)) . f
  where
    f :: Ord r => [Interval r] -> [Interval r]
    f [] = []
    f (x : xs) = g x xs
    g x [] = [x | not (Interval.null x)]
    g x (y : ys)
      | Interval.null x = g y ys
      | Interval.isConnected x y = g (x `Interval.hull` y) ys
      | otherwise = x : g y ys

-- | Convert a interval set into a list of intervals.
toList :: Ord r => IntervalSet r -> [Interval r]
toList = toAscList

-- | Convert a interval set into a list of intervals in ascending order.
toAscList :: Ord r => IntervalSet r -> [Interval r]
toAscList (IntervalSet m) = Map.elems m

-- | Convert a interval set into a list of intervals in descending order.
toDescList :: Ord r => IntervalSet r -> [Interval r]
toDescList (IntervalSet m) = fmap snd $ Map.toDescList m

-- -----------------------------------------------------------------------

splitLookupLE :: Ord k => k -> Map k v -> (Map k v, Maybe v, Map k v)
splitLookupLE k m =
  case Map.spanAntitone (<= k) m of
    (lessOrEqual, greaterThan) ->
      case Map.maxView lessOrEqual of
        Just (v, lessOrEqual') -> (lessOrEqual', Just v, greaterThan)
        Nothing -> (lessOrEqual, Nothing, greaterThan)

compareLB :: Ord r => (Extended r, Boundary) -> (Extended r, Boundary) -> Ordering
compareLB (lb1, lb1in) (lb2, lb2in) =
  -- inclusive lower endpoint shuold be considered smaller
  (lb1 `compare` lb2) `mappend` (lb2in `compare` lb1in)

upTo :: Ord r => Interval r -> Interval r
upTo i =
  case Interval.lowerBound' i of
    (NegInf, _) -> Interval.empty
    (PosInf, _) -> Interval.whole
    (Finite lb, incl) ->
      Interval.interval (NegInf, Open) (Finite lb, notB incl)

downTo :: Ord r => Interval r -> Interval r
downTo i =
  case Interval.upperBound' i of
    (PosInf, _) -> Interval.empty
    (NegInf, _) -> Interval.whole
    (Finite ub, incl) ->
      Interval.interval (Finite ub, notB incl) (PosInf, Open)

notB :: Boundary -> Boundary
notB = \case
  Open   -> Closed
  Closed -> Open

1	{-# OPTIONS_GHC -Wall #-}
2	{-# LANGUAGE CPP, LambdaCase, ScopedTypeVariables, TypeFamilies, MultiWayIf #-}
3	{-# LANGUAGE Trustworthy #-}
4	{-# LANGUAGE RoleAnnotations #-}
5	-----------------------------------------------------------------------------
6	-- \|
7	-- Module : Data.IntervalSet
8	-- Copyright : (c) Masahiro Sakai 2016
9	-- License : BSD-style
10	--
11	-- Maintainer : masahiro.sakai@gmail.com
12	-- Stability : provisional
13	--
14	-- Interval datatype and interval arithmetic.
15	--
16	-----------------------------------------------------------------------------
17	module Data.IntervalSet
18	(
19	-- * IntervalSet type
20	IntervalSet
21	, module Data.ExtendedReal
22
23	-- * Construction
24	, whole
25	, empty
26	, singleton
27
28	-- * Query
29	, null
30	, member
31	, notMember
32	, isSubsetOf
33	, isProperSubsetOf
34	, span
35
36	-- * Construction
37	, complement
38	, insert
39	, delete
40
41	-- * Combine
42	, union
43	, unions
44	, intersection
45	, intersections
46	, difference
47
48	-- * Conversion
49
50	-- ** List
51	, fromList
52	, toList
53
54	-- ** Ordered list
55	, toAscList
56	, toDescList
57	, fromAscList
58	)
59	where
60
61	import Prelude hiding (Foldable(..), span)
62	#ifdef MIN_VERSION_lattices
63	import Algebra.Lattice
64	#endif
65	import Control.DeepSeq
66	import Data.Data
67	import Data.ExtendedReal
68	import Data.Foldable hiding (null, toList)
69	import Data.Function
70	import Data.Hashable
71	import Data.List (sortBy)
72	import Data.Map (Map)
73	import qualified Data.Map as Map
74	import Data.Maybe
75	import qualified Data.Semigroup as Semigroup
76	import Data.Interval (Interval, Boundary(..))
77	import qualified Data.Interval as Interval
78	import qualified GHC.Exts as GHCExts
79
80	-- \| A set comprising zero or more non-empty, /disconnected/ intervals.
81	--
82	-- Any connected intervals are merged together, and empty intervals are ignored.
83	newtype IntervalSet r = IntervalSet (Map (Extended r) (Interval r))
84	deriving
85	( Eq	1✔
UNCOV 86	, Ord	×
87	-- ^ Note that this Ord is derived and not semantically meaningful.
88	-- The primary intended use case is to allow using 'IntervalSet'
89	-- in maps and sets that require ordering.
90	)
91
92	type role IntervalSet nominal
93
94	instance (Ord r, Show r) => Show (IntervalSet r) where
95	showsPrec p (IntervalSet m) = showParen (p > appPrec) $	1✔
96	showString "fromList " .	1✔
UNCOV 97	showsPrec (appPrec+1) (Map.elems m)	×
98
99	instance (Ord r, Read r) => Read (IntervalSet r) where
100	readsPrec p =	1✔
101	(readParen (p > appPrec) $ \s0 -> do	1✔
102	("fromList",s1) <- lex s0	1✔
UNCOV 103	(xs,s2) <- readsPrec (appPrec+1) s1	×
104	return (fromList xs, s2))	1✔
105
106	appPrec :: Int
107	appPrec = 10	1✔
108
109	-- This instance preserves data abstraction at the cost of inefficiency.
110	-- We provide limited reflection services for the sake of data abstraction.
111
112	instance (Ord r, Data r) => Data (IntervalSet r) where
113	gfoldl k z x = z fromList `k` toList x	1✔
UNCOV 114	toConstr _ = fromListConstr	×
115	gunfold k z c = case constrIndex c of	×
116	1 -> k (z fromList)	×
117	_ -> error "gunfold"	×
118	dataTypeOf _ = setDataType	×
119	dataCast1 f = gcast1 f	×
120
121	fromListConstr :: Constr
UNCOV 122	fromListConstr = mkConstr setDataType "fromList" [] Prefix	×
123
124	setDataType :: DataType
UNCOV 125	setDataType = mkDataType "Data.IntervalSet.IntervalSet" [fromListConstr]	×
126
127	instance NFData r => NFData (IntervalSet r) where
128	rnf (IntervalSet m) = rnf m	1✔
129
130	instance Hashable r => Hashable (IntervalSet r) where
131	hashWithSalt s (IntervalSet m) = hashWithSalt s (Map.toList m)	1✔
132
133	#ifdef MIN_VERSION_lattices
134	instance (Ord r) => Lattice (IntervalSet r) where
135	(\/) = union	1✔
136	(/\) = intersection	1✔
137
138	instance (Ord r) => BoundedJoinSemiLattice (IntervalSet r) where
139	bottom = empty	1✔
140
141	instance (Ord r) => BoundedMeetSemiLattice (IntervalSet r) where
142	top = whole	1✔
143	#endif
144
145	instance Ord r => Monoid (IntervalSet r) where
146	mempty = empty	1✔
UNCOV 147	mappend = (Semigroup.<>)	×
148	mconcat = unions	×
149
150	instance (Ord r) => Semigroup.Semigroup (IntervalSet r) where
151	(<>) = union	1✔
UNCOV 152	stimes = Semigroup.stimesIdempotentMonoid	×
153
154	lift1
155	:: Ord r => (Interval r -> Interval r)
156	-> IntervalSet r -> IntervalSet r
157	lift1 f as = fromList [f a \| a <- toList as]	1✔
158
159	lift2
160	:: Ord r => (Interval r -> Interval r -> Interval r)
161	-> IntervalSet r -> IntervalSet r -> IntervalSet r
162	lift2 f as bs = fromList [f a b \| a <- toList as, b <- toList bs]	1✔
163
164	instance (Num r, Ord r) => Num (IntervalSet r) where
165	(+) = lift2 (+)	1✔
166
167	() = lift2 ()	1✔
168
169	negate = lift1 negate	1✔
170
171	abs = lift1 abs	1✔
172
UNCOV 173	fromInteger i = singleton (fromInteger i)	×
174
175	signum xs = fromList $ do	1✔
176	x <- toList xs	1✔
177	y <-
178	[ if Interval.member 0 x	1✔
179	then Interval.singleton 0	1✔
180	else Interval.empty	1✔
181	, if Interval.null ((0 Interval.<..< inf) `Interval.intersection` x)	1✔
182	then Interval.empty	1✔
183	else Interval.singleton 1	1✔
184	, if Interval.null ((-inf Interval.<..< 0) `Interval.intersection` x)	1✔
185	then Interval.empty	1✔
186	else Interval.singleton (-1)	1✔
187	]
188	return y	1✔
189
190	-- \| @recip (recip xs) == delete 0 xs@
191	instance forall r. (Real r, Fractional r) => Fractional (IntervalSet r) where
192	fromRational r = singleton (fromRational r)	1✔
193	recip xs = lift1 recip (delete (Interval.singleton 0) xs)	1✔
194
195	instance Ord r => GHCExts.IsList (IntervalSet r) where
196	type Item (IntervalSet r) = Interval r
UNCOV 197	fromList = fromList	×
198	toList = toList	×
199
200	-- -----------------------------------------------------------------------
201
202	-- \| whole real number line (-∞, ∞)
203	whole :: Ord r => IntervalSet r
204	whole = singleton $ Interval.whole	1✔
205
206	-- \| empty interval set
207	empty :: Ord r => IntervalSet r
208	empty = IntervalSet Map.empty	1✔
209
210	-- \| single interval
211	singleton :: Ord r => Interval r -> IntervalSet r
212	singleton i	1✔
213	\| Interval.null i = empty	1✔
214	\| otherwise = IntervalSet $ Map.singleton (Interval.lowerBound i) i	1✔
215
216	-- -----------------------------------------------------------------------
217
218	-- \| Is the interval set empty?
219	null :: IntervalSet r -> Bool
220	null (IntervalSet m) = Map.null m	1✔
221
222	-- \| Is the element in the interval set?
223	member :: Ord r => r -> IntervalSet r -> Bool
224	member x (IntervalSet m) =	1✔
225	case Map.lookupLE (Finite x) m of	1✔
226	Nothing -> False	1✔
227	Just (_,i) -> Interval.member x i	1✔
228
229	-- \| Is the element not in the interval set?
230	notMember :: Ord r => r -> IntervalSet r -> Bool
231	notMember x is = not $ x `member` is	1✔
232
233	-- \| Is this a subset?
234	-- @(is1 \``isSubsetOf`\` is2)@ tells whether @is1@ is a subset of @is2@.
235	isSubsetOf :: Ord r => IntervalSet r -> IntervalSet r -> Bool
236	isSubsetOf is1 is2 = all (\i1 -> f i1 is2) (toList is1)	1✔
237	where
238	f i1 (IntervalSet m) =	1✔
239	case Map.lookupLE (Interval.lowerBound i1) m of	1✔
240	Nothing -> False	1✔
241	Just (_,i2) -> Interval.isSubsetOf i1 i2	1✔
242
243	-- \| Is this a proper subset? (/i.e./ a subset but not equal).
244	isProperSubsetOf :: Ord r => IntervalSet r -> IntervalSet r -> Bool
245	isProperSubsetOf is1 is2 = isSubsetOf is1 is2 && is1 /= is2	1✔
246
247	-- \| convex hull of a set of intervals.
248	span :: Ord r => IntervalSet r -> Interval r
249	span (IntervalSet m) =	1✔
250	case Map.minView m of	1✔
251	Nothing -> Interval.empty	1✔
252	Just (i1, _) ->
253	case Map.maxView m of	1✔
UNCOV 254	Nothing -> Interval.empty	×
255	Just (i2, _) ->
256	Interval.interval (Interval.lowerBound' i1) (Interval.upperBound' i2)	1✔
257
258	-- -----------------------------------------------------------------------
259
260	-- \| Complement the interval set.
261	complement :: Ord r => IntervalSet r -> IntervalSet r
UNCOV 262	complement (IntervalSet m) = fromAscList $ f (NegInf,Open) (Map.elems m)	×
263	where
UNCOV 264	f prev [] = [ Interval.interval prev (PosInf,Open) ]	×
265	f prev (i : is) =
266	case (Interval.lowerBound' i, Interval.upperBound' i) of	1✔
267	((lb, in1), (ub, in2)) ->
268	Interval.interval prev (lb, notB in1) : f (ub, notB in2) is	1✔
269
270	-- \| Insert a new interval into the interval set.
271	insert :: Ord r => Interval r -> IntervalSet r -> IntervalSet r
272	insert i is \| Interval.null i = is	1✔
273	insert i (IntervalSet is) = IntervalSet $ Map.unions	1✔
274	[ smaller'	1✔
275	, case fromList $ i : maybeToList m0 ++ maybeToList m1 ++ maybeToList m2 of	1✔
276	IntervalSet m -> m	1✔
277	, larger	1✔
278	]
279	where
280	(smaller, m1, xs) = splitLookupLE (Interval.lowerBound i) is	1✔
281	(_, m2, larger) = splitLookupLE (Interval.upperBound i) xs	1✔
282
283	-- A tricky case is when an interval @i@ connects two adjacent
284	-- members of IntervalSet, e. g., inserting {0} into (whole \\ {0}).
285	(smaller', m0) = case Map.maxView smaller of	1✔
286	Nothing -> (smaller, Nothing)	1✔
287	Just (v, rest)
288	\| Interval.isConnected v i -> (rest, Just v)	1✔
289	_ -> (smaller, Nothing)	1✔
290
291	-- \| Delete an interval from the interval set.
292	delete :: Ord r => Interval r -> IntervalSet r -> IntervalSet r
293	delete i is \| Interval.null i = is	1✔
294	delete i (IntervalSet is) = IntervalSet $	1✔
295	case splitLookupLE (Interval.lowerBound i) is of	1✔
296	(smaller, m1, xs) ->
297	case splitLookupLE (Interval.upperBound i) xs of	1✔
298	(_, m2, larger) ->
299	Map.unions	1✔
300	[ smaller	1✔
301	, case m1 of	1✔
302	Nothing -> Map.empty	1✔
303	Just j -> Map.fromList	1✔
304	[ (Interval.lowerBound k, k)	1✔
305	\| i' <- [upTo i, downTo i], let k = i' `Interval.intersection` j, not (Interval.null k)	1✔
306	]
307	, if	1✔
308	\| Just j <- m2, j' <- downTo i `Interval.intersection` j, not (Interval.null j') ->	1✔
309	Map.singleton (Interval.lowerBound j') j'	1✔
310	\| otherwise -> Map.empty	1✔
311	, larger	1✔
312	]
313
314	-- \| union of two interval sets
315	union :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r
316	union is1@(IntervalSet m1) is2@(IntervalSet m2) =	1✔
317	if Map.size m1 >= Map.size m2	1✔
318	then foldl' (\is i -> insert i is) is1 (toList is2)	1✔
319	else foldl' (\is i -> insert i is) is2 (toList is1)	1✔
320
321	-- \| union of a list of interval sets
322	unions :: Ord r => [IntervalSet r] -> IntervalSet r
323	unions = foldl' union empty	1✔
324
325	-- \| intersection of two interval sets
326	intersection :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r
327	intersection is1 is2 = difference is1 (complement is2)	1✔
328
329	-- \| intersection of a list of interval sets
330	intersections :: Ord r => [IntervalSet r] -> IntervalSet r
331	intersections = foldl' intersection whole	1✔
332
333	-- \| difference of two interval sets
334	difference :: Ord r => IntervalSet r -> IntervalSet r -> IntervalSet r
335	difference is1 is2 =	1✔
336	foldl' (\is i -> delete i is) is1 (toList is2)	1✔
337
338	-- -----------------------------------------------------------------------
339
340	-- \| Build a interval set from a list of intervals.
341	fromList :: Ord r => [Interval r] -> IntervalSet r
342	fromList = IntervalSet . fromAscList' . sortBy (compareLB `on` Interval.lowerBound')	1✔
343
344	-- \| Build a map from an ascending list of intervals.
345	-- /The precondition is not checked./
346	fromAscList :: Ord r => [Interval r] -> IntervalSet r
347	fromAscList = IntervalSet . fromAscList'	1✔
348
349	fromAscList' :: Ord r => [Interval r] -> Map (Extended r) (Interval r)
350	fromAscList' = Map.fromDistinctAscList . map (\i -> (Interval.lowerBound i, i)) . f	1✔
351	where
352	f :: Ord r => [Interval r] -> [Interval r]
353	f [] = []	1✔
354	f (x : xs) = g x xs	1✔
355	g x [] = [x \| not (Interval.null x)]	1✔
356	g x (y : ys)
357	\| Interval.null x = g y ys	1✔
358	\| Interval.isConnected x y = g (x `Interval.hull` y) ys	1✔
359	\| otherwise = x : g y ys	1✔
360
361	-- \| Convert a interval set into a list of intervals.
362	toList :: Ord r => IntervalSet r -> [Interval r]
363	toList = toAscList	1✔
364
365	-- \| Convert a interval set into a list of intervals in ascending order.
366	toAscList :: Ord r => IntervalSet r -> [Interval r]
367	toAscList (IntervalSet m) = Map.elems m	1✔
368
369	-- \| Convert a interval set into a list of intervals in descending order.
370	toDescList :: Ord r => IntervalSet r -> [Interval r]
371	toDescList (IntervalSet m) = fmap snd $ Map.toDescList m	1✔
372
373	-- -----------------------------------------------------------------------
374
375	splitLookupLE :: Ord k => k -> Map k v -> (Map k v, Maybe v, Map k v)
376	splitLookupLE k m =	1✔
377	case Map.spanAntitone (<= k) m of	1✔
378	(lessOrEqual, greaterThan) ->
379	case Map.maxView lessOrEqual of	1✔
380	Just (v, lessOrEqual') -> (lessOrEqual', Just v, greaterThan)	1✔
381	Nothing -> (lessOrEqual, Nothing, greaterThan)	1✔
382
383	compareLB :: Ord r => (Extended r, Boundary) -> (Extended r, Boundary) -> Ordering
384	compareLB (lb1, lb1in) (lb2, lb2in) =	1✔
385	-- inclusive lower endpoint shuold be considered smaller
386	(lb1 `compare` lb2) `mappend` (lb2in `compare` lb1in)	1✔
387
388	upTo :: Ord r => Interval r -> Interval r
389	upTo i =	1✔
390	case Interval.lowerBound' i of	1✔
391	(NegInf, _) -> Interval.empty	1✔
UNCOV 392	(PosInf, _) -> Interval.whole	×
393	(Finite lb, incl) ->
UNCOV 394	Interval.interval (NegInf, Open) (Finite lb, notB incl)	×
395
396	downTo :: Ord r => Interval r -> Interval r
397	downTo i =	1✔
398	case Interval.upperBound' i of	1✔
399	(PosInf, _) -> Interval.empty	1✔
UNCOV 400	(NegInf, _) -> Interval.whole	×
401	(Finite ub, incl) ->
UNCOV 402	Interval.interval (Finite ub, notB incl) (PosInf, Open)	×
403
404	notB :: Boundary -> Boundary
405	notB = \case	1✔
406	Open -> Closed	1✔
407	Closed -> Open	1✔

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