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