Data/IntMap.hs

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