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