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
 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
 608   readListPrec = readListPrecDefault
 609 #else
 610   readsPrec p = readParen (p > 10) $ \ r -> do
 611     ("fromList",s) <- lex r
 612     (xs,t) <- reads s
 613     return (fromList xs,t)
 614 #endif
 615
 616 {--------------------------------------------------------------------
 617   Typeable
 618 --------------------------------------------------------------------}
 619
 620 #include "Typeable.h"
 621 INSTANCE_TYPEABLE0(IntSet,intSetTc,"IntSet")
 622
 623 {--------------------------------------------------------------------
 624   Debugging
 625 --------------------------------------------------------------------}
 626 -- | /O(n)/. Show the tree that implements the set. The tree is shown
 627 -- in a compressed, hanging format.
 628 showTree :: IntSet -> String
 629 showTree s
 630   = showTreeWith True False s
 631
 632
 633 {- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
 634  the tree that implements the set. If @hang@ is
 635  'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
 636  @wide@ is 'True', an extra wide version is shown.
 637 -}
 638 showTreeWith :: Bool -> Bool -> IntSet -> String
 639 showTreeWith hang wide t
 640   | hang      = (showsTreeHang wide [] t) ""
 641   | otherwise = (showsTree wide [] [] t) ""
 642
 643 showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS
 644 showsTree wide lbars rbars t
 645   = case t of
 646       Bin p m l r
 647           -> showsTree wide (withBar rbars) (withEmpty rbars) r .
 648              showWide wide rbars .
 649              showsBars lbars . showString (showBin p m) . showString "\n" .
 650              showWide wide lbars .
 651              showsTree wide (withEmpty lbars) (withBar lbars) l
 652       Tip x
 653           -> showsBars lbars . showString " " . shows x . showString "\n"
 654       Nil -> showsBars lbars . showString "|\n"
 655
 656 showsTreeHang :: Bool -> [String] -> IntSet -> ShowS
 657 showsTreeHang wide bars t
 658   = case t of
 659       Bin p m l r
 660           -> showsBars bars . showString (showBin p m) . showString "\n" .
 661              showWide wide bars .
 662              showsTreeHang wide (withBar bars) l .
 663              showWide wide bars .
 664              showsTreeHang wide (withEmpty bars) r
 665       Tip x
 666           -> showsBars bars . showString " " . shows x . showString "\n"
 667       Nil -> showsBars bars . showString "|\n"
 668
 669 showBin p m
 670   = "*" -- ++ show (p,m)
 671
 672 showWide wide bars
 673   | wide      = showString (concat (reverse bars)) . showString "|\n"
 674   | otherwise = id
 675
 676 showsBars :: [String] -> ShowS
 677 showsBars bars
 678   = case bars of
 679       [] -> id
 680       _  -> showString (concat (reverse (tail bars))) . showString node
 681
 682 node           = "+--"
 683 withBar bars   = "|  ":bars
 684 withEmpty bars = "   ":bars
 685
 686
 687 {--------------------------------------------------------------------
 688   Helpers
 689 --------------------------------------------------------------------}
 690 {--------------------------------------------------------------------
 691   Join
 692 --------------------------------------------------------------------}
 693 join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet
 694 join p1 t1 p2 t2
 695   | zero p1 m = Bin p m t1 t2
 696   | otherwise = Bin p m t2 t1
 697   where
 698     m = branchMask p1 p2
 699     p = mask p1 m
 700
 701 {--------------------------------------------------------------------
 702   @bin@ assures that we never have empty trees within a tree.
 703 --------------------------------------------------------------------}
 704 bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
 705 bin p m l Nil = l
 706 bin p m Nil r = r
 707 bin p m l r   = Bin p m l r
 708
 709
 710 {--------------------------------------------------------------------
 711   Endian independent bit twiddling
 712 --------------------------------------------------------------------}
 713 zero :: Int -> Mask -> Bool
 714 zero i m
 715   = (natFromInt i) .&. (natFromInt m) == 0
 716
 717 nomatch,match :: Int -> Prefix -> Mask -> Bool
 718 nomatch i p m
 719   = (mask i m) /= p
 720
 721 match i p m
 722   = (mask i m) == p
 723
 724 mask :: Int -> Mask -> Prefix
 725 mask i m
 726   = maskW (natFromInt i) (natFromInt m)
 727
 728 zeroN :: Nat -> Nat -> Bool
 729 zeroN i m = (i .&. m) == 0
 730
 731 {--------------------------------------------------------------------
 732   Big endian operations
 733 --------------------------------------------------------------------}
 734 maskW :: Nat -> Nat -> Prefix
 735 maskW i m
 736   = intFromNat (i .&. (complement (m-1) `xor` m))
 737
 738 shorter :: Mask -> Mask -> Bool
 739 shorter m1 m2
 740   = (natFromInt m1) > (natFromInt m2)
 741
 742 branchMask :: Prefix -> Prefix -> Mask
 743 branchMask p1 p2
 744   = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
 745
 746 {----------------------------------------------------------------------
 747   Finding the highest bit (mask) in a word [x] can be done efficiently in
 748   three ways:
 749   * convert to a floating point value and the mantissa tells us the
 750     [log2(x)] that corresponds with the highest bit position. The mantissa
 751     is retrieved either via the standard C function [frexp] or by some bit
 752     twiddling on IEEE compatible numbers (float). Note that one needs to
 753     use at least [double] precision for an accurate mantissa of 32 bit
 754     numbers.
 755   * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
 756   * use processor specific assembler instruction (asm).
 757
 758   The most portable way would be [bit], but is it efficient enough?
 759   I have measured the cycle counts of the different methods on an AMD
 760   Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
 761
 762   highestBitMask: method  cycles
 763                   --------------
 764                    frexp   200
 765                    float    33
 766                    bit      11
 767                    asm      12
 768
 769   highestBit:     method  cycles
 770                   --------------
 771                    frexp   195
 772                    float    33
 773                    bit      11
 774                    asm      11
 775
 776   Wow, the bit twiddling is on today's RISC like machines even faster
 777   than a single CISC instruction (BSR)!
 778 ----------------------------------------------------------------------}
 779
 780 {----------------------------------------------------------------------
 781   [highestBitMask] returns a word where only the highest bit is set.
 782   It is found by first setting all bits in lower positions than the
 783   highest bit and than taking an exclusive or with the original value.
 784   Allthough the function may look expensive, GHC compiles this into
 785   excellent C code that subsequently compiled into highly efficient
 786   machine code. The algorithm is derived from Jorg Arndt's FXT library.
 787 ----------------------------------------------------------------------}
 788 highestBitMask :: Nat -> Nat
 789 highestBitMask x
 790   = case (x .|. shiftRL x 1) of
 791      x -> case (x .|. shiftRL x 2) of
 792       x -> case (x .|. shiftRL x 4) of
 793        x -> case (x .|. shiftRL x 8) of
 794         x -> case (x .|. shiftRL x 16) of
 795          x -> case (x .|. shiftRL x 32) of   -- for 64 bit platforms
 796           x -> (x `xor` (shiftRL x 1))
 797
 798
 799 {--------------------------------------------------------------------
 800   Utilities
 801 --------------------------------------------------------------------}
 802 foldlStrict f z xs
 803   = case xs of
 804       []     -> z
 805       (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
 806
 807
 808 {-
 809 {--------------------------------------------------------------------
 810   Testing
 811 --------------------------------------------------------------------}
 812 testTree :: [Int] -> IntSet
 813 testTree xs   = fromList xs
 814 test1 = testTree [1..20]
 815 test2 = testTree [30,29..10]
 816 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
 817
 818 {--------------------------------------------------------------------
 819   QuickCheck
 820 --------------------------------------------------------------------}
 821 qcheck prop
 822   = check config prop
 823   where
 824     config = Config
 825       { configMaxTest = 500
 826       , configMaxFail = 5000
 827       , configSize    = \n -> (div n 2 + 3)
 828       , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
 829       }
 830
 831
 832 {--------------------------------------------------------------------
 833   Arbitrary, reasonably balanced trees
 834 --------------------------------------------------------------------}
 835 instance Arbitrary IntSet where
 836   arbitrary = do{ xs <- arbitrary
 837                 ; return (fromList xs)
 838                 }
 839
 840
 841 {--------------------------------------------------------------------
 842   Single, Insert, Delete
 843 --------------------------------------------------------------------}
 844 prop_Single :: Int -> Bool
 845 prop_Single x
 846   = (insert x empty == singleton x)
 847
 848 prop_InsertDelete :: Int -> IntSet -> Property
 849 prop_InsertDelete k t
 850   = not (member k t) ==> delete k (insert k t) == t
 851
 852
 853 {--------------------------------------------------------------------
 854   Union
 855 --------------------------------------------------------------------}
 856 prop_UnionInsert :: Int -> IntSet -> Bool
 857 prop_UnionInsert x t
 858   = union t (singleton x) == insert x t
 859
 860 prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool
 861 prop_UnionAssoc t1 t2 t3
 862   = union t1 (union t2 t3) == union (union t1 t2) t3
 863
 864 prop_UnionComm :: IntSet -> IntSet -> Bool
 865 prop_UnionComm t1 t2
 866   = (union t1 t2 == union t2 t1)
 867
 868 prop_Diff :: [Int] -> [Int] -> Bool
 869 prop_Diff xs ys
 870   =  toAscList (difference (fromList xs) (fromList ys))
 871     == List.sort ((List.\\) (nub xs)  (nub ys))
 872
 873 prop_Int :: [Int] -> [Int] -> Bool
 874 prop_Int xs ys
 875   =  toAscList (intersection (fromList xs) (fromList ys))
 876     == List.sort (nub ((List.intersect) (xs)  (ys)))
 877
 878 {--------------------------------------------------------------------
 879   Lists
 880 --------------------------------------------------------------------}
 881 prop_Ordered
 882   = forAll (choose (5,100)) $ \n ->
 883     let xs = [0..n::Int]
 884     in fromAscList xs == fromList xs
 885
 886 prop_List :: [Int] -> Bool
 887 prop_List xs
 888   = (sort (nub xs) == toAscList (fromList xs))
 889 -}