Data/Map.hs

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