1 {-# OPTIONS_GHC -fno-bang-patterns #-}
3 -----------------------------------------------------------------------------
6 -- Copyright : (c) Daan Leijen 2002
8 -- Maintainer : libraries@haskell.org
9 -- Stability : provisional
10 -- Portability : portable
12 -- An efficient implementation of maps from keys to values (dictionaries).
14 -- This module is intended to be imported @qualified@, to avoid name
15 -- clashes with Prelude functions. eg.
17 -- > import Data.Map as Map
19 -- The implementation of 'Map' is based on /size balanced/ binary trees (or
20 -- trees of /bounded balance/) as described by:
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>.
26 -- * J. Nievergelt and E.M. Reingold,
27 -- \"/Binary search trees of bounded balance/\",
28 -- SIAM journal of computing 2(1), March 1973.
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 -----------------------------------------------------------------------------
37 Map -- instance Eq,Show,Read
57 , insertWith, insertWithKey, insertLookupWithKey
118 , fromDistinctAscList
135 , isSubmapOf, isSubmapOfBy
136 , isProperSubmapOf, isProperSubmapOfBy
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(..))
170 import Control.Applicative (Applicative(..), (<$>))
171 import Data.Traversable (Traversable(traverse))
172 import Data.Foldable (Foldable(foldMap))
176 import qualified Prelude
177 import qualified List
178 import Debug.QuickCheck
179 import List(nub,sort)
182 #if __GLASGOW_HASKELL__
184 import Data.Generics.Basics
185 import Data.Generics.Instances
188 {--------------------------------------------------------------------
190 --------------------------------------------------------------------}
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
198 -- | /O(n+m)/. See 'difference'.
199 (\\) :: Ord k => Map k a -> Map k b -> Map k a
200 m1 \\ m2 = difference m1 m2
202 {--------------------------------------------------------------------
204 --------------------------------------------------------------------}
205 -- | A Map from keys @k@ to values @a@.
207 | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
211 instance (Ord k) => Monoid (Map k v) where
216 #if __GLASGOW_HASKELL__
218 {--------------------------------------------------------------------
220 --------------------------------------------------------------------}
222 -- This instance preserves data abstraction at the cost of inefficiency.
223 -- We omit reflection services for the sake of data abstraction.
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
234 {--------------------------------------------------------------------
236 --------------------------------------------------------------------}
237 -- | /O(1)/. Is the map empty?
238 null :: Map k a -> Bool
242 Bin sz k x l r -> False
244 -- | /O(1)/. The number of elements in the map.
245 size :: Map k a -> Int
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
256 Nothing -> fail "Data.Map.lookup: Key not found"
257 lookup' :: Ord k => k -> Map k a -> Maybe a
262 -> case compare k kx of
267 lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
272 -> case compare k kx of
273 LT -> lookupAssoc k l
274 GT -> lookupAssoc k r
277 -- | /O(log n)/. Is the key a member of the map?
278 member :: Ord k => k -> Map k a -> Bool
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
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
293 Nothing -> error "Map.find: element not in the map"
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
306 {--------------------------------------------------------------------
308 --------------------------------------------------------------------}
309 -- | /O(1)/. The empty map.
314 -- | /O(1)/. A map with a single element.
315 singleton :: k -> a -> Map k a
319 {--------------------------------------------------------------------
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
329 Tip -> singleton kx x
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
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
343 = insertWithKey (\k x y -> f x y) k x m
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
354 Tip -> singleton kx x
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
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
367 Tip -> (Nothing, singleton kx x)
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)
374 {--------------------------------------------------------------------
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
385 -> case compare k kx of
386 LT -> balance kx x (delete k l) r
387 GT -> balance kx x l (delete k r)
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
394 = adjustWithKey (\k x -> f x) k m
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
400 = updateWithKey (\k x -> Just (f k x)) k m
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
407 = updateWithKey (\k x -> f x) k m
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
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)
422 Just x' -> Bin sx kx x' l r
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
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')
435 Just x' -> (Just x',Bin sx kx x' l r)
436 Nothing -> (Just x,glue l r)
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
444 Tip -> case f Nothing of
446 Just x -> singleton k x
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
455 {--------------------------------------------------------------------
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
463 = case lookupIndex k t of
464 Nothing -> error "Map.findIndex: element is not in the map"
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."
474 lookup idx Tip = Nothing
475 lookup idx (Bin _ kx x l r)
476 = case compare k kx of
478 GT -> lookup (idx + size l + 1) r
479 EQ -> Just (idx + size l)
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
488 GT -> elemAt (i-sizeL-1) r
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
500 GT -> updateAt f (i-sizeL-1) r
502 Just x' -> Bin sx kx x' l r
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
511 = updateAt (\k x -> Nothing) i map
514 {--------------------------------------------------------------------
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"
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"
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
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)
541 -- | /O(log n)/. Update the value at the minimal key.
542 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
544 = updateMinWithKey (\k x -> f x) m
546 -- | /O(log n)/. Update the value at the maximal key.
547 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
549 = updateMaxWithKey (\k x -> f x) m
552 -- | /O(log n)/. Update the value at the minimal key.
553 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
556 Bin sx kx x Tip r -> case f kx x of
558 Just x' -> Bin sx kx x' Tip r
559 Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
562 -- | /O(log n)/. Update the value at the maximal key.
563 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
566 Bin sx kx x l Tip -> case f kx x of
568 Just x' -> Bin sx kx x' l Tip
569 Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
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)
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)
586 {--------------------------------------------------------------------
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
593 = foldlStrict union empty ts
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
599 = foldlStrict (unionWith f) empty ts
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
610 union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2
612 -- left-biased hedge union
613 hedgeUnionL cmplo cmphi t1 Tip
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))
621 cmpkx k = compare kx k
623 -- right-biased hedge union
624 hedgeUnionR cmplo cmphi t1 Tip
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)
632 cmpkx k = compare kx k
633 lt = trim cmplo cmpkx t2
634 (found,gt) = trimLookupLo kx cmphi t2
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
645 = unionWithKey (\k x y -> f x y) m1 m2
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
655 hedgeUnionWithKey f cmplo cmphi t1 Tip
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)
663 cmpkx k = compare kx k
664 lt = trim cmplo cmpkx t2
665 (found,gt) = trimLookupLo kx cmphi t2
668 Just (_,y) -> f kx x y
670 {--------------------------------------------------------------------
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
680 hedgeDiff cmplo cmphi Tip t
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)
688 cmpkx k = compare kx k
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
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
706 hedgeDiffWithKey f cmplo cmphi Tip t
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)
712 Nothing -> merge tl tr
715 Nothing -> merge tl tr
716 Just z -> join ky z tl tr
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
726 {--------------------------------------------------------------------
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
733 = intersectionWithKey (\k x y -> x) m1 m2
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
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
747 --intersectWithKey f Tip t = Tip
748 --intersectWithKey f t Tip = Tip
749 --intersectWithKey f t (Bin _ kx x l r)
751 -- Nothing -> merge tl tr
752 -- Just y -> join kx (f kx y x) tl tr
754 -- (lt,found,gt) = splitLookup kx t
755 -- tl = intersectWithKey f lt l
756 -- tr = intersectWithKey f gt r
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) =
764 let (lt,found,gt) = splitLookupWithKey k2 t1
765 tl = intersectionWithKey f lt l2
766 tr = intersectionWithKey f gt r2
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
774 Just x -> join k1 (f k1 x1 x) tl tr
775 Nothing -> merge tl tr
779 {--------------------------------------------------------------------
781 --------------------------------------------------------------------}
783 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
784 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
786 = isSubmapOfBy (==) m1 m2
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':
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)])
798 But the following are all 'False':
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)])
804 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
806 = (size t1 <= size t2) && (submap' f t1 t2)
808 submap' f Tip t = True
809 submap' f t Tip = False
810 submap' f (Bin _ kx x l r) t
813 Just y -> f x y && submap' f l lt && submap' f r gt
815 (lt,found,gt) = splitLookup kx t
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
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':
830 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
831 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
833 But the following are all 'False':
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)])
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)
843 {--------------------------------------------------------------------
845 --------------------------------------------------------------------}
846 -- | /O(n)/. Filter all values that satisfy the predicate.
847 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
849 = filterWithKey (\k x -> p x) m
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)
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)
864 = partitionWithKey (\k x -> p x) m
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)
875 (l1,l2) = partitionWithKey p l
876 (r1,r2) = partitionWithKey p r
878 -- | /O(n)/. Map values and collect the 'Just' results.
879 mapMaybe :: Ord k => (a -> Maybe b) -> Map k a -> Map k b
881 = mapMaybeWithKey (\k x -> f x) m
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)
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)
893 = mapEitherWithKey (\k x -> f x) m
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)
903 (l1,l2) = mapEitherWithKey f l
904 (r1,r2) = mapEitherWithKey f r
906 {--------------------------------------------------------------------
908 --------------------------------------------------------------------}
909 -- | /O(n)/. Map a function over all values in the map.
910 map :: (a -> b) -> Map k a -> Map k b
912 = mapWithKey (\k x -> f x) m
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)
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)
924 = mapAccumWithKey (\a k x -> f a x) a m
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
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)
939 -> let (a1,l') = mapAccumL f a l
941 (a3,r') = mapAccumL f a2 r
942 in (a3,Bin sx kx x' l' r')
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)
951 -> let (a1,r') = mapAccumR f a r
953 (a3,l') = mapAccumR f a2 l
954 in (a3,Bin sx kx x' l' r')
957 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
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.
963 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
964 mapKeys = mapKeysWith (\x y->x)
967 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
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@.
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)
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:
984 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
985 -- > ==> mapKeysMonotonic f s == mapKeys f s
986 -- > where ls = keys s
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)
993 {--------------------------------------------------------------------
995 --------------------------------------------------------------------}
997 -- | /O(n)/. Fold the values in the map, such that
998 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
1001 -- > elems map = fold (:) [] map
1003 fold :: (a -> b -> b) -> b -> Map k a -> b
1005 = foldWithKey (\k x z -> f x z) z m
1007 -- | /O(n)/. Fold the keys and values in the map, such that
1008 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
1011 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
1013 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
1017 -- | /O(n)/. In-order fold.
1018 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
1020 foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
1022 -- | /O(n)/. Post-order fold.
1023 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
1025 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
1027 -- | /O(n)/. Pre-order fold.
1028 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
1030 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
1032 {--------------------------------------------------------------------
1034 --------------------------------------------------------------------}
1036 -- Return all elements of the map in the ascending order of their keys.
1037 elems :: Map k a -> [a]
1039 = [x | (k,x) <- assocs m]
1041 -- | /O(n)/. Return all keys of the map in ascending order.
1042 keys :: Map k a -> [k]
1044 = [k | (k,x) <- assocs m]
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)
1050 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
1051 assocs :: Map k a -> [(k,a)]
1055 {--------------------------------------------------------------------
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
1062 = foldlStrict ins empty xs
1064 ins t (k,x) = insert k x t
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
1069 = fromListWithKey (\k x y -> f x y) xs
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
1076 ins t (k,x) = insertWithKey f k x t
1078 -- | /O(n)/. Convert to a list of key\/value pairs.
1079 toList :: Map k a -> [(k,a)]
1080 toList t = toAscList t
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
1087 toDescList :: Map k a -> [(k,a)]
1088 toDescList t = foldl (\xs k x -> (k,x):xs) [] t
1091 {--------------------------------------------------------------------
1092 Building trees from ascending/descending lists can be done in linear time.
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
1102 = fromAscListWithKey (\k x y -> x) xs
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
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)
1117 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1122 (x:xx) -> combineEq' x xx
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
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
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
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
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].
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]
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 --------------------------------------------------------------------}
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)
1178 LT -> case cmphi kx of
1180 le -> trim cmplo cmphi l
1181 ge -> trim cmplo cmphi r
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)
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)
1202 LT -> join kx x (filterGt cmp l) r
1203 GT -> filterGt cmp r
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)
1210 LT -> filterLt cmp l
1211 GT -> join kx x l (filterLt cmp r)
1214 {--------------------------------------------------------------------
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)
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)
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)
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)
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.
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.
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]
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.
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 --------------------------------------------------------------------}
1282 {--------------------------------------------------------------------
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
1294 -- insertMin and insertMax don't perform potentially expensive comparisons.
1295 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1298 Tip -> singleton kx x
1300 -> balance ky y l (insertMax kx x r)
1304 Tip -> singleton kx x
1306 -> balance ky y (insertMin kx x l) r
1308 {--------------------------------------------------------------------
1309 [merge l r]: merges two trees.
1310 --------------------------------------------------------------------}
1311 merge :: Map k a -> Map k a -> Map k a
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
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
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'
1331 -- | /O(log n)/. Delete and find the minimal element.
1332 deleteFindMin :: Map k a -> ((k,a),Map k a)
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)
1339 -- | /O(log n)/. Delete and find the maximal element.
1340 deleteFindMax :: Map k a -> ((k,a),Map k a)
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)
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).
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.
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.
1365 - A lower [delta] leads to a more 'perfectly' balanced tree.
1366 - A higher [delta] performs less rebalancing.
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.
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 --------------------------------------------------------------------}
1382 balance :: k -> a -> Map k a -> Map k a -> Map k a
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
1391 sizeX = sizeL + sizeR + 1
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
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
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)
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)
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
1415 = Bin (size l + size r + 1) k x l r
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)
1426 {--------------------------------------------------------------------
1428 --------------------------------------------------------------------}
1430 instance (Ord k, Ord v) => Ord (Map k v) where
1431 compare m1 m2 = compare (toAscList m1) (toAscList m2)
1433 {--------------------------------------------------------------------
1435 --------------------------------------------------------------------}
1436 instance Functor (Map k) where
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
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
1449 {--------------------------------------------------------------------
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
1457 return (fromList xs)
1459 readListPrec = readListPrecDefault
1461 readsPrec p = readParen (p > 10) $ \ r -> do
1462 ("fromList",s) <- lex r
1464 return (fromList xs,t)
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
1474 {--------------------------------------------------------------------
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)
1481 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1485 = showChar '{' . showElem x . showTail xs
1487 showTail [] = showChar '}'
1488 showTail (x:xs) = showString ", " . showElem x . showTail xs
1490 showElem (k,x) = shows k . showString " := " . shows x
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
1497 = showTreeWith showElem True False m
1499 showElem k x = show k ++ ":=" ++ show x
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.
1507 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1508 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1515 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1526 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
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) ""
1543 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1544 showsTree showelem wide lbars rbars t
1546 Tip -> showsBars lbars . showString "|\n"
1548 -> showsBars lbars . showString (showelem kx x) . showString "\n"
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
1556 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1557 showsTreeHang showelem wide bars t
1559 Tip -> showsBars bars . showString "|\n"
1561 -> showsBars bars . showString (showelem kx x) . showString "\n"
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
1571 | wide = showString (concat (reverse bars)) . showString "|\n"
1574 showsBars :: [String] -> ShowS
1578 _ -> showString (concat (reverse (tail bars))) . showString node
1581 withBar bars = "| ":bars
1582 withEmpty bars = " ":bars
1584 {--------------------------------------------------------------------
1586 --------------------------------------------------------------------}
1588 #include "Typeable.h"
1589 INSTANCE_TYPEABLE2(Map,mapTc,"Map")
1591 {--------------------------------------------------------------------
1593 --------------------------------------------------------------------}
1594 -- | /O(n)/. Test if the internal map structure is valid.
1595 valid :: Ord k => Map k a -> Bool
1597 = balanced t && ordered t && validsize t
1600 = bounded (const True) (const True) t
1605 Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1607 -- | Exported only for "Debug.QuickCheck"
1608 balanced :: Map k a -> Bool
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
1617 = (realsize t == Just (size t))
1622 Bin sz kx x l r -> case (realsize l,realsize r) of
1623 (Just n,Just m) | n+m+1 == sz -> Just sz
1626 {--------------------------------------------------------------------
1628 --------------------------------------------------------------------}
1632 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1636 {--------------------------------------------------------------------
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]
1644 {--------------------------------------------------------------------
1646 --------------------------------------------------------------------}
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 ]
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
1665 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
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)
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)
1682 {--------------------------------------------------------------------
1684 --------------------------------------------------------------------}
1685 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
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" $
1695 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1699 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1705 = forValidUnitTree $ \t -> valid t
1707 {--------------------------------------------------------------------
1708 Single, Insert, Delete
1709 --------------------------------------------------------------------}
1710 prop_Single :: Int -> Int -> Bool
1712 = (insert k x empty == singleton k x)
1714 prop_InsertValid :: Int -> Property
1716 = forValidUnitTree $ \t -> valid (insert k () t)
1718 prop_InsertDelete :: Int -> Map Int () -> Property
1719 prop_InsertDelete k t
1720 = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1722 prop_DeleteValid :: Int -> Property
1724 = forValidUnitTree $ \t ->
1725 valid (delete k (insert k () t))
1727 {--------------------------------------------------------------------
1729 --------------------------------------------------------------------}
1730 prop_Join :: Int -> Property
1732 = forValidUnitTree $ \t ->
1733 let (l,r) = split k t
1734 in valid (join k () l r)
1736 prop_Merge :: Int -> Property
1738 = forValidUnitTree $ \t ->
1739 let (l,r) = split k t
1740 in valid (merge l r)
1743 {--------------------------------------------------------------------
1745 --------------------------------------------------------------------}
1746 prop_UnionValid :: Property
1748 = forValidUnitTree $ \t1 ->
1749 forValidUnitTree $ \t2 ->
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
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
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)
1765 = forValidIntTree $ \t1 ->
1766 forValidIntTree $ \t2 ->
1767 valid (unionWithKey (\k x y -> x+y) t1 t2)
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))
1775 = forValidUnitTree $ \t1 ->
1776 forValidUnitTree $ \t2 ->
1777 valid (difference t1 t2)
1779 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1781 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1782 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1785 = forValidUnitTree $ \t1 ->
1786 forValidUnitTree $ \t2 ->
1787 valid (intersection t1 t2)
1789 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1791 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1792 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1794 {--------------------------------------------------------------------
1796 --------------------------------------------------------------------}
1798 = forAll (choose (5,100)) $ \n ->
1799 let xs = [(x,()) | x <- [0..n::Int]]
1800 in fromAscList xs == fromList xs
1802 prop_List :: [Int] -> Bool
1804 = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])