Data/IntMap.hs

   1 {-# OPTIONS -cpp -fglasgow-exts #-}
   2 -----------------------------------------------------------------------------
   3 -- Module      :  Data.IntMap
   4 -- Copyright   :  (c) Daan Leijen 2002
   5 -- License     :  BSD-style
   6 -- Maintainer  :  libraries@haskell.org
   7 -- Stability   :  provisional
   8 -- Portability :  portable
   9 --
  10 -- An efficient implementation of maps from integer keys to values.
  11 --
  12 -- This module is intended to be imported @qualified@, to avoid name
  13 -- clashes with "Prelude" functions.  eg.
  14 --
  15 -- >  import Data.IntMap as Map
  16 --
  17 -- The implementation is based on /big-endian patricia trees/.  This data
  18 -- structure performs especially well on binary operations like 'union'
  19 -- and 'intersection'.  However, my benchmarks show that it is also
  20 -- (much) faster on insertions and deletions when compared to a generic
  21 -- size-balanced map implementation (see "Data.Map" and "Data.FiniteMap").
  22 --
  23 --    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",
  24 --      Workshop on ML, September 1998, pages 77-86,
  25 --      <http://www.cse.ogi.edu/~andy/pub/finite.htm>
  26 --
  27 --    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
  28 --      Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
  29 --      October 1968, pages 514-534.
  30 --
  31 -- Many operations have a worst-case complexity of /O(min(n,W))/.
  32 -- This means that the operation can become linear in the number of
  33 -- elements with a maximum of /W/ -- the number of bits in an 'Int'
  34 -- (32 or 64).
  35 -----------------------------------------------------------------------------
  36
  37 module Data.IntMap  (
  38             -- * Map type
  39               IntMap, Key          -- instance Eq,Show
  40
  41             -- * Operators
  42             , (!), (\\)
  43
  44             -- * Query
  45             , null
  46             , size
  47             , member
  48             , lookup
  49             , findWithDefault
  50
  51             -- * Construction
  52             , empty
  53             , singleton
  54
  55             -- ** Insertion
  56             , insert
  57             , insertWith, insertWithKey, insertLookupWithKey
  58
  59             -- ** Delete\/Update
  60             , delete
  61             , adjust
  62             , adjustWithKey
  63             , update
  64             , updateWithKey
  65             , updateLookupWithKey
  66
  67             -- * Combine
  68
  69             -- ** Union
  70             , union
  71             , unionWith
  72             , unionWithKey
  73             , unions
  74             , unionsWith
  75
  76             -- ** Difference
  77             , difference
  78             , differenceWith
  79             , differenceWithKey
  80
  81             -- ** Intersection
  82             , intersection
  83             , intersectionWith
  84             , intersectionWithKey
  85
  86             -- * Traversal
  87             -- ** Map
  88             , map
  89             , mapWithKey
  90             , mapAccum
  91             , mapAccumWithKey
  92
  93             -- ** Fold
  94             , fold
  95             , foldWithKey
  96
  97             -- * Conversion
  98             , elems
  99             , keys
 100             , keysSet
 101             , assocs
 102
 103             -- ** Lists
 104             , toList
 105             , fromList
 106             , fromListWith
 107             , fromListWithKey
 108
 109             -- ** Ordered lists
 110             , toAscList
 111             , fromAscList
 112             , fromAscListWith
 113             , fromAscListWithKey
 114             , fromDistinctAscList
 115
 116             -- * Filter
 117             , filter
 118             , filterWithKey
 119             , partition
 120             , partitionWithKey
 121
 122             , split
 123             , splitLookup
 124
 125             -- * Submap
 126             , isSubmapOf, isSubmapOfBy
 127             , isProperSubmapOf, isProperSubmapOfBy
 128
 129             -- * Debugging
 130             , showTree
 131             , showTreeWith
 132             ) where
 133
 134
 135 import Prelude hiding (lookup,map,filter,foldr,foldl,null)
 136 import Data.Bits
 137 import Data.Int
 138 import Data.Monoid
 139 import qualified Data.IntSet as IntSet
 140
 141 {-
 142 -- just for testing
 143 import qualified Prelude
 144 import Debug.QuickCheck
 145 import List (nub,sort)
 146 import qualified List
 147 -}
 148
 149 #ifdef __GLASGOW_HASKELL__
 150 {--------------------------------------------------------------------
 151   GHC: use unboxing to get @shiftRL@ inlined.
 152 --------------------------------------------------------------------}
 153 #if __GLASGOW_HASKELL__ >= 503
 154 import GHC.Word
 155 import GHC.Exts ( Word(..), Int(..), shiftRL# )
 156 #else
 157 import Word
 158 import GlaExts ( Word(..), Int(..), shiftRL# )
 159 #endif
 160
 161 infixl 9 \\{-This comment teaches CPP correct behaviour -}
 162
 163 type Nat = Word
 164
 165 natFromInt :: Key -> Nat
 166 natFromInt i = fromIntegral i
 167
 168 intFromNat :: Nat -> Key
 169 intFromNat w = fromIntegral w
 170
 171 shiftRL :: Nat -> Key -> Nat
 172 shiftRL (W# x) (I# i)
 173   = W# (shiftRL# x i)
 174
 175 #elif __HUGS__
 176 {--------------------------------------------------------------------
 177  Hugs:
 178  * raises errors on boundary values when using 'fromIntegral'
 179    but not with the deprecated 'fromInt/toInt'.
 180  * Older Hugs doesn't define 'Word'.
 181  * Newer Hugs defines 'Word' in the Prelude but no operations.
 182 --------------------------------------------------------------------}
 183 import Data.Word
 184 infixl 9 \\
 185
 186 type Nat = Word32   -- illegal on 64-bit platforms!
 187
 188 natFromInt :: Key -> Nat
 189 natFromInt i = fromInt i
 190
 191 intFromNat :: Nat -> Key
 192 intFromNat w = toInt w
 193
 194 shiftRL :: Nat -> Key -> Nat
 195 shiftRL x i   = shiftR x i
 196
 197 #else
 198 {--------------------------------------------------------------------
 199   'Standard' Haskell
 200   * A "Nat" is a natural machine word (an unsigned Int)
 201 --------------------------------------------------------------------}
 202 import Data.Word
 203 infixl 9 \\
 204
 205 type Nat = Word
 206
 207 natFromInt :: Key -> Nat
 208 natFromInt i = fromIntegral i
 209
 210 intFromNat :: Nat -> Key
 211 intFromNat w = fromIntegral w
 212
 213 shiftRL :: Nat -> Key -> Nat
 214 shiftRL w i   = shiftR w i
 215
 216 #endif
 217
 218
 219 {--------------------------------------------------------------------
 220   Operators
 221 --------------------------------------------------------------------}
 222
 223 -- | /O(min(n,W))/. Find the value of a key. Calls @error@ when the element can not be found.
 224
 225 (!) :: IntMap a -> Key -> a
 226 m ! k    = find' k m
 227
 228 -- | /O(n+m)/. See 'difference'.
 229 (\\) :: IntMap a -> IntMap b -> IntMap a
 230 m1 \\ m2 = difference m1 m2
 231
 232 {--------------------------------------------------------------------
 233   Types
 234 --------------------------------------------------------------------}
 235 -- | A map of integers to values @a@.
 236 data IntMap a = Nil
 237               | Tip {-# UNPACK #-} !Key a
 238               | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a)
 239
 240 type Prefix = Int
 241 type Mask   = Int
 242 type Key    = Int
 243
 244 {--------------------------------------------------------------------
 245   Query
 246 --------------------------------------------------------------------}
 247 -- | /O(1)/. Is the map empty?
 248 null :: IntMap a -> Bool
 249 null Nil   = True
 250 null other = False
 251
 252 -- | /O(n)/. Number of elements in the map.
 253 size :: IntMap a -> Int
 254 size t
 255   = case t of
 256       Bin p m l r -> size l + size r
 257       Tip k x -> 1
 258       Nil     -> 0
 259
 260 -- | /O(min(n,W))/. Is the key a member of the map?
 261 member :: Key -> IntMap a -> Bool
 262 member k m
 263   = case lookup k m of
 264       Nothing -> False
 265       Just x  -> True
 266
 267 -- | /O(min(n,W))/. Lookup the value of a key in the map.
 268 lookup :: Key -> IntMap a -> Maybe a
 269 lookup k t
 270   = let nk = natFromInt k  in seq nk (lookupN nk t)
 271
 272 lookupN :: Nat -> IntMap a -> Maybe a
 273 lookupN k t
 274   = case t of
 275       Bin p m l r
 276         | zeroN k (natFromInt m) -> lookupN k l
 277         | otherwise              -> lookupN k r
 278       Tip kx x
 279         | (k == natFromInt kx)  -> Just x
 280         | otherwise             -> Nothing
 281       Nil -> Nothing
 282
 283 find' :: Key -> IntMap a -> a
 284 find' k m
 285   = case lookup k m of
 286       Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")
 287       Just x  -> x
 288
 289
 290 -- | /O(min(n,W))/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when
 291 -- the key is not an element of the map.
 292 findWithDefault :: a -> Key -> IntMap a -> a
 293 findWithDefault def k m
 294   = case lookup k m of
 295       Nothing -> def
 296       Just x  -> x
 297
 298 {--------------------------------------------------------------------
 299   Construction
 300 --------------------------------------------------------------------}
 301 -- | /O(1)/. The empty map.
 302 empty :: IntMap a
 303 empty
 304   = Nil
 305
 306 -- | /O(1)/. A map of one element.
 307 singleton :: Key -> a -> IntMap a
 308 singleton k x
 309   = Tip k x
 310
 311 {--------------------------------------------------------------------
 312   Insert
 313   'insert' is the inlined version of 'insertWith (\k x y -> x)'
 314 --------------------------------------------------------------------}
 315 -- | /O(min(n,W))/. Insert a new key\/value pair in the map. When the key
 316 -- is already an element of the set, its value is replaced by the new value,
 317 -- ie. 'insert' is left-biased.
 318 insert :: Key -> a -> IntMap a -> IntMap a
 319 insert k x t
 320   = case t of
 321       Bin p m l r
 322         | nomatch k p m -> join k (Tip k x) p t
 323         | zero k m      -> Bin p m (insert k x l) r
 324         | otherwise     -> Bin p m l (insert k x r)
 325       Tip ky y
 326         | k==ky         -> Tip k x
 327         | otherwise     -> join k (Tip k x) ky t
 328       Nil -> Tip k x
 329
 330 -- right-biased insertion, used by 'union'
 331 -- | /O(min(n,W))/. Insert with a combining function.
 332 insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
 333 insertWith f k x t
 334   = insertWithKey (\k x y -> f x y) k x t
 335
 336 -- | /O(min(n,W))/. Insert with a combining function.
 337 insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
 338 insertWithKey f k x t
 339   = case t of
 340       Bin p m l r
 341         | nomatch k p m -> join k (Tip k x) p t
 342         | zero k m      -> Bin p m (insertWithKey f k x l) r
 343         | otherwise     -> Bin p m l (insertWithKey f k x r)
 344       Tip ky y
 345         | k==ky         -> Tip k (f k x y)
 346         | otherwise     -> join k (Tip k x) ky t
 347       Nil -> Tip k x
 348
 349
 350 -- | /O(min(n,W))/. The expression (@insertLookupWithKey f k x map@) is a pair where
 351 -- the first element is equal to (@lookup k map@) and the second element
 352 -- equal to (@insertWithKey f k x map@).
 353 insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
 354 insertLookupWithKey f k x t
 355   = case t of
 356       Bin p m l r
 357         | nomatch k p m -> (Nothing,join k (Tip k x) p t)
 358         | zero k m      -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
 359         | otherwise     -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
 360       Tip ky y
 361         | k==ky         -> (Just y,Tip k (f k x y))
 362         | otherwise     -> (Nothing,join k (Tip k x) ky t)
 363       Nil -> (Nothing,Tip k x)
 364
 365
 366 {--------------------------------------------------------------------
 367   Deletion
 368   [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
 369 --------------------------------------------------------------------}
 370 -- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not
 371 -- a member of the map, the original map is returned.
 372 delete :: Key -> IntMap a -> IntMap a
 373 delete k t
 374   = case t of
 375       Bin p m l r
 376         | nomatch k p m -> t
 377         | zero k m      -> bin p m (delete k l) r
 378         | otherwise     -> bin p m l (delete k r)
 379       Tip ky y
 380         | k==ky         -> Nil
 381         | otherwise     -> t
 382       Nil -> Nil
 383
 384 -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
 385 -- a member of the map, the original map is returned.
 386 adjust ::  (a -> a) -> Key -> IntMap a -> IntMap a
 387 adjust f k m
 388   = adjustWithKey (\k x -> f x) k m
 389
 390 -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
 391 -- a member of the map, the original map is returned.
 392 adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a
 393 adjustWithKey f k m
 394   = updateWithKey (\k x -> Just (f k x)) k m
 395
 396 -- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@
 397 -- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is
 398 -- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
 399 update ::  (a -> Maybe a) -> Key -> IntMap a -> IntMap a
 400 update f k m
 401   = updateWithKey (\k x -> f x) k m
 402
 403 -- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@
 404 -- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is
 405 -- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
 406 updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
 407 updateWithKey f k t
 408   = case t of
 409       Bin p m l r
 410         | nomatch k p m -> t
 411         | zero k m      -> bin p m (updateWithKey f k l) r
 412         | otherwise     -> bin p m l (updateWithKey f k r)
 413       Tip ky y
 414         | k==ky         -> case (f k y) of
 415                              Just y' -> Tip ky y'
 416                              Nothing -> Nil
 417         | otherwise     -> t
 418       Nil -> Nil
 419
 420 -- | /O(min(n,W))/. Lookup and update.
 421 updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
 422 updateLookupWithKey f k t
 423   = case t of
 424       Bin p m l r
 425         | nomatch k p m -> (Nothing,t)
 426         | zero k m      -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)
 427         | otherwise     -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')
 428       Tip ky y
 429         | k==ky         -> case (f k y) of
 430                              Just y' -> (Just y,Tip ky y')
 431                              Nothing -> (Just y,Nil)
 432         | otherwise     -> (Nothing,t)
 433       Nil -> (Nothing,Nil)
 434
 435
 436 {--------------------------------------------------------------------
 437   Union
 438 --------------------------------------------------------------------}
 439 -- | The union of a list of maps.
 440 unions :: [IntMap a] -> IntMap a
 441 unions xs
 442   = foldlStrict union empty xs
 443
 444 -- | The union of a list of maps, with a combining operation
 445 unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a
 446 unionsWith f ts
 447   = foldlStrict (unionWith f) empty ts
 448
 449 -- | /O(n+m)/. The (left-biased) union of two sets.
 450 union :: IntMap a -> IntMap a -> IntMap a
 451 union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 452   | shorter m1 m2  = union1
 453   | shorter m2 m1  = union2
 454   | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)
 455   | otherwise      = join p1 t1 p2 t2
 456   where
 457     union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2
 458             | zero p2 m1        = Bin p1 m1 (union l1 t2) r1
 459             | otherwise         = Bin p1 m1 l1 (union r1 t2)
 460
 461     union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2
 462             | zero p1 m2        = Bin p2 m2 (union t1 l2) r2
 463             | otherwise         = Bin p2 m2 l2 (union t1 r2)
 464
 465 union (Tip k x) t = insert k x t
 466 union t (Tip k x) = insertWith (\x y -> y) k x t  -- right bias
 467 union Nil t       = t
 468 union t Nil       = t
 469
 470 -- | /O(n+m)/. The union with a combining function.
 471 unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
 472 unionWith f m1 m2
 473   = unionWithKey (\k x y -> f x y) m1 m2
 474
 475 -- | /O(n+m)/. The union with a combining function.
 476 unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
 477 unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 478   | shorter m1 m2  = union1
 479   | shorter m2 m1  = union2
 480   | p1 == p2       = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)
 481   | otherwise      = join p1 t1 p2 t2
 482   where
 483     union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2
 484             | zero p2 m1        = Bin p1 m1 (unionWithKey f l1 t2) r1
 485             | otherwise         = Bin p1 m1 l1 (unionWithKey f r1 t2)
 486
 487     union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2
 488             | zero p1 m2        = Bin p2 m2 (unionWithKey f t1 l2) r2
 489             | otherwise         = Bin p2 m2 l2 (unionWithKey f t1 r2)
 490
 491 unionWithKey f (Tip k x) t = insertWithKey f k x t
 492 unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t  -- right bias
 493 unionWithKey f Nil t  = t
 494 unionWithKey f t Nil  = t
 495
 496 {--------------------------------------------------------------------
 497   Difference
 498 --------------------------------------------------------------------}
 499 -- | /O(n+m)/. Difference between two maps (based on keys).
 500 difference :: IntMap a -> IntMap b -> IntMap a
 501 difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 502   | shorter m1 m2  = difference1
 503   | shorter m2 m1  = difference2
 504   | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)
 505   | otherwise      = t1
 506   where
 507     difference1 | nomatch p2 p1 m1  = t1
 508                 | zero p2 m1        = bin p1 m1 (difference l1 t2) r1
 509                 | otherwise         = bin p1 m1 l1 (difference r1 t2)
 510
 511     difference2 | nomatch p1 p2 m2  = t1
 512                 | zero p1 m2        = difference t1 l2
 513                 | otherwise         = difference t1 r2
 514
 515 difference t1@(Tip k x) t2
 516   | member k t2  = Nil
 517   | otherwise    = t1
 518
 519 difference Nil t       = Nil
 520 difference t (Tip k x) = delete k t
 521 difference t Nil       = t
 522
 523 -- | /O(n+m)/. Difference with a combining function.
 524 differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
 525 differenceWith f m1 m2
 526   = differenceWithKey (\k x y -> f x y) m1 m2
 527
 528 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
 529 -- encountered, the combining function is applied to the key and both values.
 530 -- If it returns @Nothing@, the element is discarded (proper set difference). If
 531 -- it returns (@Just y@), the element is updated with a new value @y@.
 532 differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
 533 differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 534   | shorter m1 m2  = difference1
 535   | shorter m2 m1  = difference2
 536   | p1 == p2       = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)
 537   | otherwise      = t1
 538   where
 539     difference1 | nomatch p2 p1 m1  = t1
 540                 | zero p2 m1        = bin p1 m1 (differenceWithKey f l1 t2) r1
 541                 | otherwise         = bin p1 m1 l1 (differenceWithKey f r1 t2)
 542
 543     difference2 | nomatch p1 p2 m2  = t1
 544                 | zero p1 m2        = differenceWithKey f t1 l2
 545                 | otherwise         = differenceWithKey f t1 r2
 546
 547 differenceWithKey f t1@(Tip k x) t2
 548   = case lookup k t2 of
 549       Just y  -> case f k x y of
 550                    Just y' -> Tip k y'
 551                    Nothing -> Nil
 552       Nothing -> t1
 553
 554 differenceWithKey f Nil t       = Nil
 555 differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t
 556 differenceWithKey f t Nil       = t
 557
 558
 559 {--------------------------------------------------------------------
 560   Intersection
 561 --------------------------------------------------------------------}
 562 -- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).
 563 intersection :: IntMap a -> IntMap b -> IntMap a
 564 intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 565   | shorter m1 m2  = intersection1
 566   | shorter m2 m1  = intersection2
 567   | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
 568   | otherwise      = Nil
 569   where
 570     intersection1 | nomatch p2 p1 m1  = Nil
 571                   | zero p2 m1        = intersection l1 t2
 572                   | otherwise         = intersection r1 t2
 573
 574     intersection2 | nomatch p1 p2 m2  = Nil
 575                   | zero p1 m2        = intersection t1 l2
 576                   | otherwise         = intersection t1 r2
 577
 578 intersection t1@(Tip k x) t2
 579   | member k t2  = t1
 580   | otherwise    = Nil
 581 intersection t (Tip k x)
 582   = case lookup k t of
 583       Just y  -> Tip k y
 584       Nothing -> Nil
 585 intersection Nil t = Nil
 586 intersection t Nil = Nil
 587
 588 -- | /O(n+m)/. The intersection with a combining function.
 589 intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
 590 intersectionWith f m1 m2
 591   = intersectionWithKey (\k x y -> f x y) m1 m2
 592
 593 -- | /O(n+m)/. The intersection with a combining function.
 594 intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
 595 intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 596   | shorter m1 m2  = intersection1
 597   | shorter m2 m1  = intersection2
 598   | p1 == p2       = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)
 599   | otherwise      = Nil
 600   where
 601     intersection1 | nomatch p2 p1 m1  = Nil
 602                   | zero p2 m1        = intersectionWithKey f l1 t2
 603                   | otherwise         = intersectionWithKey f r1 t2
 604
 605     intersection2 | nomatch p1 p2 m2  = Nil
 606                   | zero p1 m2        = intersectionWithKey f t1 l2
 607                   | otherwise         = intersectionWithKey f t1 r2
 608
 609 intersectionWithKey f t1@(Tip k x) t2
 610   = case lookup k t2 of
 611       Just y  -> Tip k (f k x y)
 612       Nothing -> Nil
 613 intersectionWithKey f t1 (Tip k y)
 614   = case lookup k t1 of
 615       Just x  -> Tip k (f k x y)
 616       Nothing -> Nil
 617 intersectionWithKey f Nil t = Nil
 618 intersectionWithKey f t Nil = Nil
 619
 620
 621 {--------------------------------------------------------------------
 622   Submap
 623 --------------------------------------------------------------------}
 624 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
 625 -- Defined as (@isProperSubmapOf = isProperSubmapOfBy (==)@).
 626 isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
 627 isProperSubmapOf m1 m2
 628   = isProperSubmapOfBy (==) m1 m2
 629
 630 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
 631  The expression (@isProperSubmapOfBy f m1 m2@) returns @True@ when
 632  @m1@ and @m2@ are not equal,
 633  all keys in @m1@ are in @m2@, and when @f@ returns @True@ when
 634  applied to their respective values. For example, the following
 635  expressions are all @True@.
 636
 637   > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 638   > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 639
 640  But the following are all @False@:
 641
 642   > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
 643   > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
 644   > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])
 645 -}
 646 isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
 647 isProperSubmapOfBy pred t1 t2
 648   = case submapCmp pred t1 t2 of
 649       LT -> True
 650       ge -> False
 651
 652 submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 653   | shorter m1 m2  = GT
 654   | shorter m2 m1  = submapCmpLt
 655   | p1 == p2       = submapCmpEq
 656   | otherwise      = GT  -- disjoint
 657   where
 658     submapCmpLt | nomatch p1 p2 m2  = GT
 659                 | zero p1 m2        = submapCmp pred t1 l2
 660                 | otherwise         = submapCmp pred t1 r2
 661     submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of
 662                     (GT,_ ) -> GT
 663                     (_ ,GT) -> GT
 664                     (EQ,EQ) -> EQ
 665                     other   -> LT
 666
 667 submapCmp pred (Bin p m l r) t  = GT
 668 submapCmp pred (Tip kx x) (Tip ky y)
 669   | (kx == ky) && pred x y = EQ
 670   | otherwise              = GT  -- disjoint
 671 submapCmp pred (Tip k x) t
 672   = case lookup k t of
 673      Just y  | pred x y -> LT
 674      other   -> GT -- disjoint
 675 submapCmp pred Nil Nil = EQ
 676 submapCmp pred Nil t   = LT
 677
 678 -- | /O(n+m)/. Is this a submap? Defined as (@isSubmapOf = isSubmapOfBy (==)@).
 679 isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
 680 isSubmapOf m1 m2
 681   = isSubmapOfBy (==) m1 m2
 682
 683 {- | /O(n+m)/.
 684  The expression (@isSubmapOfBy f m1 m2@) returns @True@ if
 685  all keys in @m1@ are in @m2@, and when @f@ returns @True@ when
 686  applied to their respective values. For example, the following
 687  expressions are all @True@.
 688
 689   > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 690   > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 691   > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
 692
 693  But the following are all @False@:
 694
 695   > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])
 696   > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 697   > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
 698 -}
 699
 700 isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
 701 isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 702   | shorter m1 m2  = False
 703   | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2
 704                                                       else isSubmapOfBy pred t1 r2)
 705   | otherwise      = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2
 706 isSubmapOfBy pred (Bin p m l r) t  = False
 707 isSubmapOfBy pred (Tip k x) t      = case lookup k t of
 708                                    Just y  -> pred x y
 709                                    Nothing -> False
 710 isSubmapOfBy pred Nil t            = True
 711
 712 {--------------------------------------------------------------------
 713   Mapping
 714 --------------------------------------------------------------------}
 715 -- | /O(n)/. Map a function over all values in the map.
 716 map :: (a -> b) -> IntMap a -> IntMap b
 717 map f m
 718   = mapWithKey (\k x -> f x) m
 719
 720 -- | /O(n)/. Map a function over all values in the map.
 721 mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
 722 mapWithKey f t
 723   = case t of
 724       Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
 725       Tip k x     -> Tip k (f k x)
 726       Nil         -> Nil
 727
 728 -- | /O(n)/. The function @mapAccum@ threads an accumulating
 729 -- argument through the map in an unspecified order.
 730 mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
 731 mapAccum f a m
 732   = mapAccumWithKey (\a k x -> f a x) a m
 733
 734 -- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating
 735 -- argument through the map in an unspecified order.
 736 mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
 737 mapAccumWithKey f a t
 738   = mapAccumL f a t
 739
 740 -- | /O(n)/. The function @mapAccumL@ threads an accumulating
 741 -- argument through the map in pre-order.
 742 mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
 743 mapAccumL f a t
 744   = case t of
 745       Bin p m l r -> let (a1,l') = mapAccumL f a l
 746                          (a2,r') = mapAccumL f a1 r
 747                      in (a2,Bin p m l' r')
 748       Tip k x     -> let (a',x') = f a k x in (a',Tip k x')
 749       Nil         -> (a,Nil)
 750
 751
 752 -- | /O(n)/. The function @mapAccumR@ threads an accumulating
 753 -- argument throught the map in post-order.
 754 mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
 755 mapAccumR f a t
 756   = case t of
 757       Bin p m l r -> let (a1,r') = mapAccumR f a r
 758                          (a2,l') = mapAccumR f a1 l
 759                      in (a2,Bin p m l' r')
 760       Tip k x     -> let (a',x') = f a k x in (a',Tip k x')
 761       Nil         -> (a,Nil)
 762
 763 {--------------------------------------------------------------------
 764   Filter
 765 --------------------------------------------------------------------}
 766 -- | /O(n)/. Filter all values that satisfy some predicate.
 767 filter :: (a -> Bool) -> IntMap a -> IntMap a
 768 filter p m
 769   = filterWithKey (\k x -> p x) m
 770
 771 -- | /O(n)/. Filter all keys\/values that satisfy some predicate.
 772 filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
 773 filterWithKey pred t
 774   = case t of
 775       Bin p m l r
 776         -> bin p m (filterWithKey pred l) (filterWithKey pred r)
 777       Tip k x
 778         | pred k x  -> t
 779         | otherwise -> Nil
 780       Nil -> Nil
 781
 782 -- | /O(n)/. partition the map according to some predicate. The first
 783 -- map contains all elements that satisfy the predicate, the second all
 784 -- elements that fail the predicate. See also 'split'.
 785 partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
 786 partition p m
 787   = partitionWithKey (\k x -> p x) m
 788
 789 -- | /O(n)/. partition the map according to some predicate. The first
 790 -- map contains all elements that satisfy the predicate, the second all
 791 -- elements that fail the predicate. See also 'split'.
 792 partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
 793 partitionWithKey pred t
 794   = case t of
 795       Bin p m l r
 796         -> let (l1,l2) = partitionWithKey pred l
 797                (r1,r2) = partitionWithKey pred r
 798            in (bin p m l1 r1, bin p m l2 r2)
 799       Tip k x
 800         | pred k x  -> (t,Nil)
 801         | otherwise -> (Nil,t)
 802       Nil -> (Nil,Nil)
 803
 804
 805 -- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@
 806 -- where all keys in @map1@ are lower than @k@ and all keys in
 807 -- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
 808 split :: Key -> IntMap a -> (IntMap a,IntMap a)
 809 split k t
 810   = case t of
 811       Bin p m l r
 812         | zero k m  -> let (lt,gt) = split k l in (lt,union gt r)
 813         | otherwise -> let (lt,gt) = split k r in (union l lt,gt)
 814       Tip ky y
 815         | k>ky      -> (t,Nil)
 816         | k<ky      -> (Nil,t)
 817         | otherwise -> (Nil,Nil)
 818       Nil -> (Nil,Nil)
 819
 820 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
 821 -- key was found in the original map.
 822 splitLookup :: Key -> IntMap a -> (Maybe a,IntMap a,IntMap a)
 823 splitLookup k t
 824   = case t of
 825       Bin p m l r
 826         | zero k m  -> let (found,lt,gt) = splitLookup k l in (found,lt,union gt r)
 827         | otherwise -> let (found,lt,gt) = splitLookup k r in (found,union l lt,gt)
 828       Tip ky y
 829         | k>ky      -> (Nothing,t,Nil)
 830         | k<ky      -> (Nothing,Nil,t)
 831         | otherwise -> (Just y,Nil,Nil)
 832       Nil -> (Nothing,Nil,Nil)
 833
 834 {--------------------------------------------------------------------
 835   Fold
 836 --------------------------------------------------------------------}
 837 -- | /O(n)/. Fold over the elements of a map in an unspecified order.
 838 --
 839 -- > sum map   = fold (+) 0 map
 840 -- > elems map = fold (:) [] map
 841 fold :: (a -> b -> b) -> b -> IntMap a -> b
 842 fold f z t
 843   = foldWithKey (\k x y -> f x y) z t
 844
 845 -- | /O(n)/. Fold over the elements of a map in an unspecified order.
 846 --
 847 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
 848 foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
 849 foldWithKey f z t
 850   = foldr f z t
 851
 852 foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
 853 foldr f z t
 854   = case t of
 855       Bin p m l r -> foldr f (foldr f z r) l
 856       Tip k x     -> f k x z
 857       Nil         -> z
 858
 859 {--------------------------------------------------------------------
 860   List variations
 861 --------------------------------------------------------------------}
 862 -- | /O(n)/. Return all elements of the map.
 863 elems :: IntMap a -> [a]
 864 elems m
 865   = foldWithKey (\k x xs -> x:xs) [] m
 866
 867 -- | /O(n)/. Return all keys of the map.
 868 keys  :: IntMap a -> [Key]
 869 keys m
 870   = foldWithKey (\k x ks -> k:ks) [] m
 871
 872 -- | /O(n*min(n,W))/. The set of all keys of the map.
 873 keysSet :: IntMap a -> IntSet.IntSet
 874 keysSet m = IntSet.fromDistinctAscList (keys m)
 875
 876
 877 -- | /O(n)/. Return all key\/value pairs in the map.
 878 assocs :: IntMap a -> [(Key,a)]
 879 assocs m
 880   = toList m
 881
 882
 883 {--------------------------------------------------------------------
 884   Lists
 885 --------------------------------------------------------------------}
 886 -- | /O(n)/. Convert the map to a list of key\/value pairs.
 887 toList :: IntMap a -> [(Key,a)]
 888 toList t
 889   = foldWithKey (\k x xs -> (k,x):xs) [] t
 890
 891 -- | /O(n)/. Convert the map to a list of key\/value pairs where the
 892 -- keys are in ascending order.
 893 toAscList :: IntMap a -> [(Key,a)]
 894 toAscList t
 895   = -- NOTE: the following algorithm only works for big-endian trees
 896     let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos
 897
 898 -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.
 899 fromList :: [(Key,a)] -> IntMap a
 900 fromList xs
 901   = foldlStrict ins empty xs
 902   where
 903     ins t (k,x)  = insert k x t
 904
 905 -- | /O(n*min(n,W))/.  Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
 906 fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
 907 fromListWith f xs
 908   = fromListWithKey (\k x y -> f x y) xs
 909
 910 -- | /O(n*min(n,W))/.  Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.
 911 fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
 912 fromListWithKey f xs
 913   = foldlStrict ins empty xs
 914   where
 915     ins t (k,x) = insertWithKey f k x t
 916
 917 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
 918 -- the keys are in ascending order.
 919 fromAscList :: [(Key,a)] -> IntMap a
 920 fromAscList xs
 921   = fromList xs
 922
 923 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
 924 -- the keys are in ascending order, with a combining function on equal keys.
 925 fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
 926 fromAscListWith f xs
 927   = fromListWith f xs
 928
 929 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
 930 -- the keys are in ascending order, with a combining function on equal keys.
 931 fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
 932 fromAscListWithKey f xs
 933   = fromListWithKey f xs
 934
 935 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
 936 -- the keys are in ascending order and all distinct.
 937 fromDistinctAscList :: [(Key,a)] -> IntMap a
 938 fromDistinctAscList xs
 939   = fromList xs
 940
 941
 942 {--------------------------------------------------------------------
 943   Eq
 944 --------------------------------------------------------------------}
 945 instance Eq a => Eq (IntMap a) where
 946   t1 == t2  = equal t1 t2
 947   t1 /= t2  = nequal t1 t2
 948
 949 equal :: Eq a => IntMap a -> IntMap a -> Bool
 950 equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
 951   = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
 952 equal (Tip kx x) (Tip ky y)
 953   = (kx == ky) && (x==y)
 954 equal Nil Nil = True
 955 equal t1 t2   = False
 956
 957 nequal :: Eq a => IntMap a -> IntMap a -> Bool
 958 nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
 959   = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
 960 nequal (Tip kx x) (Tip ky y)
 961   = (kx /= ky) || (x/=y)
 962 nequal Nil Nil = False
 963 nequal t1 t2   = True
 964
 965 {--------------------------------------------------------------------
 966   Ord
 967 --------------------------------------------------------------------}
 968
 969 instance Ord a => Ord (IntMap a) where
 970     compare m1 m2 = compare (toList m1) (toList m2)
 971
 972 {--------------------------------------------------------------------
 973   Functor
 974 --------------------------------------------------------------------}
 975
 976 instance Functor IntMap where
 977     fmap = map
 978
 979 {--------------------------------------------------------------------
 980   Monoid
 981 --------------------------------------------------------------------}
 982
 983 instance Ord a => Monoid (IntMap a) where
 984     mempty = empty
 985     mappend = union
 986     mconcat = unions
 987
 988 {--------------------------------------------------------------------
 989   Show
 990 --------------------------------------------------------------------}
 991
 992 instance Show a => Show (IntMap a) where
 993   showsPrec d t   = showMap (toList t)
 994
 995
 996 showMap :: (Show a) => [(Key,a)] -> ShowS
 997 showMap []
 998   = showString "{}"
 999 showMap (x:xs)
1000   = showChar '{' . showElem x . showTail xs
1001   where
1002     showTail []     = showChar '}'
1003     showTail (x:xs) = showChar ',' . showElem x . showTail xs
1004
1005     showElem (k,x)  = shows k . showString ":=" . shows x
1006
1007 {--------------------------------------------------------------------
1008   Debugging
1009 --------------------------------------------------------------------}
1010 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1011 -- in a compressed, hanging format.
1012 showTree :: Show a => IntMap a -> String
1013 showTree s
1014   = showTreeWith True False s
1015
1016
1017 {- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
1018  the tree that implements the map. If @hang@ is
1019  @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
1020  @wide@ is true, an extra wide version is shown.
1021 -}
1022 showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
1023 showTreeWith hang wide t
1024   | hang      = (showsTreeHang wide [] t) ""
1025   | otherwise = (showsTree wide [] [] t) ""
1026
1027 showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS
1028 showsTree wide lbars rbars t
1029   = case t of
1030       Bin p m l r
1031           -> showsTree wide (withBar rbars) (withEmpty rbars) r .
1032              showWide wide rbars .
1033              showsBars lbars . showString (showBin p m) . showString "\n" .
1034              showWide wide lbars .
1035              showsTree wide (withEmpty lbars) (withBar lbars) l
1036       Tip k x
1037           -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"
1038       Nil -> showsBars lbars . showString "|\n"
1039
1040 showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS
1041 showsTreeHang wide bars t
1042   = case t of
1043       Bin p m l r
1044           -> showsBars bars . showString (showBin p m) . showString "\n" .
1045              showWide wide bars .
1046              showsTreeHang wide (withBar bars) l .
1047              showWide wide bars .
1048              showsTreeHang wide (withEmpty bars) r
1049       Tip k x
1050           -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"
1051       Nil -> showsBars bars . showString "|\n"
1052
1053 showBin p m
1054   = "*" -- ++ show (p,m)
1055
1056 showWide wide bars
1057   | wide      = showString (concat (reverse bars)) . showString "|\n"
1058   | otherwise = id
1059
1060 showsBars :: [String] -> ShowS
1061 showsBars bars
1062   = case bars of
1063       [] -> id
1064       _  -> showString (concat (reverse (tail bars))) . showString node
1065
1066 node           = "+--"
1067 withBar bars   = "|  ":bars
1068 withEmpty bars = "   ":bars
1069
1070
1071 {--------------------------------------------------------------------
1072   Helpers
1073 --------------------------------------------------------------------}
1074 {--------------------------------------------------------------------
1075   Join
1076 --------------------------------------------------------------------}
1077 join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
1078 join p1 t1 p2 t2
1079   | zero p1 m = Bin p m t1 t2
1080   | otherwise = Bin p m t2 t1
1081   where
1082     m = branchMask p1 p2
1083     p = mask p1 m
1084
1085 {--------------------------------------------------------------------
1086   @bin@ assures that we never have empty trees within a tree.
1087 --------------------------------------------------------------------}
1088 bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
1089 bin p m l Nil = l
1090 bin p m Nil r = r
1091 bin p m l r   = Bin p m l r
1092
1093
1094 {--------------------------------------------------------------------
1095   Endian independent bit twiddling
1096 --------------------------------------------------------------------}
1097 zero :: Key -> Mask -> Bool
1098 zero i m
1099   = (natFromInt i) .&. (natFromInt m) == 0
1100
1101 nomatch,match :: Key -> Prefix -> Mask -> Bool
1102 nomatch i p m
1103   = (mask i m) /= p
1104
1105 match i p m
1106   = (mask i m) == p
1107
1108 mask :: Key -> Mask -> Prefix
1109 mask i m
1110   = maskW (natFromInt i) (natFromInt m)
1111
1112
1113 zeroN :: Nat -> Nat -> Bool
1114 zeroN i m = (i .&. m) == 0
1115
1116 {--------------------------------------------------------------------
1117   Big endian operations
1118 --------------------------------------------------------------------}
1119 maskW :: Nat -> Nat -> Prefix
1120 maskW i m
1121   = intFromNat (i .&. (complement (m-1) `xor` m))
1122
1123 shorter :: Mask -> Mask -> Bool
1124 shorter m1 m2
1125   = (natFromInt m1) > (natFromInt m2)
1126
1127 branchMask :: Prefix -> Prefix -> Mask
1128 branchMask p1 p2
1129   = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
1130
1131 {----------------------------------------------------------------------
1132   Finding the highest bit (mask) in a word [x] can be done efficiently in
1133   three ways:
1134   * convert to a floating point value and the mantissa tells us the
1135     [log2(x)] that corresponds with the highest bit position. The mantissa
1136     is retrieved either via the standard C function [frexp] or by some bit
1137     twiddling on IEEE compatible numbers (float). Note that one needs to
1138     use at least [double] precision for an accurate mantissa of 32 bit
1139     numbers.
1140   * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
1141   * use processor specific assembler instruction (asm).
1142
1143   The most portable way would be [bit], but is it efficient enough?
1144   I have measured the cycle counts of the different methods on an AMD
1145   Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
1146
1147   highestBitMask: method  cycles
1148                   --------------
1149                    frexp   200
1150                    float    33
1151                    bit      11
1152                    asm      12
1153
1154   highestBit:     method  cycles
1155                   --------------
1156                    frexp   195
1157                    float    33
1158                    bit      11
1159                    asm      11
1160
1161   Wow, the bit twiddling is on today's RISC like machines even faster
1162   than a single CISC instruction (BSR)!
1163 ----------------------------------------------------------------------}
1164
1165 {----------------------------------------------------------------------
1166   [highestBitMask] returns a word where only the highest bit is set.
1167   It is found by first setting all bits in lower positions than the
1168   highest bit and than taking an exclusive or with the original value.
1169   Allthough the function may look expensive, GHC compiles this into
1170   excellent C code that subsequently compiled into highly efficient
1171   machine code. The algorithm is derived from Jorg Arndt's FXT library.
1172 ----------------------------------------------------------------------}
1173 highestBitMask :: Nat -> Nat
1174 highestBitMask x
1175   = case (x .|. shiftRL x 1) of
1176      x -> case (x .|. shiftRL x 2) of
1177       x -> case (x .|. shiftRL x 4) of
1178        x -> case (x .|. shiftRL x 8) of
1179         x -> case (x .|. shiftRL x 16) of
1180          x -> case (x .|. shiftRL x 32) of   -- for 64 bit platforms
1181           x -> (x `xor` (shiftRL x 1))
1182
1183
1184 {--------------------------------------------------------------------
1185   Utilities
1186 --------------------------------------------------------------------}
1187 foldlStrict f z xs
1188   = case xs of
1189       []     -> z
1190       (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1191
1192 {-
1193 {--------------------------------------------------------------------
1194   Testing
1195 --------------------------------------------------------------------}
1196 testTree :: [Int] -> IntMap Int
1197 testTree xs   = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]
1198 test1 = testTree [1..20]
1199 test2 = testTree [30,29..10]
1200 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1201
1202 {--------------------------------------------------------------------
1203   QuickCheck
1204 --------------------------------------------------------------------}
1205 qcheck prop
1206   = check config prop
1207   where
1208     config = Config
1209       { configMaxTest = 500
1210       , configMaxFail = 5000
1211       , configSize    = \n -> (div n 2 + 3)
1212       , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1213       }
1214
1215
1216 {--------------------------------------------------------------------
1217   Arbitrary, reasonably balanced trees
1218 --------------------------------------------------------------------}
1219 instance Arbitrary a => Arbitrary (IntMap a) where
1220   arbitrary = do{ ks <- arbitrary
1221                 ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks
1222                 ; return (fromList xs)
1223                 }
1224
1225
1226 {--------------------------------------------------------------------
1227   Single, Insert, Delete
1228 --------------------------------------------------------------------}
1229 prop_Single :: Key -> Int -> Bool
1230 prop_Single k x
1231   = (insert k x empty == singleton k x)
1232
1233 prop_InsertDelete :: Key -> Int -> IntMap Int -> Property
1234 prop_InsertDelete k x t
1235   = not (member k t) ==> delete k (insert k x t) == t
1236
1237 prop_UpdateDelete :: Key -> IntMap Int -> Bool
1238 prop_UpdateDelete k t
1239   = update (const Nothing) k t == delete k t
1240
1241
1242 {--------------------------------------------------------------------
1243   Union
1244 --------------------------------------------------------------------}
1245 prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool
1246 prop_UnionInsert k x t
1247   = union (singleton k x) t == insert k x t
1248
1249 prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool
1250 prop_UnionAssoc t1 t2 t3
1251   = union t1 (union t2 t3) == union (union t1 t2) t3
1252
1253 prop_UnionComm :: IntMap Int -> IntMap Int -> Bool
1254 prop_UnionComm t1 t2
1255   = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1256
1257
1258 prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool
1259 prop_Diff xs ys
1260   =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1261     == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))
1262
1263 prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool
1264 prop_Int xs ys
1265   =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1266     == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))
1267
1268 {--------------------------------------------------------------------
1269   Lists
1270 --------------------------------------------------------------------}
1271 prop_Ordered
1272   = forAll (choose (5,100)) $ \n ->
1273     let xs = [(x,()) | x <- [0..n::Int]]
1274     in fromAscList xs == fromList xs
1275
1276 prop_List :: [Key] -> Bool
1277 prop_List xs
1278   = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])
1279 -}