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