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