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