Added fixity declarations for member, notMember, union, and intersection.
[packages/containers.git] / Data / IntSet / Base.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__
3 {-# LANGUAGE MagicHash, BangPatterns, DeriveDataTypeable, StandaloneDeriving #-}
4 #endif
5 #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
6 {-# LANGUAGE Trustworthy #-}
7 #endif
8 #if __GLASGOW_HASKELL__ >= 708
9 {-# LANGUAGE TypeFamilies #-}
10 #endif
11 -----------------------------------------------------------------------------
12 -- |
13 -- Module : Data.IntSet.Base
14 -- Copyright : (c) Daan Leijen 2002
15 -- (c) Joachim Breitner 2011
16 -- License : BSD-style
17 -- Maintainer : libraries@haskell.org
18 -- Stability : provisional
19 -- Portability : portable
20 --
21 -- An efficient implementation of integer sets.
22 --
23 -- These modules are intended to be imported qualified, to avoid name
24 -- clashes with Prelude functions, e.g.
25 --
26 -- > import Data.IntSet (IntSet)
27 -- > import qualified Data.IntSet as IntSet
28 --
29 -- The implementation is based on /big-endian patricia trees/. This data
30 -- structure performs especially well on binary operations like 'union'
31 -- and 'intersection'. However, my benchmarks show that it is also
32 -- (much) faster on insertions and deletions when compared to a generic
33 -- size-balanced set implementation (see "Data.Set").
34 --
35 -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
36 -- Workshop on ML, September 1998, pages 77-86,
37 -- <http://citeseer.ist.psu.edu/okasaki98fast.html>
38 --
39 -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
40 -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
41 -- October 1968, pages 514-534.
42 --
43 -- Additionally, this implementation places bitmaps in the leaves of the tree.
44 -- Their size is the natural size of a machine word (32 or 64 bits) and greatly
45 -- reduce memory footprint and execution times for dense sets, e.g. sets where
46 -- it is likely that many values lie close to each other. The asymptotics are
47 -- not affected by this optimization.
48 --
49 -- Many operations have a worst-case complexity of /O(min(n,W))/.
50 -- This means that the operation can become linear in the number of
51 -- elements with a maximum of /W/ -- the number of bits in an 'Int'
52 -- (32 or 64).
53 -----------------------------------------------------------------------------
54
55 -- [Note: INLINE bit fiddling]
56 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
57 -- It is essential that the bit fiddling functions like mask, zero, branchMask
58 -- etc are inlined. If they do not, the memory allocation skyrockets. The GHC
59 -- usually gets it right, but it is disastrous if it does not. Therefore we
60 -- explicitly mark these functions INLINE.
61
62
63 -- [Note: Local 'go' functions and capturing]
64 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
65 -- Care must be taken when using 'go' function which captures an argument.
66 -- Sometimes (for example when the argument is passed to a data constructor,
67 -- as in insert), GHC heap-allocates more than necessary. Therefore C-- code
68 -- must be checked for increased allocation when creating and modifying such
69 -- functions.
70
71
72 -- [Note: Order of constructors]
73 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
74 -- The order of constructors of IntSet matters when considering performance.
75 -- Currently in GHC 7.0, when type has 3 constructors, they are matched from
76 -- the first to the last -- the best performance is achieved when the
77 -- constructors are ordered by frequency.
78 -- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil
79 -- improves the benchmark by circa 10%.
80
81 module Data.IntSet.Base (
82 -- * Set type
83 IntSet(..), Key -- instance Eq,Show
84
85 -- * Operators
86 , (\\)
87
88 -- * Query
89 , null
90 , size
91 , member
92 , notMember
93 , lookupLT
94 , lookupGT
95 , lookupLE
96 , lookupGE
97 , isSubsetOf
98 , isProperSubsetOf
99
100 -- * Construction
101 , empty
102 , singleton
103 , insert
104 , delete
105
106 -- * Combine
107 , union
108 , unions
109 , difference
110 , intersection
111
112 -- * Filter
113 , filter
114 , partition
115 , split
116 , splitMember
117 , splitRoot
118
119 -- * Map
120 , map
121
122 -- * Folds
123 , foldr
124 , foldl
125 -- ** Strict folds
126 , foldr'
127 , foldl'
128 -- ** Legacy folds
129 , fold
130
131 -- * Min\/Max
132 , findMin
133 , findMax
134 , deleteMin
135 , deleteMax
136 , deleteFindMin
137 , deleteFindMax
138 , maxView
139 , minView
140
141 -- * Conversion
142
143 -- ** List
144 , elems
145 , toList
146 , fromList
147
148 -- ** Ordered list
149 , toAscList
150 , toDescList
151 , fromAscList
152 , fromDistinctAscList
153
154 -- * Debugging
155 , showTree
156 , showTreeWith
157
158 -- * Internals
159 , match
160 , suffixBitMask
161 , prefixBitMask
162 , bitmapOf
163 ) where
164
165 -- We want to be able to compile without cabal. Nevertheless
166 -- #if defined(MIN_VERSION_base) && MIN_VERSION_base(4,5,0)
167 -- does not work, because if MIN_VERSION_base is undefined,
168 -- the last condition is syntactically wrong.
169 #define MIN_VERSION_base_4_5_0 0
170 #ifdef MIN_VERSION_base
171 #if MIN_VERSION_base(4,5,0)
172 #undef MIN_VERSION_base_4_5_0
173 #define MIN_VERSION_base_4_5_0 1
174 #endif
175 #endif
176
177 #define MIN_VERSION_base_4_7_0 0
178 #ifdef MIN_VERSION_base
179 #if MIN_VERSION_base(4,7,0)
180 #undef MIN_VERSION_base_4_7_0
181 #define MIN_VERSION_base_4_7_0 1
182 #endif
183 #endif
184
185 import Control.DeepSeq (NFData)
186 import Data.Bits
187 import qualified Data.List as List
188 import Data.Maybe (fromMaybe)
189 import Data.Monoid (Monoid(..))
190 import Data.Typeable
191 import Data.Word (Word)
192 import Prelude hiding (filter, foldr, foldl, null, map)
193
194 import Data.BitUtil
195 import Data.StrictPair
196
197 #if __GLASGOW_HASKELL__
198 import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), DataType, mkDataType)
199 import Text.Read
200 #endif
201
202 #if __GLASGOW_HASKELL__
203 import GHC.Exts (Int(..), build)
204 #if __GLASGOW_HASKELL__ >= 708
205 import qualified GHC.Exts as GHCExts
206 #endif
207 import GHC.Prim (indexInt8OffAddr#)
208 #endif
209
210 -- On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.
211 #if defined(__GLASGOW_HASKELL__)
212 # include "MachDeps.h"
213 #endif
214
215 -- Use macros to define strictness of functions.
216 -- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.
217 -- We do not use BangPatterns, because they are not in any standard and we
218 -- want the compilers to be compiled by as many compilers as possible.
219 #define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined
220 #define STRICT_2_OF_2(fn) fn _ arg | arg `seq` False = undefined
221 #define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined
222 #define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined
223
224 infixl 9 \\{-This comment teaches CPP correct behaviour -}
225
226 -- A "Nat" is a natural machine word (an unsigned Int)
227 type Nat = Word
228
229 natFromInt :: Int -> Nat
230 natFromInt i = fromIntegral i
231 {-# INLINE natFromInt #-}
232
233 intFromNat :: Nat -> Int
234 intFromNat w = fromIntegral w
235 {-# INLINE intFromNat #-}
236
237 {--------------------------------------------------------------------
238 Operators
239 --------------------------------------------------------------------}
240 -- | /O(n+m)/. See 'difference'.
241 (\\) :: IntSet -> IntSet -> IntSet
242 m1 \\ m2 = difference m1 m2
243
244 {--------------------------------------------------------------------
245 Types
246 --------------------------------------------------------------------}
247
248 -- | A set of integers.
249
250 -- See Note: Order of constructors
251 data IntSet = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntSet !IntSet
252 -- Invariant: Nil is never found as a child of Bin.
253 -- Invariant: The Mask is a power of 2. It is the largest bit position at which
254 -- two elements of the set differ.
255 -- Invariant: Prefix is the common high-order bits that all elements share to
256 -- the left of the Mask bit.
257 -- Invariant: In Bin prefix mask left right, left consists of the elements that
258 -- don't have the mask bit set; right is all the elements that do.
259 | Tip {-# UNPACK #-} !Prefix {-# UNPACK #-} !BitMap
260 -- Invariant: The Prefix is zero for all but the last 5 (on 32 bit arches) or 6
261 -- bits (on 64 bit arches). The values of the map represented by a tip
262 -- are the prefix plus the indices of the set bits in the bit map.
263 | Nil
264
265 -- A number stored in a set is stored as
266 -- * Prefix (all but last 5-6 bits) and
267 -- * BitMap (last 5-6 bits stored as a bitmask)
268 -- Last 5-6 bits are called a Suffix.
269
270 type Prefix = Int
271 type Mask = Int
272 type BitMap = Word
273 type Key = Int
274
275 instance Monoid IntSet where
276 mempty = empty
277 mappend = union
278 mconcat = unions
279
280 #if __GLASGOW_HASKELL__
281
282 {--------------------------------------------------------------------
283 A Data instance
284 --------------------------------------------------------------------}
285
286 -- This instance preserves data abstraction at the cost of inefficiency.
287 -- We provide limited reflection services for the sake of data abstraction.
288
289 instance Data IntSet where
290 gfoldl f z is = z fromList `f` (toList is)
291 toConstr _ = fromListConstr
292 gunfold k z c = case constrIndex c of
293 1 -> k (z fromList)
294 _ -> error "gunfold"
295 dataTypeOf _ = intSetDataType
296
297 fromListConstr :: Constr
298 fromListConstr = mkConstr intSetDataType "fromList" [] Prefix
299
300 intSetDataType :: DataType
301 intSetDataType = mkDataType "Data.IntSet.Base.IntSet" [fromListConstr]
302
303 #endif
304
305 {--------------------------------------------------------------------
306 Query
307 --------------------------------------------------------------------}
308 -- | /O(1)/. Is the set empty?
309 null :: IntSet -> Bool
310 null Nil = True
311 null _ = False
312 {-# INLINE null #-}
313
314 -- | /O(n)/. Cardinality of the set.
315 size :: IntSet -> Int
316 size t
317 = case t of
318 Bin _ _ l r -> size l + size r
319 Tip _ bm -> bitcount 0 bm
320 Nil -> 0
321
322 -- | /O(min(n,W))/. Is the value a member of the set?
323
324 -- See Note: Local 'go' functions and capturing]
325 member :: Key -> IntSet -> Bool
326 member x = x `seq` go
327 where
328 go (Bin p m l r)
329 | nomatch x p m = False
330 | zero x m = go l
331 | otherwise = go r
332 go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0
333 go Nil = False
334
335 infix 4 member
336
337 -- | /O(min(n,W))/. Is the element not in the set?
338 notMember :: Key -> IntSet -> Bool
339 notMember k = not . member k
340
341 infix 4 notMember
342
343 -- | /O(log n)/. Find largest element smaller than the given one.
344 --
345 -- > lookupLT 3 (fromList [3, 5]) == Nothing
346 -- > lookupLT 5 (fromList [3, 5]) == Just 3
347
348 -- See Note: Local 'go' functions and capturing.
349 lookupLT :: Key -> IntSet -> Maybe Key
350 lookupLT x t = x `seq` case t of
351 Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r
352 _ -> go Nil t
353 where
354 go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r
355 | zero x m = go def l
356 | otherwise = go l r
357 go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm
358 | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT
359 | otherwise = unsafeFindMax def
360 where maskLT = (bitmapOf x - 1) .&. bm
361 go def Nil = unsafeFindMax def
362
363
364 -- | /O(log n)/. Find smallest element greater than the given one.
365 --
366 -- > lookupGT 4 (fromList [3, 5]) == Just 5
367 -- > lookupGT 5 (fromList [3, 5]) == Nothing
368
369 -- See Note: Local 'go' functions and capturing.
370 lookupGT :: Key -> IntSet -> Maybe Key
371 lookupGT x t = x `seq` case t of
372 Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r
373 _ -> go Nil t
374 where
375 go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def
376 | zero x m = go r l
377 | otherwise = go def r
378 go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm
379 | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT
380 | otherwise = unsafeFindMin def
381 where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm
382 go def Nil = unsafeFindMin def
383
384
385 -- | /O(log n)/. Find largest element smaller or equal to the given one.
386 --
387 -- > lookupLE 2 (fromList [3, 5]) == Nothing
388 -- > lookupLE 4 (fromList [3, 5]) == Just 3
389 -- > lookupLE 5 (fromList [3, 5]) == Just 5
390
391 -- See Note: Local 'go' functions and capturing.
392 lookupLE :: Key -> IntSet -> Maybe Key
393 lookupLE x t = x `seq` case t of
394 Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r
395 _ -> go Nil t
396 where
397 go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r
398 | zero x m = go def l
399 | otherwise = go l r
400 go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm
401 | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE
402 | otherwise = unsafeFindMax def
403 where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm
404 go def Nil = unsafeFindMax def
405
406
407 -- | /O(log n)/. Find smallest element greater or equal to the given one.
408 --
409 -- > lookupGE 3 (fromList [3, 5]) == Just 3
410 -- > lookupGE 4 (fromList [3, 5]) == Just 5
411 -- > lookupGE 6 (fromList [3, 5]) == Nothing
412
413 -- See Note: Local 'go' functions and capturing.
414 lookupGE :: Key -> IntSet -> Maybe Key
415 lookupGE x t = x `seq` case t of
416 Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r
417 _ -> go Nil t
418 where
419 go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def
420 | zero x m = go r l
421 | otherwise = go def r
422 go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm
423 | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE
424 | otherwise = unsafeFindMin def
425 where maskGE = (- (bitmapOf x)) .&. bm
426 go def Nil = unsafeFindMin def
427
428
429
430 -- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is
431 -- given, it has m > 0.
432 unsafeFindMin :: IntSet -> Maybe Key
433 unsafeFindMin Nil = Nothing
434 unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm
435 unsafeFindMin (Bin _ _ l _) = unsafeFindMin l
436
437 -- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is
438 -- given, it has m > 0.
439 unsafeFindMax :: IntSet -> Maybe Key
440 unsafeFindMax Nil = Nothing
441 unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm
442 unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r
443
444 {--------------------------------------------------------------------
445 Construction
446 --------------------------------------------------------------------}
447 -- | /O(1)/. The empty set.
448 empty :: IntSet
449 empty
450 = Nil
451 {-# INLINE empty #-}
452
453 -- | /O(1)/. A set of one element.
454 singleton :: Key -> IntSet
455 singleton x
456 = Tip (prefixOf x) (bitmapOf x)
457 {-# INLINE singleton #-}
458
459 {--------------------------------------------------------------------
460 Insert
461 --------------------------------------------------------------------}
462 -- | /O(min(n,W))/. Add a value to the set. There is no left- or right bias for
463 -- IntSets.
464 insert :: Key -> IntSet -> IntSet
465 insert x = x `seq` insertBM (prefixOf x) (bitmapOf x)
466
467 -- Helper function for insert and union.
468 insertBM :: Prefix -> BitMap -> IntSet -> IntSet
469 insertBM kx bm t = kx `seq` bm `seq`
470 case t of
471 Bin p m l r
472 | nomatch kx p m -> link kx (Tip kx bm) p t
473 | zero kx m -> Bin p m (insertBM kx bm l) r
474 | otherwise -> Bin p m l (insertBM kx bm r)
475 Tip kx' bm'
476 | kx' == kx -> Tip kx' (bm .|. bm')
477 | otherwise -> link kx (Tip kx bm) kx' t
478 Nil -> Tip kx bm
479
480 -- | /O(min(n,W))/. Delete a value in the set. Returns the
481 -- original set when the value was not present.
482 delete :: Key -> IntSet -> IntSet
483 delete x = x `seq` deleteBM (prefixOf x) (bitmapOf x)
484
485 -- Deletes all values mentioned in the BitMap from the set.
486 -- Helper function for delete and difference.
487 deleteBM :: Prefix -> BitMap -> IntSet -> IntSet
488 deleteBM kx bm t = kx `seq` bm `seq`
489 case t of
490 Bin p m l r
491 | nomatch kx p m -> t
492 | zero kx m -> bin p m (deleteBM kx bm l) r
493 | otherwise -> bin p m l (deleteBM kx bm r)
494 Tip kx' bm'
495 | kx' == kx -> tip kx (bm' .&. complement bm)
496 | otherwise -> t
497 Nil -> Nil
498
499
500 {--------------------------------------------------------------------
501 Union
502 --------------------------------------------------------------------}
503 -- | The union of a list of sets.
504 unions :: [IntSet] -> IntSet
505 unions xs
506 = foldlStrict union empty xs
507
508
509 -- | /O(n+m)/. The union of two sets.
510 union :: IntSet -> IntSet -> IntSet
511 union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
512 | shorter m1 m2 = union1
513 | shorter m2 m1 = union2
514 | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
515 | otherwise = link p1 t1 p2 t2
516 where
517 union1 | nomatch p2 p1 m1 = link p1 t1 p2 t2
518 | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
519 | otherwise = Bin p1 m1 l1 (union r1 t2)
520
521 union2 | nomatch p1 p2 m2 = link p1 t1 p2 t2
522 | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
523 | otherwise = Bin p2 m2 l2 (union t1 r2)
524
525 union t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t
526 union t@(Bin _ _ _ _) Nil = t
527 union (Tip kx bm) t = insertBM kx bm t
528 union Nil t = t
529
530 infixl 5 union
531
532 {--------------------------------------------------------------------
533 Difference
534 --------------------------------------------------------------------}
535 -- | /O(n+m)/. Difference between two sets.
536 difference :: IntSet -> IntSet -> IntSet
537 difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
538 | shorter m1 m2 = difference1
539 | shorter m2 m1 = difference2
540 | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
541 | otherwise = t1
542 where
543 difference1 | nomatch p2 p1 m1 = t1
544 | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
545 | otherwise = bin p1 m1 l1 (difference r1 t2)
546
547 difference2 | nomatch p1 p2 m2 = t1
548 | zero p1 m2 = difference t1 l2
549 | otherwise = difference t1 r2
550
551 difference t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t
552 difference t@(Bin _ _ _ _) Nil = t
553
554 difference t1@(Tip kx bm) t2 = differenceTip t2
555 where differenceTip (Bin p2 m2 l2 r2) | nomatch kx p2 m2 = t1
556 | zero kx m2 = differenceTip l2
557 | otherwise = differenceTip r2
558 differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2)
559 | otherwise = t1
560 differenceTip Nil = t1
561
562 difference Nil _ = Nil
563
564
565
566 {--------------------------------------------------------------------
567 Intersection
568 --------------------------------------------------------------------}
569 -- | /O(n+m)/. The intersection of two sets.
570 intersection :: IntSet -> IntSet -> IntSet
571 intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
572 | shorter m1 m2 = intersection1
573 | shorter m2 m1 = intersection2
574 | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
575 | otherwise = Nil
576 where
577 intersection1 | nomatch p2 p1 m1 = Nil
578 | zero p2 m1 = intersection l1 t2
579 | otherwise = intersection r1 t2
580
581 intersection2 | nomatch p1 p2 m2 = Nil
582 | zero p1 m2 = intersection t1 l2
583 | otherwise = intersection t1 r2
584
585 intersection t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1
586 where intersectBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = Nil
587 | zero kx2 m1 = intersectBM l1
588 | otherwise = intersectBM r1
589 intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)
590 | otherwise = Nil
591 intersectBM Nil = Nil
592
593 intersection (Bin _ _ _ _) Nil = Nil
594
595 intersection (Tip kx1 bm1) t2 = intersectBM t2
596 where intersectBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = Nil
597 | zero kx1 m2 = intersectBM l2
598 | otherwise = intersectBM r2
599 intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)
600 | otherwise = Nil
601 intersectBM Nil = Nil
602
603 intersection Nil _ = Nil
604
605 infixl 5 intersection
606
607 {--------------------------------------------------------------------
608 Subset
609 --------------------------------------------------------------------}
610 -- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
611 isProperSubsetOf :: IntSet -> IntSet -> Bool
612 isProperSubsetOf t1 t2
613 = case subsetCmp t1 t2 of
614 LT -> True
615 _ -> False
616
617 subsetCmp :: IntSet -> IntSet -> Ordering
618 subsetCmp t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
619 | shorter m1 m2 = GT
620 | shorter m2 m1 = case subsetCmpLt of
621 GT -> GT
622 _ -> LT
623 | p1 == p2 = subsetCmpEq
624 | otherwise = GT -- disjoint
625 where
626 subsetCmpLt | nomatch p1 p2 m2 = GT
627 | zero p1 m2 = subsetCmp t1 l2
628 | otherwise = subsetCmp t1 r2
629 subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of
630 (GT,_ ) -> GT
631 (_ ,GT) -> GT
632 (EQ,EQ) -> EQ
633 _ -> LT
634
635 subsetCmp (Bin _ _ _ _) _ = GT
636 subsetCmp (Tip kx1 bm1) (Tip kx2 bm2)
637 | kx1 /= kx2 = GT -- disjoint
638 | bm1 == bm2 = EQ
639 | bm1 .&. complement bm2 == 0 = LT
640 | otherwise = GT
641 subsetCmp t1@(Tip kx _) (Bin p m l r)
642 | nomatch kx p m = GT
643 | zero kx m = case subsetCmp t1 l of GT -> GT ; _ -> LT
644 | otherwise = case subsetCmp t1 r of GT -> GT ; _ -> LT
645 subsetCmp (Tip _ _) Nil = GT -- disjoint
646 subsetCmp Nil Nil = EQ
647 subsetCmp Nil _ = LT
648
649 -- | /O(n+m)/. Is this a subset?
650 -- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
651
652 isSubsetOf :: IntSet -> IntSet -> Bool
653 isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
654 | shorter m1 m2 = False
655 | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2
656 else isSubsetOf t1 r2)
657 | otherwise = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2
658 isSubsetOf (Bin _ _ _ _) _ = False
659 isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0
660 isSubsetOf t1@(Tip kx _) (Bin p m l r)
661 | nomatch kx p m = False
662 | zero kx m = isSubsetOf t1 l
663 | otherwise = isSubsetOf t1 r
664 isSubsetOf (Tip _ _) Nil = False
665 isSubsetOf Nil _ = True
666
667
668 {--------------------------------------------------------------------
669 Filter
670 --------------------------------------------------------------------}
671 -- | /O(n)/. Filter all elements that satisfy some predicate.
672 filter :: (Key -> Bool) -> IntSet -> IntSet
673 filter predicate t
674 = case t of
675 Bin p m l r
676 -> bin p m (filter predicate l) (filter predicate r)
677 Tip kx bm
678 -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm)
679 Nil -> Nil
680 where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi
681 | otherwise = bm
682 {-# INLINE bitPred #-}
683
684 -- | /O(n)/. partition the set according to some predicate.
685 partition :: (Key -> Bool) -> IntSet -> (IntSet,IntSet)
686 partition predicate0 t0 = toPair $ go predicate0 t0
687 where
688 go predicate t
689 = case t of
690 Bin p m l r
691 -> let (l1 :*: l2) = go predicate l
692 (r1 :*: r2) = go predicate r
693 in bin p m l1 r1 :*: bin p m l2 r2
694 Tip kx bm
695 -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm
696 in tip kx bm1 :*: tip kx (bm `xor` bm1)
697 Nil -> (Nil :*: Nil)
698 where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi
699 | otherwise = bm
700 {-# INLINE bitPred #-}
701
702
703 -- | /O(min(n,W))/. The expression (@'split' x set@) is a pair @(set1,set2)@
704 -- where @set1@ comprises the elements of @set@ less than @x@ and @set2@
705 -- comprises the elements of @set@ greater than @x@.
706 --
707 -- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])
708 split :: Key -> IntSet -> (IntSet,IntSet)
709 split x t =
710 case t of
711 Bin _ m l r
712 | m < 0 -> if x >= 0 -- handle negative numbers.
713 then case go x l of (lt :*: gt) -> let lt' = union lt r
714 in lt' `seq` (lt', gt)
715 else case go x r of (lt :*: gt) -> let gt' = union gt l
716 in gt' `seq` (lt, gt')
717 _ -> case go x t of
718 (lt :*: gt) -> (lt, gt)
719 where
720 go !x' t'@(Bin p m l r)
721 | match x' p m = if zero x' m
722 then case go x' l of
723 (lt :*: gt) -> lt :*: union gt r
724 else case go x' r of
725 (lt :*: gt) -> union lt l :*: gt
726 | otherwise = if x' < p then (Nil :*: t')
727 else (t' :*: Nil)
728 go x' t'@(Tip kx' bm)
729 | kx' > x' = (Nil :*: t')
730 -- equivalent to kx' > prefixOf x'
731 | kx' < prefixOf x' = (t' :*: Nil)
732 | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)
733 where lowerBitmap = bitmapOf x' - 1
734 higherBitmap = complement (lowerBitmap + bitmapOf x')
735 go _ Nil = (Nil :*: Nil)
736
737 -- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot
738 -- element was found in the original set.
739 splitMember :: Key -> IntSet -> (IntSet,Bool,IntSet)
740 splitMember x t =
741 case t of
742 Bin _ m l r | m < 0 -> if x >= 0
743 then case go x l of
744 (lt, fnd, gt) -> let lt' = union lt r
745 in lt' `seq` (lt', fnd, gt)
746 else case go x r of
747 (lt, fnd, gt) -> let gt' = union gt l
748 in gt' `seq` (lt, fnd, gt')
749 _ -> go x t
750 where
751 go x' t'@(Bin p m l r)
752 | match x' p m = if zero x' m
753 then case go x' l of
754 (lt, fnd, gt) -> (lt, fnd, union gt r)
755 else case go x' r of
756 (lt, fnd, gt) -> (union lt l, fnd, gt)
757 | otherwise = if x' < p then (Nil, False, t') else (t', False, Nil)
758 go x' t'@(Tip kx' bm)
759 | kx' > x' = (Nil, False, t')
760 -- equivalent to kx' > prefixOf x'
761 | kx' < prefixOf x' = (t', False, Nil)
762 | otherwise = let lt = tip kx' (bm .&. lowerBitmap)
763 found = (bm .&. bitmapOfx') /= 0
764 gt = tip kx' (bm .&. higherBitmap)
765 in lt `seq` found `seq` gt `seq` (lt, found, gt)
766 where bitmapOfx' = bitmapOf x'
767 lowerBitmap = bitmapOfx' - 1
768 higherBitmap = complement (lowerBitmap + bitmapOfx')
769 go _ Nil = (Nil, False, Nil)
770
771
772 {----------------------------------------------------------------------
773 Min/Max
774 ----------------------------------------------------------------------}
775
776 -- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set
777 -- stripped of that element, or 'Nothing' if passed an empty set.
778 maxView :: IntSet -> Maybe (Key, IntSet)
779 maxView t =
780 case t of Nil -> Nothing
781 Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, bin p m l' r)
782 _ -> Just (go t)
783 where
784 go (Bin p m l r) = case go r of (result, r') -> (result, bin p m l r')
785 go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))
786 go Nil = error "maxView Nil"
787
788 -- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set
789 -- stripped of that element, or 'Nothing' if passed an empty set.
790 minView :: IntSet -> Maybe (Key, IntSet)
791 minView t =
792 case t of Nil -> Nothing
793 Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, bin p m l r')
794 _ -> Just (go t)
795 where
796 go (Bin p m l r) = case go l of (result, l') -> (result, bin p m l' r)
797 go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))
798 go Nil = error "minView Nil"
799
800 -- | /O(min(n,W))/. Delete and find the minimal element.
801 --
802 -- > deleteFindMin set = (findMin set, deleteMin set)
803 deleteFindMin :: IntSet -> (Key, IntSet)
804 deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView
805
806 -- | /O(min(n,W))/. Delete and find the maximal element.
807 --
808 -- > deleteFindMax set = (findMax set, deleteMax set)
809 deleteFindMax :: IntSet -> (Key, IntSet)
810 deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView
811
812
813 -- | /O(min(n,W))/. The minimal element of the set.
814 findMin :: IntSet -> Key
815 findMin Nil = error "findMin: empty set has no minimal element"
816 findMin (Tip kx bm) = kx + lowestBitSet bm
817 findMin (Bin _ m l r)
818 | m < 0 = find r
819 | otherwise = find l
820 where find (Tip kx bm) = kx + lowestBitSet bm
821 find (Bin _ _ l' _) = find l'
822 find Nil = error "findMin Nil"
823
824 -- | /O(min(n,W))/. The maximal element of a set.
825 findMax :: IntSet -> Key
826 findMax Nil = error "findMax: empty set has no maximal element"
827 findMax (Tip kx bm) = kx + highestBitSet bm
828 findMax (Bin _ m l r)
829 | m < 0 = find l
830 | otherwise = find r
831 where find (Tip kx bm) = kx + highestBitSet bm
832 find (Bin _ _ _ r') = find r'
833 find Nil = error "findMax Nil"
834
835
836 -- | /O(min(n,W))/. Delete the minimal element. Returns an empty set if the set is empty.
837 --
838 -- Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#8211;
839 -- versions prior to 0.5 threw an error if the 'IntSet' was already empty.
840 deleteMin :: IntSet -> IntSet
841 deleteMin = maybe Nil snd . minView
842
843 -- | /O(min(n,W))/. Delete the maximal element. Returns an empty set if the set is empty.
844 --
845 -- Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#8211;
846 -- versions prior to 0.5 threw an error if the 'IntSet' was already empty.
847 deleteMax :: IntSet -> IntSet
848 deleteMax = maybe Nil snd . maxView
849
850 {----------------------------------------------------------------------
851 Map
852 ----------------------------------------------------------------------}
853
854 -- | /O(n*min(n,W))/.
855 -- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
856 --
857 -- It's worth noting that the size of the result may be smaller if,
858 -- for some @(x,y)@, @x \/= y && f x == f y@
859
860 map :: (Key -> Key) -> IntSet -> IntSet
861 map f = fromList . List.map f . toList
862
863 {--------------------------------------------------------------------
864 Fold
865 --------------------------------------------------------------------}
866 -- | /O(n)/. Fold the elements in the set using the given right-associative
867 -- binary operator. This function is an equivalent of 'foldr' and is present
868 -- for compatibility only.
869 --
870 -- /Please note that fold will be deprecated in the future and removed./
871 fold :: (Key -> b -> b) -> b -> IntSet -> b
872 fold = foldr
873 {-# INLINE fold #-}
874
875 -- | /O(n)/. Fold the elements in the set using the given right-associative
876 -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.
877 --
878 -- For example,
879 --
880 -- > toAscList set = foldr (:) [] set
881 foldr :: (Key -> b -> b) -> b -> IntSet -> b
882 foldr f z = \t -> -- Use lambda t to be inlinable with two arguments only.
883 case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before
884 | otherwise -> go (go z r) l
885 _ -> go z t
886 where
887 go z' Nil = z'
888 go z' (Tip kx bm) = foldrBits kx f z' bm
889 go z' (Bin _ _ l r) = go (go z' r) l
890 {-# INLINE foldr #-}
891
892 -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is
893 -- evaluated before using the result in the next application. This
894 -- function is strict in the starting value.
895 foldr' :: (Key -> b -> b) -> b -> IntSet -> b
896 foldr' f z = \t -> -- Use lambda t to be inlinable with two arguments only.
897 case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before
898 | otherwise -> go (go z r) l
899 _ -> go z t
900 where
901 STRICT_1_OF_2(go)
902 go z' Nil = z'
903 go z' (Tip kx bm) = foldr'Bits kx f z' bm
904 go z' (Bin _ _ l r) = go (go z' r) l
905 {-# INLINE foldr' #-}
906
907 -- | /O(n)/. Fold the elements in the set using the given left-associative
908 -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.
909 --
910 -- For example,
911 --
912 -- > toDescList set = foldl (flip (:)) [] set
913 foldl :: (a -> Key -> a) -> a -> IntSet -> a
914 foldl f z = \t -> -- Use lambda t to be inlinable with two arguments only.
915 case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before
916 | otherwise -> go (go z l) r
917 _ -> go z t
918 where
919 STRICT_1_OF_2(go)
920 go z' Nil = z'
921 go z' (Tip kx bm) = foldlBits kx f z' bm
922 go z' (Bin _ _ l r) = go (go z' l) r
923 {-# INLINE foldl #-}
924
925 -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is
926 -- evaluated before using the result in the next application. This
927 -- function is strict in the starting value.
928 foldl' :: (a -> Key -> a) -> a -> IntSet -> a
929 foldl' f z = \t -> -- Use lambda t to be inlinable with two arguments only.
930 case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before
931 | otherwise -> go (go z l) r
932 _ -> go z t
933 where
934 STRICT_1_OF_2(go)
935 go z' Nil = z'
936 go z' (Tip kx bm) = foldl'Bits kx f z' bm
937 go z' (Bin _ _ l r) = go (go z' l) r
938 {-# INLINE foldl' #-}
939
940 {--------------------------------------------------------------------
941 List variations
942 --------------------------------------------------------------------}
943 -- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order.
944 -- Subject to list fusion.
945 elems :: IntSet -> [Key]
946 elems
947 = toAscList
948
949 {--------------------------------------------------------------------
950 Lists
951 --------------------------------------------------------------------}
952 #if __GLASGOW_HASKELL__ >= 708
953 instance GHCExts.IsList IntSet where
954 type Item IntSet = Key
955 fromList = fromList
956 toList = toList
957 #endif
958
959 -- | /O(n)/. Convert the set to a list of elements. Subject to list fusion.
960 toList :: IntSet -> [Key]
961 toList
962 = toAscList
963
964 -- | /O(n)/. Convert the set to an ascending list of elements. Subject to list
965 -- fusion.
966 toAscList :: IntSet -> [Key]
967 toAscList = foldr (:) []
968
969 -- | /O(n)/. Convert the set to a descending list of elements. Subject to list
970 -- fusion.
971 toDescList :: IntSet -> [Key]
972 toDescList = foldl (flip (:)) []
973
974 -- List fusion for the list generating functions.
975 #if __GLASGOW_HASKELL__
976 -- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.
977 -- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.
978 foldrFB :: (Key -> b -> b) -> b -> IntSet -> b
979 foldrFB = foldr
980 {-# INLINE[0] foldrFB #-}
981 foldlFB :: (a -> Key -> a) -> a -> IntSet -> a
982 foldlFB = foldl
983 {-# INLINE[0] foldlFB #-}
984
985 -- Inline elems and toList, so that we need to fuse only toAscList.
986 {-# INLINE elems #-}
987 {-# INLINE toList #-}
988
989 -- The fusion is enabled up to phase 2 included. If it does not succeed,
990 -- convert in phase 1 the expanded to{Asc,Desc}List calls back to
991 -- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in
992 -- a list fusion, otherwise it would go away in phase 1), and let compiler do
993 -- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it
994 -- before phase 0, otherwise the fusion rules would not fire at all.
995 {-# NOINLINE[0] toAscList #-}
996 {-# NOINLINE[0] toDescList #-}
997 {-# RULES "IntSet.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-}
998 {-# RULES "IntSet.toAscListBack" [1] foldrFB (:) [] = toAscList #-}
999 {-# RULES "IntSet.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}
1000 {-# RULES "IntSet.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}
1001 #endif
1002
1003
1004 -- | /O(n*min(n,W))/. Create a set from a list of integers.
1005 fromList :: [Key] -> IntSet
1006 fromList xs
1007 = foldlStrict ins empty xs
1008 where
1009 ins t x = insert x t
1010
1011 -- | /O(n)/. Build a set from an ascending list of elements.
1012 -- /The precondition (input list is ascending) is not checked./
1013 fromAscList :: [Key] -> IntSet
1014 fromAscList [] = Nil
1015 fromAscList (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)
1016 where
1017 combineEq x' [] = [x']
1018 combineEq x' (x:xs)
1019 | x==x' = combineEq x' xs
1020 | otherwise = x' : combineEq x xs
1021
1022 -- | /O(n)/. Build a set from an ascending list of distinct elements.
1023 -- /The precondition (input list is strictly ascending) is not checked./
1024 fromDistinctAscList :: [Key] -> IntSet
1025 fromDistinctAscList [] = Nil
1026 fromDistinctAscList (z0 : zs0) = work (prefixOf z0) (bitmapOf z0) zs0 Nada
1027 where
1028 -- 'work' accumulates all values that go into one tip, before passing this Tip
1029 -- to 'reduce'
1030 work kx bm [] stk = finish kx (Tip kx bm) stk
1031 work kx bm (z:zs) stk | kx == prefixOf z = work kx (bm .|. bitmapOf z) zs stk
1032 work kx bm (z:zs) stk = reduce z zs (branchMask z kx) kx (Tip kx bm) stk
1033
1034 reduce z zs _ px tx Nada = work (prefixOf z) (bitmapOf z) zs (Push px tx Nada)
1035 reduce z zs m px tx stk@(Push py ty stk') =
1036 let mxy = branchMask px py
1037 pxy = mask px mxy
1038 in if shorter m mxy
1039 then reduce z zs m pxy (Bin pxy mxy ty tx) stk'
1040 else work (prefixOf z) (bitmapOf z) zs (Push px tx stk)
1041
1042 finish _ t Nada = t
1043 finish px tx (Push py ty stk) = finish p (link py ty px tx) stk
1044 where m = branchMask px py
1045 p = mask px m
1046
1047 data Stack = Push {-# UNPACK #-} !Prefix !IntSet !Stack | Nada
1048
1049
1050 {--------------------------------------------------------------------
1051 Eq
1052 --------------------------------------------------------------------}
1053 instance Eq IntSet where
1054 t1 == t2 = equal t1 t2
1055 t1 /= t2 = nequal t1 t2
1056
1057 equal :: IntSet -> IntSet -> Bool
1058 equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
1059 = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
1060 equal (Tip kx1 bm1) (Tip kx2 bm2)
1061 = kx1 == kx2 && bm1 == bm2
1062 equal Nil Nil = True
1063 equal _ _ = False
1064
1065 nequal :: IntSet -> IntSet -> Bool
1066 nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
1067 = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
1068 nequal (Tip kx1 bm1) (Tip kx2 bm2)
1069 = kx1 /= kx2 || bm1 /= bm2
1070 nequal Nil Nil = False
1071 nequal _ _ = True
1072
1073 {--------------------------------------------------------------------
1074 Ord
1075 --------------------------------------------------------------------}
1076
1077 instance Ord IntSet where
1078 compare s1 s2 = compare (toAscList s1) (toAscList s2)
1079 -- tentative implementation. See if more efficient exists.
1080
1081 {--------------------------------------------------------------------
1082 Show
1083 --------------------------------------------------------------------}
1084 instance Show IntSet where
1085 showsPrec p xs = showParen (p > 10) $
1086 showString "fromList " . shows (toList xs)
1087
1088 {--------------------------------------------------------------------
1089 Read
1090 --------------------------------------------------------------------}
1091 instance Read IntSet where
1092 #ifdef __GLASGOW_HASKELL__
1093 readPrec = parens $ prec 10 $ do
1094 Ident "fromList" <- lexP
1095 xs <- readPrec
1096 return (fromList xs)
1097
1098 readListPrec = readListPrecDefault
1099 #else
1100 readsPrec p = readParen (p > 10) $ \ r -> do
1101 ("fromList",s) <- lex r
1102 (xs,t) <- reads s
1103 return (fromList xs,t)
1104 #endif
1105
1106 {--------------------------------------------------------------------
1107 Typeable
1108 --------------------------------------------------------------------}
1109
1110 #include "Typeable.h"
1111 INSTANCE_TYPEABLE0(IntSet,intSetTc,"IntSet")
1112
1113 {--------------------------------------------------------------------
1114 NFData
1115 --------------------------------------------------------------------}
1116
1117 -- The IntSet constructors consist only of strict fields of Ints and
1118 -- IntSets, thus the default NFData instance which evaluates to whnf
1119 -- should suffice
1120 instance NFData IntSet
1121
1122 {--------------------------------------------------------------------
1123 Debugging
1124 --------------------------------------------------------------------}
1125 -- | /O(n)/. Show the tree that implements the set. The tree is shown
1126 -- in a compressed, hanging format.
1127 showTree :: IntSet -> String
1128 showTree s
1129 = showTreeWith True False s
1130
1131
1132 {- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
1133 the tree that implements the set. If @hang@ is
1134 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1135 @wide@ is 'True', an extra wide version is shown.
1136 -}
1137 showTreeWith :: Bool -> Bool -> IntSet -> String
1138 showTreeWith hang wide t
1139 | hang = (showsTreeHang wide [] t) ""
1140 | otherwise = (showsTree wide [] [] t) ""
1141
1142 showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS
1143 showsTree wide lbars rbars t
1144 = case t of
1145 Bin p m l r
1146 -> showsTree wide (withBar rbars) (withEmpty rbars) r .
1147 showWide wide rbars .
1148 showsBars lbars . showString (showBin p m) . showString "\n" .
1149 showWide wide lbars .
1150 showsTree wide (withEmpty lbars) (withBar lbars) l
1151 Tip kx bm
1152 -> showsBars lbars . showString " " . shows kx . showString " + " .
1153 showsBitMap bm . showString "\n"
1154 Nil -> showsBars lbars . showString "|\n"
1155
1156 showsTreeHang :: Bool -> [String] -> IntSet -> ShowS
1157 showsTreeHang wide bars t
1158 = case t of
1159 Bin p m l r
1160 -> showsBars bars . showString (showBin p m) . showString "\n" .
1161 showWide wide bars .
1162 showsTreeHang wide (withBar bars) l .
1163 showWide wide bars .
1164 showsTreeHang wide (withEmpty bars) r
1165 Tip kx bm
1166 -> showsBars bars . showString " " . shows kx . showString " + " .
1167 showsBitMap bm . showString "\n"
1168 Nil -> showsBars bars . showString "|\n"
1169
1170 showBin :: Prefix -> Mask -> String
1171 showBin _ _
1172 = "*" -- ++ show (p,m)
1173
1174 showWide :: Bool -> [String] -> String -> String
1175 showWide wide bars
1176 | wide = showString (concat (reverse bars)) . showString "|\n"
1177 | otherwise = id
1178
1179 showsBars :: [String] -> ShowS
1180 showsBars bars
1181 = case bars of
1182 [] -> id
1183 _ -> showString (concat (reverse (tail bars))) . showString node
1184
1185 showsBitMap :: Word -> ShowS
1186 showsBitMap = showString . showBitMap
1187
1188 showBitMap :: Word -> String
1189 showBitMap w = show $ foldrBits 0 (:) [] w
1190
1191 node :: String
1192 node = "+--"
1193
1194 withBar, withEmpty :: [String] -> [String]
1195 withBar bars = "| ":bars
1196 withEmpty bars = " ":bars
1197
1198
1199 {--------------------------------------------------------------------
1200 Helpers
1201 --------------------------------------------------------------------}
1202 {--------------------------------------------------------------------
1203 Link
1204 --------------------------------------------------------------------}
1205 link :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet
1206 link p1 t1 p2 t2
1207 | zero p1 m = Bin p m t1 t2
1208 | otherwise = Bin p m t2 t1
1209 where
1210 m = branchMask p1 p2
1211 p = mask p1 m
1212 {-# INLINE link #-}
1213
1214 {--------------------------------------------------------------------
1215 @bin@ assures that we never have empty trees within a tree.
1216 --------------------------------------------------------------------}
1217 bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
1218 bin _ _ l Nil = l
1219 bin _ _ Nil r = r
1220 bin p m l r = Bin p m l r
1221 {-# INLINE bin #-}
1222
1223 {--------------------------------------------------------------------
1224 @tip@ assures that we never have empty bitmaps within a tree.
1225 --------------------------------------------------------------------}
1226 tip :: Prefix -> BitMap -> IntSet
1227 tip _ 0 = Nil
1228 tip kx bm = Tip kx bm
1229 {-# INLINE tip #-}
1230
1231
1232 {----------------------------------------------------------------------
1233 Functions that generate Prefix and BitMap of a Key or a Suffix.
1234 ----------------------------------------------------------------------}
1235
1236 suffixBitMask :: Int
1237 #if MIN_VERSION_base_4_7_0
1238 suffixBitMask = finiteBitSize (undefined::Word) - 1
1239 #else
1240 suffixBitMask = bitSize (undefined::Word) - 1
1241 #endif
1242 {-# INLINE suffixBitMask #-}
1243
1244 prefixBitMask :: Int
1245 prefixBitMask = complement suffixBitMask
1246 {-# INLINE prefixBitMask #-}
1247
1248 prefixOf :: Int -> Prefix
1249 prefixOf x = x .&. prefixBitMask
1250 {-# INLINE prefixOf #-}
1251
1252 suffixOf :: Int -> Int
1253 suffixOf x = x .&. suffixBitMask
1254 {-# INLINE suffixOf #-}
1255
1256 bitmapOfSuffix :: Int -> BitMap
1257 bitmapOfSuffix s = 1 `shiftLL` s
1258 {-# INLINE bitmapOfSuffix #-}
1259
1260 bitmapOf :: Int -> BitMap
1261 bitmapOf x = bitmapOfSuffix (suffixOf x)
1262 {-# INLINE bitmapOf #-}
1263
1264
1265 {--------------------------------------------------------------------
1266 Endian independent bit twiddling
1267 --------------------------------------------------------------------}
1268 zero :: Int -> Mask -> Bool
1269 zero i m
1270 = (natFromInt i) .&. (natFromInt m) == 0
1271 {-# INLINE zero #-}
1272
1273 nomatch,match :: Int -> Prefix -> Mask -> Bool
1274 nomatch i p m
1275 = (mask i m) /= p
1276 {-# INLINE nomatch #-}
1277
1278 match i p m
1279 = (mask i m) == p
1280 {-# INLINE match #-}
1281
1282 -- Suppose a is largest such that 2^a divides 2*m.
1283 -- Then mask i m is i with the low a bits zeroed out.
1284 mask :: Int -> Mask -> Prefix
1285 mask i m
1286 = maskW (natFromInt i) (natFromInt m)
1287 {-# INLINE mask #-}
1288
1289 {--------------------------------------------------------------------
1290 Big endian operations
1291 --------------------------------------------------------------------}
1292 maskW :: Nat -> Nat -> Prefix
1293 maskW i m
1294 = intFromNat (i .&. (complement (m-1) `xor` m))
1295 {-# INLINE maskW #-}
1296
1297 shorter :: Mask -> Mask -> Bool
1298 shorter m1 m2
1299 = (natFromInt m1) > (natFromInt m2)
1300 {-# INLINE shorter #-}
1301
1302 branchMask :: Prefix -> Prefix -> Mask
1303 branchMask p1 p2
1304 = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
1305 {-# INLINE branchMask #-}
1306
1307 {----------------------------------------------------------------------
1308 To get best performance, we provide fast implementations of
1309 lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.
1310 If the intel bsf and bsr instructions ever become GHC primops,
1311 this code should be reimplemented using these.
1312
1313 Performance of this code is crucial for folds, toList, filter, partition.
1314
1315 The signatures of methods in question are placed after this comment.
1316 ----------------------------------------------------------------------}
1317
1318 lowestBitSet :: Nat -> Int
1319 highestBitSet :: Nat -> Int
1320 foldlBits :: Int -> (a -> Int -> a) -> a -> Nat -> a
1321 foldl'Bits :: Int -> (a -> Int -> a) -> a -> Nat -> a
1322 foldrBits :: Int -> (Int -> a -> a) -> a -> Nat -> a
1323 foldr'Bits :: Int -> (Int -> a -> a) -> a -> Nat -> a
1324
1325 {-# INLINE lowestBitSet #-}
1326 {-# INLINE highestBitSet #-}
1327 {-# INLINE foldlBits #-}
1328 {-# INLINE foldl'Bits #-}
1329 {-# INLINE foldrBits #-}
1330 {-# INLINE foldr'Bits #-}
1331
1332 #if defined(__GLASGOW_HASKELL__) && (WORD_SIZE_IN_BITS==32 || WORD_SIZE_IN_BITS==64)
1333 {----------------------------------------------------------------------
1334 For lowestBitSet we use wordsize-dependant implementation based on
1335 multiplication and DeBrujn indeces, which was proposed by Edward Kmett
1336 <http://haskell.org/pipermail/libraries/2011-September/016749.html>
1337
1338 The core of this implementation is fast indexOfTheOnlyBit,
1339 which is given a Nat with exactly one bit set, and returns
1340 its index.
1341
1342 Lot of effort was put in these implementations, please benchmark carefully
1343 before changing this code.
1344 ----------------------------------------------------------------------}
1345
1346 indexOfTheOnlyBit :: Nat -> Int
1347 {-# INLINE indexOfTheOnlyBit #-}
1348 indexOfTheOnlyBit bitmask =
1349 I# (lsbArray `indexInt8OffAddr#` unboxInt (intFromNat ((bitmask * magic) `shiftRL` offset)))
1350 where unboxInt (I# i) = i
1351 #if WORD_SIZE_IN_BITS==32
1352 magic = 0x077CB531
1353 offset = 27
1354 !lsbArray = "\0\1\28\2\29\14\24\3\30\22\20\15\25\17\4\8\31\27\13\23\21\19\16\7\26\12\18\6\11\5\10\9"#
1355 #else
1356 magic = 0x07EDD5E59A4E28C2
1357 offset = 58
1358 !lsbArray = "\63\0\58\1\59\47\53\2\60\39\48\27\54\33\42\3\61\51\37\40\49\18\28\20\55\30\34\11\43\14\22\4\62\57\46\52\38\26\32\41\50\36\17\19\29\10\13\21\56\45\25\31\35\16\9\12\44\24\15\8\23\7\6\5"#
1359 #endif
1360 -- The lsbArray gets inlined to every call site of indexOfTheOnlyBit.
1361 -- That cannot be easily avoided, as GHC forbids top-level Addr# literal.
1362 -- One could go around that by supplying getLsbArray :: () -> Addr# marked
1363 -- as NOINLINE. But the code size of calling it and processing the result
1364 -- is 48B on 32-bit and 56B on 64-bit architectures -- so the 32B and 64B array
1365 -- is actually improvement on 32-bit and only a 8B size increase on 64-bit.
1366
1367 lowestBitMask :: Nat -> Nat
1368 lowestBitMask x = x .&. negate x
1369 {-# INLINE lowestBitMask #-}
1370
1371 -- Reverse the order of bits in the Nat.
1372 revNat :: Nat -> Nat
1373 #if WORD_SIZE_IN_BITS==32
1374 revNat x1 = case ((x1 `shiftRL` 1) .&. 0x55555555) .|. ((x1 .&. 0x55555555) `shiftLL` 1) of
1375 x2 -> case ((x2 `shiftRL` 2) .&. 0x33333333) .|. ((x2 .&. 0x33333333) `shiftLL` 2) of
1376 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F) `shiftLL` 4) of
1377 x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF) .|. ((x4 .&. 0x00FF00FF) `shiftLL` 8) of
1378 x5 -> ( x5 `shiftRL` 16 ) .|. ( x5 `shiftLL` 16);
1379 #else
1380 revNat x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of
1381 x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of
1382 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of
1383 x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of
1384 x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of
1385 x6 -> ( x6 `shiftRL` 32 ) .|. ( x6 `shiftLL` 32);
1386 #endif
1387
1388 lowestBitSet x = indexOfTheOnlyBit (lowestBitMask x)
1389
1390 highestBitSet x = indexOfTheOnlyBit (highestBitMask x)
1391
1392 foldlBits prefix f z bitmap = go bitmap z
1393 where go bm acc | bm == 0 = acc
1394 | otherwise = case lowestBitMask bm of
1395 bitmask -> bitmask `seq` case indexOfTheOnlyBit bitmask of
1396 bi -> bi `seq` go (bm `xor` bitmask) ((f acc) $! (prefix+bi))
1397
1398 foldl'Bits prefix f z bitmap = go bitmap z
1399 where STRICT_2_OF_2(go)
1400 go bm acc | bm == 0 = acc
1401 | otherwise = case lowestBitMask bm of
1402 bitmask -> bitmask `seq` case indexOfTheOnlyBit bitmask of
1403 bi -> bi `seq` go (bm `xor` bitmask) ((f acc) $! (prefix+bi))
1404
1405 foldrBits prefix f z bitmap = go (revNat bitmap) z
1406 where go bm acc | bm == 0 = acc
1407 | otherwise = case lowestBitMask bm of
1408 bitmask -> bitmask `seq` case indexOfTheOnlyBit bitmask of
1409 bi -> bi `seq` go (bm `xor` bitmask) ((f $! (prefix+(WORD_SIZE_IN_BITS-1)-bi)) acc)
1410
1411 foldr'Bits prefix f z bitmap = go (revNat bitmap) z
1412 where STRICT_2_OF_2(go)
1413 go bm acc | bm == 0 = acc
1414 | otherwise = case lowestBitMask bm of
1415 bitmask -> bitmask `seq` case indexOfTheOnlyBit bitmask of
1416 bi -> bi `seq` go (bm `xor` bitmask) ((f $! (prefix+(WORD_SIZE_IN_BITS-1)-bi)) acc)
1417
1418 #else
1419 {----------------------------------------------------------------------
1420 In general case we use logarithmic implementation of
1421 lowestBitSet and highestBitSet, which works up to bit sizes of 64.
1422
1423 Folds are linear scans.
1424 ----------------------------------------------------------------------}
1425
1426 lowestBitSet n0 =
1427 let (n1,b1) = if n0 .&. 0xFFFFFFFF /= 0 then (n0,0) else (n0 `shiftRL` 32, 32)
1428 (n2,b2) = if n1 .&. 0xFFFF /= 0 then (n1,b1) else (n1 `shiftRL` 16, 16+b1)
1429 (n3,b3) = if n2 .&. 0xFF /= 0 then (n2,b2) else (n2 `shiftRL` 8, 8+b2)
1430 (n4,b4) = if n3 .&. 0xF /= 0 then (n3,b3) else (n3 `shiftRL` 4, 4+b3)
1431 (n5,b5) = if n4 .&. 0x3 /= 0 then (n4,b4) else (n4 `shiftRL` 2, 2+b4)
1432 b6 = if n5 .&. 0x1 /= 0 then b5 else 1+b5
1433 in b6
1434
1435 highestBitSet n0 =
1436 let (n1,b1) = if n0 .&. 0xFFFFFFFF00000000 /= 0 then (n0 `shiftRL` 32, 32) else (n0,0)
1437 (n2,b2) = if n1 .&. 0xFFFF0000 /= 0 then (n1 `shiftRL` 16, 16+b1) else (n1,b1)
1438 (n3,b3) = if n2 .&. 0xFF00 /= 0 then (n2 `shiftRL` 8, 8+b2) else (n2,b2)
1439 (n4,b4) = if n3 .&. 0xF0 /= 0 then (n3 `shiftRL` 4, 4+b3) else (n3,b3)
1440 (n5,b5) = if n4 .&. 0xC /= 0 then (n4 `shiftRL` 2, 2+b4) else (n4,b4)
1441 b6 = if n5 .&. 0x2 /= 0 then 1+b5 else b5
1442 in b6
1443
1444 foldlBits prefix f z bm = let lb = lowestBitSet bm
1445 in go (prefix+lb) z (bm `shiftRL` lb)
1446 where STRICT_1_OF_3(go)
1447 go _ acc 0 = acc
1448 go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)
1449 | otherwise = go (bi + 1) acc (n `shiftRL` 1)
1450
1451 foldl'Bits prefix f z bm = let lb = lowestBitSet bm
1452 in go (prefix+lb) z (bm `shiftRL` lb)
1453 where STRICT_1_OF_3(go)
1454 STRICT_2_OF_3(go)
1455 go _ acc 0 = acc
1456 go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)
1457 | otherwise = go (bi + 1) acc (n `shiftRL` 1)
1458
1459 foldrBits prefix f z bm = let lb = lowestBitSet bm
1460 in go (prefix+lb) (bm `shiftRL` lb)
1461 where STRICT_1_OF_2(go)
1462 go _ 0 = z
1463 go bi n | n `testBit` 0 = f bi (go (bi + 1) (n `shiftRL` 1))
1464 | otherwise = go (bi + 1) (n `shiftRL` 1)
1465
1466 foldr'Bits prefix f z bm = let lb = lowestBitSet bm
1467 in go (prefix+lb) (bm `shiftRL` lb)
1468 where STRICT_1_OF_2(go)
1469 go _ 0 = z
1470 go bi n | n `testBit` 0 = f bi $! go (bi + 1) (n `shiftRL` 1)
1471 | otherwise = go (bi + 1) (n `shiftRL` 1)
1472
1473 #endif
1474
1475 {----------------------------------------------------------------------
1476 [bitcount] as posted by David F. Place to haskell-cafe on April 11, 2006,
1477 based on the code on
1478 http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan,
1479 where the following source is given:
1480 Published in 1988, the C Programming Language 2nd Ed. (by Brian W.
1481 Kernighan and Dennis M. Ritchie) mentions this in exercise 2-9. On April
1482 19, 2006 Don Knuth pointed out to me that this method "was first published
1483 by Peter Wegner in CACM 3 (1960), 322. (Also discovered independently by
1484 Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)"
1485 ----------------------------------------------------------------------}
1486
1487 bitcount :: Int -> Word -> Int
1488 #if MIN_VERSION_base_4_5_0
1489 bitcount a x = a + popCount x
1490 #else
1491 bitcount a0 x0 = go a0 x0
1492 where go a 0 = a
1493 go a x = go (a + 1) (x .&. (x-1))
1494 #endif
1495 {-# INLINE bitcount #-}
1496
1497
1498 {--------------------------------------------------------------------
1499 Utilities
1500 --------------------------------------------------------------------}
1501 foldlStrict :: (a -> b -> a) -> a -> [b] -> a
1502 foldlStrict f = go
1503 where
1504 go z [] = z
1505 go z (x:xs) = let z' = f z x in z' `seq` go z' xs
1506 {-# INLINE foldlStrict #-}
1507
1508 -- | /O(1)/. Decompose a set into pieces based on the structure of the underlying
1509 -- tree. This function is useful for consuming a set in parallel.
1510 --
1511 -- No guarantee is made as to the sizes of the pieces; an internal, but
1512 -- deterministic process determines this. However, it is guaranteed that the
1513 -- pieces returned will be in ascending order (all elements in the first submap
1514 -- less than all elements in the second, and so on).
1515 --
1516 -- Examples:
1517 --
1518 -- > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]
1519 -- > splitRoot empty == []
1520 --
1521 -- Note that the current implementation does not return more than two subsets,
1522 -- but you should not depend on this behaviour because it can change in the
1523 -- future without notice. Also, the current version does not continue
1524 -- splitting all the way to individual singleton sets -- it stops at some
1525 -- point.
1526 splitRoot :: IntSet -> [IntSet]
1527 splitRoot orig =
1528 case orig of
1529 Nil -> []
1530 -- NOTE: we don't currently split below Tip, but we could.
1531 x@(Tip _ _) -> [x]
1532 Bin _ m l r | m < 0 -> [r, l]
1533 | otherwise -> [l, r]
1534 {-# INLINE splitRoot #-}