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.Typeable
  98
  99 {-
 100 -- just for testing
 101 import QuickCheck
 102 import List (nub,sort)
 103 import qualified List
 104 -}
 105
 106 #if __GLASGOW_HASKELL__
 107 import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec)
 108 import Data.Generics.Basics
 109 import Data.Generics.Instances
 110 #endif
 111
 112 #if __GLASGOW_HASKELL__ >= 503
 113 import GHC.Word
 114 import GHC.Exts ( Word(..), Int(..), shiftRL# )
 115 #elif __GLASGOW_HASKELL__
 116 import Word
 117 import GlaExts ( Word(..), Int(..), shiftRL# )
 118 #else
 119 import Data.Word
 120 #endif
 121
 122 infixl 9 \\{-This comment teaches CPP correct behaviour -}
 123
 124 -- A "Nat" is a natural machine word (an unsigned Int)
 125 type Nat = Word
 126
 127 natFromInt :: Int -> Nat
 128 natFromInt i = fromIntegral i
 129
 130 intFromNat :: Nat -> Int
 131 intFromNat w = fromIntegral w
 132
 133 shiftRL :: Nat -> Int -> Nat
 134 #if __GLASGOW_HASKELL__
 135 {--------------------------------------------------------------------
 136   GHC: use unboxing to get @shiftRL@ inlined.
 137 --------------------------------------------------------------------}
 138 shiftRL (W# x) (I# i)
 139   = W# (shiftRL# x i)
 140 #else
 141 shiftRL x i   = shiftR x i
 142 #endif
 143
 144 {--------------------------------------------------------------------
 145   Operators
 146 --------------------------------------------------------------------}
 147 -- | /O(n+m)/. See 'difference'.
 148 (\\) :: IntSet -> IntSet -> IntSet
 149 m1 \\ m2 = difference m1 m2
 150
 151 {--------------------------------------------------------------------
 152   Types
 153 --------------------------------------------------------------------}
 154 -- | A set of integers.
 155 data IntSet = Nil
 156             | Tip {-# UNPACK #-} !Int
 157             | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntSet !IntSet
 158
 159 type Prefix = Int
 160 type Mask   = Int
 161
 162 #if __GLASGOW_HASKELL__
 163
 164 {--------------------------------------------------------------------
 165   A Data instance
 166 --------------------------------------------------------------------}
 167
 168 -- This instance preserves data abstraction at the cost of inefficiency.
 169 -- We omit reflection services for the sake of data abstraction.
 170
 171 instance Data IntSet where
 172   gfoldl f z is = z fromList `f` (toList is)
 173   toConstr _    = error "toConstr"
 174   gunfold _ _   = error "gunfold"
 175   dataTypeOf _  = mkNorepType "Data.IntSet.IntSet"
 176
 177 #endif
 178
 179 {--------------------------------------------------------------------
 180   Query
 181 --------------------------------------------------------------------}
 182 -- | /O(1)/. Is the set empty?
 183 null :: IntSet -> Bool
 184 null Nil   = True
 185 null other = False
 186
 187 -- | /O(n)/. Cardinality of the set.
 188 size :: IntSet -> Int
 189 size t
 190   = case t of
 191       Bin p m l r -> size l + size r
 192       Tip y -> 1
 193       Nil   -> 0
 194
 195 -- | /O(min(n,W))/. Is the value a member of the set?
 196 member :: Int -> IntSet -> Bool
 197 member x t
 198   = case t of
 199       Bin p m l r
 200         | nomatch x p m -> False
 201         | zero x m      -> member x l
 202         | otherwise     -> member x r
 203       Tip y -> (x==y)
 204       Nil   -> False
 205
 206 -- 'lookup' is used by 'intersection' for left-biasing
 207 lookup :: Int -> IntSet -> Maybe Int
 208 lookup k t
 209   = let nk = natFromInt k  in seq nk (lookupN nk t)
 210
 211 lookupN :: Nat -> IntSet -> Maybe Int
 212 lookupN k t
 213   = case t of
 214       Bin p m l r
 215         | zeroN k (natFromInt m) -> lookupN k l
 216         | otherwise              -> lookupN k r
 217       Tip kx
 218         | (k == natFromInt kx)  -> Just kx
 219         | otherwise             -> Nothing
 220       Nil -> Nothing
 221
 222 {--------------------------------------------------------------------
 223   Construction
 224 --------------------------------------------------------------------}
 225 -- | /O(1)/. The empty set.
 226 empty :: IntSet
 227 empty
 228   = Nil
 229
 230 -- | /O(1)/. A set of one element.
 231 singleton :: Int -> IntSet
 232 singleton x
 233   = Tip x
 234
 235 {--------------------------------------------------------------------
 236   Insert
 237 --------------------------------------------------------------------}
 238 -- | /O(min(n,W))/. Add a value to the set. When the value is already
 239 -- an element of the set, it is replaced by the new one, ie. 'insert'
 240 -- is left-biased.
 241 insert :: Int -> IntSet -> IntSet
 242 insert x t
 243   = case t of
 244       Bin p m l r
 245         | nomatch x p m -> join x (Tip x) p t
 246         | zero x m      -> Bin p m (insert x l) r
 247         | otherwise     -> Bin p m l (insert x r)
 248       Tip y
 249         | x==y          -> Tip x
 250         | otherwise     -> join x (Tip x) y t
 251       Nil -> Tip x
 252
 253 -- right-biased insertion, used by 'union'
 254 insertR :: Int -> IntSet -> IntSet
 255 insertR x t
 256   = case t of
 257       Bin p m l r
 258         | nomatch x p m -> join x (Tip x) p t
 259         | zero x m      -> Bin p m (insert x l) r
 260         | otherwise     -> Bin p m l (insert x r)
 261       Tip y
 262         | x==y          -> t
 263         | otherwise     -> join x (Tip x) y t
 264       Nil -> Tip x
 265
 266 -- | /O(min(n,W))/. Delete a value in the set. Returns the
 267 -- original set when the value was not present.
 268 delete :: Int -> IntSet -> IntSet
 269 delete x t
 270   = case t of
 271       Bin p m l r
 272         | nomatch x p m -> t
 273         | zero x m      -> bin p m (delete x l) r
 274         | otherwise     -> bin p m l (delete x r)
 275       Tip y
 276         | x==y          -> Nil
 277         | otherwise     -> t
 278       Nil -> Nil
 279
 280
 281 {--------------------------------------------------------------------
 282   Union
 283 --------------------------------------------------------------------}
 284 -- | The union of a list of sets.
 285 unions :: [IntSet] -> IntSet
 286 unions xs
 287   = foldlStrict union empty xs
 288
 289
 290 -- | /O(n+m)/. The union of two sets.
 291 union :: IntSet -> IntSet -> IntSet
 292 union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 293   | shorter m1 m2  = union1
 294   | shorter m2 m1  = union2
 295   | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)
 296   | otherwise      = join p1 t1 p2 t2
 297   where
 298     union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2
 299             | zero p2 m1        = Bin p1 m1 (union l1 t2) r1
 300             | otherwise         = Bin p1 m1 l1 (union r1 t2)
 301
 302     union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2
 303             | zero p1 m2        = Bin p2 m2 (union t1 l2) r2
 304             | otherwise         = Bin p2 m2 l2 (union t1 r2)
 305
 306 union (Tip x) t = insert x t
 307 union t (Tip x) = insertR x t  -- right bias
 308 union Nil t     = t
 309 union t Nil     = t
 310
 311
 312 {--------------------------------------------------------------------
 313   Difference
 314 --------------------------------------------------------------------}
 315 -- | /O(n+m)/. Difference between two sets.
 316 difference :: IntSet -> IntSet -> IntSet
 317 difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 318   | shorter m1 m2  = difference1
 319   | shorter m2 m1  = difference2
 320   | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)
 321   | otherwise      = t1
 322   where
 323     difference1 | nomatch p2 p1 m1  = t1
 324                 | zero p2 m1        = bin p1 m1 (difference l1 t2) r1
 325                 | otherwise         = bin p1 m1 l1 (difference r1 t2)
 326
 327     difference2 | nomatch p1 p2 m2  = t1
 328                 | zero p1 m2        = difference t1 l2
 329                 | otherwise         = difference t1 r2
 330
 331 difference t1@(Tip x) t2
 332   | member x t2  = Nil
 333   | otherwise    = t1
 334
 335 difference Nil t     = Nil
 336 difference t (Tip x) = delete x t
 337 difference t Nil     = t
 338
 339
 340
 341 {--------------------------------------------------------------------
 342   Intersection
 343 --------------------------------------------------------------------}
 344 -- | /O(n+m)/. The intersection of two sets.
 345 intersection :: IntSet -> IntSet -> IntSet
 346 intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 347   | shorter m1 m2  = intersection1
 348   | shorter m2 m1  = intersection2
 349   | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
 350   | otherwise      = Nil
 351   where
 352     intersection1 | nomatch p2 p1 m1  = Nil
 353                   | zero p2 m1        = intersection l1 t2
 354                   | otherwise         = intersection r1 t2
 355
 356     intersection2 | nomatch p1 p2 m2  = Nil
 357                   | zero p1 m2        = intersection t1 l2
 358                   | otherwise         = intersection t1 r2
 359
 360 intersection t1@(Tip x) t2
 361   | member x t2  = t1
 362   | otherwise    = Nil
 363 intersection t (Tip x)
 364   = case lookup x t of
 365       Just y  -> Tip y
 366       Nothing -> Nil
 367 intersection Nil t = Nil
 368 intersection t Nil = Nil
 369
 370
 371
 372 {--------------------------------------------------------------------
 373   Subset
 374 --------------------------------------------------------------------}
 375 -- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
 376 isProperSubsetOf :: IntSet -> IntSet -> Bool
 377 isProperSubsetOf t1 t2
 378   = case subsetCmp t1 t2 of
 379       LT -> True
 380       ge -> False
 381
 382 subsetCmp t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 383   | shorter m1 m2  = GT
 384   | shorter m2 m1  = subsetCmpLt
 385   | p1 == p2       = subsetCmpEq
 386   | otherwise      = GT  -- disjoint
 387   where
 388     subsetCmpLt | nomatch p1 p2 m2  = GT
 389                 | zero p1 m2        = subsetCmp t1 l2
 390                 | otherwise         = subsetCmp t1 r2
 391     subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of
 392                     (GT,_ ) -> GT
 393                     (_ ,GT) -> GT
 394                     (EQ,EQ) -> EQ
 395                     other   -> LT
 396
 397 subsetCmp (Bin p m l r) t  = GT
 398 subsetCmp (Tip x) (Tip y)
 399   | x==y       = EQ
 400   | otherwise  = GT  -- disjoint
 401 subsetCmp (Tip x) t
 402   | member x t = LT
 403   | otherwise  = GT  -- disjoint
 404 subsetCmp Nil Nil = EQ
 405 subsetCmp Nil t   = LT
 406
 407 -- | /O(n+m)/. Is this a subset?
 408 -- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
 409
 410 isSubsetOf :: IntSet -> IntSet -> Bool
 411 isSubsetOf t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 412   | shorter m1 m2  = False
 413   | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2
 414                                                       else isSubsetOf t1 r2)
 415   | otherwise      = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2
 416 isSubsetOf (Bin p m l r) t  = False
 417 isSubsetOf (Tip x) t        = member x t
 418 isSubsetOf Nil t            = True
 419
 420
 421 {--------------------------------------------------------------------
 422   Filter
 423 --------------------------------------------------------------------}
 424 -- | /O(n)/. Filter all elements that satisfy some predicate.
 425 filter :: (Int -> Bool) -> IntSet -> IntSet
 426 filter pred t
 427   = case t of
 428       Bin p m l r
 429         -> bin p m (filter pred l) (filter pred r)
 430       Tip x
 431         | pred x    -> t
 432         | otherwise -> Nil
 433       Nil -> Nil
 434
 435 -- | /O(n)/. partition the set according to some predicate.
 436 partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet)
 437 partition pred t
 438   = case t of
 439       Bin p m l r
 440         -> let (l1,l2) = partition pred l
 441                (r1,r2) = partition pred r
 442            in (bin p m l1 r1, bin p m l2 r2)
 443       Tip x
 444         | pred x    -> (t,Nil)
 445         | otherwise -> (Nil,t)
 446       Nil -> (Nil,Nil)
 447
 448
 449 -- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@
 450 -- where all elements in @set1@ are lower than @x@ and all elements in
 451 -- @set2@ larger than @x@.
 452 --
 453 -- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [3,4])
 454 split :: Int -> IntSet -> (IntSet,IntSet)
 455 split x t
 456   = case t of
 457       Bin p m l r
 458         | zero x m  -> let (lt,gt) = split x l in (lt,union gt r)
 459         | otherwise -> let (lt,gt) = split x r in (union l lt,gt)
 460       Tip y
 461         | x>y       -> (t,Nil)
 462         | x<y       -> (Nil,t)
 463         | otherwise -> (Nil,Nil)
 464       Nil -> (Nil,Nil)
 465
 466 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
 467 -- element was found in the original set.
 468 splitMember :: Int -> IntSet -> (IntSet,Bool,IntSet)
 469 splitMember x t
 470   = case t of
 471       Bin p m l r
 472         | zero x m  -> let (lt,found,gt) = splitMember x l in (lt,found,union gt r)
 473         | otherwise -> let (lt,found,gt) = splitMember x r in (union l lt,found,gt)
 474       Tip y
 475         | x>y       -> (t,False,Nil)
 476         | x<y       -> (Nil,False,t)
 477         | otherwise -> (Nil,True,Nil)
 478       Nil -> (Nil,False,Nil)
 479
 480 {----------------------------------------------------------------------
 481   Map
 482 ----------------------------------------------------------------------}
 483
 484 -- | /O(n*min(n,W))/.
 485 -- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
 486 --
 487 -- It's worth noting that the size of the result may be smaller if,
 488 -- for some @(x,y)@, @x \/= y && f x == f y@
 489
 490 map :: (Int->Int) -> IntSet -> IntSet
 491 map f = fromList . List.map f . toList
 492
 493 {--------------------------------------------------------------------
 494   Fold
 495 --------------------------------------------------------------------}
 496 -- | /O(n)/. Fold over the elements of a set in an unspecified order.
 497 --
 498 -- > sum set   == fold (+) 0 set
 499 -- > elems set == fold (:) [] set
 500 fold :: (Int -> b -> b) -> b -> IntSet -> b
 501 fold f z t
 502   = foldr f z t
 503
 504 foldr :: (Int -> b -> b) -> b -> IntSet -> b
 505 foldr f z t
 506   = case t of
 507       Bin p m l r -> foldr f (foldr f z r) l
 508       Tip x       -> f x z
 509       Nil         -> z
 510
 511 {--------------------------------------------------------------------
 512   List variations
 513 --------------------------------------------------------------------}
 514 -- | /O(n)/. The elements of a set. (For sets, this is equivalent to toList)
 515 elems :: IntSet -> [Int]
 516 elems s
 517   = toList s
 518
 519 {--------------------------------------------------------------------
 520   Lists
 521 --------------------------------------------------------------------}
 522 -- | /O(n)/. Convert the set to a list of elements.
 523 toList :: IntSet -> [Int]
 524 toList t
 525   = fold (:) [] t
 526
 527 -- | /O(n)/. Convert the set to an ascending list of elements.
 528 toAscList :: IntSet -> [Int]
 529 toAscList t
 530   = -- NOTE: the following algorithm only works for big-endian trees
 531     let (pos,neg) = span (>=0) (foldr (:) [] t) in neg ++ pos
 532
 533 -- | /O(n*min(n,W))/. Create a set from a list of integers.
 534 fromList :: [Int] -> IntSet
 535 fromList xs
 536   = foldlStrict ins empty xs
 537   where
 538     ins t x  = insert x t
 539
 540 -- | /O(n*min(n,W))/. Build a set from an ascending list of elements.
 541 fromAscList :: [Int] -> IntSet
 542 fromAscList xs
 543   = fromList xs
 544
 545 -- | /O(n*min(n,W))/. Build a set from an ascending list of distinct elements.
 546 fromDistinctAscList :: [Int] -> IntSet
 547 fromDistinctAscList xs
 548   = fromList xs
 549
 550
 551 {--------------------------------------------------------------------
 552   Eq
 553 --------------------------------------------------------------------}
 554 instance Eq IntSet where
 555   t1 == t2  = equal t1 t2
 556   t1 /= t2  = nequal t1 t2
 557
 558 equal :: IntSet -> IntSet -> Bool
 559 equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
 560   = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
 561 equal (Tip x) (Tip y)
 562   = (x==y)
 563 equal Nil Nil = True
 564 equal t1 t2   = False
 565
 566 nequal :: IntSet -> IntSet -> Bool
 567 nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
 568   = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
 569 nequal (Tip x) (Tip y)
 570   = (x/=y)
 571 nequal Nil Nil = False
 572 nequal t1 t2   = True
 573
 574 {--------------------------------------------------------------------
 575   Ord
 576 --------------------------------------------------------------------}
 577
 578 instance Ord IntSet where
 579     compare s1 s2 = compare (toAscList s1) (toAscList s2)
 580     -- tentative implementation. See if more efficient exists.
 581
 582 {--------------------------------------------------------------------
 583   Show
 584 --------------------------------------------------------------------}
 585 instance Show IntSet where
 586   showsPrec p xs = showParen (p > 10) $
 587     showString "fromList " . shows (toList xs)
 588
 589 showSet :: [Int] -> ShowS
 590 showSet []
 591   = showString "{}"
 592 showSet (x:xs)
 593   = showChar '{' . shows x . showTail xs
 594   where
 595     showTail []     = showChar '}'
 596     showTail (x:xs) = showChar ',' . shows x . showTail xs
 597
 598 {--------------------------------------------------------------------
 599   Read
 600 --------------------------------------------------------------------}
 601 instance Read IntSet where
 602 #ifdef __GLASGOW_HASKELL__
 603   readPrec = parens $ prec 10 $ do
 604     Ident "fromList" <- lexP
 605     xs <- readPrec
 606     return (fromList xs)
 607 #else
 608   readsPrec p = readParen (p > 10) $ \ r -> do
 609     ("fromList",s) <- lex
 610     (xs,t) <- reads
 611     return (fromList xs,t)
 612 #endif
 613
 614 {--------------------------------------------------------------------
 615   Typeable
 616 --------------------------------------------------------------------}
 617
 618 #include "Typeable.h"
 619 INSTANCE_TYPEABLE0(IntSet,intSetTc,"IntSet")
 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 -}