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