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