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