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