Data/IntSet.hs

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