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