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