Add lookupLT, lookupGT, lookupLE, lookupGE methods.
[packages/containers.git] / Data / Set.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__
3 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
4 #endif
5 #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
6 {-# LANGUAGE Trustworthy #-}
7 #endif
8 -----------------------------------------------------------------------------
9 -- |
10 -- Module : Data.Set
11 -- Copyright : (c) Daan Leijen 2002
12 -- License : BSD-style
13 -- Maintainer : libraries@haskell.org
14 -- Stability : provisional
15 -- Portability : portable
16 --
17 -- An efficient implementation of sets.
18 --
19 -- These modules are intended to be imported qualified, to avoid name
20 -- clashes with Prelude functions, e.g.
21 --
22 -- > import Data.Set (Set)
23 -- > import qualified Data.Set as Set
24 --
25 -- The implementation of 'Set' is based on /size balanced/ binary trees (or
26 -- trees of /bounded balance/) as described by:
27 --
28 -- * Stephen Adams, \"/Efficient sets: a balancing act/\",
29 -- Journal of Functional Programming 3(4):553-562, October 1993,
30 -- <http://www.swiss.ai.mit.edu/~adams/BB/>.
31 --
32 -- * J. Nievergelt and E.M. Reingold,
33 -- \"/Binary search trees of bounded balance/\",
34 -- SIAM journal of computing 2(1), March 1973.
35 --
36 -- Note that the implementation is /left-biased/ -- the elements of a
37 -- first argument are always preferred to the second, for example in
38 -- 'union' or 'insert'. Of course, left-biasing can only be observed
39 -- when equality is an equivalence relation instead of structural
40 -- equality.
41 -----------------------------------------------------------------------------
42
43 -- [Note: Using INLINABLE]
44 -- ~~~~~~~~~~~~~~~~~~~~~~~
45 -- It is crucial to the performance that the functions specialize on the Ord
46 -- type when possible. GHC 7.0 and higher does this by itself when it sees th
47 -- unfolding of a function -- that is why all public functions are marked
48 -- INLINABLE (that exposes the unfolding).
49
50
51 -- [Note: Using INLINE]
52 -- ~~~~~~~~~~~~~~~~~~~~
53 -- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.
54 -- We mark the functions that just navigate down the tree (lookup, insert,
55 -- delete and similar). That navigation code gets inlined and thus specialized
56 -- when possible. There is a price to pay -- code growth. The code INLINED is
57 -- therefore only the tree navigation, all the real work (rebalancing) is not
58 -- INLINED by using a NOINLINE.
59 --
60 -- All methods marked INLINE have to be nonrecursive -- a 'go' function doing
61 -- the real work is provided.
62
63
64 -- [Note: Type of local 'go' function]
65 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
66 -- If the local 'go' function uses an Ord class, it must be given a type
67 -- which mentions this Ord class. Otherwise it is not passed as an argument and
68 -- it is instead heap-allocated at the entry of the outer method.
69
70
71 -- [Note: Local 'go' functions and capturing]
72 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
73 -- Care must be taken when using 'go' function which captures an argument.
74 -- Sometimes (for example when the argument is passed to a data constructor,
75 -- as in insert), GHC heap-allocates more than necessary. Therefore C-- code
76 -- must be checked for increased allocation when creating and modifying such
77 -- functions.
78
79
80 -- [Note: Order of constructors]
81 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
82 -- The order of constructors of Set matters when considering performance.
83 -- Currently in GHC 7.0, when type has 2 constructors, a forward conditional
84 -- jump is made when successfully matching second constructor. Successful match
85 -- of first constructor results in the forward jump not taken.
86 -- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip
87 -- improves the benchmark by up to 10% on x86.
88
89 module Data.Set (
90 -- * Strictness properties
91 -- $strictness
92
93 -- * Set type
94 #if !defined(TESTING)
95 Set -- instance Eq,Ord,Show,Read,Data,Typeable
96 #else
97 Set(..)
98 #endif
99
100 -- * Operators
101 , (\\)
102
103 -- * Query
104 , null
105 , size
106 , member
107 , notMember
108 , lookupLT
109 , lookupGT
110 , lookupLE
111 , lookupGE
112 , isSubsetOf
113 , isProperSubsetOf
114
115 -- * Construction
116 , empty
117 , singleton
118 , insert
119 , delete
120
121 -- * Combine
122 , union
123 , unions
124 , difference
125 , intersection
126
127 -- * Filter
128 , filter
129 , partition
130 , split
131 , splitMember
132
133 -- * Map
134 , map
135 , mapMonotonic
136
137 -- * Folds
138 , foldr
139 , foldl
140 -- ** Strict folds
141 , foldr'
142 , foldl'
143 -- ** Legacy folds
144 , fold
145
146 -- * Min\/Max
147 , findMin
148 , findMax
149 , deleteMin
150 , deleteMax
151 , deleteFindMin
152 , deleteFindMax
153 , maxView
154 , minView
155
156 -- * Conversion
157
158 -- ** List
159 , elems
160 , toList
161 , fromList
162
163 -- ** Ordered list
164 , toAscList
165 , toDescList
166 , fromAscList
167 , fromDistinctAscList
168
169 -- * Debugging
170 , showTree
171 , showTreeWith
172 , valid
173
174 #if defined(TESTING)
175 -- Internals (for testing)
176 , bin
177 , balanced
178 , join
179 , merge
180 #endif
181 ) where
182
183 import Prelude hiding (filter,foldl,foldr,null,map)
184 import qualified Data.List as List
185 import Data.Monoid (Monoid(..))
186 import qualified Data.Foldable as Foldable
187 import Data.Typeable
188 import Control.DeepSeq (NFData(rnf))
189
190 #if __GLASGOW_HASKELL__
191 import GHC.Exts ( build )
192 import Text.Read
193 import Data.Data
194 #endif
195
196 -- Use macros to define strictness of functions.
197 -- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.
198 -- We do not use BangPatterns, because they are not in any standard and we
199 -- want the compilers to be compiled by as many compilers as possible.
200 #define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined
201
202 -- $strictness
203 --
204 -- This module satisfies the following strictness property:
205 --
206 -- * Key arguments are evaluated to WHNF
207 --
208 -- Here are some examples that illustrate the property:
209 --
210 -- > delete undefined s == undefined
211
212 {--------------------------------------------------------------------
213 Operators
214 --------------------------------------------------------------------}
215 infixl 9 \\ --
216
217 -- | /O(n+m)/. See 'difference'.
218 (\\) :: Ord a => Set a -> Set a -> Set a
219 m1 \\ m2 = difference m1 m2
220 #if __GLASGOW_HASKELL__ >= 700
221 {-# INLINABLE (\\) #-}
222 #endif
223
224 {--------------------------------------------------------------------
225 Sets are size balanced trees
226 --------------------------------------------------------------------}
227 -- | A set of values @a@.
228
229 -- See Note: Order of constructors
230 data Set a = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)
231 | Tip
232
233 type Size = Int
234
235 instance Ord a => Monoid (Set a) where
236 mempty = empty
237 mappend = union
238 mconcat = unions
239
240 instance Foldable.Foldable Set where
241 fold Tip = mempty
242 fold (Bin _ k l r) = Foldable.fold l `mappend` k `mappend` Foldable.fold r
243 foldr = foldr
244 foldl = foldl
245 foldMap _ Tip = mempty
246 foldMap f (Bin _ k l r) = Foldable.foldMap f l `mappend` f k `mappend` Foldable.foldMap f r
247
248 #if __GLASGOW_HASKELL__
249
250 {--------------------------------------------------------------------
251 A Data instance
252 --------------------------------------------------------------------}
253
254 -- This instance preserves data abstraction at the cost of inefficiency.
255 -- We omit reflection services for the sake of data abstraction.
256
257 instance (Data a, Ord a) => Data (Set a) where
258 gfoldl f z set = z fromList `f` (toList set)
259 toConstr _ = error "toConstr"
260 gunfold _ _ = error "gunfold"
261 dataTypeOf _ = mkNoRepType "Data.Set.Set"
262 dataCast1 f = gcast1 f
263
264 #endif
265
266 {--------------------------------------------------------------------
267 Query
268 --------------------------------------------------------------------}
269 -- | /O(1)/. Is this the empty set?
270 null :: Set a -> Bool
271 null Tip = True
272 null (Bin {}) = False
273 {-# INLINE null #-}
274
275 -- | /O(1)/. The number of elements in the set.
276 size :: Set a -> Int
277 size Tip = 0
278 size (Bin sz _ _ _) = sz
279 {-# INLINE size #-}
280
281 -- | /O(log n)/. Is the element in the set?
282
283 -- See Note: Local 'go' functions and capturing
284 member :: Ord a => a -> Set a -> Bool
285 member x = x `seq` go
286 where
287 go Tip = False
288 go (Bin _ y l r) = case compare x y of
289 LT -> go l
290 GT -> go r
291 EQ -> True
292 #if __GLASGOW_HASKELL__ >= 700
293 {-# INLINABLE member #-}
294 #else
295 {-# INLINE member #-}
296 #endif
297
298 -- | /O(log n)/. Is the element not in the set?
299 notMember :: Ord a => a -> Set a -> Bool
300 notMember a t = not $ member a t
301 #if __GLASGOW_HASKELL__ >= 700
302 {-# INLINABLE notMember #-}
303 #else
304 {-# INLINE notMember #-}
305 #endif
306
307 -- | /O(log n)/. Find largest element smaller than the given one.
308 --
309 -- > lookupLT 3 (fromList [3, 5]) == Nothing
310 -- > lookupLT 5 (fromList [3, 5]) == Just 3
311
312 -- See Note: Local 'go' functions and capturing.
313 lookupLT :: Ord a => a -> Set a -> Maybe a
314 lookupLT x = x `seq` goNothing
315 where
316 goNothing Tip = Nothing
317 goNothing (Bin _ y l r) | x <= y = goNothing l
318 | otherwise = goJust y r
319
320 goJust best Tip = Just best
321 goJust best (Bin _ y l r) | x <= y = goJust best l
322 | otherwise = goJust y r
323 #if __GLASGOW_HASKELL__ >= 700
324 {-# INLINABLE lookupLT #-}
325 #else
326 {-# INLINE lookupLT #-}
327 #endif
328
329 -- | /O(log n)/. Find smallest element greater than the given one.
330 --
331 -- > lookupGT 4 (fromList [3, 5]) == Just 5
332 -- > lookupGT 5 (fromList [3, 5]) == Nothing
333
334 -- See Note: Local 'go' functions and capturing.
335 lookupGT :: Ord a => a -> Set a -> Maybe a
336 lookupGT x = x `seq` goNothing
337 where
338 goNothing Tip = Nothing
339 goNothing (Bin _ y l r) | x < y = goJust y l
340 | otherwise = goNothing r
341
342 goJust best Tip = Just best
343 goJust best (Bin _ y l r) | x < y = goJust y l
344 | otherwise = goJust best r
345 #if __GLASGOW_HASKELL__ >= 700
346 {-# INLINABLE lookupGT #-}
347 #else
348 {-# INLINE lookupGT #-}
349 #endif
350
351 -- | /O(log n)/. Find largest element smaller or equal to the given one.
352 --
353 -- > lookupLE 2 (fromList [3, 5]) == Nothing
354 -- > lookupLE 4 (fromList [3, 5]) == Just 3
355 -- > lookupLE 5 (fromList [3, 5]) == Just 5
356
357 -- See Note: Local 'go' functions and capturing.
358 lookupLE :: Ord a => a -> Set a -> Maybe a
359 lookupLE x = x `seq` goNothing
360 where
361 goNothing Tip = Nothing
362 goNothing (Bin _ y l r) = case compare x y of LT -> goNothing l
363 EQ -> Just y
364 GT -> goJust y r
365
366 goJust best Tip = Just best
367 goJust best (Bin _ y l r) = case compare x y of LT -> goJust best l
368 EQ -> Just y
369 GT -> goJust y r
370 #if __GLASGOW_HASKELL__ >= 700
371 {-# INLINABLE lookupLE #-}
372 #else
373 {-# INLINE lookupLE #-}
374 #endif
375
376 -- | /O(log n)/. Find smallest element greater or equal to the given one.
377 --
378 -- > lookupGE 3 (fromList [3, 5]) == Just 3
379 -- > lookupGE 4 (fromList [3, 5]) == Just 5
380 -- > lookupGE 6 (fromList [3, 5]) == Nothing
381
382 -- See Note: Local 'go' functions and capturing.
383 lookupGE :: Ord a => a -> Set a -> Maybe a
384 lookupGE x = x `seq` goNothing
385 where
386 goNothing Tip = Nothing
387 goNothing (Bin _ y l r) = case compare x y of LT -> goJust y l
388 EQ -> Just y
389 GT -> goNothing r
390
391 goJust best Tip = Just best
392 goJust best (Bin _ y l r) = case compare x y of LT -> goJust y l
393 EQ -> Just y
394 GT -> goJust best r
395 #if __GLASGOW_HASKELL__ >= 700
396 {-# INLINABLE lookupGE #-}
397 #else
398 {-# INLINE lookupGE #-}
399 #endif
400
401 {--------------------------------------------------------------------
402 Construction
403 --------------------------------------------------------------------}
404 -- | /O(1)/. The empty set.
405 empty :: Set a
406 empty = Tip
407 {-# INLINE empty #-}
408
409 -- | /O(1)/. Create a singleton set.
410 singleton :: a -> Set a
411 singleton x = Bin 1 x Tip Tip
412 {-# INLINE singleton #-}
413
414 {--------------------------------------------------------------------
415 Insertion, Deletion
416 --------------------------------------------------------------------}
417 -- | /O(log n)/. Insert an element in a set.
418 -- If the set already contains an element equal to the given value,
419 -- it is replaced with the new value.
420
421 -- See Note: Type of local 'go' function
422 insert :: Ord a => a -> Set a -> Set a
423 insert = go
424 where
425 go :: Ord a => a -> Set a -> Set a
426 STRICT_1_OF_2(go)
427 go x Tip = singleton x
428 go x (Bin sz y l r) = case compare x y of
429 LT -> balanceL y (go x l) r
430 GT -> balanceR y l (go x r)
431 EQ -> Bin sz x l r
432 #if __GLASGOW_HASKELL__ >= 700
433 {-# INLINABLE insert #-}
434 #else
435 {-# INLINE insert #-}
436 #endif
437
438 -- Insert an element to the set only if it is not in the set. Used by
439 -- `union`.
440
441 -- See Note: Type of local 'go' function
442 insertR :: Ord a => a -> Set a -> Set a
443 insertR = go
444 where
445 go :: Ord a => a -> Set a -> Set a
446 STRICT_1_OF_2(go)
447 go x Tip = singleton x
448 go x t@(Bin _ y l r) = case compare x y of
449 LT -> balanceL y (go x l) r
450 GT -> balanceR y l (go x r)
451 EQ -> t
452 #if __GLASGOW_HASKELL__ >= 700
453 {-# INLINABLE insertR #-}
454 #else
455 {-# INLINE insertR #-}
456 #endif
457
458 -- | /O(log n)/. Delete an element from a set.
459
460 -- See Note: Type of local 'go' function
461 delete :: Ord a => a -> Set a -> Set a
462 delete = go
463 where
464 go :: Ord a => a -> Set a -> Set a
465 STRICT_1_OF_2(go)
466 go _ Tip = Tip
467 go x (Bin _ y l r) = case compare x y of
468 LT -> balanceR y (go x l) r
469 GT -> balanceL y l (go x r)
470 EQ -> glue l r
471 #if __GLASGOW_HASKELL__ >= 700
472 {-# INLINABLE delete #-}
473 #else
474 {-# INLINE delete #-}
475 #endif
476
477 {--------------------------------------------------------------------
478 Subset
479 --------------------------------------------------------------------}
480 -- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
481 isProperSubsetOf :: Ord a => Set a -> Set a -> Bool
482 isProperSubsetOf s1 s2
483 = (size s1 < size s2) && (isSubsetOf s1 s2)
484 #if __GLASGOW_HASKELL__ >= 700
485 {-# INLINABLE isProperSubsetOf #-}
486 #endif
487
488
489 -- | /O(n+m)/. Is this a subset?
490 -- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
491 isSubsetOf :: Ord a => Set a -> Set a -> Bool
492 isSubsetOf t1 t2
493 = (size t1 <= size t2) && (isSubsetOfX t1 t2)
494 #if __GLASGOW_HASKELL__ >= 700
495 {-# INLINABLE isSubsetOf #-}
496 #endif
497
498 isSubsetOfX :: Ord a => Set a -> Set a -> Bool
499 isSubsetOfX Tip _ = True
500 isSubsetOfX _ Tip = False
501 isSubsetOfX (Bin _ x l r) t
502 = found && isSubsetOfX l lt && isSubsetOfX r gt
503 where
504 (lt,found,gt) = splitMember x t
505 #if __GLASGOW_HASKELL__ >= 700
506 {-# INLINABLE isSubsetOfX #-}
507 #endif
508
509
510 {--------------------------------------------------------------------
511 Minimal, Maximal
512 --------------------------------------------------------------------}
513 -- | /O(log n)/. The minimal element of a set.
514 findMin :: Set a -> a
515 findMin (Bin _ x Tip _) = x
516 findMin (Bin _ _ l _) = findMin l
517 findMin Tip = error "Set.findMin: empty set has no minimal element"
518
519 -- | /O(log n)/. The maximal element of a set.
520 findMax :: Set a -> a
521 findMax (Bin _ x _ Tip) = x
522 findMax (Bin _ _ _ r) = findMax r
523 findMax Tip = error "Set.findMax: empty set has no maximal element"
524
525 -- | /O(log n)/. Delete the minimal element.
526 deleteMin :: Set a -> Set a
527 deleteMin (Bin _ _ Tip r) = r
528 deleteMin (Bin _ x l r) = balanceR x (deleteMin l) r
529 deleteMin Tip = Tip
530
531 -- | /O(log n)/. Delete the maximal element.
532 deleteMax :: Set a -> Set a
533 deleteMax (Bin _ _ l Tip) = l
534 deleteMax (Bin _ x l r) = balanceL x l (deleteMax r)
535 deleteMax Tip = Tip
536
537 {--------------------------------------------------------------------
538 Union.
539 --------------------------------------------------------------------}
540 -- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).
541 unions :: Ord a => [Set a] -> Set a
542 unions = foldlStrict union empty
543 #if __GLASGOW_HASKELL__ >= 700
544 {-# INLINABLE unions #-}
545 #endif
546
547 -- | /O(n+m)/. The union of two sets, preferring the first set when
548 -- equal elements are encountered.
549 -- The implementation uses the efficient /hedge-union/ algorithm.
550 -- Hedge-union is more efficient on (bigset `union` smallset).
551 union :: Ord a => Set a -> Set a -> Set a
552 union Tip t2 = t2
553 union t1 Tip = t1
554 union (Bin _ x Tip Tip) t = insert x t
555 union t (Bin _ x Tip Tip) = insertR x t
556 union t1 t2 = hedgeUnion NothingS NothingS t1 t2
557 #if __GLASGOW_HASKELL__ >= 700
558 {-# INLINABLE union #-}
559 #endif
560
561 hedgeUnion :: Ord a
562 => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a
563 hedgeUnion _ _ t1 Tip
564 = t1
565 hedgeUnion blo bhi Tip (Bin _ x l r)
566 = join x (filterGt blo l) (filterLt bhi r)
567 hedgeUnion blo bhi (Bin _ x l r) t2
568 = join x (hedgeUnion blo bmi l (trim blo bmi t2))
569 (hedgeUnion bmi bhi r (trim bmi bhi t2))
570 where
571 bmi = JustS x
572 #if __GLASGOW_HASKELL__ >= 700
573 {-# INLINABLE hedgeUnion #-}
574 #endif
575
576 {--------------------------------------------------------------------
577 Difference
578 --------------------------------------------------------------------}
579 -- | /O(n+m)/. Difference of two sets.
580 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
581 difference :: Ord a => Set a -> Set a -> Set a
582 difference Tip _ = Tip
583 difference t1 Tip = t1
584 difference t1 t2 = hedgeDiff NothingS NothingS t1 t2
585 #if __GLASGOW_HASKELL__ >= 700
586 {-# INLINABLE difference #-}
587 #endif
588
589 hedgeDiff :: Ord a
590 => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a
591 hedgeDiff _ _ Tip _
592 = Tip
593 hedgeDiff blo bhi (Bin _ x l r) Tip
594 = join x (filterGt blo l) (filterLt bhi r)
595 hedgeDiff blo bhi t (Bin _ x l r)
596 = merge (hedgeDiff blo bmi (trim blo bmi t) l)
597 (hedgeDiff bmi bhi (trim bmi bhi t) r)
598 where
599 bmi = JustS x
600 #if __GLASGOW_HASKELL__ >= 700
601 {-# INLINABLE hedgeDiff #-}
602 #endif
603
604 {--------------------------------------------------------------------
605 Intersection
606 --------------------------------------------------------------------}
607 -- | /O(n+m)/. The intersection of two sets.
608 -- Elements of the result come from the first set, so for example
609 --
610 -- > import qualified Data.Set as S
611 -- > data AB = A | B deriving Show
612 -- > instance Ord AB where compare _ _ = EQ
613 -- > instance Eq AB where _ == _ = True
614 -- > main = print (S.singleton A `S.intersection` S.singleton B,
615 -- > S.singleton B `S.intersection` S.singleton A)
616 --
617 -- prints @(fromList [A],fromList [B])@.
618 intersection :: Ord a => Set a -> Set a -> Set a
619 intersection Tip _ = Tip
620 intersection _ Tip = Tip
621 intersection t1@(Bin s1 x1 l1 r1) t2@(Bin s2 x2 l2 r2) =
622 if s1 >= s2 then
623 let (lt,found,gt) = splitLookup x2 t1
624 tl = intersection lt l2
625 tr = intersection gt r2
626 in case found of
627 Just x -> join x tl tr
628 Nothing -> merge tl tr
629 else let (lt,found,gt) = splitMember x1 t2
630 tl = intersection l1 lt
631 tr = intersection r1 gt
632 in if found then join x1 tl tr
633 else merge tl tr
634 #if __GLASGOW_HASKELL__ >= 700
635 {-# INLINABLE intersection #-}
636 #endif
637
638 {--------------------------------------------------------------------
639 Filter and partition
640 --------------------------------------------------------------------}
641 -- | /O(n)/. Filter all elements that satisfy the predicate.
642 filter :: (a -> Bool) -> Set a -> Set a
643 filter _ Tip = Tip
644 filter p (Bin _ x l r)
645 | p x = join x (filter p l) (filter p r)
646 | otherwise = merge (filter p l) (filter p r)
647
648 -- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
649 -- the predicate and one with all elements that don't satisfy the predicate.
650 -- See also 'split'.
651 partition :: (a -> Bool) -> Set a -> (Set a,Set a)
652 partition _ Tip = (Tip, Tip)
653 partition p (Bin _ x l r) = case (partition p l, partition p r) of
654 ((l1, l2), (r1, r2))
655 | p x -> (join x l1 r1, merge l2 r2)
656 | otherwise -> (merge l1 r1, join x l2 r2)
657
658 {----------------------------------------------------------------------
659 Map
660 ----------------------------------------------------------------------}
661
662 -- | /O(n*log n)/.
663 -- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
664 --
665 -- It's worth noting that the size of the result may be smaller if,
666 -- for some @(x,y)@, @x \/= y && f x == f y@
667
668 map :: (Ord a, Ord b) => (a->b) -> Set a -> Set b
669 map f = fromList . List.map f . toList
670 #if __GLASGOW_HASKELL__ >= 700
671 {-# INLINABLE map #-}
672 #endif
673
674 -- | /O(n)/. The
675 --
676 -- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic.
677 -- /The precondition is not checked./
678 -- Semi-formally, we have:
679 --
680 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
681 -- > ==> mapMonotonic f s == map f s
682 -- > where ls = toList s
683
684 mapMonotonic :: (a->b) -> Set a -> Set b
685 mapMonotonic _ Tip = Tip
686 mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)
687
688 {--------------------------------------------------------------------
689 Fold
690 --------------------------------------------------------------------}
691 -- | /O(n)/. Fold the elements in the set using the given right-associative
692 -- binary operator. This function is an equivalent of 'foldr' and is present
693 -- for compatibility only.
694 --
695 -- /Please note that fold will be deprecated in the future and removed./
696 fold :: (a -> b -> b) -> b -> Set a -> b
697 fold = foldr
698 {-# INLINE fold #-}
699
700 -- | /O(n)/. Fold the elements in the set using the given right-associative
701 -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.
702 --
703 -- For example,
704 --
705 -- > toAscList set = foldr (:) [] set
706 foldr :: (a -> b -> b) -> b -> Set a -> b
707 foldr f z = go z
708 where
709 go z' Tip = z'
710 go z' (Bin _ x l r) = go (f x (go z' r)) l
711 {-# INLINE foldr #-}
712
713 -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is
714 -- evaluated before using the result in the next application. This
715 -- function is strict in the starting value.
716 foldr' :: (a -> b -> b) -> b -> Set a -> b
717 foldr' f z = go z
718 where
719 STRICT_1_OF_2(go)
720 go z' Tip = z'
721 go z' (Bin _ x l r) = go (f x (go z' r)) l
722 {-# INLINE foldr' #-}
723
724 -- | /O(n)/. Fold the elements in the set using the given left-associative
725 -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.
726 --
727 -- For example,
728 --
729 -- > toDescList set = foldl (flip (:)) [] set
730 foldl :: (a -> b -> a) -> a -> Set b -> a
731 foldl f z = go z
732 where
733 go z' Tip = z'
734 go z' (Bin _ x l r) = go (f (go z' l) x) r
735 {-# INLINE foldl #-}
736
737 -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is
738 -- evaluated before using the result in the next application. This
739 -- function is strict in the starting value.
740 foldl' :: (a -> b -> a) -> a -> Set b -> a
741 foldl' f z = go z
742 where
743 STRICT_1_OF_2(go)
744 go z' Tip = z'
745 go z' (Bin _ x l r) = go (f (go z' l) x) r
746 {-# INLINE foldl' #-}
747
748 {--------------------------------------------------------------------
749 List variations
750 --------------------------------------------------------------------}
751 -- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order.
752 -- Subject to list fusion.
753 elems :: Set a -> [a]
754 elems = toAscList
755
756 {--------------------------------------------------------------------
757 Lists
758 --------------------------------------------------------------------}
759 -- | /O(n)/. Convert the set to a list of elements. Subject to list fusion.
760 toList :: Set a -> [a]
761 toList = toAscList
762
763 -- | /O(n)/. Convert the set to an ascending list of elements. Subject to list fusion.
764 toAscList :: Set a -> [a]
765 toAscList = foldr (:) []
766
767 -- | /O(n)/. Convert the set to a descending list of elements. Subject to list
768 -- fusion.
769 toDescList :: Set a -> [a]
770 toDescList = foldl (flip (:)) []
771
772 -- List fusion for the list generating functions.
773 #if __GLASGOW_HASKELL__
774 -- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.
775 -- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.
776 foldrFB :: (a -> b -> b) -> b -> Set a -> b
777 foldrFB = foldr
778 {-# INLINE[0] foldrFB #-}
779 foldlFB :: (a -> b -> a) -> a -> Set b -> a
780 foldlFB = foldl
781 {-# INLINE[0] foldlFB #-}
782
783 -- Inline elems and toList, so that we need to fuse only toAscList.
784 {-# INLINE elems #-}
785 {-# INLINE toList #-}
786
787 -- The fusion is enabled up to phase 2 included. If it does not succeed,
788 -- convert in phase 1 the expanded to{Asc,Desc}List calls back to
789 -- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in
790 -- a list fusion, otherwise it would go away in phase 1), and let compiler do
791 -- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it
792 -- before phase 0, otherwise the fusion rules would not fire at all.
793 {-# NOINLINE[0] toAscList #-}
794 {-# NOINLINE[0] toDescList #-}
795 {-# RULES "Set.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-}
796 {-# RULES "Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-}
797 {-# RULES "Set.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}
798 {-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}
799 #endif
800
801 -- | /O(n*log n)/. Create a set from a list of elements.
802 fromList :: Ord a => [a] -> Set a
803 fromList = foldlStrict ins empty
804 where
805 ins t x = insert x t
806 #if __GLASGOW_HASKELL__ >= 700
807 {-# INLINABLE fromList #-}
808 #endif
809
810 {--------------------------------------------------------------------
811 Building trees from ascending/descending lists can be done in linear time.
812
813 Note that if [xs] is ascending that:
814 fromAscList xs == fromList xs
815 --------------------------------------------------------------------}
816 -- | /O(n)/. Build a set from an ascending list in linear time.
817 -- /The precondition (input list is ascending) is not checked./
818 fromAscList :: Eq a => [a] -> Set a
819 fromAscList xs
820 = fromDistinctAscList (combineEq xs)
821 where
822 -- [combineEq xs] combines equal elements with [const] in an ordered list [xs]
823 combineEq xs'
824 = case xs' of
825 [] -> []
826 [x] -> [x]
827 (x:xx) -> combineEq' x xx
828
829 combineEq' z [] = [z]
830 combineEq' z (x:xs')
831 | z==x = combineEq' z xs'
832 | otherwise = z:combineEq' x xs'
833 #if __GLASGOW_HASKELL__ >= 700
834 {-# INLINABLE fromAscList #-}
835 #endif
836
837
838 -- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.
839 -- /The precondition (input list is strictly ascending) is not checked./
840 fromDistinctAscList :: [a] -> Set a
841 fromDistinctAscList xs
842 = create const (length xs) xs
843 where
844 -- 1) use continutations so that we use heap space instead of stack space.
845 -- 2) special case for n==5 to create bushier trees.
846 create c 0 xs' = c Tip xs'
847 create c 5 xs' = case xs' of
848 (x1:x2:x3:x4:x5:xx)
849 -> c (bin x4 (bin x2 (singleton x1) (singleton x3)) (singleton x5)) xx
850 _ -> error "fromDistinctAscList create 5"
851 create c n xs' = seq nr $ create (createR nr c) nl xs'
852 where nl = n `div` 2
853 nr = n - nl - 1
854
855 createR n c l (x:ys) = create (createB l x c) n ys
856 createR _ _ _ [] = error "fromDistinctAscList createR []"
857 createB l x c r zs = c (bin x l r) zs
858
859 {--------------------------------------------------------------------
860 Eq converts the set to a list. In a lazy setting, this
861 actually seems one of the faster methods to compare two trees
862 and it is certainly the simplest :-)
863 --------------------------------------------------------------------}
864 instance Eq a => Eq (Set a) where
865 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
866
867 {--------------------------------------------------------------------
868 Ord
869 --------------------------------------------------------------------}
870
871 instance Ord a => Ord (Set a) where
872 compare s1 s2 = compare (toAscList s1) (toAscList s2)
873
874 {--------------------------------------------------------------------
875 Show
876 --------------------------------------------------------------------}
877 instance Show a => Show (Set a) where
878 showsPrec p xs = showParen (p > 10) $
879 showString "fromList " . shows (toList xs)
880
881 {--------------------------------------------------------------------
882 Read
883 --------------------------------------------------------------------}
884 instance (Read a, Ord a) => Read (Set a) where
885 #ifdef __GLASGOW_HASKELL__
886 readPrec = parens $ prec 10 $ do
887 Ident "fromList" <- lexP
888 xs <- readPrec
889 return (fromList xs)
890
891 readListPrec = readListPrecDefault
892 #else
893 readsPrec p = readParen (p > 10) $ \ r -> do
894 ("fromList",s) <- lex r
895 (xs,t) <- reads s
896 return (fromList xs,t)
897 #endif
898
899 {--------------------------------------------------------------------
900 Typeable/Data
901 --------------------------------------------------------------------}
902
903 #include "Typeable.h"
904 INSTANCE_TYPEABLE1(Set,setTc,"Set")
905
906 {--------------------------------------------------------------------
907 NFData
908 --------------------------------------------------------------------}
909
910 instance NFData a => NFData (Set a) where
911 rnf Tip = ()
912 rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r
913
914 {--------------------------------------------------------------------
915 Utility functions that return sub-ranges of the original
916 tree. Some functions take a `Maybe value` as an argument to
917 allow comparisons against infinite values. These are called `blow`
918 (Nothing is -\infty) and `bhigh` (here Nothing is +\infty).
919 We use MaybeS value, which is a Maybe strict in the Just case.
920
921 [trim blow bhigh t] A tree that is either empty or where [x > blow]
922 and [x < bhigh] for the value [x] of the root.
923 [filterGt blow t] A tree where for all values [k]. [k > blow]
924 [filterLt bhigh t] A tree where for all values [k]. [k < bhigh]
925
926 [split k t] Returns two trees [l] and [r] where all values
927 in [l] are <[k] and all keys in [r] are >[k].
928 [splitMember k t] Just like [split] but also returns whether [k]
929 was found in the tree.
930 --------------------------------------------------------------------}
931
932 data MaybeS a = NothingS | JustS !a
933
934 {--------------------------------------------------------------------
935 [trim blo bhi t] trims away all subtrees that surely contain no
936 values between the range [blo] to [bhi]. The returned tree is either
937 empty or the key of the root is between @blo@ and @bhi@.
938 --------------------------------------------------------------------}
939 trim :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a
940 trim NothingS NothingS t = t
941 trim (JustS lx) NothingS t = greater lx t where greater lo (Bin _ x _ r) | x <= lo = greater lo r
942 greater _ t' = t'
943 trim NothingS (JustS hx) t = lesser hx t where lesser hi (Bin _ x l _) | x >= hi = lesser hi l
944 lesser _ t' = t'
945 trim (JustS lx) (JustS hx) t = middle lx hx t where middle lo hi (Bin _ x _ r) | x <= lo = middle lo hi r
946 middle lo hi (Bin _ x l _) | x >= hi = middle lo hi l
947 middle _ _ t' = t'
948 #if __GLASGOW_HASKELL__ >= 700
949 {-# INLINABLE trim #-}
950 #endif
951
952 {--------------------------------------------------------------------
953 [filterGt b t] filter all values >[b] from tree [t]
954 [filterLt b t] filter all values <[b] from tree [t]
955 --------------------------------------------------------------------}
956 filterGt :: Ord a => MaybeS a -> Set a -> Set a
957 filterGt NothingS t = t
958 filterGt (JustS b) t = filter' b t
959 where filter' _ Tip = Tip
960 filter' b' (Bin _ x l r) =
961 case compare b' x of LT -> join x (filter' b' l) r
962 EQ -> r
963 GT -> filter' b' r
964 #if __GLASGOW_HASKELL__ >= 700
965 {-# INLINABLE filterGt #-}
966 #endif
967
968 filterLt :: Ord a => MaybeS a -> Set a -> Set a
969 filterLt NothingS t = t
970 filterLt (JustS b) t = filter' b t
971 where filter' _ Tip = Tip
972 filter' b' (Bin _ x l r) =
973 case compare x b' of LT -> join x l (filter' b' r)
974 EQ -> l
975 GT -> filter' b' l
976 #if __GLASGOW_HASKELL__ >= 700
977 {-# INLINABLE filterLt #-}
978 #endif
979
980 {--------------------------------------------------------------------
981 Split
982 --------------------------------------------------------------------}
983 -- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@
984 -- where @set1@ comprises the elements of @set@ less than @x@ and @set2@
985 -- comprises the elements of @set@ greater than @x@.
986 split :: Ord a => a -> Set a -> (Set a,Set a)
987 split _ Tip = (Tip,Tip)
988 split x (Bin _ y l r)
989 = case compare x y of
990 LT -> let (lt,gt) = split x l in (lt,join y gt r)
991 GT -> let (lt,gt) = split x r in (join y l lt,gt)
992 EQ -> (l,r)
993 #if __GLASGOW_HASKELL__ >= 700
994 {-# INLINABLE split #-}
995 #endif
996
997 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
998 -- element was found in the original set.
999 splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)
1000 splitMember x t = let (l,m,r) = splitLookup x t in
1001 (l,maybe False (const True) m,r)
1002 #if __GLASGOW_HASKELL__ >= 700
1003 {-# INLINABLE splitMember #-}
1004 #endif
1005
1006 -- | /O(log n)/. Performs a 'split' but also returns the pivot
1007 -- element that was found in the original set.
1008 splitLookup :: Ord a => a -> Set a -> (Set a,Maybe a,Set a)
1009 splitLookup _ Tip = (Tip,Nothing,Tip)
1010 splitLookup x (Bin _ y l r)
1011 = case compare x y of
1012 LT -> let (lt,found,gt) = splitLookup x l in (lt,found,join y gt r)
1013 GT -> let (lt,found,gt) = splitLookup x r in (join y l lt,found,gt)
1014 EQ -> (l,Just y,r)
1015 #if __GLASGOW_HASKELL__ >= 700
1016 {-# INLINABLE splitLookup #-}
1017 #endif
1018
1019 {--------------------------------------------------------------------
1020 Utility functions that maintain the balance properties of the tree.
1021 All constructors assume that all values in [l] < [x] and all values
1022 in [r] > [x], and that [l] and [r] are valid trees.
1023
1024 In order of sophistication:
1025 [Bin sz x l r] The type constructor.
1026 [bin x l r] Maintains the correct size, assumes that both [l]
1027 and [r] are balanced with respect to each other.
1028 [balance x l r] Restores the balance and size.
1029 Assumes that the original tree was balanced and
1030 that [l] or [r] has changed by at most one element.
1031 [join x l r] Restores balance and size.
1032
1033 Furthermore, we can construct a new tree from two trees. Both operations
1034 assume that all values in [l] < all values in [r] and that [l] and [r]
1035 are valid:
1036 [glue l r] Glues [l] and [r] together. Assumes that [l] and
1037 [r] are already balanced with respect to each other.
1038 [merge l r] Merges two trees and restores balance.
1039
1040 Note: in contrast to Adam's paper, we use (<=) comparisons instead
1041 of (<) comparisons in [join], [merge] and [balance].
1042 Quickcheck (on [difference]) showed that this was necessary in order
1043 to maintain the invariants. It is quite unsatisfactory that I haven't
1044 been able to find out why this is actually the case! Fortunately, it
1045 doesn't hurt to be a bit more conservative.
1046 --------------------------------------------------------------------}
1047
1048 {--------------------------------------------------------------------
1049 Join
1050 --------------------------------------------------------------------}
1051 join :: a -> Set a -> Set a -> Set a
1052 join x Tip r = insertMin x r
1053 join x l Tip = insertMax x l
1054 join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)
1055 | delta*sizeL < sizeR = balanceL z (join x l lz) rz
1056 | delta*sizeR < sizeL = balanceR y ly (join x ry r)
1057 | otherwise = bin x l r
1058
1059
1060 -- insertMin and insertMax don't perform potentially expensive comparisons.
1061 insertMax,insertMin :: a -> Set a -> Set a
1062 insertMax x t
1063 = case t of
1064 Tip -> singleton x
1065 Bin _ y l r
1066 -> balanceR y l (insertMax x r)
1067
1068 insertMin x t
1069 = case t of
1070 Tip -> singleton x
1071 Bin _ y l r
1072 -> balanceL y (insertMin x l) r
1073
1074 {--------------------------------------------------------------------
1075 [merge l r]: merges two trees.
1076 --------------------------------------------------------------------}
1077 merge :: Set a -> Set a -> Set a
1078 merge Tip r = r
1079 merge l Tip = l
1080 merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
1081 | delta*sizeL < sizeR = balanceL y (merge l ly) ry
1082 | delta*sizeR < sizeL = balanceR x lx (merge rx r)
1083 | otherwise = glue l r
1084
1085 {--------------------------------------------------------------------
1086 [glue l r]: glues two trees together.
1087 Assumes that [l] and [r] are already balanced with respect to each other.
1088 --------------------------------------------------------------------}
1089 glue :: Set a -> Set a -> Set a
1090 glue Tip r = r
1091 glue l Tip = l
1092 glue l r
1093 | size l > size r = let (m,l') = deleteFindMax l in balanceR m l' r
1094 | otherwise = let (m,r') = deleteFindMin r in balanceL m l r'
1095
1096 -- | /O(log n)/. Delete and find the minimal element.
1097 --
1098 -- > deleteFindMin set = (findMin set, deleteMin set)
1099
1100 deleteFindMin :: Set a -> (a,Set a)
1101 deleteFindMin t
1102 = case t of
1103 Bin _ x Tip r -> (x,r)
1104 Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balanceR x l' r)
1105 Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)
1106
1107 -- | /O(log n)/. Delete and find the maximal element.
1108 --
1109 -- > deleteFindMax set = (findMax set, deleteMax set)
1110 deleteFindMax :: Set a -> (a,Set a)
1111 deleteFindMax t
1112 = case t of
1113 Bin _ x l Tip -> (x,l)
1114 Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balanceL x l r')
1115 Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)
1116
1117 -- | /O(log n)/. Retrieves the minimal key of the set, and the set
1118 -- stripped of that element, or 'Nothing' if passed an empty set.
1119 minView :: Set a -> Maybe (a, Set a)
1120 minView Tip = Nothing
1121 minView x = Just (deleteFindMin x)
1122
1123 -- | /O(log n)/. Retrieves the maximal key of the set, and the set
1124 -- stripped of that element, or 'Nothing' if passed an empty set.
1125 maxView :: Set a -> Maybe (a, Set a)
1126 maxView Tip = Nothing
1127 maxView x = Just (deleteFindMax x)
1128
1129 {--------------------------------------------------------------------
1130 [balance x l r] balances two trees with value x.
1131 The sizes of the trees should balance after decreasing the
1132 size of one of them. (a rotation).
1133
1134 [delta] is the maximal relative difference between the sizes of
1135 two trees, it corresponds with the [w] in Adams' paper.
1136 [ratio] is the ratio between an outer and inner sibling of the
1137 heavier subtree in an unbalanced setting. It determines
1138 whether a double or single rotation should be performed
1139 to restore balance. It is correspondes with the inverse
1140 of $\alpha$ in Adam's article.
1141
1142 Note that according to the Adam's paper:
1143 - [delta] should be larger than 4.646 with a [ratio] of 2.
1144 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1145
1146 But the Adam's paper is errorneous:
1147 - it can be proved that for delta=2 and delta>=5 there does
1148 not exist any ratio that would work
1149 - delta=4.5 and ratio=2 does not work
1150
1151 That leaves two reasonable variants, delta=3 and delta=4,
1152 both with ratio=2.
1153
1154 - A lower [delta] leads to a more 'perfectly' balanced tree.
1155 - A higher [delta] performs less rebalancing.
1156
1157 In the benchmarks, delta=3 is faster on insert operations,
1158 and delta=4 has slightly better deletes. As the insert speedup
1159 is larger, we currently use delta=3.
1160
1161 --------------------------------------------------------------------}
1162 delta,ratio :: Int
1163 delta = 3
1164 ratio = 2
1165
1166 -- The balance function is equivalent to the following:
1167 --
1168 -- balance :: a -> Set a -> Set a -> Set a
1169 -- balance x l r
1170 -- | sizeL + sizeR <= 1 = Bin sizeX x l r
1171 -- | sizeR > delta*sizeL = rotateL x l r
1172 -- | sizeL > delta*sizeR = rotateR x l r
1173 -- | otherwise = Bin sizeX x l r
1174 -- where
1175 -- sizeL = size l
1176 -- sizeR = size r
1177 -- sizeX = sizeL + sizeR + 1
1178 --
1179 -- rotateL :: a -> Set a -> Set a -> Set a
1180 -- rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r
1181 -- | otherwise = doubleL x l r
1182 -- rotateR :: a -> Set a -> Set a -> Set a
1183 -- rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r
1184 -- | otherwise = doubleR x l r
1185 --
1186 -- singleL, singleR :: a -> Set a -> Set a -> Set a
1187 -- singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3
1188 -- singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)
1189 --
1190 -- doubleL, doubleR :: a -> Set a -> Set a -> Set a
1191 -- doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
1192 -- doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
1193 --
1194 -- It is only written in such a way that every node is pattern-matched only once.
1195 --
1196 -- Only balanceL and balanceR are needed at the moment, so balance is not here anymore.
1197 -- In case it is needed, it can be found in Data.Map.
1198
1199 -- Functions balanceL and balanceR are specialised versions of balance.
1200 -- balanceL only checks whether the left subtree is too big,
1201 -- balanceR only checks whether the right subtree is too big.
1202
1203 -- balanceL is called when left subtree might have been inserted to or when
1204 -- right subtree might have been deleted from.
1205 balanceL :: a -> Set a -> Set a -> Set a
1206 balanceL x l r = case r of
1207 Tip -> case l of
1208 Tip -> Bin 1 x Tip Tip
1209 (Bin _ _ Tip Tip) -> Bin 2 x l Tip
1210 (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)
1211 (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)
1212 (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))
1213 | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)
1214 | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)
1215
1216 (Bin rs _ _ _) -> case l of
1217 Tip -> Bin (1+rs) x Tip r
1218
1219 (Bin ls lx ll lr)
1220 | ls > delta*rs -> case (ll, lr) of
1221 (Bin lls _ _ _, Bin lrs lrx lrl lrr)
1222 | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)
1223 | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)
1224 (_, _) -> error "Failure in Data.Map.balanceL"
1225 | otherwise -> Bin (1+ls+rs) x l r
1226 {-# NOINLINE balanceL #-}
1227
1228 -- balanceR is called when right subtree might have been inserted to or when
1229 -- left subtree might have been deleted from.
1230 balanceR :: a -> Set a -> Set a -> Set a
1231 balanceR x l r = case l of
1232 Tip -> case r of
1233 Tip -> Bin 1 x Tip Tip
1234 (Bin _ _ Tip Tip) -> Bin 2 x Tip r
1235 (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr
1236 (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)
1237 (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))
1238 | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr
1239 | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)
1240
1241 (Bin ls _ _ _) -> case r of
1242 Tip -> Bin (1+ls) x l Tip
1243
1244 (Bin rs rx rl rr)
1245 | rs > delta*ls -> case (rl, rr) of
1246 (Bin rls rlx rll rlr, Bin rrs _ _ _)
1247 | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr
1248 | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)
1249 (_, _) -> error "Failure in Data.Map.balanceR"
1250 | otherwise -> Bin (1+ls+rs) x l r
1251 {-# NOINLINE balanceR #-}
1252
1253 {--------------------------------------------------------------------
1254 The bin constructor maintains the size of the tree
1255 --------------------------------------------------------------------}
1256 bin :: a -> Set a -> Set a -> Set a
1257 bin x l r
1258 = Bin (size l + size r + 1) x l r
1259 {-# INLINE bin #-}
1260
1261
1262 {--------------------------------------------------------------------
1263 Utilities
1264 --------------------------------------------------------------------}
1265 foldlStrict :: (a -> b -> a) -> a -> [b] -> a
1266 foldlStrict f = go
1267 where
1268 go z [] = z
1269 go z (x:xs) = let z' = f z x in z' `seq` go z' xs
1270 {-# INLINE foldlStrict #-}
1271
1272 {--------------------------------------------------------------------
1273 Debugging
1274 --------------------------------------------------------------------}
1275 -- | /O(n)/. Show the tree that implements the set. The tree is shown
1276 -- in a compressed, hanging format.
1277 showTree :: Show a => Set a -> String
1278 showTree s
1279 = showTreeWith True False s
1280
1281
1282 {- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
1283 the tree that implements the set. If @hang@ is
1284 @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
1285 @wide@ is 'True', an extra wide version is shown.
1286
1287 > Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]
1288 > 4
1289 > +--2
1290 > | +--1
1291 > | +--3
1292 > +--5
1293 >
1294 > Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]
1295 > 4
1296 > |
1297 > +--2
1298 > | |
1299 > | +--1
1300 > | |
1301 > | +--3
1302 > |
1303 > +--5
1304 >
1305 > Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]
1306 > +--5
1307 > |
1308 > 4
1309 > |
1310 > | +--3
1311 > | |
1312 > +--2
1313 > |
1314 > +--1
1315
1316 -}
1317 showTreeWith :: Show a => Bool -> Bool -> Set a -> String
1318 showTreeWith hang wide t
1319 | hang = (showsTreeHang wide [] t) ""
1320 | otherwise = (showsTree wide [] [] t) ""
1321
1322 showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS
1323 showsTree wide lbars rbars t
1324 = case t of
1325 Tip -> showsBars lbars . showString "|\n"
1326 Bin _ x Tip Tip
1327 -> showsBars lbars . shows x . showString "\n"
1328 Bin _ x l r
1329 -> showsTree wide (withBar rbars) (withEmpty rbars) r .
1330 showWide wide rbars .
1331 showsBars lbars . shows x . showString "\n" .
1332 showWide wide lbars .
1333 showsTree wide (withEmpty lbars) (withBar lbars) l
1334
1335 showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS
1336 showsTreeHang wide bars t
1337 = case t of
1338 Tip -> showsBars bars . showString "|\n"
1339 Bin _ x Tip Tip
1340 -> showsBars bars . shows x . showString "\n"
1341 Bin _ x l r
1342 -> showsBars bars . shows x . showString "\n" .
1343 showWide wide bars .
1344 showsTreeHang wide (withBar bars) l .
1345 showWide wide bars .
1346 showsTreeHang wide (withEmpty bars) r
1347
1348 showWide :: Bool -> [String] -> String -> String
1349 showWide wide bars
1350 | wide = showString (concat (reverse bars)) . showString "|\n"
1351 | otherwise = id
1352
1353 showsBars :: [String] -> ShowS
1354 showsBars bars
1355 = case bars of
1356 [] -> id
1357 _ -> showString (concat (reverse (tail bars))) . showString node
1358
1359 node :: String
1360 node = "+--"
1361
1362 withBar, withEmpty :: [String] -> [String]
1363 withBar bars = "| ":bars
1364 withEmpty bars = " ":bars
1365
1366 {--------------------------------------------------------------------
1367 Assertions
1368 --------------------------------------------------------------------}
1369 -- | /O(n)/. Test if the internal set structure is valid.
1370 valid :: Ord a => Set a -> Bool
1371 valid t
1372 = balanced t && ordered t && validsize t
1373
1374 ordered :: Ord a => Set a -> Bool
1375 ordered t
1376 = bounded (const True) (const True) t
1377 where
1378 bounded lo hi t'
1379 = case t' of
1380 Tip -> True
1381 Bin _ x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r
1382
1383 balanced :: Set a -> Bool
1384 balanced t
1385 = case t of
1386 Tip -> True
1387 Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1388 balanced l && balanced r
1389
1390 validsize :: Set a -> Bool
1391 validsize t
1392 = (realsize t == Just (size t))
1393 where
1394 realsize t'
1395 = case t' of
1396 Tip -> Just 0
1397 Bin sz _ l r -> case (realsize l,realsize r) of
1398 (Just n,Just m) | n+m+1 == sz -> Just sz
1399 _ -> Nothing