msakai / data-interval / 77

Committed 07 Jun 2025 02:32PM UTC coverage: 86.702% (+0.1%) from 86.572%

Build # 77

Build Type

push

github

Committed by

Bodigrim

Commit Message

Drop support of GHC < 8.6

Run Details

991 of 1143 relevant lines covered (86.7%)

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, DeriveDataTypeable, MultiWayIf #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE RoleAnnotations #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.IntervalSet
-- Copyright   :  (c) Masahiro Sakai 2016
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable (CPP, ScopedTypeVariables, TypeFamilies, DeriveDataTypeable, MultiWayIf)
--
-- 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 (null, span)
#ifdef MIN_VERSION_lattices
import Algebra.Lattice
#endif
import Control.DeepSeq
import Data.Data
import Data.ExtendedReal
import Data.Function
import Data.Hashable
import Data.List (sortBy, foldl')
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.
    , Typeable
    )

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

msakai / data-interval / 77

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