Data/IntSet.hs

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