Data/Map.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Data.Map
   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 keys to values (dictionaries).
  11 --
  12 -- This module is intended to be imported @qualified@, to avoid name
  13 -- clashes with Prelude functions.  eg.
  14 --
  15 -- >  import Data.Map as Map
  16 --
  17 -- The implementation of 'Map' is based on /size balanced/ binary trees (or
  18 -- trees of /bounded balance/) as described by:
  19 --
  20 --    * Stephen Adams, \"/Efficient sets: a balancing act/\",
  21 --      Journal of Functional Programming 3(4):553-562, October 1993,
  22 --      <http://www.swiss.ai.mit.edu/~adams/BB>.
  23 --
  24 --    * J. Nievergelt and E.M. Reingold,
  25 --      \"/Binary search trees of bounded balance/\",
  26 --      SIAM journal of computing 2(1), March 1973.
  27 --
  28 -- Note that the implementation is /left-biased/ -- the elements of a
  29 -- first argument are always preferred to the second, for example in
  30 -- 'union' or 'insert'.
  31 -----------------------------------------------------------------------------
  32
  33 module Data.Map  (
  34             -- * Map type
  35               Map          -- instance Eq,Show,Read
  36
  37             -- * Operators
  38             , (!), (\\)
  39
  40
  41             -- * Query
  42             , null
  43             , size
  44             , member
  45             , lookup
  46             , findWithDefault
  47
  48             -- * Construction
  49             , empty
  50             , singleton
  51
  52             -- ** Insertion
  53             , insert
  54             , insertWith, insertWithKey, insertLookupWithKey
  55
  56             -- ** Delete\/Update
  57             , delete
  58             , adjust
  59             , adjustWithKey
  60             , update
  61             , updateWithKey
  62             , updateLookupWithKey
  63
  64             -- * Combine
  65
  66             -- ** Union
  67             , union
  68             , unionWith
  69             , unionWithKey
  70             , unions
  71             , unionsWith
  72
  73             -- ** Difference
  74             , difference
  75             , differenceWith
  76             , differenceWithKey
  77
  78             -- ** Intersection
  79             , intersection
  80             , intersectionWith
  81             , intersectionWithKey
  82
  83             -- * Traversal
  84             -- ** Map
  85             , map
  86             , mapWithKey
  87             , mapAccum
  88             , mapAccumWithKey
  89             , mapKeys
  90             , mapKeysWith
  91             , mapKeysMonotonic
  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             -- * Indexed
 130             , lookupIndex
 131             , findIndex
 132             , elemAt
 133             , updateAt
 134             , deleteAt
 135
 136             -- * Min\/Max
 137             , findMin
 138             , findMax
 139             , deleteMin
 140             , deleteMax
 141             , deleteFindMin
 142             , deleteFindMax
 143             , updateMin
 144             , updateMax
 145             , updateMinWithKey
 146             , updateMaxWithKey
 147
 148             -- * Debugging
 149             , showTree
 150             , showTreeWith
 151             , valid
 152             ) where
 153
 154 import Prelude hiding (lookup,map,filter,foldr,foldl,null)
 155 import qualified Data.Set as Set
 156 import qualified Data.List as List
 157 import Data.Monoid (Monoid(..))
 158 import Data.Typeable
 159 import Control.Applicative (Applicative(..))
 160 import Data.Traversable (Traversable(traverse))
 161 import Data.Foldable (Foldable(foldMap))
 162
 163 {-
 164 -- for quick check
 165 import qualified Prelude
 166 import qualified List
 167 import Debug.QuickCheck
 168 import List(nub,sort)
 169 -}
 170
 171 #if __GLASGOW_HASKELL__
 172 import Text.Read
 173 import Data.Generics.Basics
 174 import Data.Generics.Instances
 175 #endif
 176
 177 {--------------------------------------------------------------------
 178   Operators
 179 --------------------------------------------------------------------}
 180 infixl 9 !,\\ --
 181
 182 -- | /O(log n)/. Find the value at a key.
 183 -- Calls 'error' when the element can not be found.
 184 (!) :: Ord k => Map k a -> k -> a
 185 m ! k    = find k m
 186
 187 -- | /O(n+m)/. See 'difference'.
 188 (\\) :: Ord k => Map k a -> Map k b -> Map k a
 189 m1 \\ m2 = difference m1 m2
 190
 191 {--------------------------------------------------------------------
 192   Size balanced trees.
 193 --------------------------------------------------------------------}
 194 -- | A Map from keys @k@ to values @a@.
 195 data Map k a  = Tip
 196               | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
 197
 198 type Size     = Int
 199
 200 instance (Ord k) => Monoid (Map k v) where
 201     mempty  = empty
 202     mappend = union
 203     mconcat = unions
 204
 205 #if __GLASGOW_HASKELL__
 206
 207 {--------------------------------------------------------------------
 208   A Data instance
 209 --------------------------------------------------------------------}
 210
 211 -- This instance preserves data abstraction at the cost of inefficiency.
 212 -- We omit reflection services for the sake of data abstraction.
 213
 214 instance (Data k, Data a, Ord k) => Data (Map k a) where
 215   gfoldl f z map = z fromList `f` (toList map)
 216   toConstr _     = error "toConstr"
 217   gunfold _ _    = error "gunfold"
 218   dataTypeOf _   = mkNorepType "Data.Map.Map"
 219   dataCast2 f    = gcast2 f
 220
 221 #endif
 222
 223 {--------------------------------------------------------------------
 224   Query
 225 --------------------------------------------------------------------}
 226 -- | /O(1)/. Is the map empty?
 227 null :: Map k a -> Bool
 228 null t
 229   = case t of
 230       Tip             -> True
 231       Bin sz k x l r  -> False
 232
 233 -- | /O(1)/. The number of elements in the map.
 234 size :: Map k a -> Int
 235 size t
 236   = case t of
 237       Tip             -> 0
 238       Bin sz k x l r  -> sz
 239
 240
 241 -- | /O(log n)/. Lookup the value at a key in the map.
 242 lookup :: (Monad m,Ord k) => k -> Map k a -> m a
 243 lookup k t = case lookup' k t of
 244     Just x -> return x
 245     Nothing -> fail "Data.Map.lookup: Key not found"
 246 lookup' :: Ord k => k -> Map k a -> Maybe a
 247 lookup' k t
 248   = case t of
 249       Tip -> Nothing
 250       Bin sz kx x l r
 251           -> case compare k kx of
 252                LT -> lookup' k l
 253                GT -> lookup' k r
 254                EQ -> Just x
 255
 256 lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
 257 lookupAssoc  k t
 258   = case t of
 259       Tip -> Nothing
 260       Bin sz kx x l r
 261           -> case compare k kx of
 262                LT -> lookupAssoc k l
 263                GT -> lookupAssoc k r
 264                EQ -> Just (kx,x)
 265
 266 -- | /O(log n)/. Is the key a member of the map?
 267 member :: Ord k => k -> Map k a -> Bool
 268 member k m
 269   = case lookup k m of
 270       Nothing -> False
 271       Just x  -> True
 272
 273 -- | /O(log n)/. Find the value at a key.
 274 -- Calls 'error' when the element can not be found.
 275 find :: Ord k => k -> Map k a -> a
 276 find k m
 277   = case lookup k m of
 278       Nothing -> error "Map.find: element not in the map"
 279       Just x  -> x
 280
 281 -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
 282 -- the value at key @k@ or returns @def@ when the key is not in the map.
 283 findWithDefault :: Ord k => a -> k -> Map k a -> a
 284 findWithDefault def k m
 285   = case lookup k m of
 286       Nothing -> def
 287       Just x  -> x
 288
 289
 290
 291 {--------------------------------------------------------------------
 292   Construction
 293 --------------------------------------------------------------------}
 294 -- | /O(1)/. The empty map.
 295 empty :: Map k a
 296 empty
 297   = Tip
 298
 299 -- | /O(1)/. A map with a single element.
 300 singleton :: k -> a -> Map k a
 301 singleton k x
 302   = Bin 1 k x Tip Tip
 303
 304 {--------------------------------------------------------------------
 305   Insertion
 306 --------------------------------------------------------------------}
 307 -- | /O(log n)/. Insert a new key and value in the map.
 308 -- If the key is already present in the map, the associated value is
 309 -- replaced with the supplied value, i.e. 'insert' is equivalent to
 310 -- @'insertWith' 'const'@.
 311 insert :: Ord k => k -> a -> Map k a -> Map k a
 312 insert kx x t
 313   = case t of
 314       Tip -> singleton kx x
 315       Bin sz ky y l r
 316           -> case compare kx ky of
 317                LT -> balance ky y (insert kx x l) r
 318                GT -> balance ky y l (insert kx x r)
 319                EQ -> Bin sz kx x l r
 320
 321 -- | /O(log n)/. Insert with a combining function.
 322 -- @'insertWith' f key value mp@
 323 -- will insert the pair (key, value) into @mp@ if key does
 324 -- not exist in the map. If the key does exist, the function will
 325 -- insert the pair @(key, f new_value old_value)@.
 326 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
 327 insertWith f k x m
 328   = insertWithKey (\k x y -> f x y) k x m
 329
 330 -- | /O(log n)/. Insert with a combining function.
 331 -- @'insertWithKey' f key value mp@
 332 -- will insert the pair (key, value) into @mp@ if key does
 333 -- not exist in the map. If the key does exist, the function will
 334 -- insert the pair @(key,f key new_value old_value)@.
 335 -- Note that the key passed to f is the same key passed to 'insertWithKey'.
 336 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
 337 insertWithKey f kx x t
 338   = case t of
 339       Tip -> singleton kx x
 340       Bin sy ky y l r
 341           -> case compare kx ky of
 342                LT -> balance ky y (insertWithKey f kx x l) r
 343                GT -> balance ky y l (insertWithKey f kx x r)
 344                EQ -> Bin sy kx (f kx x y) l r
 345
 346 -- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@)
 347 -- is a pair where the first element is equal to (@'lookup' k map@)
 348 -- and the second element equal to (@'insertWithKey' f k x map@).
 349 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
 350 insertLookupWithKey f kx x t
 351   = case t of
 352       Tip -> (Nothing, singleton kx x)
 353       Bin sy ky y l r
 354           -> case compare kx ky of
 355                LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
 356                GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
 357                EQ -> (Just y, Bin sy kx (f kx x y) l r)
 358
 359 {--------------------------------------------------------------------
 360   Deletion
 361   [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
 362 --------------------------------------------------------------------}
 363 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
 364 -- a member of the map, the original map is returned.
 365 delete :: Ord k => k -> Map k a -> Map k a
 366 delete k t
 367   = case t of
 368       Tip -> Tip
 369       Bin sx kx x l r
 370           -> case compare k kx of
 371                LT -> balance kx x (delete k l) r
 372                GT -> balance kx x l (delete k r)
 373                EQ -> glue l r
 374
 375 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
 376 -- a member of the map, the original map is returned.
 377 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
 378 adjust f k m
 379   = adjustWithKey (\k x -> f x) k m
 380
 381 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
 382 -- a member of the map, the original map is returned.
 383 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
 384 adjustWithKey f k m
 385   = updateWithKey (\k x -> Just (f k x)) k m
 386
 387 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
 388 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
 389 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
 390 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
 391 update f k m
 392   = updateWithKey (\k x -> f x) k m
 393
 394 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
 395 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
 396 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
 397 -- to the new value @y@.
 398 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
 399 updateWithKey f k t
 400   = case t of
 401       Tip -> Tip
 402       Bin sx kx x l r
 403           -> case compare k kx of
 404                LT -> balance kx x (updateWithKey f k l) r
 405                GT -> balance kx x l (updateWithKey f k r)
 406                EQ -> case f kx x of
 407                        Just x' -> Bin sx kx x' l r
 408                        Nothing -> glue l r
 409
 410 -- | /O(log n)/. Lookup and update.
 411 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
 412 updateLookupWithKey f k t
 413   = case t of
 414       Tip -> (Nothing,Tip)
 415       Bin sx kx x l r
 416           -> case compare k kx of
 417                LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
 418                GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
 419                EQ -> case f kx x of
 420                        Just x' -> (Just x',Bin sx kx x' l r)
 421                        Nothing -> (Just x,glue l r)
 422
 423 {--------------------------------------------------------------------
 424   Indexing
 425 --------------------------------------------------------------------}
 426 -- | /O(log n)/. Return the /index/ of a key. The index is a number from
 427 -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
 428 -- the key is not a 'member' of the map.
 429 findIndex :: Ord k => k -> Map k a -> Int
 430 findIndex k t
 431   = case lookupIndex k t of
 432       Nothing  -> error "Map.findIndex: element is not in the map"
 433       Just idx -> idx
 434
 435 -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
 436 -- /0/ up to, but not including, the 'size' of the map.
 437 lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
 438 lookupIndex k t = case lookup 0 t of
 439     Nothing -> fail "Data.Map.lookupIndex: Key not found."
 440     Just x -> return x
 441   where
 442     lookup idx Tip  = Nothing
 443     lookup idx (Bin _ kx x l r)
 444       = case compare k kx of
 445           LT -> lookup idx l
 446           GT -> lookup (idx + size l + 1) r
 447           EQ -> Just (idx + size l)
 448
 449 -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
 450 -- invalid index is used.
 451 elemAt :: Int -> Map k a -> (k,a)
 452 elemAt i Tip = error "Map.elemAt: index out of range"
 453 elemAt i (Bin _ kx x l r)
 454   = case compare i sizeL of
 455       LT -> elemAt i l
 456       GT -> elemAt (i-sizeL-1) r
 457       EQ -> (kx,x)
 458   where
 459     sizeL = size l
 460
 461 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
 462 -- invalid index is used.
 463 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
 464 updateAt f i Tip  = error "Map.updateAt: index out of range"
 465 updateAt f i (Bin sx kx x l r)
 466   = case compare i sizeL of
 467       LT -> updateAt f i l
 468       GT -> updateAt f (i-sizeL-1) r
 469       EQ -> case f kx x of
 470               Just x' -> Bin sx kx x' l r
 471               Nothing -> glue l r
 472   where
 473     sizeL = size l
 474
 475 -- | /O(log n)/. Delete the element at /index/.
 476 -- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
 477 deleteAt :: Int -> Map k a -> Map k a
 478 deleteAt i map
 479   = updateAt (\k x -> Nothing) i map
 480
 481
 482 {--------------------------------------------------------------------
 483   Minimal, Maximal
 484 --------------------------------------------------------------------}
 485 -- | /O(log n)/. The minimal key of the map.
 486 findMin :: Map k a -> (k,a)
 487 findMin (Bin _ kx x Tip r)  = (kx,x)
 488 findMin (Bin _ kx x l r)    = findMin l
 489 findMin Tip                 = error "Map.findMin: empty tree has no minimal element"
 490
 491 -- | /O(log n)/. The maximal key of the map.
 492 findMax :: Map k a -> (k,a)
 493 findMax (Bin _ kx x l Tip)  = (kx,x)
 494 findMax (Bin _ kx x l r)    = findMax r
 495 findMax Tip                 = error "Map.findMax: empty tree has no maximal element"
 496
 497 -- | /O(log n)/. Delete the minimal key.
 498 deleteMin :: Map k a -> Map k a
 499 deleteMin (Bin _ kx x Tip r)  = r
 500 deleteMin (Bin _ kx x l r)    = balance kx x (deleteMin l) r
 501 deleteMin Tip                 = Tip
 502
 503 -- | /O(log n)/. Delete the maximal key.
 504 deleteMax :: Map k a -> Map k a
 505 deleteMax (Bin _ kx x l Tip)  = l
 506 deleteMax (Bin _ kx x l r)    = balance kx x l (deleteMax r)
 507 deleteMax Tip                 = Tip
 508
 509 -- | /O(log n)/. Update the value at the minimal key.
 510 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
 511 updateMin f m
 512   = updateMinWithKey (\k x -> f x) m
 513
 514 -- | /O(log n)/. Update the value at the maximal key.
 515 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
 516 updateMax f m
 517   = updateMaxWithKey (\k x -> f x) m
 518
 519
 520 -- | /O(log n)/. Update the value at the minimal key.
 521 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
 522 updateMinWithKey f t
 523   = case t of
 524       Bin sx kx x Tip r  -> case f kx x of
 525                               Nothing -> r
 526                               Just x' -> Bin sx kx x' Tip r
 527       Bin sx kx x l r    -> balance kx x (updateMinWithKey f l) r
 528       Tip                -> Tip
 529
 530 -- | /O(log n)/. Update the value at the maximal key.
 531 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
 532 updateMaxWithKey f t
 533   = case t of
 534       Bin sx kx x l Tip  -> case f kx x of
 535                               Nothing -> l
 536                               Just x' -> Bin sx kx x' l Tip
 537       Bin sx kx x l r    -> balance kx x l (updateMaxWithKey f r)
 538       Tip                -> Tip
 539
 540
 541 {--------------------------------------------------------------------
 542   Union.
 543 --------------------------------------------------------------------}
 544 -- | The union of a list of maps:
 545 --   (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
 546 unions :: Ord k => [Map k a] -> Map k a
 547 unions ts
 548   = foldlStrict union empty ts
 549
 550 -- | The union of a list of maps, with a combining operation:
 551 --   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
 552 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
 553 unionsWith f ts
 554   = foldlStrict (unionWith f) empty ts
 555
 556 -- | /O(n+m)/.
 557 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
 558 -- It prefers @t1@ when duplicate keys are encountered,
 559 -- i.e. (@'union' == 'unionWith' 'const'@).
 560 -- The implementation uses the efficient /hedge-union/ algorithm.
 561 -- Hedge-union is more efficient on (bigset `union` smallset)
 562 union :: Ord k => Map k a -> Map k a -> Map k a
 563 union Tip t2  = t2
 564 union t1 Tip  = t1
 565 union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2
 566
 567 -- left-biased hedge union
 568 hedgeUnionL cmplo cmphi t1 Tip
 569   = t1
 570 hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
 571   = join kx x (filterGt cmplo l) (filterLt cmphi r)
 572 hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
 573   = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
 574               (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
 575   where
 576     cmpkx k  = compare kx k
 577
 578 -- right-biased hedge union
 579 hedgeUnionR cmplo cmphi t1 Tip
 580   = t1
 581 hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
 582   = join kx x (filterGt cmplo l) (filterLt cmphi r)
 583 hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
 584   = join kx newx (hedgeUnionR cmplo cmpkx l lt)
 585                  (hedgeUnionR cmpkx cmphi r gt)
 586   where
 587     cmpkx k     = compare kx k
 588     lt          = trim cmplo cmpkx t2
 589     (found,gt)  = trimLookupLo kx cmphi t2
 590     newx        = case found of
 591                     Nothing -> x
 592                     Just (_,y) -> y
 593
 594 {--------------------------------------------------------------------
 595   Union with a combining function
 596 --------------------------------------------------------------------}
 597 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
 598 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
 599 unionWith f m1 m2
 600   = unionWithKey (\k x y -> f x y) m1 m2
 601
 602 -- | /O(n+m)/.
 603 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
 604 -- Hedge-union is more efficient on (bigset `union` smallset).
 605 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
 606 unionWithKey f Tip t2  = t2
 607 unionWithKey f t1 Tip  = t1
 608 unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
 609
 610 hedgeUnionWithKey f cmplo cmphi t1 Tip
 611   = t1
 612 hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
 613   = join kx x (filterGt cmplo l) (filterLt cmphi r)
 614 hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
 615   = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
 616                  (hedgeUnionWithKey f cmpkx cmphi r gt)
 617   where
 618     cmpkx k     = compare kx k
 619     lt          = trim cmplo cmpkx t2
 620     (found,gt)  = trimLookupLo kx cmphi t2
 621     newx        = case found of
 622                     Nothing -> x
 623                     Just (_,y) -> f kx x y
 624
 625 {--------------------------------------------------------------------
 626   Difference
 627 --------------------------------------------------------------------}
 628 -- | /O(n+m)/. Difference of two maps.
 629 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
 630 difference :: Ord k => Map k a -> Map k b -> Map k a
 631 difference Tip t2  = Tip
 632 difference t1 Tip  = t1
 633 difference t1 t2   = hedgeDiff (const LT) (const GT) t1 t2
 634
 635 hedgeDiff cmplo cmphi Tip t
 636   = Tip
 637 hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
 638   = join kx x (filterGt cmplo l) (filterLt cmphi r)
 639 hedgeDiff cmplo cmphi t (Bin _ kx x l r)
 640   = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
 641           (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
 642   where
 643     cmpkx k = compare kx k
 644
 645 -- | /O(n+m)/. Difference with a combining function.
 646 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
 647 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
 648 differenceWith f m1 m2
 649   = differenceWithKey (\k x y -> f x y) m1 m2
 650
 651 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
 652 -- encountered, the combining function is applied to the key and both values.
 653 -- If it returns 'Nothing', the element is discarded (proper set difference). If
 654 -- it returns (@'Just' y@), the element is updated with a new value @y@.
 655 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
 656 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
 657 differenceWithKey f Tip t2  = Tip
 658 differenceWithKey f t1 Tip  = t1
 659 differenceWithKey f t1 t2   = hedgeDiffWithKey f (const LT) (const GT) t1 t2
 660
 661 hedgeDiffWithKey f cmplo cmphi Tip t
 662   = Tip
 663 hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
 664   = join kx x (filterGt cmplo l) (filterLt cmphi r)
 665 hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
 666   = case found of
 667       Nothing -> merge tl tr
 668       Just (ky,y) ->
 669           case f ky y x of
 670             Nothing -> merge tl tr
 671             Just z  -> join ky z tl tr
 672   where
 673     cmpkx k     = compare kx k
 674     lt          = trim cmplo cmpkx t
 675     (found,gt)  = trimLookupLo kx cmphi t
 676     tl          = hedgeDiffWithKey f cmplo cmpkx lt l
 677     tr          = hedgeDiffWithKey f cmpkx cmphi gt r
 678
 679
 680
 681 {--------------------------------------------------------------------
 682   Intersection
 683 --------------------------------------------------------------------}
 684 -- | /O(n+m)/. Intersection of two maps. The values in the first
 685 -- map are returned, i.e. (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
 686 intersection :: Ord k => Map k a -> Map k b -> Map k a
 687 intersection m1 m2
 688   = intersectionWithKey (\k x y -> x) m1 m2
 689
 690 -- | /O(n+m)/. Intersection with a combining function.
 691 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
 692 intersectionWith f m1 m2
 693   = intersectionWithKey (\k x y -> f x y) m1 m2
 694
 695 -- | /O(n+m)/. Intersection with a combining function.
 696 -- Intersection is more efficient on (bigset `intersection` smallset)
 697 --intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
 698 --intersectionWithKey f Tip t = Tip
 699 --intersectionWithKey f t Tip = Tip
 700 --intersectionWithKey f t1 t2 = intersectWithKey f t1 t2
 701 --
 702 --intersectWithKey f Tip t = Tip
 703 --intersectWithKey f t Tip = Tip
 704 --intersectWithKey f t (Bin _ kx x l r)
 705 --  = case found of
 706 --      Nothing -> merge tl tr
 707 --      Just y  -> join kx (f kx y x) tl tr
 708 --  where
 709 --    (lt,found,gt) = splitLookup kx t
 710 --    tl            = intersectWithKey f lt l
 711 --    tr            = intersectWithKey f gt r
 712
 713
 714 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
 715 intersectionWithKey f Tip t = Tip
 716 intersectionWithKey f t Tip = Tip
 717 intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =
 718    if s1 >= s2 then
 719       let (lt,found,gt) = splitLookupWithKey k2 t1
 720           tl            = intersectionWithKey f lt l2
 721           tr            = intersectionWithKey f gt r2
 722       in case found of
 723       Just (k,x) -> join k (f k x x2) tl tr
 724       Nothing -> merge tl tr
 725    else let (lt,found,gt) = splitLookup k1 t2
 726             tl            = intersectionWithKey f l1 lt
 727             tr            = intersectionWithKey f r1 gt
 728       in case found of
 729       Just x -> join k1 (f k1 x1 x) tl tr
 730       Nothing -> merge tl tr
 731
 732
 733
 734 {--------------------------------------------------------------------
 735   Submap
 736 --------------------------------------------------------------------}
 737 -- | /O(n+m)/.
 738 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
 739 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
 740 isSubmapOf m1 m2
 741   = isSubmapOfBy (==) m1 m2
 742
 743 {- | /O(n+m)/.
 744  The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
 745  all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
 746  applied to their respective values. For example, the following
 747  expressions are all 'True':
 748
 749  > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
 750  > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
 751  > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
 752
 753  But the following are all 'False':
 754
 755  > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
 756  > isSubmapOfBy (<)  (fromList [('a',1)]) (fromList [('a',1),('b',2)])
 757  > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
 758 -}
 759 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
 760 isSubmapOfBy f t1 t2
 761   = (size t1 <= size t2) && (submap' f t1 t2)
 762
 763 submap' f Tip t = True
 764 submap' f t Tip = False
 765 submap' f (Bin _ kx x l r) t
 766   = case found of
 767       Nothing -> False
 768       Just y  -> f x y && submap' f l lt && submap' f r gt
 769   where
 770     (lt,found,gt) = splitLookup kx t
 771
 772 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
 773 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
 774 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
 775 isProperSubmapOf m1 m2
 776   = isProperSubmapOfBy (==) m1 m2
 777
 778 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
 779  The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
 780  @m1@ and @m2@ are not equal,
 781  all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
 782  applied to their respective values. For example, the following
 783  expressions are all 'True':
 784
 785   > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 786   > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
 787
 788  But the following are all 'False':
 789
 790   > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
 791   > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
 792   > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])
 793 -}
 794 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
 795 isProperSubmapOfBy f t1 t2
 796   = (size t1 < size t2) && (submap' f t1 t2)
 797
 798 {--------------------------------------------------------------------
 799   Filter and partition
 800 --------------------------------------------------------------------}
 801 -- | /O(n)/. Filter all values that satisfy the predicate.
 802 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
 803 filter p m
 804   = filterWithKey (\k x -> p x) m
 805
 806 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
 807 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
 808 filterWithKey p Tip = Tip
 809 filterWithKey p (Bin _ kx x l r)
 810   | p kx x    = join kx x (filterWithKey p l) (filterWithKey p r)
 811   | otherwise = merge (filterWithKey p l) (filterWithKey p r)
 812
 813
 814 -- | /O(n)/. partition the map according to a predicate. The first
 815 -- map contains all elements that satisfy the predicate, the second all
 816 -- elements that fail the predicate. See also 'split'.
 817 partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
 818 partition p m
 819   = partitionWithKey (\k x -> p x) m
 820
 821 -- | /O(n)/. partition the map according to a predicate. The first
 822 -- map contains all elements that satisfy the predicate, the second all
 823 -- elements that fail the predicate. See also 'split'.
 824 partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
 825 partitionWithKey p Tip = (Tip,Tip)
 826 partitionWithKey p (Bin _ kx x l r)
 827   | p kx x    = (join kx x l1 r1,merge l2 r2)
 828   | otherwise = (merge l1 r1,join kx x l2 r2)
 829   where
 830     (l1,l2) = partitionWithKey p l
 831     (r1,r2) = partitionWithKey p r
 832
 833
 834 {--------------------------------------------------------------------
 835   Mapping
 836 --------------------------------------------------------------------}
 837 -- | /O(n)/. Map a function over all values in the map.
 838 map :: (a -> b) -> Map k a -> Map k b
 839 map f m
 840   = mapWithKey (\k x -> f x) m
 841
 842 -- | /O(n)/. Map a function over all values in the map.
 843 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
 844 mapWithKey f Tip = Tip
 845 mapWithKey f (Bin sx kx x l r)
 846   = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
 847
 848 -- | /O(n)/. The function 'mapAccum' threads an accumulating
 849 -- argument through the map in ascending order of keys.
 850 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
 851 mapAccum f a m
 852   = mapAccumWithKey (\a k x -> f a x) a m
 853
 854 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
 855 -- argument through the map in ascending order of keys.
 856 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
 857 mapAccumWithKey f a t
 858   = mapAccumL f a t
 859
 860 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
 861 -- argument throught the map in ascending order of keys.
 862 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
 863 mapAccumL f a t
 864   = case t of
 865       Tip -> (a,Tip)
 866       Bin sx kx x l r
 867           -> let (a1,l') = mapAccumL f a l
 868                  (a2,x') = f a1 kx x
 869                  (a3,r') = mapAccumL f a2 r
 870              in (a3,Bin sx kx x' l' r')
 871
 872 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
 873 -- argument throught the map in descending order of keys.
 874 mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
 875 mapAccumR f a t
 876   = case t of
 877       Tip -> (a,Tip)
 878       Bin sx kx x l r
 879           -> let (a1,r') = mapAccumR f a r
 880                  (a2,x') = f a1 kx x
 881                  (a3,l') = mapAccumR f a2 l
 882              in (a3,Bin sx kx x' l' r')
 883
 884 -- | /O(n*log n)/.
 885 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
 886 --
 887 -- The size of the result may be smaller if @f@ maps two or more distinct
 888 -- keys to the same new key.  In this case the value at the smallest of
 889 -- these keys is retained.
 890
 891 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
 892 mapKeys = mapKeysWith (\x y->x)
 893
 894 -- | /O(n*log n)/.
 895 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
 896 --
 897 -- The size of the result may be smaller if @f@ maps two or more distinct
 898 -- keys to the same new key.  In this case the associated values will be
 899 -- combined using @c@.
 900
 901 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
 902 mapKeysWith c f = fromListWith c . List.map fFirst . toList
 903     where fFirst (x,y) = (f x, y)
 904
 905
 906 -- | /O(n)/.
 907 -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
 908 -- is strictly monotonic.
 909 -- /The precondition is not checked./
 910 -- Semi-formally, we have:
 911 --
 912 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
 913 -- >                     ==> mapKeysMonotonic f s == mapKeys f s
 914 -- >     where ls = keys s
 915
 916 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
 917 mapKeysMonotonic f Tip = Tip
 918 mapKeysMonotonic f (Bin sz k x l r) =
 919     Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
 920
 921 {--------------------------------------------------------------------
 922   Folds
 923 --------------------------------------------------------------------}
 924
 925 -- | /O(n)/. Fold the values in the map, such that
 926 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
 927 -- For example,
 928 --
 929 -- > elems map = fold (:) [] map
 930 --
 931 fold :: (a -> b -> b) -> b -> Map k a -> b
 932 fold f z m
 933   = foldWithKey (\k x z -> f x z) z m
 934
 935 -- | /O(n)/. Fold the keys and values in the map, such that
 936 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
 937 -- For example,
 938 --
 939 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
 940 --
 941 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
 942 foldWithKey f z t
 943   = foldr f z t
 944
 945 -- | /O(n)/. In-order fold.
 946 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
 947 foldi f z Tip               = z
 948 foldi f z (Bin _ kx x l r)  = f kx x (foldi f z l) (foldi f z r)
 949
 950 -- | /O(n)/. Post-order fold.
 951 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
 952 foldr f z Tip              = z
 953 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
 954
 955 -- | /O(n)/. Pre-order fold.
 956 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
 957 foldl f z Tip              = z
 958 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
 959
 960 {--------------------------------------------------------------------
 961   List variations
 962 --------------------------------------------------------------------}
 963 -- | /O(n)/.
 964 -- Return all elements of the map in the ascending order of their keys.
 965 elems :: Map k a -> [a]
 966 elems m
 967   = [x | (k,x) <- assocs m]
 968
 969 -- | /O(n)/. Return all keys of the map in ascending order.
 970 keys  :: Map k a -> [k]
 971 keys m
 972   = [k | (k,x) <- assocs m]
 973
 974 -- | /O(n)/. The set of all keys of the map.
 975 keysSet :: Map k a -> Set.Set k
 976 keysSet m = Set.fromDistinctAscList (keys m)
 977
 978 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
 979 assocs :: Map k a -> [(k,a)]
 980 assocs m
 981   = toList m
 982
 983 {--------------------------------------------------------------------
 984   Lists
 985   use [foldlStrict] to reduce demand on the control-stack
 986 --------------------------------------------------------------------}
 987 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
 988 fromList :: Ord k => [(k,a)] -> Map k a
 989 fromList xs
 990   = foldlStrict ins empty xs
 991   where
 992     ins t (k,x) = insert k x t
 993
 994 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
 995 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
 996 fromListWith f xs
 997   = fromListWithKey (\k x y -> f x y) xs
 998
 999 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
1000 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1001 fromListWithKey f xs
1002   = foldlStrict ins empty xs
1003   where
1004     ins t (k,x) = insertWithKey f k x t
1005
1006 -- | /O(n)/. Convert to a list of key\/value pairs.
1007 toList :: Map k a -> [(k,a)]
1008 toList t      = toAscList t
1009
1010 -- | /O(n)/. Convert to an ascending list.
1011 toAscList :: Map k a -> [(k,a)]
1012 toAscList t   = foldr (\k x xs -> (k,x):xs) [] t
1013
1014 -- | /O(n)/.
1015 toDescList :: Map k a -> [(k,a)]
1016 toDescList t  = foldl (\xs k x -> (k,x):xs) [] t
1017
1018
1019 {--------------------------------------------------------------------
1020   Building trees from ascending/descending lists can be done in linear time.
1021
1022   Note that if [xs] is ascending that:
1023     fromAscList xs       == fromList xs
1024     fromAscListWith f xs == fromListWith f xs
1025 --------------------------------------------------------------------}
1026 -- | /O(n)/. Build a map from an ascending list in linear time.
1027 -- /The precondition (input list is ascending) is not checked./
1028 fromAscList :: Eq k => [(k,a)] -> Map k a
1029 fromAscList xs
1030   = fromAscListWithKey (\k x y -> x) xs
1031
1032 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
1033 -- /The precondition (input list is ascending) is not checked./
1034 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
1035 fromAscListWith f xs
1036   = fromAscListWithKey (\k x y -> f x y) xs
1037
1038 -- | /O(n)/. Build a map from an ascending list in linear time with a
1039 -- combining function for equal keys.
1040 -- /The precondition (input list is ascending) is not checked./
1041 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1042 fromAscListWithKey f xs
1043   = fromDistinctAscList (combineEq f xs)
1044   where
1045   -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1046   combineEq f xs
1047     = case xs of
1048         []     -> []
1049         [x]    -> [x]
1050         (x:xx) -> combineEq' x xx
1051
1052   combineEq' z [] = [z]
1053   combineEq' z@(kz,zz) (x@(kx,xx):xs)
1054     | kx==kz    = let yy = f kx xx zz in combineEq' (kx,yy) xs
1055     | otherwise = z:combineEq' x xs
1056
1057
1058 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
1059 -- /The precondition is not checked./
1060 fromDistinctAscList :: [(k,a)] -> Map k a
1061 fromDistinctAscList xs
1062   = build const (length xs) xs
1063   where
1064     -- 1) use continutations so that we use heap space instead of stack space.
1065     -- 2) special case for n==5 to build bushier trees.
1066     build c 0 xs   = c Tip xs
1067     build c 5 xs   = case xs of
1068                        ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
1069                             -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
1070     build c n xs   = seq nr $ build (buildR nr c) nl xs
1071                    where
1072                      nl = n `div` 2
1073                      nr = n - nl - 1
1074
1075     buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
1076     buildB l k x c r zs     = c (bin k x l r) zs
1077
1078
1079
1080 {--------------------------------------------------------------------
1081   Utility functions that return sub-ranges of the original
1082   tree. Some functions take a comparison function as argument to
1083   allow comparisons against infinite values. A function [cmplo k]
1084   should be read as [compare lo k].
1085
1086   [trim cmplo cmphi t]  A tree that is either empty or where [cmplo k == LT]
1087                         and [cmphi k == GT] for the key [k] of the root.
1088   [filterGt cmp t]      A tree where for all keys [k]. [cmp k == LT]
1089   [filterLt cmp t]      A tree where for all keys [k]. [cmp k == GT]
1090
1091   [split k t]           Returns two trees [l] and [r] where all keys
1092                         in [l] are <[k] and all keys in [r] are >[k].
1093   [splitLookup k t]     Just like [split] but also returns whether [k]
1094                         was found in the tree.
1095 --------------------------------------------------------------------}
1096
1097 {--------------------------------------------------------------------
1098   [trim lo hi t] trims away all subtrees that surely contain no
1099   values between the range [lo] to [hi]. The returned tree is either
1100   empty or the key of the root is between @lo@ and @hi@.
1101 --------------------------------------------------------------------}
1102 trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1103 trim cmplo cmphi Tip = Tip
1104 trim cmplo cmphi t@(Bin sx kx x l r)
1105   = case cmplo kx of
1106       LT -> case cmphi kx of
1107               GT -> t
1108               le -> trim cmplo cmphi l
1109       ge -> trim cmplo cmphi r
1110
1111 trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe (k,a), Map k a)
1112 trimLookupLo lo cmphi Tip = (Nothing,Tip)
1113 trimLookupLo lo cmphi t@(Bin sx kx x l r)
1114   = case compare lo kx of
1115       LT -> case cmphi kx of
1116               GT -> (lookupAssoc lo t, t)
1117               le -> trimLookupLo lo cmphi l
1118       GT -> trimLookupLo lo cmphi r
1119       EQ -> (Just (kx,x),trim (compare lo) cmphi r)
1120
1121
1122 {--------------------------------------------------------------------
1123   [filterGt k t] filter all keys >[k] from tree [t]
1124   [filterLt k t] filter all keys <[k] from tree [t]
1125 --------------------------------------------------------------------}
1126 filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1127 filterGt cmp Tip = Tip
1128 filterGt cmp (Bin sx kx x l r)
1129   = case cmp kx of
1130       LT -> join kx x (filterGt cmp l) r
1131       GT -> filterGt cmp r
1132       EQ -> r
1133
1134 filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1135 filterLt cmp Tip = Tip
1136 filterLt cmp (Bin sx kx x l r)
1137   = case cmp kx of
1138       LT -> filterLt cmp l
1139       GT -> join kx x l (filterLt cmp r)
1140       EQ -> l
1141
1142 {--------------------------------------------------------------------
1143   Split
1144 --------------------------------------------------------------------}
1145 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
1146 -- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
1147 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1148 split k Tip = (Tip,Tip)
1149 split k (Bin sx kx x l r)
1150   = case compare k kx of
1151       LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1152       GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1153       EQ -> (l,r)
1154
1155 -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
1156 -- like 'split' but also returns @'lookup' k map@.
1157 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
1158 splitLookup k Tip = (Tip,Nothing,Tip)
1159 splitLookup k (Bin sx kx x l r)
1160   = case compare k kx of
1161       LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
1162       GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
1163       EQ -> (l,Just x,r)
1164
1165 -- | /O(log n)/.
1166 splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)
1167 splitLookupWithKey k Tip = (Tip,Nothing,Tip)
1168 splitLookupWithKey k (Bin sx kx x l r)
1169   = case compare k kx of
1170       LT -> let (lt,z,gt) = splitLookupWithKey k l in (lt,z,join kx x gt r)
1171       GT -> let (lt,z,gt) = splitLookupWithKey k r in (join kx x l lt,z,gt)
1172       EQ -> (l,Just (kx, x),r)
1173
1174 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
1175 -- element was found in the original set.
1176 splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)
1177 splitMember x t = let (l,m,r) = splitLookup x t in
1178      (l,maybe False (const True) m,r)
1179
1180
1181 {--------------------------------------------------------------------
1182   Utility functions that maintain the balance properties of the tree.
1183   All constructors assume that all values in [l] < [k] and all values
1184   in [r] > [k], and that [l] and [r] are valid trees.
1185
1186   In order of sophistication:
1187     [Bin sz k x l r]  The type constructor.
1188     [bin k x l r]     Maintains the correct size, assumes that both [l]
1189                       and [r] are balanced with respect to each other.
1190     [balance k x l r] Restores the balance and size.
1191                       Assumes that the original tree was balanced and
1192                       that [l] or [r] has changed by at most one element.
1193     [join k x l r]    Restores balance and size.
1194
1195   Furthermore, we can construct a new tree from two trees. Both operations
1196   assume that all values in [l] < all values in [r] and that [l] and [r]
1197   are valid:
1198     [glue l r]        Glues [l] and [r] together. Assumes that [l] and
1199                       [r] are already balanced with respect to each other.
1200     [merge l r]       Merges two trees and restores balance.
1201
1202   Note: in contrast to Adam's paper, we use (<=) comparisons instead
1203   of (<) comparisons in [join], [merge] and [balance].
1204   Quickcheck (on [difference]) showed that this was necessary in order
1205   to maintain the invariants. It is quite unsatisfactory that I haven't
1206   been able to find out why this is actually the case! Fortunately, it
1207   doesn't hurt to be a bit more conservative.
1208 --------------------------------------------------------------------}
1209
1210 {--------------------------------------------------------------------
1211   Join
1212 --------------------------------------------------------------------}
1213 join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1214 join kx x Tip r  = insertMin kx x r
1215 join kx x l Tip  = insertMax kx x l
1216 join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1217   | delta*sizeL <= sizeR  = balance kz z (join kx x l lz) rz
1218   | delta*sizeR <= sizeL  = balance ky y ly (join kx x ry r)
1219   | otherwise             = bin kx x l r
1220
1221
1222 -- insertMin and insertMax don't perform potentially expensive comparisons.
1223 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1224 insertMax kx x t
1225   = case t of
1226       Tip -> singleton kx x
1227       Bin sz ky y l r
1228           -> balance ky y l (insertMax kx x r)
1229
1230 insertMin kx x t
1231   = case t of
1232       Tip -> singleton kx x
1233       Bin sz ky y l r
1234           -> balance ky y (insertMin kx x l) r
1235
1236 {--------------------------------------------------------------------
1237   [merge l r]: merges two trees.
1238 --------------------------------------------------------------------}
1239 merge :: Map k a -> Map k a -> Map k a
1240 merge Tip r   = r
1241 merge l Tip   = l
1242 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1243   | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1244   | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1245   | otherwise            = glue l r
1246
1247 {--------------------------------------------------------------------
1248   [glue l r]: glues two trees together.
1249   Assumes that [l] and [r] are already balanced with respect to each other.
1250 --------------------------------------------------------------------}
1251 glue :: Map k a -> Map k a -> Map k a
1252 glue Tip r = r
1253 glue l Tip = l
1254 glue l r
1255   | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1256   | otherwise       = let ((km,m),r') = deleteFindMin r in balance km m l r'
1257
1258
1259 -- | /O(log n)/. Delete and find the minimal element.
1260 deleteFindMin :: Map k a -> ((k,a),Map k a)
1261 deleteFindMin t
1262   = case t of
1263       Bin _ k x Tip r -> ((k,x),r)
1264       Bin _ k x l r   -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1265       Tip             -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1266
1267 -- | /O(log n)/. Delete and find the maximal element.
1268 deleteFindMax :: Map k a -> ((k,a),Map k a)
1269 deleteFindMax t
1270   = case t of
1271       Bin _ k x l Tip -> ((k,x),l)
1272       Bin _ k x l r   -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1273       Tip             -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1274
1275
1276 {--------------------------------------------------------------------
1277   [balance l x r] balances two trees with value x.
1278   The sizes of the trees should balance after decreasing the
1279   size of one of them. (a rotation).
1280
1281   [delta] is the maximal relative difference between the sizes of
1282           two trees, it corresponds with the [w] in Adams' paper.
1283   [ratio] is the ratio between an outer and inner sibling of the
1284           heavier subtree in an unbalanced setting. It determines
1285           whether a double or single rotation should be performed
1286           to restore balance. It is correspondes with the inverse
1287           of $\alpha$ in Adam's article.
1288
1289   Note that:
1290   - [delta] should be larger than 4.646 with a [ratio] of 2.
1291   - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1292
1293   - A lower [delta] leads to a more 'perfectly' balanced tree.
1294   - A higher [delta] performs less rebalancing.
1295
1296   - Balancing is automatic for random data and a balancing
1297     scheme is only necessary to avoid pathological worst cases.
1298     Almost any choice will do, and in practice, a rather large
1299     [delta] may perform better than smaller one.
1300
1301   Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1302   to decide whether a single or double rotation is needed. Allthough
1303   he actually proves that this ratio is needed to maintain the
1304   invariants, his implementation uses an invalid ratio of [1].
1305 --------------------------------------------------------------------}
1306 delta,ratio :: Int
1307 delta = 5
1308 ratio = 2
1309
1310 balance :: k -> a -> Map k a -> Map k a -> Map k a
1311 balance k x l r
1312   | sizeL + sizeR <= 1    = Bin sizeX k x l r
1313   | sizeR >= delta*sizeL  = rotateL k x l r
1314   | sizeL >= delta*sizeR  = rotateR k x l r
1315   | otherwise             = Bin sizeX k x l r
1316   where
1317     sizeL = size l
1318     sizeR = size r
1319     sizeX = sizeL + sizeR + 1
1320
1321 -- rotate
1322 rotateL k x l r@(Bin _ _ _ ly ry)
1323   | size ly < ratio*size ry = singleL k x l r
1324   | otherwise               = doubleL k x l r
1325
1326 rotateR k x l@(Bin _ _ _ ly ry) r
1327   | size ry < ratio*size ly = singleR k x l r
1328   | otherwise               = doubleR k x l r
1329
1330 -- basic rotations
1331 singleL k1 x1 t1 (Bin _ k2 x2 t2 t3)  = bin k2 x2 (bin k1 x1 t1 t2) t3
1332 singleR k1 x1 (Bin _ k2 x2 t1 t2) t3  = bin k2 x2 t1 (bin k1 x1 t2 t3)
1333
1334 doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)
1335 doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)
1336
1337
1338 {--------------------------------------------------------------------
1339   The bin constructor maintains the size of the tree
1340 --------------------------------------------------------------------}
1341 bin :: k -> a -> Map k a -> Map k a -> Map k a
1342 bin k x l r
1343   = Bin (size l + size r + 1) k x l r
1344
1345
1346 {--------------------------------------------------------------------
1347   Eq converts the tree to a list. In a lazy setting, this
1348   actually seems one of the faster methods to compare two trees
1349   and it is certainly the simplest :-)
1350 --------------------------------------------------------------------}
1351 instance (Eq k,Eq a) => Eq (Map k a) where
1352   t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1353
1354 {--------------------------------------------------------------------
1355   Ord
1356 --------------------------------------------------------------------}
1357
1358 instance (Ord k, Ord v) => Ord (Map k v) where
1359     compare m1 m2 = compare (toAscList m1) (toAscList m2)
1360
1361 {--------------------------------------------------------------------
1362   Functor
1363 --------------------------------------------------------------------}
1364 instance Functor (Map k) where
1365   fmap f m  = map f m
1366
1367 instance Traversable (Map k) where
1368   traverse f Tip = pure Tip
1369   traverse f (Bin s k v l r)
1370     = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
1371
1372 instance Foldable (Map k) where
1373   foldMap _f Tip = mempty
1374   foldMap f (Bin _s _k v l r)
1375     = foldMap f l `mappend` f v `mappend` foldMap f r
1376
1377 {--------------------------------------------------------------------
1378   Read
1379 --------------------------------------------------------------------}
1380 instance (Ord k, Read k, Read e) => Read (Map k e) where
1381 #ifdef __GLASGOW_HASKELL__
1382   readPrec = parens $ prec 10 $ do
1383     Ident "fromList" <- lexP
1384     xs <- readPrec
1385     return (fromList xs)
1386
1387   readListPrec = readListPrecDefault
1388 #else
1389   readsPrec p = readParen (p > 10) $ \ r -> do
1390     ("fromList",s) <- lex r
1391     (xs,t) <- reads s
1392     return (fromList xs,t)
1393 #endif
1394
1395 -- parses a pair of things with the syntax a:=b
1396 readPair :: (Read a, Read b) => ReadS (a,b)
1397 readPair s = do (a, ct1)    <- reads s
1398                 (":=", ct2) <- lex ct1
1399                 (b, ct3)    <- reads ct2
1400                 return ((a,b), ct3)
1401
1402 {--------------------------------------------------------------------
1403   Show
1404 --------------------------------------------------------------------}
1405 instance (Show k, Show a) => Show (Map k a) where
1406   showsPrec d m  = showParen (d > 10) $
1407     showString "fromList " . shows (toList m)
1408
1409 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1410 showMap []
1411   = showString "{}"
1412 showMap (x:xs)
1413   = showChar '{' . showElem x . showTail xs
1414   where
1415     showTail []     = showChar '}'
1416     showTail (x:xs) = showString ", " . showElem x . showTail xs
1417
1418     showElem (k,x)  = shows k . showString " := " . shows x
1419
1420
1421 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1422 -- in a compressed, hanging format.
1423 showTree :: (Show k,Show a) => Map k a -> String
1424 showTree m
1425   = showTreeWith showElem True False m
1426   where
1427     showElem k x  = show k ++ ":=" ++ show x
1428
1429
1430 {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
1431  the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1432  'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1433  @wide@ is 'True', an extra wide version is shown.
1434
1435 >  Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1436 >  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1437 >  (4,())
1438 >  +--(2,())
1439 >  |  +--(1,())
1440 >  |  +--(3,())
1441 >  +--(5,())
1442 >
1443 >  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1444 >  (4,())
1445 >  |
1446 >  +--(2,())
1447 >  |  |
1448 >  |  +--(1,())
1449 >  |  |
1450 >  |  +--(3,())
1451 >  |
1452 >  +--(5,())
1453 >
1454 >  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
1455 >  +--(5,())
1456 >  |
1457 >  (4,())
1458 >  |
1459 >  |  +--(3,())
1460 >  |  |
1461 >  +--(2,())
1462 >     |
1463 >     +--(1,())
1464
1465 -}
1466 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
1467 showTreeWith showelem hang wide t
1468   | hang      = (showsTreeHang showelem wide [] t) ""
1469   | otherwise = (showsTree showelem wide [] [] t) ""
1470
1471 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1472 showsTree showelem wide lbars rbars t
1473   = case t of
1474       Tip -> showsBars lbars . showString "|\n"
1475       Bin sz kx x Tip Tip
1476           -> showsBars lbars . showString (showelem kx x) . showString "\n"
1477       Bin sz kx x l r
1478           -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
1479              showWide wide rbars .
1480              showsBars lbars . showString (showelem kx x) . showString "\n" .
1481              showWide wide lbars .
1482              showsTree showelem wide (withEmpty lbars) (withBar lbars) l
1483
1484 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1485 showsTreeHang showelem wide bars t
1486   = case t of
1487       Tip -> showsBars bars . showString "|\n"
1488       Bin sz kx x Tip Tip
1489           -> showsBars bars . showString (showelem kx x) . showString "\n"
1490       Bin sz kx x l r
1491           -> showsBars bars . showString (showelem kx x) . showString "\n" .
1492              showWide wide bars .
1493              showsTreeHang showelem wide (withBar bars) l .
1494              showWide wide bars .
1495              showsTreeHang showelem wide (withEmpty bars) r
1496
1497
1498 showWide wide bars
1499   | wide      = showString (concat (reverse bars)) . showString "|\n"
1500   | otherwise = id
1501
1502 showsBars :: [String] -> ShowS
1503 showsBars bars
1504   = case bars of
1505       [] -> id
1506       _  -> showString (concat (reverse (tail bars))) . showString node
1507
1508 node           = "+--"
1509 withBar bars   = "|  ":bars
1510 withEmpty bars = "   ":bars
1511
1512 {--------------------------------------------------------------------
1513   Typeable
1514 --------------------------------------------------------------------}
1515
1516 #include "Typeable.h"
1517 INSTANCE_TYPEABLE2(Map,mapTc,"Map")
1518
1519 {--------------------------------------------------------------------
1520   Assertions
1521 --------------------------------------------------------------------}
1522 -- | /O(n)/. Test if the internal map structure is valid.
1523 valid :: Ord k => Map k a -> Bool
1524 valid t
1525   = balanced t && ordered t && validsize t
1526
1527 ordered t
1528   = bounded (const True) (const True) t
1529   where
1530     bounded lo hi t
1531       = case t of
1532           Tip              -> True
1533           Bin sz kx x l r  -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1534
1535 -- | Exported only for "Debug.QuickCheck"
1536 balanced :: Map k a -> Bool
1537 balanced t
1538   = case t of
1539       Tip              -> True
1540       Bin sz kx x l r  -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1541                           balanced l && balanced r
1542
1543
1544 validsize t
1545   = (realsize t == Just (size t))
1546   where
1547     realsize t
1548       = case t of
1549           Tip             -> Just 0
1550           Bin sz kx x l r -> case (realsize l,realsize r) of
1551                               (Just n,Just m)  | n+m+1 == sz  -> Just sz
1552                               other            -> Nothing
1553
1554 {--------------------------------------------------------------------
1555   Utilities
1556 --------------------------------------------------------------------}
1557 foldlStrict f z xs
1558   = case xs of
1559       []     -> z
1560       (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1561
1562
1563 {-
1564 {--------------------------------------------------------------------
1565   Testing
1566 --------------------------------------------------------------------}
1567 testTree xs   = fromList [(x,"*") | x <- xs]
1568 test1 = testTree [1..20]
1569 test2 = testTree [30,29..10]
1570 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1571
1572 {--------------------------------------------------------------------
1573   QuickCheck
1574 --------------------------------------------------------------------}
1575 qcheck prop
1576   = check config prop
1577   where
1578     config = Config
1579       { configMaxTest = 500
1580       , configMaxFail = 5000
1581       , configSize    = \n -> (div n 2 + 3)
1582       , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1583       }
1584
1585
1586 {--------------------------------------------------------------------
1587   Arbitrary, reasonably balanced trees
1588 --------------------------------------------------------------------}
1589 instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
1590   arbitrary = sized (arbtree 0 maxkey)
1591             where maxkey  = 10000
1592
1593 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
1594 arbtree lo hi n
1595   | n <= 0        = return Tip
1596   | lo >= hi      = return Tip
1597   | otherwise     = do{ x  <- arbitrary
1598                       ; i  <- choose (lo,hi)
1599                       ; m  <- choose (1,30)
1600                       ; let (ml,mr)  | m==(1::Int)= (1,2)
1601                                      | m==2       = (2,1)
1602                                      | m==3       = (1,1)
1603                                      | otherwise  = (2,2)
1604                       ; l  <- arbtree lo (i-1) (n `div` ml)
1605                       ; r  <- arbtree (i+1) hi (n `div` mr)
1606                       ; return (bin (toEnum i) x l r)
1607                       }
1608
1609
1610 {--------------------------------------------------------------------
1611   Valid tree's
1612 --------------------------------------------------------------------}
1613 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
1614 forValid f
1615   = forAll arbitrary $ \t ->
1616 --    classify (balanced t) "balanced" $
1617     classify (size t == 0) "empty" $
1618     classify (size t > 0  && size t <= 10) "small" $
1619     classify (size t > 10 && size t <= 64) "medium" $
1620     classify (size t > 64) "large" $
1621     balanced t ==> f t
1622
1623 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1624 forValidIntTree f
1625   = forValid f
1626
1627 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1628 forValidUnitTree f
1629   = forValid f
1630
1631
1632 prop_Valid
1633   = forValidUnitTree $ \t -> valid t
1634
1635 {--------------------------------------------------------------------
1636   Single, Insert, Delete
1637 --------------------------------------------------------------------}
1638 prop_Single :: Int -> Int -> Bool
1639 prop_Single k x
1640   = (insert k x empty == singleton k x)
1641
1642 prop_InsertValid :: Int -> Property
1643 prop_InsertValid k
1644   = forValidUnitTree $ \t -> valid (insert k () t)
1645
1646 prop_InsertDelete :: Int -> Map Int () -> Property
1647 prop_InsertDelete k t
1648   = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1649
1650 prop_DeleteValid :: Int -> Property
1651 prop_DeleteValid k
1652   = forValidUnitTree $ \t ->
1653     valid (delete k (insert k () t))
1654
1655 {--------------------------------------------------------------------
1656   Balance
1657 --------------------------------------------------------------------}
1658 prop_Join :: Int -> Property
1659 prop_Join k
1660   = forValidUnitTree $ \t ->
1661     let (l,r) = split k t
1662     in valid (join k () l r)
1663
1664 prop_Merge :: Int -> Property
1665 prop_Merge k
1666   = forValidUnitTree $ \t ->
1667     let (l,r) = split k t
1668     in valid (merge l r)
1669
1670
1671 {--------------------------------------------------------------------
1672   Union
1673 --------------------------------------------------------------------}
1674 prop_UnionValid :: Property
1675 prop_UnionValid
1676   = forValidUnitTree $ \t1 ->
1677     forValidUnitTree $ \t2 ->
1678     valid (union t1 t2)
1679
1680 prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
1681 prop_UnionInsert k x t
1682   = union (singleton k x) t == insert k x t
1683
1684 prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
1685 prop_UnionAssoc t1 t2 t3
1686   = union t1 (union t2 t3) == union (union t1 t2) t3
1687
1688 prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
1689 prop_UnionComm t1 t2
1690   = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1691
1692 prop_UnionWithValid
1693   = forValidIntTree $ \t1 ->
1694     forValidIntTree $ \t2 ->
1695     valid (unionWithKey (\k x y -> x+y) t1 t2)
1696
1697 prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
1698 prop_UnionWith xs ys
1699   = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
1700     == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
1701
1702 prop_DiffValid
1703   = forValidUnitTree $ \t1 ->
1704     forValidUnitTree $ \t2 ->
1705     valid (difference t1 t2)
1706
1707 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1708 prop_Diff xs ys
1709   =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1710     == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))
1711
1712 prop_IntValid
1713   = forValidUnitTree $ \t1 ->
1714     forValidUnitTree $ \t2 ->
1715     valid (intersection t1 t2)
1716
1717 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1718 prop_Int xs ys
1719   =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1720     == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))
1721
1722 {--------------------------------------------------------------------
1723   Lists
1724 --------------------------------------------------------------------}
1725 prop_Ordered
1726   = forAll (choose (5,100)) $ \n ->
1727     let xs = [(x,()) | x <- [0..n::Int]]
1728     in fromAscList xs == fromList xs
1729
1730 prop_List :: [Int] -> Bool
1731 prop_List xs
1732   = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])
1733 -}