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