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