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