Data/Map.hs

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