msakai / data-interval / 74

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

Build # 74

Build Type

push

github

Committed by

web-flow

Commit Message

Merge 0e36d5686 into 8f4ec0ead

Run Details

992 of 1143 relevant lines covered (86.79%)

0.87 hits per line

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

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

msakai / data-interval / 74

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

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