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