Data/Map.hs

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