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   'insert' is the inlined version of 'insertWith (\k x y -> x)'
 300 --------------------------------------------------------------------}
 301 -- | /O(min(n,W))/. Insert a new key\/value pair in the map. When the key
 302 -- is already an element of the set, its value is replaced by the new value,
 303 -- ie. 'insert' is left-biased.
 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 sets.
 436 union :: IntMap a -> IntMap a -> IntMap a
 437 union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 438   | shorter m1 m2  = union1
 439   | shorter m2 m1  = union2
 440   | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)
 441   | otherwise      = join p1 t1 p2 t2
 442   where
 443     union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2
 444             | zero p2 m1        = Bin p1 m1 (union l1 t2) r1
 445             | otherwise         = Bin p1 m1 l1 (union r1 t2)
 446
 447     union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2
 448             | zero p1 m2        = Bin p2 m2 (union t1 l2) r2
 449             | otherwise         = Bin p2 m2 l2 (union t1 r2)
 450
 451 union (Tip k x) t = insert k x t
 452 union t (Tip k x) = insertWith (\x y -> y) k x t  -- right bias
 453 union Nil t       = t
 454 union t Nil       = t
 455
 456 -- | /O(n+m)/. The union with a combining function.
 457 unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
 458 unionWith f m1 m2
 459   = unionWithKey (\k x y -> f x y) m1 m2
 460
 461 -- | /O(n+m)/. The union with a combining function.
 462 unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
 463 unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 464   | shorter m1 m2  = union1
 465   | shorter m2 m1  = union2
 466   | p1 == p2       = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)
 467   | otherwise      = join p1 t1 p2 t2
 468   where
 469     union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2
 470             | zero p2 m1        = Bin p1 m1 (unionWithKey f l1 t2) r1
 471             | otherwise         = Bin p1 m1 l1 (unionWithKey f r1 t2)
 472
 473     union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2
 474             | zero p1 m2        = Bin p2 m2 (unionWithKey f t1 l2) r2
 475             | otherwise         = Bin p2 m2 l2 (unionWithKey f t1 r2)
 476
 477 unionWithKey f (Tip k x) t = insertWithKey f k x t
 478 unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t  -- right bias
 479 unionWithKey f Nil t  = t
 480 unionWithKey f t Nil  = t
 481
 482 {--------------------------------------------------------------------
 483   Difference
 484 --------------------------------------------------------------------}
 485 -- | /O(n+m)/. Difference between two maps (based on keys).
 486 difference :: IntMap a -> IntMap b -> IntMap a
 487 difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 488   | shorter m1 m2  = difference1
 489   | shorter m2 m1  = difference2
 490   | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)
 491   | otherwise      = t1
 492   where
 493     difference1 | nomatch p2 p1 m1  = t1
 494                 | zero p2 m1        = bin p1 m1 (difference l1 t2) r1
 495                 | otherwise         = bin p1 m1 l1 (difference r1 t2)
 496
 497     difference2 | nomatch p1 p2 m2  = t1
 498                 | zero p1 m2        = difference t1 l2
 499                 | otherwise         = difference t1 r2
 500
 501 difference t1@(Tip k x) t2
 502   | member k t2  = Nil
 503   | otherwise    = t1
 504
 505 difference Nil t       = Nil
 506 difference t (Tip k x) = delete k t
 507 difference t Nil       = t
 508
 509 -- | /O(n+m)/. Difference with a combining function.
 510 differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
 511 differenceWith f m1 m2
 512   = differenceWithKey (\k x y -> f x y) m1 m2
 513
 514 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
 515 -- encountered, the combining function is applied to the key and both values.
 516 -- If it returns 'Nothing', the element is discarded (proper set difference).
 517 -- If it returns (@'Just' y@), the element is updated with a new value @y@.
 518 differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
 519 differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 520   | shorter m1 m2  = difference1
 521   | shorter m2 m1  = difference2
 522   | p1 == p2       = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)
 523   | otherwise      = t1
 524   where
 525     difference1 | nomatch p2 p1 m1  = t1
 526                 | zero p2 m1        = bin p1 m1 (differenceWithKey f l1 t2) r1
 527                 | otherwise         = bin p1 m1 l1 (differenceWithKey f r1 t2)
 528
 529     difference2 | nomatch p1 p2 m2  = t1
 530                 | zero p1 m2        = differenceWithKey f t1 l2
 531                 | otherwise         = differenceWithKey f t1 r2
 532
 533 differenceWithKey f t1@(Tip k x) t2
 534   = case lookup k t2 of
 535       Just y  -> case f k x y of
 536                    Just y' -> Tip k y'
 537                    Nothing -> Nil
 538       Nothing -> t1
 539
 540 differenceWithKey f Nil t       = Nil
 541 differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t
 542 differenceWithKey f t Nil       = t
 543
 544
 545 {--------------------------------------------------------------------
 546   Intersection
 547 --------------------------------------------------------------------}
 548 -- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).
 549 intersection :: IntMap a -> IntMap b -> IntMap a
 550 intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 551   | shorter m1 m2  = intersection1
 552   | shorter m2 m1  = intersection2
 553   | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
 554   | otherwise      = Nil
 555   where
 556     intersection1 | nomatch p2 p1 m1  = Nil
 557                   | zero p2 m1        = intersection l1 t2
 558                   | otherwise         = intersection r1 t2
 559
 560     intersection2 | nomatch p1 p2 m2  = Nil
 561                   | zero p1 m2        = intersection t1 l2
 562                   | otherwise         = intersection t1 r2
 563
 564 intersection t1@(Tip k x) t2
 565   | member k t2  = t1
 566   | otherwise    = Nil
 567 intersection t (Tip k x)
 568   = case lookup k t of
 569       Just y  -> Tip k y
 570       Nothing -> Nil
 571 intersection Nil t = Nil
 572 intersection t Nil = Nil
 573
 574 -- | /O(n+m)/. The intersection with a combining function.
 575 intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
 576 intersectionWith f m1 m2
 577   = intersectionWithKey (\k x y -> f x y) m1 m2
 578
 579 -- | /O(n+m)/. The intersection with a combining function.
 580 intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
 581 intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 582   | shorter m1 m2  = intersection1
 583   | shorter m2 m1  = intersection2
 584   | p1 == p2       = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)
 585   | otherwise      = Nil
 586   where
 587     intersection1 | nomatch p2 p1 m1  = Nil
 588                   | zero p2 m1        = intersectionWithKey f l1 t2
 589                   | otherwise         = intersectionWithKey f r1 t2
 590
 591     intersection2 | nomatch p1 p2 m2  = Nil
 592                   | zero p1 m2        = intersectionWithKey f t1 l2
 593                   | otherwise         = intersectionWithKey f t1 r2
 594
 595 intersectionWithKey f t1@(Tip k x) t2
 596   = case lookup k t2 of
 597       Just y  -> Tip k (f k x y)
 598       Nothing -> Nil
 599 intersectionWithKey f t1 (Tip k y)
 600   = case lookup k t1 of
 601       Just x  -> Tip k (f k x y)
 602       Nothing -> Nil
 603 intersectionWithKey f Nil t = Nil
 604 intersectionWithKey f t Nil = Nil
 605
 606
 607 {--------------------------------------------------------------------
 608   Submap
 609 --------------------------------------------------------------------}
 610 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
 611 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
 612 isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
 613 isProperSubmapOf m1 m2
 614   = isProperSubmapOfBy (==) m1 m2
 615
 616 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
 617  The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
 618  @m1@ and @m2@ are not equal,
 619  all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
 620  applied to their respective values. For example, the following
 621  expressions are all 'True':
 622
 623   > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 624   > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 625
 626  But the following are all 'False':
 627
 628   > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
 629   > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
 630   > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])
 631 -}
 632 isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
 633 isProperSubmapOfBy pred t1 t2
 634   = case submapCmp pred t1 t2 of
 635       LT -> True
 636       ge -> False
 637
 638 submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 639   | shorter m1 m2  = GT
 640   | shorter m2 m1  = submapCmpLt
 641   | p1 == p2       = submapCmpEq
 642   | otherwise      = GT  -- disjoint
 643   where
 644     submapCmpLt | nomatch p1 p2 m2  = GT
 645                 | zero p1 m2        = submapCmp pred t1 l2
 646                 | otherwise         = submapCmp pred t1 r2
 647     submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of
 648                     (GT,_ ) -> GT
 649                     (_ ,GT) -> GT
 650                     (EQ,EQ) -> EQ
 651                     other   -> LT
 652
 653 submapCmp pred (Bin p m l r) t  = GT
 654 submapCmp pred (Tip kx x) (Tip ky y)
 655   | (kx == ky) && pred x y = EQ
 656   | otherwise              = GT  -- disjoint
 657 submapCmp pred (Tip k x) t
 658   = case lookup k t of
 659      Just y  | pred x y -> LT
 660      other   -> GT -- disjoint
 661 submapCmp pred Nil Nil = EQ
 662 submapCmp pred Nil t   = LT
 663
 664 -- | /O(n+m)/. Is this a submap?
 665 -- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
 666 isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
 667 isSubmapOf m1 m2
 668   = isSubmapOfBy (==) m1 m2
 669
 670 {- | /O(n+m)/.
 671  The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if
 672  all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
 673  applied to their respective values. For example, the following
 674  expressions are all 'True':
 675
 676   > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 677   > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 678   > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
 679
 680  But the following are all 'False':
 681
 682   > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])
 683   > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 684   > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
 685 -}
 686
 687 isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
 688 isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
 689   | shorter m1 m2  = False
 690   | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2
 691                                                       else isSubmapOfBy pred t1 r2)
 692   | otherwise      = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2
 693 isSubmapOfBy pred (Bin p m l r) t  = False
 694 isSubmapOfBy pred (Tip k x) t      = case lookup k t of
 695                                    Just y  -> pred x y
 696                                    Nothing -> False
 697 isSubmapOfBy pred Nil t            = True
 698
 699 {--------------------------------------------------------------------
 700   Mapping
 701 --------------------------------------------------------------------}
 702 -- | /O(n)/. Map a function over all values in the map.
 703 map :: (a -> b) -> IntMap a -> IntMap b
 704 map f m
 705   = mapWithKey (\k x -> f x) m
 706
 707 -- | /O(n)/. Map a function over all values in the map.
 708 mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
 709 mapWithKey f t
 710   = case t of
 711       Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
 712       Tip k x     -> Tip k (f k x)
 713       Nil         -> Nil
 714
 715 -- | /O(n)/. The function @'mapAccum'@ threads an accumulating
 716 -- argument through the map in ascending order of keys.
 717 mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
 718 mapAccum f a m
 719   = mapAccumWithKey (\a k x -> f a x) a m
 720
 721 -- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating
 722 -- argument through the map in ascending order of keys.
 723 mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
 724 mapAccumWithKey f a t
 725   = mapAccumL f a t
 726
 727 -- | /O(n)/. The function @'mapAccumL'@ threads an accumulating
 728 -- argument through the map in ascending order of keys.
 729 mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
 730 mapAccumL f a t
 731   = case t of
 732       Bin p m l r -> let (a1,l') = mapAccumL f a l
 733                          (a2,r') = mapAccumL f a1 r
 734                      in (a2,Bin p m l' r')
 735       Tip k x     -> let (a',x') = f a k x in (a',Tip k x')
 736       Nil         -> (a,Nil)
 737
 738
 739 -- | /O(n)/. The function @'mapAccumR'@ threads an accumulating
 740 -- argument throught the map in descending order of keys.
 741 mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
 742 mapAccumR f a t
 743   = case t of
 744       Bin p m l r -> let (a1,r') = mapAccumR f a r
 745                          (a2,l') = mapAccumR f a1 l
 746                      in (a2,Bin p m l' r')
 747       Tip k x     -> let (a',x') = f a k x in (a',Tip k x')
 748       Nil         -> (a,Nil)
 749
 750 {--------------------------------------------------------------------
 751   Filter
 752 --------------------------------------------------------------------}
 753 -- | /O(n)/. Filter all values that satisfy some predicate.
 754 filter :: (a -> Bool) -> IntMap a -> IntMap a
 755 filter p m
 756   = filterWithKey (\k x -> p x) m
 757
 758 -- | /O(n)/. Filter all keys\/values that satisfy some predicate.
 759 filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
 760 filterWithKey pred t
 761   = case t of
 762       Bin p m l r
 763         -> bin p m (filterWithKey pred l) (filterWithKey pred r)
 764       Tip k x
 765         | pred k x  -> t
 766         | otherwise -> Nil
 767       Nil -> Nil
 768
 769 -- | /O(n)/. partition the map according to some predicate. The first
 770 -- map contains all elements that satisfy the predicate, the second all
 771 -- elements that fail the predicate. See also 'split'.
 772 partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
 773 partition p m
 774   = partitionWithKey (\k x -> p x) m
 775
 776 -- | /O(n)/. partition the map according to some predicate. The first
 777 -- map contains all elements that satisfy the predicate, the second all
 778 -- elements that fail the predicate. See also 'split'.
 779 partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
 780 partitionWithKey pred t
 781   = case t of
 782       Bin p m l r
 783         -> let (l1,l2) = partitionWithKey pred l
 784                (r1,r2) = partitionWithKey pred r
 785            in (bin p m l1 r1, bin p m l2 r2)
 786       Tip k x
 787         | pred k x  -> (t,Nil)
 788         | otherwise -> (Nil,t)
 789       Nil -> (Nil,Nil)
 790
 791
 792 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@
 793 -- where all keys in @map1@ are lower than @k@ and all keys in
 794 -- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
 795 split :: Key -> IntMap a -> (IntMap a,IntMap a)
 796 split k t
 797   = case t of
 798       Bin p m l r
 799         | zero k m  -> let (lt,gt) = split k l in (lt,union gt r)
 800         | otherwise -> let (lt,gt) = split k r in (union l lt,gt)
 801       Tip ky y
 802         | k>ky      -> (t,Nil)
 803         | k<ky      -> (Nil,t)
 804         | otherwise -> (Nil,Nil)
 805       Nil -> (Nil,Nil)
 806
 807 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
 808 -- key was found in the original map.
 809 splitLookup :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)
 810 splitLookup k t
 811   = case t of
 812       Bin p m l r
 813         | zero k m  -> let (lt,found,gt) = splitLookup k l in (lt,found,union gt r)
 814         | otherwise -> let (lt,found,gt) = splitLookup k r in (union l lt,found,gt)
 815       Tip ky y
 816         | k>ky      -> (t,Nothing,Nil)
 817         | k<ky      -> (Nil,Nothing,t)
 818         | otherwise -> (Nil,Just y,Nil)
 819       Nil -> (Nil,Nothing,Nil)
 820
 821 {--------------------------------------------------------------------
 822   Fold
 823 --------------------------------------------------------------------}
 824 -- | /O(n)/. Fold the values in the map, such that
 825 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
 826 -- For example,
 827 --
 828 -- > elems map = fold (:) [] map
 829 --
 830 fold :: (a -> b -> b) -> b -> IntMap a -> b
 831 fold f z t
 832   = foldWithKey (\k x y -> f x y) z t
 833
 834 -- | /O(n)/. Fold the keys and values in the map, such that
 835 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
 836 -- For example,
 837 --
 838 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
 839 --
 840 foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
 841 foldWithKey f z t
 842   = foldr f z t
 843
 844 foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
 845 foldr f z t
 846   = case t of
 847       Bin p m l r -> foldr f (foldr f z r) l
 848       Tip k x     -> f k x z
 849       Nil         -> z
 850
 851 {--------------------------------------------------------------------
 852   List variations
 853 --------------------------------------------------------------------}
 854 -- | /O(n)/.
 855 -- Return all elements of the map in the ascending order of their keys.
 856 elems :: IntMap a -> [a]
 857 elems m
 858   = foldWithKey (\k x xs -> x:xs) [] m
 859
 860 -- | /O(n)/. Return all keys of the map in ascending order.
 861 keys  :: IntMap a -> [Key]
 862 keys m
 863   = foldWithKey (\k x ks -> k:ks) [] m
 864
 865 -- | /O(n*min(n,W))/. The set of all keys of the map.
 866 keysSet :: IntMap a -> IntSet.IntSet
 867 keysSet m = IntSet.fromDistinctAscList (keys m)
 868
 869
 870 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
 871 assocs :: IntMap a -> [(Key,a)]
 872 assocs m
 873   = toList m
 874
 875
 876 {--------------------------------------------------------------------
 877   Lists
 878 --------------------------------------------------------------------}
 879 -- | /O(n)/. Convert the map to a list of key\/value pairs.
 880 toList :: IntMap a -> [(Key,a)]
 881 toList t
 882   = foldWithKey (\k x xs -> (k,x):xs) [] t
 883
 884 -- | /O(n)/. Convert the map to a list of key\/value pairs where the
 885 -- keys are in ascending order.
 886 toAscList :: IntMap a -> [(Key,a)]
 887 toAscList t
 888   = -- NOTE: the following algorithm only works for big-endian trees
 889     let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos
 890
 891 -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.
 892 fromList :: [(Key,a)] -> IntMap a
 893 fromList xs
 894   = foldlStrict ins empty xs
 895   where
 896     ins t (k,x)  = insert k x t
 897
 898 -- | /O(n*min(n,W))/.  Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
 899 fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
 900 fromListWith f xs
 901   = fromListWithKey (\k x y -> f x y) xs
 902
 903 -- | /O(n*min(n,W))/.  Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.
 904 fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
 905 fromListWithKey f xs
 906   = foldlStrict ins empty xs
 907   where
 908     ins t (k,x) = insertWithKey f k x t
 909
 910 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
 911 -- the keys are in ascending order.
 912 fromAscList :: [(Key,a)] -> IntMap a
 913 fromAscList xs
 914   = fromList xs
 915
 916 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
 917 -- the keys are in ascending order, with a combining function on equal keys.
 918 fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
 919 fromAscListWith f xs
 920   = fromListWith f xs
 921
 922 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
 923 -- the keys are in ascending order, with a combining function on equal keys.
 924 fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
 925 fromAscListWithKey f xs
 926   = fromListWithKey f xs
 927
 928 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
 929 -- the keys are in ascending order and all distinct.
 930 fromDistinctAscList :: [(Key,a)] -> IntMap a
 931 fromDistinctAscList xs
 932   = fromList xs
 933
 934
 935 {--------------------------------------------------------------------
 936   Eq
 937 --------------------------------------------------------------------}
 938 instance Eq a => Eq (IntMap a) where
 939   t1 == t2  = equal t1 t2
 940   t1 /= t2  = nequal t1 t2
 941
 942 equal :: Eq a => IntMap a -> IntMap a -> Bool
 943 equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
 944   = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
 945 equal (Tip kx x) (Tip ky y)
 946   = (kx == ky) && (x==y)
 947 equal Nil Nil = True
 948 equal t1 t2   = False
 949
 950 nequal :: Eq a => IntMap a -> IntMap a -> Bool
 951 nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
 952   = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
 953 nequal (Tip kx x) (Tip ky y)
 954   = (kx /= ky) || (x/=y)
 955 nequal Nil Nil = False
 956 nequal t1 t2   = True
 957
 958 {--------------------------------------------------------------------
 959   Ord
 960 --------------------------------------------------------------------}
 961
 962 instance Ord a => Ord (IntMap a) where
 963     compare m1 m2 = compare (toList m1) (toList m2)
 964
 965 {--------------------------------------------------------------------
 966   Functor
 967 --------------------------------------------------------------------}
 968
 969 instance Functor IntMap where
 970     fmap = map
 971
 972 {--------------------------------------------------------------------
 973   Show
 974 --------------------------------------------------------------------}
 975
 976 instance Show a => Show (IntMap a) where
 977   showsPrec d t   = showMap (toList t)
 978
 979
 980 showMap :: (Show a) => [(Key,a)] -> ShowS
 981 showMap []
 982   = showString "{}"
 983 showMap (x:xs)
 984   = showChar '{' . showElem x . showTail xs
 985   where
 986     showTail []     = showChar '}'
 987     showTail (x:xs) = showChar ',' . showElem x . showTail xs
 988
 989     showElem (k,x)  = shows k . showString ":=" . shows x
 990
 991 {--------------------------------------------------------------------
 992   Typeable
 993 --------------------------------------------------------------------}
 994
 995 #include "Typeable.h"
 996 INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")
 997
 998 {--------------------------------------------------------------------
 999   Debugging
1000 --------------------------------------------------------------------}
1001 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1002 -- in a compressed, hanging format.
1003 showTree :: Show a => IntMap a -> String
1004 showTree s
1005   = showTreeWith True False s
1006
1007
1008 {- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
1009  the tree that implements the map. If @hang@ is
1010  'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1011  @wide@ is 'True', an extra wide version is shown.
1012 -}
1013 showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
1014 showTreeWith hang wide t
1015   | hang      = (showsTreeHang wide [] t) ""
1016   | otherwise = (showsTree wide [] [] t) ""
1017
1018 showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS
1019 showsTree wide lbars rbars t
1020   = case t of
1021       Bin p m l r
1022           -> showsTree wide (withBar rbars) (withEmpty rbars) r .
1023              showWide wide rbars .
1024              showsBars lbars . showString (showBin p m) . showString "\n" .
1025              showWide wide lbars .
1026              showsTree wide (withEmpty lbars) (withBar lbars) l
1027       Tip k x
1028           -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"
1029       Nil -> showsBars lbars . showString "|\n"
1030
1031 showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS
1032 showsTreeHang wide bars t
1033   = case t of
1034       Bin p m l r
1035           -> showsBars bars . showString (showBin p m) . showString "\n" .
1036              showWide wide bars .
1037              showsTreeHang wide (withBar bars) l .
1038              showWide wide bars .
1039              showsTreeHang wide (withEmpty bars) r
1040       Tip k x
1041           -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"
1042       Nil -> showsBars bars . showString "|\n"
1043
1044 showBin p m
1045   = "*" -- ++ show (p,m)
1046
1047 showWide wide bars
1048   | wide      = showString (concat (reverse bars)) . showString "|\n"
1049   | otherwise = id
1050
1051 showsBars :: [String] -> ShowS
1052 showsBars bars
1053   = case bars of
1054       [] -> id
1055       _  -> showString (concat (reverse (tail bars))) . showString node
1056
1057 node           = "+--"
1058 withBar bars   = "|  ":bars
1059 withEmpty bars = "   ":bars
1060
1061
1062 {--------------------------------------------------------------------
1063   Helpers
1064 --------------------------------------------------------------------}
1065 {--------------------------------------------------------------------
1066   Join
1067 --------------------------------------------------------------------}
1068 join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
1069 join p1 t1 p2 t2
1070   | zero p1 m = Bin p m t1 t2
1071   | otherwise = Bin p m t2 t1
1072   where
1073     m = branchMask p1 p2
1074     p = mask p1 m
1075
1076 {--------------------------------------------------------------------
1077   @bin@ assures that we never have empty trees within a tree.
1078 --------------------------------------------------------------------}
1079 bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
1080 bin p m l Nil = l
1081 bin p m Nil r = r
1082 bin p m l r   = Bin p m l r
1083
1084
1085 {--------------------------------------------------------------------
1086   Endian independent bit twiddling
1087 --------------------------------------------------------------------}
1088 zero :: Key -> Mask -> Bool
1089 zero i m
1090   = (natFromInt i) .&. (natFromInt m) == 0
1091
1092 nomatch,match :: Key -> Prefix -> Mask -> Bool
1093 nomatch i p m
1094   = (mask i m) /= p
1095
1096 match i p m
1097   = (mask i m) == p
1098
1099 mask :: Key -> Mask -> Prefix
1100 mask i m
1101   = maskW (natFromInt i) (natFromInt m)
1102
1103
1104 zeroN :: Nat -> Nat -> Bool
1105 zeroN i m = (i .&. m) == 0
1106
1107 {--------------------------------------------------------------------
1108   Big endian operations
1109 --------------------------------------------------------------------}
1110 maskW :: Nat -> Nat -> Prefix
1111 maskW i m
1112   = intFromNat (i .&. (complement (m-1) `xor` m))
1113
1114 shorter :: Mask -> Mask -> Bool
1115 shorter m1 m2
1116   = (natFromInt m1) > (natFromInt m2)
1117
1118 branchMask :: Prefix -> Prefix -> Mask
1119 branchMask p1 p2
1120   = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
1121
1122 {----------------------------------------------------------------------
1123   Finding the highest bit (mask) in a word [x] can be done efficiently in
1124   three ways:
1125   * convert to a floating point value and the mantissa tells us the
1126     [log2(x)] that corresponds with the highest bit position. The mantissa
1127     is retrieved either via the standard C function [frexp] or by some bit
1128     twiddling on IEEE compatible numbers (float). Note that one needs to
1129     use at least [double] precision for an accurate mantissa of 32 bit
1130     numbers.
1131   * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
1132   * use processor specific assembler instruction (asm).
1133
1134   The most portable way would be [bit], but is it efficient enough?
1135   I have measured the cycle counts of the different methods on an AMD
1136   Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
1137
1138   highestBitMask: method  cycles
1139                   --------------
1140                    frexp   200
1141                    float    33
1142                    bit      11
1143                    asm      12
1144
1145   highestBit:     method  cycles
1146                   --------------
1147                    frexp   195
1148                    float    33
1149                    bit      11
1150                    asm      11
1151
1152   Wow, the bit twiddling is on today's RISC like machines even faster
1153   than a single CISC instruction (BSR)!
1154 ----------------------------------------------------------------------}
1155
1156 {----------------------------------------------------------------------
1157   [highestBitMask] returns a word where only the highest bit is set.
1158   It is found by first setting all bits in lower positions than the
1159   highest bit and than taking an exclusive or with the original value.
1160   Allthough the function may look expensive, GHC compiles this into
1161   excellent C code that subsequently compiled into highly efficient
1162   machine code. The algorithm is derived from Jorg Arndt's FXT library.
1163 ----------------------------------------------------------------------}
1164 highestBitMask :: Nat -> Nat
1165 highestBitMask x
1166   = case (x .|. shiftRL x 1) of
1167      x -> case (x .|. shiftRL x 2) of
1168       x -> case (x .|. shiftRL x 4) of
1169        x -> case (x .|. shiftRL x 8) of
1170         x -> case (x .|. shiftRL x 16) of
1171          x -> case (x .|. shiftRL x 32) of   -- for 64 bit platforms
1172           x -> (x `xor` (shiftRL x 1))
1173
1174
1175 {--------------------------------------------------------------------
1176   Utilities
1177 --------------------------------------------------------------------}
1178 foldlStrict f z xs
1179   = case xs of
1180       []     -> z
1181       (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1182
1183 {-
1184 {--------------------------------------------------------------------
1185   Testing
1186 --------------------------------------------------------------------}
1187 testTree :: [Int] -> IntMap Int
1188 testTree xs   = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]
1189 test1 = testTree [1..20]
1190 test2 = testTree [30,29..10]
1191 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1192
1193 {--------------------------------------------------------------------
1194   QuickCheck
1195 --------------------------------------------------------------------}
1196 qcheck prop
1197   = check config prop
1198   where
1199     config = Config
1200       { configMaxTest = 500
1201       , configMaxFail = 5000
1202       , configSize    = \n -> (div n 2 + 3)
1203       , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1204       }
1205
1206
1207 {--------------------------------------------------------------------
1208   Arbitrary, reasonably balanced trees
1209 --------------------------------------------------------------------}
1210 instance Arbitrary a => Arbitrary (IntMap a) where
1211   arbitrary = do{ ks <- arbitrary
1212                 ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks
1213                 ; return (fromList xs)
1214                 }
1215
1216
1217 {--------------------------------------------------------------------
1218   Single, Insert, Delete
1219 --------------------------------------------------------------------}
1220 prop_Single :: Key -> Int -> Bool
1221 prop_Single k x
1222   = (insert k x empty == singleton k x)
1223
1224 prop_InsertDelete :: Key -> Int -> IntMap Int -> Property
1225 prop_InsertDelete k x t
1226   = not (member k t) ==> delete k (insert k x t) == t
1227
1228 prop_UpdateDelete :: Key -> IntMap Int -> Bool
1229 prop_UpdateDelete k t
1230   = update (const Nothing) k t == delete k t
1231
1232
1233 {--------------------------------------------------------------------
1234   Union
1235 --------------------------------------------------------------------}
1236 prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool
1237 prop_UnionInsert k x t
1238   = union (singleton k x) t == insert k x t
1239
1240 prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool
1241 prop_UnionAssoc t1 t2 t3
1242   = union t1 (union t2 t3) == union (union t1 t2) t3
1243
1244 prop_UnionComm :: IntMap Int -> IntMap Int -> Bool
1245 prop_UnionComm t1 t2
1246   = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1247
1248
1249 prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool
1250 prop_Diff xs ys
1251   =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1252     == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))
1253
1254 prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool
1255 prop_Int xs ys
1256   =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1257     == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))
1258
1259 {--------------------------------------------------------------------
1260   Lists
1261 --------------------------------------------------------------------}
1262 prop_Ordered
1263   = forAll (choose (5,100)) $ \n ->
1264     let xs = [(x,()) | x <- [0..n::Int]]
1265     in fromAscList xs == fromList xs
1266
1267 prop_List :: [Key] -> Bool
1268 prop_List xs
1269   = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])
1270 -}