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