Improve fusion rules.
[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 = build 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 build bushier trees.
699 build c 0 xs' = c Tip xs'
700 build 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 build 5"
704 build c n xs' = seq nr $ build (buildR nr c) nl xs'
705 where
706 nl = n `div` 2
707 nr = n - nl - 1
708
709 buildR n c l (x:ys) = build (buildB l x c) n ys
710 buildR _ _ _ [] = error "fromDistinctAscList buildR []"
711 buildB l x c r zs = c (bin x l r) zs
712 #if __GLASGOW_HASKELL__ >= 700
713 {-# INLINABLE fromDistinctAscList #-}
714 #endif
715
716 {--------------------------------------------------------------------
717 Eq converts the set to a list. In a lazy setting, this
718 actually seems one of the faster methods to compare two trees
719 and it is certainly the simplest :-)
720 --------------------------------------------------------------------}
721 instance Eq a => Eq (Set a) where
722 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
723
724 {--------------------------------------------------------------------
725 Ord
726 --------------------------------------------------------------------}
727
728 instance Ord a => Ord (Set a) where
729 compare s1 s2 = compare (toAscList s1) (toAscList s2)
730
731 {--------------------------------------------------------------------
732 Show
733 --------------------------------------------------------------------}
734 instance Show a => Show (Set a) where
735 showsPrec p xs = showParen (p > 10) $
736 showString "fromList " . shows (toList xs)
737
738 {--------------------------------------------------------------------
739 Read
740 --------------------------------------------------------------------}
741 instance (Read a, Ord a) => Read (Set a) where
742 #ifdef __GLASGOW_HASKELL__
743 readPrec = parens $ prec 10 $ do
744 Ident "fromList" <- lexP
745 xs <- readPrec
746 return (fromList xs)
747
748 readListPrec = readListPrecDefault
749 #else
750 readsPrec p = readParen (p > 10) $ \ r -> do
751 ("fromList",s) <- lex r
752 (xs,t) <- reads s
753 return (fromList xs,t)
754 #endif
755
756 {--------------------------------------------------------------------
757 Typeable/Data
758 --------------------------------------------------------------------}
759
760 #include "Typeable.h"
761 INSTANCE_TYPEABLE1(Set,setTc,"Set")
762
763 {--------------------------------------------------------------------
764 NFData
765 --------------------------------------------------------------------}
766
767 instance NFData a => NFData (Set a) where
768 rnf Tip = ()
769 rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r
770
771 {--------------------------------------------------------------------
772 Utility functions that return sub-ranges of the original
773 tree. Some functions take a `Maybe value` as an argument to
774 allow comparisons against infinite values. These are called `blow`
775 (Nothing is -\infty) and `bhigh` (here Nothing is +\infty).
776 We use MaybeS value, which is a Maybe strict in the Just case.
777
778 [trim blow bhigh t] A tree that is either empty or where [x > blow]
779 and [x < bhigh] for the value [x] of the root.
780 [filterGt blow t] A tree where for all values [k]. [k > blow]
781 [filterLt bhigh t] A tree where for all values [k]. [k < bhigh]
782
783 [split k t] Returns two trees [l] and [r] where all values
784 in [l] are <[k] and all keys in [r] are >[k].
785 [splitMember k t] Just like [split] but also returns whether [k]
786 was found in the tree.
787 --------------------------------------------------------------------}
788
789 data MaybeS a = NothingS | JustS !a
790
791 {--------------------------------------------------------------------
792 [trim blo bhi t] trims away all subtrees that surely contain no
793 values between the range [blo] to [bhi]. The returned tree is either
794 empty or the key of the root is between @blo@ and @bhi@.
795 --------------------------------------------------------------------}
796 trim :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a
797 trim NothingS NothingS t = t
798 trim (JustS lx) NothingS t = greater lx t where greater lo (Bin _ x _ r) | x <= lo = greater lo r
799 greater _ t' = t'
800 trim NothingS (JustS hx) t = lesser hx t where lesser hi (Bin _ x l _) | x >= hi = lesser hi l
801 lesser _ t' = t'
802 trim (JustS lx) (JustS hx) t = middle lx hx t where middle lo hi (Bin _ x _ r) | x <= lo = middle lo hi r
803 middle lo hi (Bin _ x l _) | x >= hi = middle lo hi l
804 middle _ _ t' = t'
805 #if __GLASGOW_HASKELL__ >= 700
806 {-# INLINABLE trim #-}
807 #endif
808
809 {--------------------------------------------------------------------
810 [filterGt b t] filter all values >[b] from tree [t]
811 [filterLt b t] filter all values <[b] from tree [t]
812 --------------------------------------------------------------------}
813 filterGt :: Ord a => MaybeS a -> Set a -> Set a
814 filterGt NothingS t = t
815 filterGt (JustS b) t = filter' b t
816 where filter' _ Tip = Tip
817 filter' b' (Bin _ x l r) =
818 case compare b' x of LT -> join x (filter' b' l) r
819 EQ -> r
820 GT -> filter' b' r
821 #if __GLASGOW_HASKELL__ >= 700
822 {-# INLINABLE filterGt #-}
823 #endif
824
825 filterLt :: Ord a => MaybeS a -> Set a -> Set a
826 filterLt NothingS t = t
827 filterLt (JustS b) t = filter' b t
828 where filter' _ Tip = Tip
829 filter' b' (Bin _ x l r) =
830 case compare x b' of LT -> join x l (filter' b' r)
831 EQ -> l
832 GT -> filter' b' l
833 #if __GLASGOW_HASKELL__ >= 700
834 {-# INLINABLE filterLt #-}
835 #endif
836
837 {--------------------------------------------------------------------
838 Split
839 --------------------------------------------------------------------}
840 -- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@
841 -- where @set1@ comprises the elements of @set@ less than @x@ and @set2@
842 -- comprises the elements of @set@ greater than @x@.
843 split :: Ord a => a -> Set a -> (Set a,Set a)
844 split _ Tip = (Tip,Tip)
845 split x (Bin _ y l r)
846 = case compare x y of
847 LT -> let (lt,gt) = split x l in (lt,join y gt r)
848 GT -> let (lt,gt) = split x r in (join y l lt,gt)
849 EQ -> (l,r)
850 #if __GLASGOW_HASKELL__ >= 700
851 {-# INLINABLE split #-}
852 #endif
853
854 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
855 -- element was found in the original set.
856 splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)
857 splitMember x t = let (l,m,r) = splitLookup x t in
858 (l,maybe False (const True) m,r)
859 #if __GLASGOW_HASKELL__ >= 700
860 {-# INLINABLE splitMember #-}
861 #endif
862
863 -- | /O(log n)/. Performs a 'split' but also returns the pivot
864 -- element that was found in the original set.
865 splitLookup :: Ord a => a -> Set a -> (Set a,Maybe a,Set a)
866 splitLookup _ Tip = (Tip,Nothing,Tip)
867 splitLookup x (Bin _ y l r)
868 = case compare x y of
869 LT -> let (lt,found,gt) = splitLookup x l in (lt,found,join y gt r)
870 GT -> let (lt,found,gt) = splitLookup x r in (join y l lt,found,gt)
871 EQ -> (l,Just y,r)
872 #if __GLASGOW_HASKELL__ >= 700
873 {-# INLINABLE splitLookup #-}
874 #endif
875
876 {--------------------------------------------------------------------
877 Utility functions that maintain the balance properties of the tree.
878 All constructors assume that all values in [l] < [x] and all values
879 in [r] > [x], and that [l] and [r] are valid trees.
880
881 In order of sophistication:
882 [Bin sz x l r] The type constructor.
883 [bin x l r] Maintains the correct size, assumes that both [l]
884 and [r] are balanced with respect to each other.
885 [balance x l r] Restores the balance and size.
886 Assumes that the original tree was balanced and
887 that [l] or [r] has changed by at most one element.
888 [join x l r] Restores balance and size.
889
890 Furthermore, we can construct a new tree from two trees. Both operations
891 assume that all values in [l] < all values in [r] and that [l] and [r]
892 are valid:
893 [glue l r] Glues [l] and [r] together. Assumes that [l] and
894 [r] are already balanced with respect to each other.
895 [merge l r] Merges two trees and restores balance.
896
897 Note: in contrast to Adam's paper, we use (<=) comparisons instead
898 of (<) comparisons in [join], [merge] and [balance].
899 Quickcheck (on [difference]) showed that this was necessary in order
900 to maintain the invariants. It is quite unsatisfactory that I haven't
901 been able to find out why this is actually the case! Fortunately, it
902 doesn't hurt to be a bit more conservative.
903 --------------------------------------------------------------------}
904
905 {--------------------------------------------------------------------
906 Join
907 --------------------------------------------------------------------}
908 join :: a -> Set a -> Set a -> Set a
909 join x Tip r = insertMin x r
910 join x l Tip = insertMax x l
911 join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)
912 | delta*sizeL < sizeR = balanceL z (join x l lz) rz
913 | delta*sizeR < sizeL = balanceR y ly (join x ry r)
914 | otherwise = bin x l r
915 #if __GLASGOW_HASKELL__ >= 700
916 {-# INLINABLE join #-}
917 #endif
918
919
920 -- insertMin and insertMax don't perform potentially expensive comparisons.
921 insertMax,insertMin :: a -> Set a -> Set a
922 insertMax x t
923 = case t of
924 Tip -> singleton x
925 Bin _ y l r
926 -> balanceR y l (insertMax x r)
927 #if __GLASGOW_HASKELL__ >= 700
928 {-# INLINABLE insertMax #-}
929 #endif
930
931 insertMin x t
932 = case t of
933 Tip -> singleton x
934 Bin _ y l r
935 -> balanceL y (insertMin x l) r
936 #if __GLASGOW_HASKELL__ >= 700
937 {-# INLINABLE insertMin #-}
938 #endif
939
940 {--------------------------------------------------------------------
941 [merge l r]: merges two trees.
942 --------------------------------------------------------------------}
943 merge :: Set a -> Set a -> Set a
944 merge Tip r = r
945 merge l Tip = l
946 merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
947 | delta*sizeL < sizeR = balanceL y (merge l ly) ry
948 | delta*sizeR < sizeL = balanceR x lx (merge rx r)
949 | otherwise = glue l r
950 #if __GLASGOW_HASKELL__ >= 700
951 {-# INLINABLE merge #-}
952 #endif
953
954 {--------------------------------------------------------------------
955 [glue l r]: glues two trees together.
956 Assumes that [l] and [r] are already balanced with respect to each other.
957 --------------------------------------------------------------------}
958 glue :: Set a -> Set a -> Set a
959 glue Tip r = r
960 glue l Tip = l
961 glue l r
962 | size l > size r = let (m,l') = deleteFindMax l in balanceR m l' r
963 | otherwise = let (m,r') = deleteFindMin r in balanceL m l r'
964 #if __GLASGOW_HASKELL__ >= 700
965 {-# INLINABLE glue #-}
966 #endif
967
968
969 -- | /O(log n)/. Delete and find the minimal element.
970 --
971 -- > deleteFindMin set = (findMin set, deleteMin set)
972
973 deleteFindMin :: Set a -> (a,Set a)
974 deleteFindMin t
975 = case t of
976 Bin _ x Tip r -> (x,r)
977 Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balanceR x l' r)
978 Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)
979 #if __GLASGOW_HASKELL__ >= 700
980 {-# INLINABLE deleteFindMin #-}
981 #endif
982
983 -- | /O(log n)/. Delete and find the maximal element.
984 --
985 -- > deleteFindMax set = (findMax set, deleteMax set)
986 deleteFindMax :: Set a -> (a,Set a)
987 deleteFindMax t
988 = case t of
989 Bin _ x l Tip -> (x,l)
990 Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balanceL x l r')
991 Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)
992 #if __GLASGOW_HASKELL__ >= 700
993 {-# INLINABLE deleteFindMax #-}
994 #endif
995
996 -- | /O(log n)/. Retrieves the minimal key of the set, and the set
997 -- stripped of that element, or 'Nothing' if passed an empty set.
998 minView :: Set a -> Maybe (a, Set a)
999 minView Tip = Nothing
1000 minView x = Just (deleteFindMin x)
1001 #if __GLASGOW_HASKELL__ >= 700
1002 {-# INLINABLE minView #-}
1003 #endif
1004
1005 -- | /O(log n)/. Retrieves the maximal key of the set, and the set
1006 -- stripped of that element, or 'Nothing' if passed an empty set.
1007 maxView :: Set a -> Maybe (a, Set a)
1008 maxView Tip = Nothing
1009 maxView x = Just (deleteFindMax x)
1010 #if __GLASGOW_HASKELL__ >= 700
1011 {-# INLINABLE maxView #-}
1012 #endif
1013
1014 {--------------------------------------------------------------------
1015 [balance x l r] balances two trees with value x.
1016 The sizes of the trees should balance after decreasing the
1017 size of one of them. (a rotation).
1018
1019 [delta] is the maximal relative difference between the sizes of
1020 two trees, it corresponds with the [w] in Adams' paper.
1021 [ratio] is the ratio between an outer and inner sibling of the
1022 heavier subtree in an unbalanced setting. It determines
1023 whether a double or single rotation should be performed
1024 to restore balance. It is correspondes with the inverse
1025 of $\alpha$ in Adam's article.
1026
1027 Note that according to the Adam's paper:
1028 - [delta] should be larger than 4.646 with a [ratio] of 2.
1029 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1030
1031 But the Adam's paper is errorneous:
1032 - it can be proved that for delta=2 and delta>=5 there does
1033 not exist any ratio that would work
1034 - delta=4.5 and ratio=2 does not work
1035
1036 That leaves two reasonable variants, delta=3 and delta=4,
1037 both with ratio=2.
1038
1039 - A lower [delta] leads to a more 'perfectly' balanced tree.
1040 - A higher [delta] performs less rebalancing.
1041
1042 In the benchmarks, delta=3 is faster on insert operations,
1043 and delta=4 has slightly better deletes. As the insert speedup
1044 is larger, we currently use delta=3.
1045
1046 --------------------------------------------------------------------}
1047 delta,ratio :: Int
1048 delta = 3
1049 ratio = 2
1050
1051 -- The balance function is equivalent to the following:
1052 --
1053 -- balance :: a -> Set a -> Set a -> Set a
1054 -- balance x l r
1055 -- | sizeL + sizeR <= 1 = Bin sizeX x l r
1056 -- | sizeR > delta*sizeL = rotateL x l r
1057 -- | sizeL > delta*sizeR = rotateR x l r
1058 -- | otherwise = Bin sizeX x l r
1059 -- where
1060 -- sizeL = size l
1061 -- sizeR = size r
1062 -- sizeX = sizeL + sizeR + 1
1063 --
1064 -- rotateL :: a -> Set a -> Set a -> Set a
1065 -- rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r
1066 -- | otherwise = doubleL x l r
1067 -- rotateR :: a -> Set a -> Set a -> Set a
1068 -- rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r
1069 -- | otherwise = doubleR x l r
1070 --
1071 -- singleL, singleR :: a -> Set a -> Set a -> Set a
1072 -- singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3
1073 -- singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)
1074 --
1075 -- doubleL, doubleR :: a -> Set a -> Set a -> Set a
1076 -- doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
1077 -- doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
1078 --
1079 -- It is only written in such a way that every node is pattern-matched only once.
1080 --
1081 -- Only balanceL and balanceR are needed at the moment, so balance is not here anymore.
1082 -- In case it is needed, it can be found in Data.Map.
1083
1084 -- Functions balanceL and balanceR are specialised versions of balance.
1085 -- balanceL only checks whether the left subtree is too big,
1086 -- balanceR only checks whether the right subtree is too big.
1087
1088 -- balanceL is called when left subtree might have been inserted to or when
1089 -- right subtree might have been deleted from.
1090 balanceL :: a -> Set a -> Set a -> Set a
1091 balanceL x l r = case r of
1092 Tip -> case l of
1093 Tip -> Bin 1 x Tip Tip
1094 (Bin _ _ Tip Tip) -> Bin 2 x l Tip
1095 (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)
1096 (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)
1097 (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))
1098 | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)
1099 | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)
1100
1101 (Bin rs _ _ _) -> case l of
1102 Tip -> Bin (1+rs) x Tip r
1103
1104 (Bin ls lx ll lr)
1105 | ls > delta*rs -> case (ll, lr) of
1106 (Bin lls _ _ _, Bin lrs lrx lrl lrr)
1107 | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)
1108 | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)
1109 (_, _) -> error "Failure in Data.Map.balanceL"
1110 | otherwise -> Bin (1+ls+rs) x l r
1111 {-# NOINLINE balanceL #-}
1112
1113 -- balanceR is called when right subtree might have been inserted to or when
1114 -- left subtree might have been deleted from.
1115 balanceR :: a -> Set a -> Set a -> Set a
1116 balanceR x l r = case l of
1117 Tip -> case r of
1118 Tip -> Bin 1 x Tip Tip
1119 (Bin _ _ Tip Tip) -> Bin 2 x Tip r
1120 (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr
1121 (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)
1122 (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))
1123 | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr
1124 | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)
1125
1126 (Bin ls _ _ _) -> case r of
1127 Tip -> Bin (1+ls) x l Tip
1128
1129 (Bin rs rx rl rr)
1130 | rs > delta*ls -> case (rl, rr) of
1131 (Bin rls rlx rll rlr, Bin rrs _ _ _)
1132 | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr
1133 | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)
1134 (_, _) -> error "Failure in Data.Map.balanceR"
1135 | otherwise -> Bin (1+ls+rs) x l r
1136 {-# NOINLINE balanceR #-}
1137
1138 {--------------------------------------------------------------------
1139 The bin constructor maintains the size of the tree
1140 --------------------------------------------------------------------}
1141 bin :: a -> Set a -> Set a -> Set a
1142 bin x l r
1143 = Bin (size l + size r + 1) x l r
1144 {-# INLINE bin #-}
1145
1146
1147 {--------------------------------------------------------------------
1148 Utilities
1149 --------------------------------------------------------------------}
1150 foldlStrict :: (a -> b -> a) -> a -> [b] -> a
1151 foldlStrict f = go
1152 where
1153 go z [] = z
1154 go z (x:xs) = let z' = f z x in z' `seq` go z' xs
1155 {-# INLINE foldlStrict #-}
1156
1157 {--------------------------------------------------------------------
1158 Debugging
1159 --------------------------------------------------------------------}
1160 -- | /O(n)/. Show the tree that implements the set. The tree is shown
1161 -- in a compressed, hanging format.
1162 showTree :: Show a => Set a -> String
1163 showTree s
1164 = showTreeWith True False s
1165
1166
1167 {- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
1168 the tree that implements the set. If @hang@ is
1169 @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
1170 @wide@ is 'True', an extra wide version is shown.
1171
1172 > Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]
1173 > 4
1174 > +--2
1175 > | +--1
1176 > | +--3
1177 > +--5
1178 >
1179 > Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]
1180 > 4
1181 > |
1182 > +--2
1183 > | |
1184 > | +--1
1185 > | |
1186 > | +--3
1187 > |
1188 > +--5
1189 >
1190 > Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]
1191 > +--5
1192 > |
1193 > 4
1194 > |
1195 > | +--3
1196 > | |
1197 > +--2
1198 > |
1199 > +--1
1200
1201 -}
1202 showTreeWith :: Show a => Bool -> Bool -> Set a -> String
1203 showTreeWith hang wide t
1204 | hang = (showsTreeHang wide [] t) ""
1205 | otherwise = (showsTree wide [] [] t) ""
1206
1207 showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS
1208 showsTree wide lbars rbars t
1209 = case t of
1210 Tip -> showsBars lbars . showString "|\n"
1211 Bin _ x Tip Tip
1212 -> showsBars lbars . shows x . showString "\n"
1213 Bin _ x l r
1214 -> showsTree wide (withBar rbars) (withEmpty rbars) r .
1215 showWide wide rbars .
1216 showsBars lbars . shows x . showString "\n" .
1217 showWide wide lbars .
1218 showsTree wide (withEmpty lbars) (withBar lbars) l
1219
1220 showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS
1221 showsTreeHang wide bars t
1222 = case t of
1223 Tip -> showsBars bars . showString "|\n"
1224 Bin _ x Tip Tip
1225 -> showsBars bars . shows x . showString "\n"
1226 Bin _ x l r
1227 -> showsBars bars . shows x . showString "\n" .
1228 showWide wide bars .
1229 showsTreeHang wide (withBar bars) l .
1230 showWide wide bars .
1231 showsTreeHang wide (withEmpty bars) r
1232
1233 showWide :: Bool -> [String] -> String -> String
1234 showWide wide bars
1235 | wide = showString (concat (reverse bars)) . showString "|\n"
1236 | otherwise = id
1237
1238 showsBars :: [String] -> ShowS
1239 showsBars bars
1240 = case bars of
1241 [] -> id
1242 _ -> showString (concat (reverse (tail bars))) . showString node
1243
1244 node :: String
1245 node = "+--"
1246
1247 withBar, withEmpty :: [String] -> [String]
1248 withBar bars = "| ":bars
1249 withEmpty bars = " ":bars
1250
1251 {--------------------------------------------------------------------
1252 Assertions
1253 --------------------------------------------------------------------}
1254 -- | /O(n)/. Test if the internal set structure is valid.
1255 valid :: Ord a => Set a -> Bool
1256 valid t
1257 = balanced t && ordered t && validsize t
1258
1259 ordered :: Ord a => Set a -> Bool
1260 ordered t
1261 = bounded (const True) (const True) t
1262 where
1263 bounded lo hi t'
1264 = case t' of
1265 Tip -> True
1266 Bin _ x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r
1267
1268 balanced :: Set a -> Bool
1269 balanced t
1270 = case t of
1271 Tip -> True
1272 Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1273 balanced l && balanced r
1274
1275 validsize :: Set a -> Bool
1276 validsize t
1277 = (realsize t == Just (size t))
1278 where
1279 realsize t'
1280 = case t' of
1281 Tip -> Just 0
1282 Bin sz _ l r -> case (realsize l,realsize r) of
1283 (Just n,Just m) | n+m+1 == sz -> Just sz
1284 _ -> Nothing