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