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