90b9bd9f7c6358a4361ba33fe490482fb849a998
[packages/old-time.git] / Data / IntSet.hs
1 {-# OPTIONS -cpp -fglasgow-exts #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : Data.IntSet
5 -- Copyright : (c) Daan Leijen 2002
6 -- License : BSD-style
7 -- Maintainer : libraries@haskell.org
8 -- Stability : provisional
9 -- Portability : portable
10 --
11 -- An efficient implementation of integer sets.
12 --
13 -- This module is intended to be imported @qualified@, to avoid name
14 -- clashes with "Prelude" functions. eg.
15 --
16 -- > import Data.IntSet as Set
17 --
18 -- The implementation is based on /big-endian patricia trees/. This data
19 -- structure performs especially well on binary operations like 'union'
20 -- and 'intersection'. However, my benchmarks show that it is also
21 -- (much) faster on insertions and deletions when compared to a generic
22 -- size-balanced set implementation (see "Data.Set").
23 --
24 -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
25 -- Workshop on ML, September 1998, pages 77-86,
26 -- <http://www.cse.ogi.edu/~andy/pub/finite.htm>
27 --
28 -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
29 -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
30 -- October 1968, pages 514-534.
31 --
32 -- Many operations have a worst-case complexity of /O(min(n,W))/.
33 -- This means that the operation can become linear in the number of
34 -- elements with a maximum of /W/ -- the number of bits in an 'Int'
35 -- (32 or 64).
36 -----------------------------------------------------------------------------
37
38 module Data.IntSet (
39 -- * Set type
40 IntSet -- instance Eq,Show
41
42 -- * Operators
43 , (\\)
44
45 -- * Query
46 , null
47 , size
48 , member
49 , isSubsetOf
50 , isProperSubsetOf
51
52 -- * Construction
53 , empty
54 , singleton
55 , insert
56 , delete
57
58 -- * Combine
59 , union, unions
60 , difference
61 , intersection
62
63 -- * Filter
64 , filter
65 , partition
66 , split
67 , splitMember
68
69 -- * Map
70 , map
71
72 -- * Fold
73 , fold
74
75 -- * Conversion
76 -- ** List
77 , elems
78 , toList
79 , fromList
80
81 -- ** Ordered list
82 , toAscList
83 , fromAscList
84 , fromDistinctAscList
85
86 -- * Debugging
87 , showTree
88 , showTreeWith
89 ) where
90
91
92 import Prelude hiding (lookup,filter,foldr,foldl,null,map)
93 import Data.Bits
94 import Data.Int
95
96 import qualified Data.List as List
97 import Data.Monoid
98
99 {-
100 -- just for testing
101 import QuickCheck
102 import List (nub,sort)
103 import qualified List
104 -}
105
106
107 #ifdef __GLASGOW_HASKELL__
108 {--------------------------------------------------------------------
109 GHC: use unboxing to get @shiftRL@ inlined.
110 --------------------------------------------------------------------}
111 #if __GLASGOW_HASKELL__ >= 503
112 import GHC.Word
113 import GHC.Exts ( Word(..), Int(..), shiftRL# )
114 #else
115 import Word
116 import GlaExts ( Word(..), Int(..), shiftRL# )
117 #endif
118
119 infixl 9 \\{-This comment teaches CPP correct behaviour -}
120
121 type Nat = Word
122
123 natFromInt :: Int -> Nat
124 natFromInt i = fromIntegral i
125
126 intFromNat :: Nat -> Int
127 intFromNat w = fromIntegral w
128
129 shiftRL :: Nat -> Int -> Nat
130 shiftRL (W# x) (I# i)
131 = W# (shiftRL# x i)
132
133 #elif __HUGS__
134 {--------------------------------------------------------------------
135 Hugs:
136 * raises errors on boundary values when using 'fromIntegral'
137 but not with the deprecated 'fromInt/toInt'.
138 * Older Hugs doesn't define 'Word'.
139 * Newer Hugs defines 'Word' in the Prelude but no operations.
140 --------------------------------------------------------------------}
141 import Data.Word
142 infixl 9 \\ -- comment to fool cpp
143
144 type Nat = Word32 -- illegal on 64-bit platforms!
145
146 natFromInt :: Int -> Nat
147 natFromInt i = fromInt i
148
149 intFromNat :: Nat -> Int
150 intFromNat w = toInt w
151
152 shiftRL :: Nat -> Int -> Nat
153 shiftRL x i = shiftR x i
154
155 #else
156 {--------------------------------------------------------------------
157 'Standard' Haskell
158 * A "Nat" is a natural machine word (an unsigned Int)
159 --------------------------------------------------------------------}
160 import Data.Word
161 infixl 9 \\ -- comment to fool cpp
162
163 type Nat = Word
164
165 natFromInt :: Int -> Nat
166 natFromInt i = fromIntegral i
167
168 intFromNat :: Nat -> Int
169 intFromNat w = fromIntegral w
170
171 shiftRL :: Nat -> Int -> Nat
172 shiftRL w i = shiftR w i
173
174 #endif
175
176 {--------------------------------------------------------------------
177 Operators
178 --------------------------------------------------------------------}
179 -- | /O(n+m)/. See 'difference'.
180 (\\) :: IntSet -> IntSet -> IntSet
181 m1 \\ m2 = difference m1 m2
182
183 {--------------------------------------------------------------------
184 Types
185 --------------------------------------------------------------------}
186 -- | A set of integers.
187 data IntSet = Nil
188 | Tip {-# UNPACK #-} !Int
189 | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntSet !IntSet
190
191 type Prefix = Int
192 type Mask = Int
193
194 {--------------------------------------------------------------------
195 Query
196 --------------------------------------------------------------------}
197 -- | /O(1)/. Is the set empty?
198 null :: IntSet -> Bool
199 null Nil = True
200 null other = False
201
202 -- | /O(n)/. Cardinality of the set.
203 size :: IntSet -> Int
204 size t
205 = case t of
206 Bin p m l r -> size l + size r
207 Tip y -> 1
208 Nil -> 0
209
210 -- | /O(min(n,W))/. Is the value a member of the set?
211 member :: Int -> IntSet -> Bool
212 member x t
213 = case t of
214 Bin p m l r
215 | nomatch x p m -> False
216 | zero x m -> member x l
217 | otherwise -> member x r
218 Tip y -> (x==y)
219 Nil -> False
220
221 -- 'lookup' is used by 'intersection' for left-biasing
222 lookup :: Int -> IntSet -> Maybe Int
223 lookup k t
224 = let nk = natFromInt k in seq nk (lookupN nk t)
225
226 lookupN :: Nat -> IntSet -> Maybe Int
227 lookupN k t
228 = case t of
229 Bin p m l r
230 | zeroN k (natFromInt m) -> lookupN k l
231 | otherwise -> lookupN k r
232 Tip kx
233 | (k == natFromInt kx) -> Just kx
234 | otherwise -> Nothing
235 Nil -> Nothing
236
237 {--------------------------------------------------------------------
238 Construction
239 --------------------------------------------------------------------}
240 -- | /O(1)/. The empty set.
241 empty :: IntSet
242 empty
243 = Nil
244
245 -- | /O(1)/. A set of one element.
246 singleton :: Int -> IntSet
247 singleton x
248 = Tip x
249
250 {--------------------------------------------------------------------
251 Insert
252 --------------------------------------------------------------------}
253 -- | /O(min(n,W))/. Add a value to the set. When the value is already
254 -- an element of the set, it is replaced by the new one, ie. 'insert'
255 -- is left-biased.
256 insert :: Int -> IntSet -> IntSet
257 insert x t
258 = case t of
259 Bin p m l r
260 | nomatch x p m -> join x (Tip x) p t
261 | zero x m -> Bin p m (insert x l) r
262 | otherwise -> Bin p m l (insert x r)
263 Tip y
264 | x==y -> Tip x
265 | otherwise -> join x (Tip x) y t
266 Nil -> Tip x
267
268 -- right-biased insertion, used by 'union'
269 insertR :: Int -> IntSet -> IntSet
270 insertR x t
271 = case t of
272 Bin p m l r
273 | nomatch x p m -> join x (Tip x) p t
274 | zero x m -> Bin p m (insert x l) r
275 | otherwise -> Bin p m l (insert x r)
276 Tip y
277 | x==y -> t
278 | otherwise -> join x (Tip x) y t
279 Nil -> Tip x
280
281 -- | /O(min(n,W))/. Delete a value in the set. Returns the
282 -- original set when the value was not present.
283 delete :: Int -> IntSet -> IntSet
284 delete x t
285 = case t of
286 Bin p m l r
287 | nomatch x p m -> t
288 | zero x m -> bin p m (delete x l) r
289 | otherwise -> bin p m l (delete x r)
290 Tip y
291 | x==y -> Nil
292 | otherwise -> t
293 Nil -> Nil
294
295
296 {--------------------------------------------------------------------
297 Union
298 --------------------------------------------------------------------}
299 -- | The union of a list of sets.
300 unions :: [IntSet] -> IntSet
301 unions xs
302 = foldlStrict union empty xs
303
304
305 -- | /O(n+m)/. The union of two sets.
306 union :: IntSet -> IntSet -> IntSet
307 union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
308 | shorter m1 m2 = union1
309 | shorter m2 m1 = union2
310 | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
311 | otherwise = join p1 t1 p2 t2
312 where
313 union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
314 | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
315 | otherwise = Bin p1 m1 l1 (union r1 t2)
316
317 union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
318 | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
319 | otherwise = Bin p2 m2 l2 (union t1 r2)
320
321 union (Tip x) t = insert x t
322 union t (Tip x) = insertR x t -- right bias
323 union Nil t = t
324 union t Nil = t
325
326
327 {--------------------------------------------------------------------
328 Difference
329 --------------------------------------------------------------------}
330 -- | /O(n+m)/. Difference between two sets.
331 difference :: IntSet -> IntSet -> IntSet
332 difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
333 | shorter m1 m2 = difference1
334 | shorter m2 m1 = difference2
335 | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
336 | otherwise = t1
337 where
338 difference1 | nomatch p2 p1 m1 = t1
339 | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
340 | otherwise = bin p1 m1 l1 (difference r1 t2)
341
342 difference2 | nomatch p1 p2 m2 = t1
343 | zero p1 m2 = difference t1 l2
344 | otherwise = difference t1 r2
345
346 difference t1@(Tip x) t2
347 | member x t2 = Nil
348 | otherwise = t1
349
350 difference Nil t = Nil
351 difference t (Tip x) = delete x t
352 difference t Nil = t
353
354
355
356 {--------------------------------------------------------------------
357 Intersection
358 --------------------------------------------------------------------}
359 -- | /O(n+m)/. The intersection of two sets.
360 intersection :: IntSet -> IntSet -> IntSet
361 intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
362 | shorter m1 m2 = intersection1
363 | shorter m2 m1 = intersection2
364 | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
365 | otherwise = Nil
366 where
367 intersection1 | nomatch p2 p1 m1 = Nil
368 | zero p2 m1 = intersection l1 t2
369 | otherwise = intersection r1 t2
370
371 intersection2 | nomatch p1 p2 m2 = Nil
372 | zero p1 m2 = intersection t1 l2
373 | otherwise = intersection t1 r2
374
375 intersection t1@(Tip x) t2
376 | member x t2 = t1
377 | otherwise = Nil
378 intersection t (Tip x)
379 = case lookup x t of
380 Just y -> Tip y
381 Nothing -> Nil
382 intersection Nil t = Nil
383 intersection t Nil = Nil
384
385
386
387 {--------------------------------------------------------------------
388 Subset
389 --------------------------------------------------------------------}
390 -- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
391 isProperSubsetOf :: IntSet -> IntSet -> Bool
392 isProperSubsetOf t1 t2
393 = case subsetCmp t1 t2 of
394 LT -> True
395 ge -> False
396
397 subsetCmp t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
398 | shorter m1 m2 = GT
399 | shorter m2 m1 = subsetCmpLt
400 | p1 == p2 = subsetCmpEq
401 | otherwise = GT -- disjoint
402 where
403 subsetCmpLt | nomatch p1 p2 m2 = GT
404 | zero p1 m2 = subsetCmp t1 l2
405 | otherwise = subsetCmp t1 r2
406 subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of
407 (GT,_ ) -> GT
408 (_ ,GT) -> GT
409 (EQ,EQ) -> EQ
410 other -> LT
411
412 subsetCmp (Bin p m l r) t = GT
413 subsetCmp (Tip x) (Tip y)
414 | x==y = EQ
415 | otherwise = GT -- disjoint
416 subsetCmp (Tip x) t
417 | member x t = LT
418 | otherwise = GT -- disjoint
419 subsetCmp Nil Nil = EQ
420 subsetCmp Nil t = LT
421
422 -- | /O(n+m)/. Is this a subset?
423 -- @(s1 `isSubsetOf` s2)@ tells whether s1 is a subset of s2.
424
425 isSubsetOf :: IntSet -> IntSet -> Bool
426 isSubsetOf t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
427 | shorter m1 m2 = False
428 | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2
429 else isSubsetOf t1 r2)
430 | otherwise = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2
431 isSubsetOf (Bin p m l r) t = False
432 isSubsetOf (Tip x) t = member x t
433 isSubsetOf Nil t = True
434
435
436 {--------------------------------------------------------------------
437 Filter
438 --------------------------------------------------------------------}
439 -- | /O(n)/. Filter all elements that satisfy some predicate.
440 filter :: (Int -> Bool) -> IntSet -> IntSet
441 filter pred t
442 = case t of
443 Bin p m l r
444 -> bin p m (filter pred l) (filter pred r)
445 Tip x
446 | pred x -> t
447 | otherwise -> Nil
448 Nil -> Nil
449
450 -- | /O(n)/. partition the set according to some predicate.
451 partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet)
452 partition pred t
453 = case t of
454 Bin p m l r
455 -> let (l1,l2) = partition pred l
456 (r1,r2) = partition pred r
457 in (bin p m l1 r1, bin p m l2 r2)
458 Tip x
459 | pred x -> (t,Nil)
460 | otherwise -> (Nil,t)
461 Nil -> (Nil,Nil)
462
463
464 -- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@
465 -- where all elements in @set1@ are lower than @x@ and all elements in
466 -- @set2@ larger than @x@.
467 --
468 -- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [3,4])
469 split :: Int -> IntSet -> (IntSet,IntSet)
470 split x t
471 = case t of
472 Bin p m l r
473 | zero x m -> let (lt,gt) = split x l in (lt,union gt r)
474 | otherwise -> let (lt,gt) = split x r in (union l lt,gt)
475 Tip y
476 | x>y -> (t,Nil)
477 | x<y -> (Nil,t)
478 | otherwise -> (Nil,Nil)
479 Nil -> (Nil,Nil)
480
481 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
482 -- element was found in the original set.
483 splitMember :: Int -> IntSet -> (Bool,IntSet,IntSet)
484 splitMember x t
485 = case t of
486 Bin p m l r
487 | zero x m -> let (found,lt,gt) = splitMember x l in (found,lt,union gt r)
488 | otherwise -> let (found,lt,gt) = splitMember x r in (found,union l lt,gt)
489 Tip y
490 | x>y -> (False,t,Nil)
491 | x<y -> (False,Nil,t)
492 | otherwise -> (True,Nil,Nil)
493 Nil -> (False,Nil,Nil)
494
495 {----------------------------------------------------------------------
496 Map
497 ----------------------------------------------------------------------}
498
499 -- | /O(n*min(n,W))/.
500 -- @map f s@ is the set obtained by applying @f@ to each element of @s@.
501 --
502 -- It's worth noting that the size of the result may be smaller if,
503 -- for some @(x,y)@, @x \/= y && f x == f y@
504
505 map :: (Int->Int) -> IntSet -> IntSet
506 map f = fromList . List.map f . toList
507
508 {--------------------------------------------------------------------
509 Fold
510 --------------------------------------------------------------------}
511 -- | /O(n)/. Fold over the elements of a set in an unspecified order.
512 --
513 -- > sum set == fold (+) 0 set
514 -- > elems set == fold (:) [] set
515 fold :: (Int -> b -> b) -> b -> IntSet -> b
516 fold f z t
517 = foldr f z t
518
519 foldr :: (Int -> b -> b) -> b -> IntSet -> b
520 foldr f z t
521 = case t of
522 Bin p m l r -> foldr f (foldr f z r) l
523 Tip x -> f x z
524 Nil -> z
525
526 {--------------------------------------------------------------------
527 List variations
528 --------------------------------------------------------------------}
529 -- | /O(n)/. The elements of a set. (For sets, this is equivalent to toList)
530 elems :: IntSet -> [Int]
531 elems s
532 = toList s
533
534 {--------------------------------------------------------------------
535 Lists
536 --------------------------------------------------------------------}
537 -- | /O(n)/. Convert the set to a list of elements.
538 toList :: IntSet -> [Int]
539 toList t
540 = fold (:) [] t
541
542 -- | /O(n)/. Convert the set to an ascending list of elements.
543 toAscList :: IntSet -> [Int]
544 toAscList t
545 = -- NOTE: the following algorithm only works for big-endian trees
546 let (pos,neg) = span (>=0) (foldr (:) [] t) in neg ++ pos
547
548 -- | /O(n*min(n,W))/. Create a set from a list of integers.
549 fromList :: [Int] -> IntSet
550 fromList xs
551 = foldlStrict ins empty xs
552 where
553 ins t x = insert x t
554
555 -- | /O(n*min(n,W))/. Build a set from an ascending list of elements.
556 fromAscList :: [Int] -> IntSet
557 fromAscList xs
558 = fromList xs
559
560 -- | /O(n*min(n,W))/. Build a set from an ascending list of distinct elements.
561 fromDistinctAscList :: [Int] -> IntSet
562 fromDistinctAscList xs
563 = fromList xs
564
565
566 {--------------------------------------------------------------------
567 Eq
568 --------------------------------------------------------------------}
569 instance Eq IntSet where
570 t1 == t2 = equal t1 t2
571 t1 /= t2 = nequal t1 t2
572
573 equal :: IntSet -> IntSet -> Bool
574 equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
575 = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
576 equal (Tip x) (Tip y)
577 = (x==y)
578 equal Nil Nil = True
579 equal t1 t2 = False
580
581 nequal :: IntSet -> IntSet -> Bool
582 nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
583 = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
584 nequal (Tip x) (Tip y)
585 = (x/=y)
586 nequal Nil Nil = False
587 nequal t1 t2 = True
588
589 {--------------------------------------------------------------------
590 Ord
591 --------------------------------------------------------------------}
592
593 instance Ord IntSet where
594 compare s1 s2 = compare (toAscList s1) (toAscList s2)
595 -- tentative implementation. See if more efficient exists.
596
597 {--------------------------------------------------------------------
598 Monoid
599 --------------------------------------------------------------------}
600
601 instance Monoid IntSet where
602 mempty = empty
603 mappend = union
604 mconcat = unions
605
606 {--------------------------------------------------------------------
607 Show
608 --------------------------------------------------------------------}
609 instance Show IntSet where
610 showsPrec d s = showSet (toList s)
611
612 showSet :: [Int] -> ShowS
613 showSet []
614 = showString "{}"
615 showSet (x:xs)
616 = showChar '{' . shows x . showTail xs
617 where
618 showTail [] = showChar '}'
619 showTail (x:xs) = showChar ',' . shows x . showTail xs
620
621 {--------------------------------------------------------------------
622 Debugging
623 --------------------------------------------------------------------}
624 -- | /O(n)/. Show the tree that implements the set. The tree is shown
625 -- in a compressed, hanging format.
626 showTree :: IntSet -> String
627 showTree s
628 = showTreeWith True False s
629
630
631 {- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
632 the tree that implements the set. If @hang@ is
633 @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
634 @wide@ is true, an extra wide version is shown.
635 -}
636 showTreeWith :: Bool -> Bool -> IntSet -> String
637 showTreeWith hang wide t
638 | hang = (showsTreeHang wide [] t) ""
639 | otherwise = (showsTree wide [] [] t) ""
640
641 showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS
642 showsTree wide lbars rbars t
643 = case t of
644 Bin p m l r
645 -> showsTree wide (withBar rbars) (withEmpty rbars) r .
646 showWide wide rbars .
647 showsBars lbars . showString (showBin p m) . showString "\n" .
648 showWide wide lbars .
649 showsTree wide (withEmpty lbars) (withBar lbars) l
650 Tip x
651 -> showsBars lbars . showString " " . shows x . showString "\n"
652 Nil -> showsBars lbars . showString "|\n"
653
654 showsTreeHang :: Bool -> [String] -> IntSet -> ShowS
655 showsTreeHang wide bars t
656 = case t of
657 Bin p m l r
658 -> showsBars bars . showString (showBin p m) . showString "\n" .
659 showWide wide bars .
660 showsTreeHang wide (withBar bars) l .
661 showWide wide bars .
662 showsTreeHang wide (withEmpty bars) r
663 Tip x
664 -> showsBars bars . showString " " . shows x . showString "\n"
665 Nil -> showsBars bars . showString "|\n"
666
667 showBin p m
668 = "*" -- ++ show (p,m)
669
670 showWide wide bars
671 | wide = showString (concat (reverse bars)) . showString "|\n"
672 | otherwise = id
673
674 showsBars :: [String] -> ShowS
675 showsBars bars
676 = case bars of
677 [] -> id
678 _ -> showString (concat (reverse (tail bars))) . showString node
679
680 node = "+--"
681 withBar bars = "| ":bars
682 withEmpty bars = " ":bars
683
684
685 {--------------------------------------------------------------------
686 Helpers
687 --------------------------------------------------------------------}
688 {--------------------------------------------------------------------
689 Join
690 --------------------------------------------------------------------}
691 join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet
692 join p1 t1 p2 t2
693 | zero p1 m = Bin p m t1 t2
694 | otherwise = Bin p m t2 t1
695 where
696 m = branchMask p1 p2
697 p = mask p1 m
698
699 {--------------------------------------------------------------------
700 @bin@ assures that we never have empty trees within a tree.
701 --------------------------------------------------------------------}
702 bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
703 bin p m l Nil = l
704 bin p m Nil r = r
705 bin p m l r = Bin p m l r
706
707
708 {--------------------------------------------------------------------
709 Endian independent bit twiddling
710 --------------------------------------------------------------------}
711 zero :: Int -> Mask -> Bool
712 zero i m
713 = (natFromInt i) .&. (natFromInt m) == 0
714
715 nomatch,match :: Int -> Prefix -> Mask -> Bool
716 nomatch i p m
717 = (mask i m) /= p
718
719 match i p m
720 = (mask i m) == p
721
722 mask :: Int -> Mask -> Prefix
723 mask i m
724 = maskW (natFromInt i) (natFromInt m)
725
726 zeroN :: Nat -> Nat -> Bool
727 zeroN i m = (i .&. m) == 0
728
729 {--------------------------------------------------------------------
730 Big endian operations
731 --------------------------------------------------------------------}
732 maskW :: Nat -> Nat -> Prefix
733 maskW i m
734 = intFromNat (i .&. (complement (m-1) `xor` m))
735
736 shorter :: Mask -> Mask -> Bool
737 shorter m1 m2
738 = (natFromInt m1) > (natFromInt m2)
739
740 branchMask :: Prefix -> Prefix -> Mask
741 branchMask p1 p2
742 = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
743
744 {----------------------------------------------------------------------
745 Finding the highest bit (mask) in a word [x] can be done efficiently in
746 three ways:
747 * convert to a floating point value and the mantissa tells us the
748 [log2(x)] that corresponds with the highest bit position. The mantissa
749 is retrieved either via the standard C function [frexp] or by some bit
750 twiddling on IEEE compatible numbers (float). Note that one needs to
751 use at least [double] precision for an accurate mantissa of 32 bit
752 numbers.
753 * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
754 * use processor specific assembler instruction (asm).
755
756 The most portable way would be [bit], but is it efficient enough?
757 I have measured the cycle counts of the different methods on an AMD
758 Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
759
760 highestBitMask: method cycles
761 --------------
762 frexp 200
763 float 33
764 bit 11
765 asm 12
766
767 highestBit: method cycles
768 --------------
769 frexp 195
770 float 33
771 bit 11
772 asm 11
773
774 Wow, the bit twiddling is on today's RISC like machines even faster
775 than a single CISC instruction (BSR)!
776 ----------------------------------------------------------------------}
777
778 {----------------------------------------------------------------------
779 [highestBitMask] returns a word where only the highest bit is set.
780 It is found by first setting all bits in lower positions than the
781 highest bit and than taking an exclusive or with the original value.
782 Allthough the function may look expensive, GHC compiles this into
783 excellent C code that subsequently compiled into highly efficient
784 machine code. The algorithm is derived from Jorg Arndt's FXT library.
785 ----------------------------------------------------------------------}
786 highestBitMask :: Nat -> Nat
787 highestBitMask x
788 = case (x .|. shiftRL x 1) of
789 x -> case (x .|. shiftRL x 2) of
790 x -> case (x .|. shiftRL x 4) of
791 x -> case (x .|. shiftRL x 8) of
792 x -> case (x .|. shiftRL x 16) of
793 x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms
794 x -> (x `xor` (shiftRL x 1))
795
796
797 {--------------------------------------------------------------------
798 Utilities
799 --------------------------------------------------------------------}
800 foldlStrict f z xs
801 = case xs of
802 [] -> z
803 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
804
805
806 {-
807 {--------------------------------------------------------------------
808 Testing
809 --------------------------------------------------------------------}
810 testTree :: [Int] -> IntSet
811 testTree xs = fromList xs
812 test1 = testTree [1..20]
813 test2 = testTree [30,29..10]
814 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
815
816 {--------------------------------------------------------------------
817 QuickCheck
818 --------------------------------------------------------------------}
819 qcheck prop
820 = check config prop
821 where
822 config = Config
823 { configMaxTest = 500
824 , configMaxFail = 5000
825 , configSize = \n -> (div n 2 + 3)
826 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
827 }
828
829
830 {--------------------------------------------------------------------
831 Arbitrary, reasonably balanced trees
832 --------------------------------------------------------------------}
833 instance Arbitrary IntSet where
834 arbitrary = do{ xs <- arbitrary
835 ; return (fromList xs)
836 }
837
838
839 {--------------------------------------------------------------------
840 Single, Insert, Delete
841 --------------------------------------------------------------------}
842 prop_Single :: Int -> Bool
843 prop_Single x
844 = (insert x empty == singleton x)
845
846 prop_InsertDelete :: Int -> IntSet -> Property
847 prop_InsertDelete k t
848 = not (member k t) ==> delete k (insert k t) == t
849
850
851 {--------------------------------------------------------------------
852 Union
853 --------------------------------------------------------------------}
854 prop_UnionInsert :: Int -> IntSet -> Bool
855 prop_UnionInsert x t
856 = union t (singleton x) == insert x t
857
858 prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool
859 prop_UnionAssoc t1 t2 t3
860 = union t1 (union t2 t3) == union (union t1 t2) t3
861
862 prop_UnionComm :: IntSet -> IntSet -> Bool
863 prop_UnionComm t1 t2
864 = (union t1 t2 == union t2 t1)
865
866 prop_Diff :: [Int] -> [Int] -> Bool
867 prop_Diff xs ys
868 = toAscList (difference (fromList xs) (fromList ys))
869 == List.sort ((List.\\) (nub xs) (nub ys))
870
871 prop_Int :: [Int] -> [Int] -> Bool
872 prop_Int xs ys
873 = toAscList (intersection (fromList xs) (fromList ys))
874 == List.sort (nub ((List.intersect) (xs) (ys)))
875
876 {--------------------------------------------------------------------
877 Lists
878 --------------------------------------------------------------------}
879 prop_Ordered
880 = forAll (choose (5,100)) $ \n ->
881 let xs = [0..n::Int]
882 in fromAscList xs == fromList xs
883
884 prop_List :: [Int] -> Bool
885 prop_List xs
886 = (sort (nub xs) == toAscList (fromList xs))
887 -}