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