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