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