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