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