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
56 , insertWith, insertWithKey, insertLookupWithKey
116 , fromDistinctAscList
128 , isSubmapOf, isSubmapOfBy
129 , isProperSubmapOf, isProperSubmapOfBy
156 import Prelude hiding (lookup,map,filter,foldr,foldl,null)
157 import qualified Data.Set as Set
158 import qualified Data.List as List
159 import Data.Monoid (Monoid(..))
161 import Control.Applicative (Applicative(..))
162 import Data.Traversable (Traversable(traverse))
163 import Data.Foldable (Foldable(foldMap))
167 import qualified Prelude
168 import qualified List
169 import Debug.QuickCheck
170 import List(nub,sort)
173 #if __GLASGOW_HASKELL__
175 import Data.Generics.Basics
176 import Data.Generics.Instances
179 {--------------------------------------------------------------------
181 --------------------------------------------------------------------}
184 -- | /O(log n)/. Find the value at a key.
185 -- Calls 'error' when the element can not be found.
186 (!) :: Ord k => Map k a -> k -> a
189 -- | /O(n+m)/. See 'difference'.
190 (\\) :: Ord k => Map k a -> Map k b -> Map k a
191 m1 \\ m2 = difference m1 m2
193 {--------------------------------------------------------------------
195 --------------------------------------------------------------------}
196 -- | A Map from keys @k@ to values @a@.
198 | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
202 instance (Ord k) => Monoid (Map k v) where
207 #if __GLASGOW_HASKELL__
209 {--------------------------------------------------------------------
211 --------------------------------------------------------------------}
213 -- This instance preserves data abstraction at the cost of inefficiency.
214 -- We omit reflection services for the sake of data abstraction.
216 instance (Data k, Data a, Ord k) => Data (Map k a) where
217 gfoldl f z map = z fromList `f` (toList map)
218 toConstr _ = error "toConstr"
219 gunfold _ _ = error "gunfold"
220 dataTypeOf _ = mkNorepType "Data.Map.Map"
221 dataCast2 f = gcast2 f
225 {--------------------------------------------------------------------
227 --------------------------------------------------------------------}
228 -- | /O(1)/. Is the map empty?
229 null :: Map k a -> Bool
233 Bin sz k x l r -> False
235 -- | /O(1)/. The number of elements in the map.
236 size :: Map k a -> Int
243 -- | /O(log n)/. Lookup the value at a key in the map.
244 lookup :: (Monad m,Ord k) => k -> Map k a -> m a
245 lookup k t = case lookup' k t of
247 Nothing -> fail "Data.Map.lookup: Key not found"
248 lookup' :: Ord k => k -> Map k a -> Maybe a
253 -> case compare k kx of
258 lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
263 -> case compare k kx of
264 LT -> lookupAssoc k l
265 GT -> lookupAssoc k r
268 -- | /O(log n)/. Is the key a member of the map?
269 member :: Ord k => k -> Map k a -> Bool
275 -- | /O(log n)/. Find the value at a key.
276 -- Calls 'error' when the element can not be found.
277 find :: Ord k => k -> Map k a -> a
280 Nothing -> error "Map.find: element not in the map"
283 -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
284 -- the value at key @k@ or returns @def@ when the key is not in the map.
285 findWithDefault :: Ord k => a -> k -> Map k a -> a
286 findWithDefault def k m
293 {--------------------------------------------------------------------
295 --------------------------------------------------------------------}
296 -- | /O(1)/. The empty map.
301 -- | /O(1)/. A map with a single element.
302 singleton :: k -> a -> Map k a
306 {--------------------------------------------------------------------
308 --------------------------------------------------------------------}
309 -- | /O(log n)/. Insert a new key and value in the map.
310 -- If the key is already present in the map, the associated value is
311 -- replaced with the supplied value, i.e. 'insert' is equivalent to
312 -- @'insertWith' 'const'@.
313 insert :: Ord k => k -> a -> Map k a -> Map k a
316 Tip -> singleton kx x
318 -> case compare kx ky of
319 LT -> balance ky y (insert kx x l) r
320 GT -> balance ky y l (insert kx x r)
321 EQ -> Bin sz kx x l r
323 -- | /O(log n)/. Insert with a combining function.
324 -- @'insertWith' f key value mp@
325 -- will insert the pair (key, value) into @mp@ if key does
326 -- not exist in the map. If the key does exist, the function will
327 -- insert the pair @(key, f new_value old_value)@.
328 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
330 = insertWithKey (\k x y -> f x y) k x m
332 -- | /O(log n)/. Insert with a combining function.
333 -- @'insertWithKey' f key value mp@
334 -- will insert the pair (key, value) into @mp@ if key does
335 -- not exist in the map. If the key does exist, the function will
336 -- insert the pair @(key,f key new_value old_value)@.
337 -- Note that the key passed to f is the same key passed to 'insertWithKey'.
338 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
339 insertWithKey f kx x t
341 Tip -> singleton kx x
343 -> case compare kx ky of
344 LT -> balance ky y (insertWithKey f kx x l) r
345 GT -> balance ky y l (insertWithKey f kx x r)
346 EQ -> Bin sy kx (f kx x y) l r
348 -- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@)
349 -- is a pair where the first element is equal to (@'lookup' k map@)
350 -- and the second element equal to (@'insertWithKey' f k x map@).
351 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
352 insertLookupWithKey f kx x t
354 Tip -> (Nothing, singleton kx x)
356 -> case compare kx ky of
357 LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
358 GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
359 EQ -> (Just y, Bin sy kx (f kx x y) l r)
361 {--------------------------------------------------------------------
363 [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
364 --------------------------------------------------------------------}
365 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
366 -- a member of the map, the original map is returned.
367 delete :: Ord k => k -> Map k a -> Map k a
372 -> case compare k kx of
373 LT -> balance kx x (delete k l) r
374 GT -> balance kx x l (delete k r)
377 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
378 -- a member of the map, the original map is returned.
379 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
381 = adjustWithKey (\k x -> f x) k m
383 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
384 -- a member of the map, the original map is returned.
385 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
387 = updateWithKey (\k x -> Just (f k x)) k m
389 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
390 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
391 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
392 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
394 = updateWithKey (\k x -> f x) k m
396 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
397 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
398 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
399 -- to the new value @y@.
400 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
405 -> case compare k kx of
406 LT -> balance kx x (updateWithKey f k l) r
407 GT -> balance kx x l (updateWithKey f k r)
409 Just x' -> Bin sx kx x' l r
412 -- | /O(log n)/. Lookup and update.
413 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
414 updateLookupWithKey f k t
418 -> case compare k kx of
419 LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
420 GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
422 Just x' -> (Just x',Bin sx kx x' l r)
423 Nothing -> (Just x,glue l r)
425 {--------------------------------------------------------------------
427 --------------------------------------------------------------------}
428 -- | /O(log n)/. Return the /index/ of a key. The index is a number from
429 -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
430 -- the key is not a 'member' of the map.
431 findIndex :: Ord k => k -> Map k a -> Int
433 = case lookupIndex k t of
434 Nothing -> error "Map.findIndex: element is not in the map"
437 -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
438 -- /0/ up to, but not including, the 'size' of the map.
439 lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
440 lookupIndex k t = case lookup 0 t of
441 Nothing -> fail "Data.Map.lookupIndex: Key not found."
444 lookup idx Tip = Nothing
445 lookup idx (Bin _ kx x l r)
446 = case compare k kx of
448 GT -> lookup (idx + size l + 1) r
449 EQ -> Just (idx + size l)
451 -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
452 -- invalid index is used.
453 elemAt :: Int -> Map k a -> (k,a)
454 elemAt i Tip = error "Map.elemAt: index out of range"
455 elemAt i (Bin _ kx x l r)
456 = case compare i sizeL of
458 GT -> elemAt (i-sizeL-1) r
463 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
464 -- invalid index is used.
465 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
466 updateAt f i Tip = error "Map.updateAt: index out of range"
467 updateAt f i (Bin sx kx x l r)
468 = case compare i sizeL of
470 GT -> updateAt f (i-sizeL-1) r
472 Just x' -> Bin sx kx x' l r
477 -- | /O(log n)/. Delete the element at /index/.
478 -- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
479 deleteAt :: Int -> Map k a -> Map k a
481 = updateAt (\k x -> Nothing) i map
484 {--------------------------------------------------------------------
486 --------------------------------------------------------------------}
487 -- | /O(log n)/. The minimal key of the map.
488 findMin :: Map k a -> (k,a)
489 findMin (Bin _ kx x Tip r) = (kx,x)
490 findMin (Bin _ kx x l r) = findMin l
491 findMin Tip = error "Map.findMin: empty tree has no minimal element"
493 -- | /O(log n)/. The maximal key of the map.
494 findMax :: Map k a -> (k,a)
495 findMax (Bin _ kx x l Tip) = (kx,x)
496 findMax (Bin _ kx x l r) = findMax r
497 findMax Tip = error "Map.findMax: empty tree has no maximal element"
499 -- | /O(log n)/. Delete the minimal key.
500 deleteMin :: Map k a -> Map k a
501 deleteMin (Bin _ kx x Tip r) = r
502 deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
505 -- | /O(log n)/. Delete the maximal key.
506 deleteMax :: Map k a -> Map k a
507 deleteMax (Bin _ kx x l Tip) = l
508 deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
511 -- | /O(log n)/. Update the value at the minimal key.
512 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
514 = updateMinWithKey (\k x -> f x) m
516 -- | /O(log n)/. Update the value at the maximal key.
517 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
519 = updateMaxWithKey (\k x -> f x) m
522 -- | /O(log n)/. Update the value at the minimal key.
523 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
526 Bin sx kx x Tip r -> case f kx x of
528 Just x' -> Bin sx kx x' Tip r
529 Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
532 -- | /O(log n)/. Update the value at the maximal key.
533 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
536 Bin sx kx x l Tip -> case f kx x of
538 Just x' -> Bin sx kx x' l Tip
539 Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
543 {--------------------------------------------------------------------
545 --------------------------------------------------------------------}
546 -- | The union of a list of maps:
547 -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
548 unions :: Ord k => [Map k a] -> Map k a
550 = foldlStrict union empty ts
552 -- | The union of a list of maps, with a combining operation:
553 -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
554 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
556 = foldlStrict (unionWith f) empty ts
559 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
560 -- It prefers @t1@ when duplicate keys are encountered,
561 -- i.e. (@'union' == 'unionWith' 'const'@).
562 -- The implementation uses the efficient /hedge-union/ algorithm.
563 -- Hedge-union is more efficient on (bigset `union` smallset)
564 union :: Ord k => Map k a -> Map k a -> Map k a
567 union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2
569 -- left-biased hedge union
570 hedgeUnionL cmplo cmphi t1 Tip
572 hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
573 = join kx x (filterGt cmplo l) (filterLt cmphi r)
574 hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
575 = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
576 (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
578 cmpkx k = compare kx k
580 -- right-biased hedge union
581 hedgeUnionR cmplo cmphi t1 Tip
583 hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
584 = join kx x (filterGt cmplo l) (filterLt cmphi r)
585 hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
586 = join kx newx (hedgeUnionR cmplo cmpkx l lt)
587 (hedgeUnionR cmpkx cmphi r gt)
589 cmpkx k = compare kx k
590 lt = trim cmplo cmpkx t2
591 (found,gt) = trimLookupLo kx cmphi t2
596 {--------------------------------------------------------------------
597 Union with a combining function
598 --------------------------------------------------------------------}
599 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
600 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
602 = unionWithKey (\k x y -> f x y) m1 m2
605 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
606 -- Hedge-union is more efficient on (bigset `union` smallset).
607 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
608 unionWithKey f Tip t2 = t2
609 unionWithKey f t1 Tip = t1
610 unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
612 hedgeUnionWithKey f cmplo cmphi t1 Tip
614 hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
615 = join kx x (filterGt cmplo l) (filterLt cmphi r)
616 hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
617 = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
618 (hedgeUnionWithKey f cmpkx cmphi r gt)
620 cmpkx k = compare kx k
621 lt = trim cmplo cmpkx t2
622 (found,gt) = trimLookupLo kx cmphi t2
625 Just (_,y) -> f kx x y
627 {--------------------------------------------------------------------
629 --------------------------------------------------------------------}
630 -- | /O(n+m)/. Difference of two maps.
631 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
632 difference :: Ord k => Map k a -> Map k b -> Map k a
633 difference Tip t2 = Tip
634 difference t1 Tip = t1
635 difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
637 hedgeDiff cmplo cmphi Tip t
639 hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
640 = join kx x (filterGt cmplo l) (filterLt cmphi r)
641 hedgeDiff cmplo cmphi t (Bin _ kx x l r)
642 = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
643 (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
645 cmpkx k = compare kx k
647 -- | /O(n+m)/. Difference with a combining function.
648 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
649 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
650 differenceWith f m1 m2
651 = differenceWithKey (\k x y -> f x y) m1 m2
653 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
654 -- encountered, the combining function is applied to the key and both values.
655 -- If it returns 'Nothing', the element is discarded (proper set difference). If
656 -- it returns (@'Just' y@), the element is updated with a new value @y@.
657 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
658 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
659 differenceWithKey f Tip t2 = Tip
660 differenceWithKey f t1 Tip = t1
661 differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
663 hedgeDiffWithKey f cmplo cmphi Tip t
665 hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
666 = join kx x (filterGt cmplo l) (filterLt cmphi r)
667 hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
669 Nothing -> merge tl tr
672 Nothing -> merge tl tr
673 Just z -> join ky z tl tr
675 cmpkx k = compare kx k
676 lt = trim cmplo cmpkx t
677 (found,gt) = trimLookupLo kx cmphi t
678 tl = hedgeDiffWithKey f cmplo cmpkx lt l
679 tr = hedgeDiffWithKey f cmpkx cmphi gt r
683 {--------------------------------------------------------------------
685 --------------------------------------------------------------------}
686 -- | /O(n+m)/. Intersection of two maps. The values in the first
687 -- map are returned, i.e. (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
688 intersection :: Ord k => Map k a -> Map k b -> Map k a
690 = intersectionWithKey (\k x y -> x) m1 m2
692 -- | /O(n+m)/. Intersection with a combining function.
693 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
694 intersectionWith f m1 m2
695 = intersectionWithKey (\k x y -> f x y) m1 m2
697 -- | /O(n+m)/. Intersection with a combining function.
698 -- Intersection is more efficient on (bigset `intersection` smallset)
699 --intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
700 --intersectionWithKey f Tip t = Tip
701 --intersectionWithKey f t Tip = Tip
702 --intersectionWithKey f t1 t2 = intersectWithKey f t1 t2
704 --intersectWithKey f Tip t = Tip
705 --intersectWithKey f t Tip = Tip
706 --intersectWithKey f t (Bin _ kx x l r)
708 -- Nothing -> merge tl tr
709 -- Just y -> join kx (f kx y x) tl tr
711 -- (lt,found,gt) = splitLookup kx t
712 -- tl = intersectWithKey f lt l
713 -- tr = intersectWithKey f gt r
716 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
717 intersectionWithKey f Tip t = Tip
718 intersectionWithKey f t Tip = Tip
719 intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =
721 let (lt,found,gt) = splitLookupWithKey k2 t1
722 tl = intersectionWithKey f lt l2
723 tr = intersectionWithKey f gt r2
725 Just (k,x) -> join k (f k x x2) tl tr
726 Nothing -> merge tl tr
727 else let (lt,found,gt) = splitLookup k1 t2
728 tl = intersectionWithKey f l1 lt
729 tr = intersectionWithKey f r1 gt
731 Just x -> join k1 (f k1 x1 x) tl tr
732 Nothing -> merge tl tr
736 {--------------------------------------------------------------------
738 --------------------------------------------------------------------}
740 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
741 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
743 = isSubmapOfBy (==) m1 m2
746 The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
747 all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
748 applied to their respective values. For example, the following
749 expressions are all 'True':
751 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
752 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
753 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
755 But the following are all 'False':
757 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
758 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
759 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
761 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
763 = (size t1 <= size t2) && (submap' f t1 t2)
765 submap' f Tip t = True
766 submap' f t Tip = False
767 submap' f (Bin _ kx x l r) t
770 Just y -> f x y && submap' f l lt && submap' f r gt
772 (lt,found,gt) = splitLookup kx t
774 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
775 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
776 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
777 isProperSubmapOf m1 m2
778 = isProperSubmapOfBy (==) m1 m2
780 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
781 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
782 @m1@ and @m2@ are not equal,
783 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
784 applied to their respective values. For example, the following
785 expressions are all 'True':
787 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
788 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
790 But the following are all 'False':
792 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
793 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
794 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
796 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
797 isProperSubmapOfBy f t1 t2
798 = (size t1 < size t2) && (submap' f t1 t2)
800 {--------------------------------------------------------------------
802 --------------------------------------------------------------------}
803 -- | /O(n)/. Filter all values that satisfy the predicate.
804 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
806 = filterWithKey (\k x -> p x) m
808 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
809 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
810 filterWithKey p Tip = Tip
811 filterWithKey p (Bin _ kx x l r)
812 | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
813 | otherwise = merge (filterWithKey p l) (filterWithKey p r)
816 -- | /O(n)/. partition the map according to a predicate. The first
817 -- map contains all elements that satisfy the predicate, the second all
818 -- elements that fail the predicate. See also 'split'.
819 partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
821 = partitionWithKey (\k x -> p x) m
823 -- | /O(n)/. partition the map according to a predicate. The first
824 -- map contains all elements that satisfy the predicate, the second all
825 -- elements that fail the predicate. See also 'split'.
826 partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
827 partitionWithKey p Tip = (Tip,Tip)
828 partitionWithKey p (Bin _ kx x l r)
829 | p kx x = (join kx x l1 r1,merge l2 r2)
830 | otherwise = (merge l1 r1,join kx x l2 r2)
832 (l1,l2) = partitionWithKey p l
833 (r1,r2) = partitionWithKey p r
836 {--------------------------------------------------------------------
838 --------------------------------------------------------------------}
839 -- | /O(n)/. Map a function over all values in the map.
840 map :: (a -> b) -> Map k a -> Map k b
842 = mapWithKey (\k x -> f x) m
844 -- | /O(n)/. Map a function over all values in the map.
845 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
846 mapWithKey f Tip = Tip
847 mapWithKey f (Bin sx kx x l r)
848 = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
850 -- | /O(n)/. The function 'mapAccum' threads an accumulating
851 -- argument through the map in ascending order of keys.
852 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
854 = mapAccumWithKey (\a k x -> f a x) a m
856 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
857 -- argument through the map in ascending order of keys.
858 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
859 mapAccumWithKey f a t
862 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
863 -- argument throught the map in ascending order of keys.
864 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
869 -> let (a1,l') = mapAccumL f a l
871 (a3,r') = mapAccumL f a2 r
872 in (a3,Bin sx kx x' l' r')
874 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
875 -- argument throught the map in descending order of keys.
876 mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
881 -> let (a1,r') = mapAccumR f a r
883 (a3,l') = mapAccumR f a2 l
884 in (a3,Bin sx kx x' l' r')
887 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
889 -- The size of the result may be smaller if @f@ maps two or more distinct
890 -- keys to the same new key. In this case the value at the smallest of
891 -- these keys is retained.
893 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
894 mapKeys = mapKeysWith (\x y->x)
897 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
899 -- The size of the result may be smaller if @f@ maps two or more distinct
900 -- keys to the same new key. In this case the associated values will be
901 -- combined using @c@.
903 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
904 mapKeysWith c f = fromListWith c . List.map fFirst . toList
905 where fFirst (x,y) = (f x, y)
909 -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
910 -- is strictly monotonic.
911 -- /The precondition is not checked./
912 -- Semi-formally, we have:
914 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
915 -- > ==> mapKeysMonotonic f s == mapKeys f s
916 -- > where ls = keys s
918 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
919 mapKeysMonotonic f Tip = Tip
920 mapKeysMonotonic f (Bin sz k x l r) =
921 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
923 {--------------------------------------------------------------------
925 --------------------------------------------------------------------}
927 -- | /O(n)/. Fold the values in the map, such that
928 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
931 -- > elems map = fold (:) [] map
933 fold :: (a -> b -> b) -> b -> Map k a -> b
935 = foldWithKey (\k x z -> f x z) z m
937 -- | /O(n)/. Fold the keys and values in the map, such that
938 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
941 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
943 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
947 -- | /O(n)/. In-order fold.
948 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
950 foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
952 -- | /O(n)/. Post-order fold.
953 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
955 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
957 -- | /O(n)/. Pre-order fold.
958 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
960 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
962 {--------------------------------------------------------------------
964 --------------------------------------------------------------------}
966 -- Return all elements of the map in the ascending order of their keys.
967 elems :: Map k a -> [a]
969 = [x | (k,x) <- assocs m]
971 -- | /O(n)/. Return all keys of the map in ascending order.
972 keys :: Map k a -> [k]
974 = [k | (k,x) <- assocs m]
976 -- | /O(n)/. The set of all keys of the map.
977 keysSet :: Map k a -> Set.Set k
978 keysSet m = Set.fromDistinctAscList (keys m)
980 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
981 assocs :: Map k a -> [(k,a)]
985 {--------------------------------------------------------------------
987 use [foldlStrict] to reduce demand on the control-stack
988 --------------------------------------------------------------------}
989 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
990 fromList :: Ord k => [(k,a)] -> Map k a
992 = foldlStrict ins empty xs
994 ins t (k,x) = insert k x t
996 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
997 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
999 = fromListWithKey (\k x y -> f x y) xs
1001 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
1002 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1003 fromListWithKey f xs
1004 = foldlStrict ins empty xs
1006 ins t (k,x) = insertWithKey f k x t
1008 -- | /O(n)/. Convert to a list of key\/value pairs.
1009 toList :: Map k a -> [(k,a)]
1010 toList t = toAscList t
1012 -- | /O(n)/. Convert to an ascending list.
1013 toAscList :: Map k a -> [(k,a)]
1014 toAscList t = foldr (\k x xs -> (k,x):xs) [] t
1017 toDescList :: Map k a -> [(k,a)]
1018 toDescList t = foldl (\xs k x -> (k,x):xs) [] t
1021 {--------------------------------------------------------------------
1022 Building trees from ascending/descending lists can be done in linear time.
1024 Note that if [xs] is ascending that:
1025 fromAscList xs == fromList xs
1026 fromAscListWith f xs == fromListWith f xs
1027 --------------------------------------------------------------------}
1028 -- | /O(n)/. Build a map from an ascending list in linear time.
1029 -- /The precondition (input list is ascending) is not checked./
1030 fromAscList :: Eq k => [(k,a)] -> Map k a
1032 = fromAscListWithKey (\k x y -> x) xs
1034 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
1035 -- /The precondition (input list is ascending) is not checked./
1036 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
1037 fromAscListWith f xs
1038 = fromAscListWithKey (\k x y -> f x y) xs
1040 -- | /O(n)/. Build a map from an ascending list in linear time with a
1041 -- combining function for equal keys.
1042 -- /The precondition (input list is ascending) is not checked./
1043 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1044 fromAscListWithKey f xs
1045 = fromDistinctAscList (combineEq f xs)
1047 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1052 (x:xx) -> combineEq' x xx
1054 combineEq' z [] = [z]
1055 combineEq' z@(kz,zz) (x@(kx,xx):xs)
1056 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
1057 | otherwise = z:combineEq' x xs
1060 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
1061 -- /The precondition is not checked./
1062 fromDistinctAscList :: [(k,a)] -> Map k a
1063 fromDistinctAscList xs
1064 = build const (length xs) xs
1066 -- 1) use continutations so that we use heap space instead of stack space.
1067 -- 2) special case for n==5 to build bushier trees.
1068 build c 0 xs = c Tip xs
1069 build c 5 xs = case xs of
1070 ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
1071 -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
1072 build c n xs = seq nr $ build (buildR nr c) nl xs
1077 buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
1078 buildB l k x c r zs = c (bin k x l r) zs
1082 {--------------------------------------------------------------------
1083 Utility functions that return sub-ranges of the original
1084 tree. Some functions take a comparison function as argument to
1085 allow comparisons against infinite values. A function [cmplo k]
1086 should be read as [compare lo k].
1088 [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
1089 and [cmphi k == GT] for the key [k] of the root.
1090 [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
1091 [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
1093 [split k t] Returns two trees [l] and [r] where all keys
1094 in [l] are <[k] and all keys in [r] are >[k].
1095 [splitLookup k t] Just like [split] but also returns whether [k]
1096 was found in the tree.
1097 --------------------------------------------------------------------}
1099 {--------------------------------------------------------------------
1100 [trim lo hi t] trims away all subtrees that surely contain no
1101 values between the range [lo] to [hi]. The returned tree is either
1102 empty or the key of the root is between @lo@ and @hi@.
1103 --------------------------------------------------------------------}
1104 trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1105 trim cmplo cmphi Tip = Tip
1106 trim cmplo cmphi t@(Bin sx kx x l r)
1108 LT -> case cmphi kx of
1110 le -> trim cmplo cmphi l
1111 ge -> trim cmplo cmphi r
1113 trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe (k,a), Map k a)
1114 trimLookupLo lo cmphi Tip = (Nothing,Tip)
1115 trimLookupLo lo cmphi t@(Bin sx kx x l r)
1116 = case compare lo kx of
1117 LT -> case cmphi kx of
1118 GT -> (lookupAssoc lo t, t)
1119 le -> trimLookupLo lo cmphi l
1120 GT -> trimLookupLo lo cmphi r
1121 EQ -> (Just (kx,x),trim (compare lo) cmphi r)
1124 {--------------------------------------------------------------------
1125 [filterGt k t] filter all keys >[k] from tree [t]
1126 [filterLt k t] filter all keys <[k] from tree [t]
1127 --------------------------------------------------------------------}
1128 filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1129 filterGt cmp Tip = Tip
1130 filterGt cmp (Bin sx kx x l r)
1132 LT -> join kx x (filterGt cmp l) r
1133 GT -> filterGt cmp r
1136 filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1137 filterLt cmp Tip = Tip
1138 filterLt cmp (Bin sx kx x l r)
1140 LT -> filterLt cmp l
1141 GT -> join kx x l (filterLt cmp r)
1144 {--------------------------------------------------------------------
1146 --------------------------------------------------------------------}
1147 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
1148 -- 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@.
1149 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1150 split k Tip = (Tip,Tip)
1151 split k (Bin sx kx x l r)
1152 = case compare k kx of
1153 LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1154 GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1157 -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
1158 -- like 'split' but also returns @'lookup' k map@.
1159 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
1160 splitLookup k Tip = (Tip,Nothing,Tip)
1161 splitLookup k (Bin sx kx x l r)
1162 = case compare k kx of
1163 LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
1164 GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
1168 splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)
1169 splitLookupWithKey k Tip = (Tip,Nothing,Tip)
1170 splitLookupWithKey k (Bin sx kx x l r)
1171 = case compare k kx of
1172 LT -> let (lt,z,gt) = splitLookupWithKey k l in (lt,z,join kx x gt r)
1173 GT -> let (lt,z,gt) = splitLookupWithKey k r in (join kx x l lt,z,gt)
1174 EQ -> (l,Just (kx, x),r)
1176 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
1177 -- element was found in the original set.
1178 splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)
1179 splitMember x t = let (l,m,r) = splitLookup x t in
1180 (l,maybe False (const True) m,r)
1183 {--------------------------------------------------------------------
1184 Utility functions that maintain the balance properties of the tree.
1185 All constructors assume that all values in [l] < [k] and all values
1186 in [r] > [k], and that [l] and [r] are valid trees.
1188 In order of sophistication:
1189 [Bin sz k x l r] The type constructor.
1190 [bin k x l r] Maintains the correct size, assumes that both [l]
1191 and [r] are balanced with respect to each other.
1192 [balance k x l r] Restores the balance and size.
1193 Assumes that the original tree was balanced and
1194 that [l] or [r] has changed by at most one element.
1195 [join k x l r] Restores balance and size.
1197 Furthermore, we can construct a new tree from two trees. Both operations
1198 assume that all values in [l] < all values in [r] and that [l] and [r]
1200 [glue l r] Glues [l] and [r] together. Assumes that [l] and
1201 [r] are already balanced with respect to each other.
1202 [merge l r] Merges two trees and restores balance.
1204 Note: in contrast to Adam's paper, we use (<=) comparisons instead
1205 of (<) comparisons in [join], [merge] and [balance].
1206 Quickcheck (on [difference]) showed that this was necessary in order
1207 to maintain the invariants. It is quite unsatisfactory that I haven't
1208 been able to find out why this is actually the case! Fortunately, it
1209 doesn't hurt to be a bit more conservative.
1210 --------------------------------------------------------------------}
1212 {--------------------------------------------------------------------
1214 --------------------------------------------------------------------}
1215 join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1216 join kx x Tip r = insertMin kx x r
1217 join kx x l Tip = insertMax kx x l
1218 join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1219 | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
1220 | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
1221 | otherwise = bin kx x l r
1224 -- insertMin and insertMax don't perform potentially expensive comparisons.
1225 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1228 Tip -> singleton kx x
1230 -> balance ky y l (insertMax kx x r)
1234 Tip -> singleton kx x
1236 -> balance ky y (insertMin kx x l) r
1238 {--------------------------------------------------------------------
1239 [merge l r]: merges two trees.
1240 --------------------------------------------------------------------}
1241 merge :: Map k a -> Map k a -> Map k a
1244 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1245 | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1246 | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1247 | otherwise = glue l r
1249 {--------------------------------------------------------------------
1250 [glue l r]: glues two trees together.
1251 Assumes that [l] and [r] are already balanced with respect to each other.
1252 --------------------------------------------------------------------}
1253 glue :: Map k a -> Map k a -> Map k a
1257 | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1258 | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
1261 -- | /O(log n)/. Delete and find the minimal element.
1262 deleteFindMin :: Map k a -> ((k,a),Map k a)
1265 Bin _ k x Tip r -> ((k,x),r)
1266 Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1267 Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1269 -- | /O(log n)/. Delete and find the maximal element.
1270 deleteFindMax :: Map k a -> ((k,a),Map k a)
1273 Bin _ k x l Tip -> ((k,x),l)
1274 Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1275 Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1278 {--------------------------------------------------------------------
1279 [balance l x r] balances two trees with value x.
1280 The sizes of the trees should balance after decreasing the
1281 size of one of them. (a rotation).
1283 [delta] is the maximal relative difference between the sizes of
1284 two trees, it corresponds with the [w] in Adams' paper.
1285 [ratio] is the ratio between an outer and inner sibling of the
1286 heavier subtree in an unbalanced setting. It determines
1287 whether a double or single rotation should be performed
1288 to restore balance. It is correspondes with the inverse
1289 of $\alpha$ in Adam's article.
1292 - [delta] should be larger than 4.646 with a [ratio] of 2.
1293 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1295 - A lower [delta] leads to a more 'perfectly' balanced tree.
1296 - A higher [delta] performs less rebalancing.
1298 - Balancing is automatic for random data and a balancing
1299 scheme is only necessary to avoid pathological worst cases.
1300 Almost any choice will do, and in practice, a rather large
1301 [delta] may perform better than smaller one.
1303 Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1304 to decide whether a single or double rotation is needed. Allthough
1305 he actually proves that this ratio is needed to maintain the
1306 invariants, his implementation uses an invalid ratio of [1].
1307 --------------------------------------------------------------------}
1312 balance :: k -> a -> Map k a -> Map k a -> Map k a
1314 | sizeL + sizeR <= 1 = Bin sizeX k x l r
1315 | sizeR >= delta*sizeL = rotateL k x l r
1316 | sizeL >= delta*sizeR = rotateR k x l r
1317 | otherwise = Bin sizeX k x l r
1321 sizeX = sizeL + sizeR + 1
1324 rotateL k x l r@(Bin _ _ _ ly ry)
1325 | size ly < ratio*size ry = singleL k x l r
1326 | otherwise = doubleL k x l r
1328 rotateR k x l@(Bin _ _ _ ly ry) r
1329 | size ry < ratio*size ly = singleR k x l r
1330 | otherwise = doubleR k x l r
1333 singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
1334 singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
1336 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)
1337 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)
1340 {--------------------------------------------------------------------
1341 The bin constructor maintains the size of the tree
1342 --------------------------------------------------------------------}
1343 bin :: k -> a -> Map k a -> Map k a -> Map k a
1345 = Bin (size l + size r + 1) k x l r
1348 {--------------------------------------------------------------------
1349 Eq converts the tree to a list. In a lazy setting, this
1350 actually seems one of the faster methods to compare two trees
1351 and it is certainly the simplest :-)
1352 --------------------------------------------------------------------}
1353 instance (Eq k,Eq a) => Eq (Map k a) where
1354 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1356 {--------------------------------------------------------------------
1358 --------------------------------------------------------------------}
1360 instance (Ord k, Ord v) => Ord (Map k v) where
1361 compare m1 m2 = compare (toAscList m1) (toAscList m2)
1363 {--------------------------------------------------------------------
1365 --------------------------------------------------------------------}
1366 instance Functor (Map k) where
1369 instance Traversable (Map k) where
1370 traverse f Tip = pure Tip
1371 traverse f (Bin s k v l r)
1372 = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
1374 instance Foldable (Map k) where
1375 foldMap _f Tip = mempty
1376 foldMap f (Bin _s _k v l r)
1377 = foldMap f l `mappend` f v `mappend` foldMap f r
1379 {--------------------------------------------------------------------
1381 --------------------------------------------------------------------}
1382 instance (Ord k, Read k, Read e) => Read (Map k e) where
1383 #ifdef __GLASGOW_HASKELL__
1384 readPrec = parens $ prec 10 $ do
1385 Ident "fromList" <- lexP
1387 return (fromList xs)
1389 readListPrec = readListPrecDefault
1391 readsPrec p = readParen (p > 10) $ \ r -> do
1392 ("fromList",s) <- lex r
1394 return (fromList xs,t)
1397 -- parses a pair of things with the syntax a:=b
1398 readPair :: (Read a, Read b) => ReadS (a,b)
1399 readPair s = do (a, ct1) <- reads s
1400 (":=", ct2) <- lex ct1
1401 (b, ct3) <- reads ct2
1404 {--------------------------------------------------------------------
1406 --------------------------------------------------------------------}
1407 instance (Show k, Show a) => Show (Map k a) where
1408 showsPrec d m = showParen (d > 10) $
1409 showString "fromList " . shows (toList m)
1411 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1415 = showChar '{' . showElem x . showTail xs
1417 showTail [] = showChar '}'
1418 showTail (x:xs) = showString ", " . showElem x . showTail xs
1420 showElem (k,x) = shows k . showString " := " . shows x
1423 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1424 -- in a compressed, hanging format.
1425 showTree :: (Show k,Show a) => Map k a -> String
1427 = showTreeWith showElem True False m
1429 showElem k x = show k ++ ":=" ++ show x
1432 {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
1433 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1434 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1435 @wide@ is 'True', an extra wide version is shown.
1437 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1438 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1445 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1456 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
1468 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
1469 showTreeWith showelem hang wide t
1470 | hang = (showsTreeHang showelem wide [] t) ""
1471 | otherwise = (showsTree showelem wide [] [] t) ""
1473 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1474 showsTree showelem wide lbars rbars t
1476 Tip -> showsBars lbars . showString "|\n"
1478 -> showsBars lbars . showString (showelem kx x) . showString "\n"
1480 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
1481 showWide wide rbars .
1482 showsBars lbars . showString (showelem kx x) . showString "\n" .
1483 showWide wide lbars .
1484 showsTree showelem wide (withEmpty lbars) (withBar lbars) l
1486 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1487 showsTreeHang showelem wide bars t
1489 Tip -> showsBars bars . showString "|\n"
1491 -> showsBars bars . showString (showelem kx x) . showString "\n"
1493 -> showsBars bars . showString (showelem kx x) . showString "\n" .
1494 showWide wide bars .
1495 showsTreeHang showelem wide (withBar bars) l .
1496 showWide wide bars .
1497 showsTreeHang showelem wide (withEmpty bars) r
1501 | wide = showString (concat (reverse bars)) . showString "|\n"
1504 showsBars :: [String] -> ShowS
1508 _ -> showString (concat (reverse (tail bars))) . showString node
1511 withBar bars = "| ":bars
1512 withEmpty bars = " ":bars
1514 {--------------------------------------------------------------------
1516 --------------------------------------------------------------------}
1518 #include "Typeable.h"
1519 INSTANCE_TYPEABLE2(Map,mapTc,"Map")
1521 {--------------------------------------------------------------------
1523 --------------------------------------------------------------------}
1524 -- | /O(n)/. Test if the internal map structure is valid.
1525 valid :: Ord k => Map k a -> Bool
1527 = balanced t && ordered t && validsize t
1530 = bounded (const True) (const True) t
1535 Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1537 -- | Exported only for "Debug.QuickCheck"
1538 balanced :: Map k a -> Bool
1542 Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1543 balanced l && balanced r
1547 = (realsize t == Just (size t))
1552 Bin sz kx x l r -> case (realsize l,realsize r) of
1553 (Just n,Just m) | n+m+1 == sz -> Just sz
1556 {--------------------------------------------------------------------
1558 --------------------------------------------------------------------}
1562 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1566 {--------------------------------------------------------------------
1568 --------------------------------------------------------------------}
1569 testTree xs = fromList [(x,"*") | x <- xs]
1570 test1 = testTree [1..20]
1571 test2 = testTree [30,29..10]
1572 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1574 {--------------------------------------------------------------------
1576 --------------------------------------------------------------------}
1581 { configMaxTest = 500
1582 , configMaxFail = 5000
1583 , configSize = \n -> (div n 2 + 3)
1584 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1588 {--------------------------------------------------------------------
1589 Arbitrary, reasonably balanced trees
1590 --------------------------------------------------------------------}
1591 instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
1592 arbitrary = sized (arbtree 0 maxkey)
1593 where maxkey = 10000
1595 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
1597 | n <= 0 = return Tip
1598 | lo >= hi = return Tip
1599 | otherwise = do{ x <- arbitrary
1600 ; i <- choose (lo,hi)
1601 ; m <- choose (1,30)
1602 ; let (ml,mr) | m==(1::Int)= (1,2)
1606 ; l <- arbtree lo (i-1) (n `div` ml)
1607 ; r <- arbtree (i+1) hi (n `div` mr)
1608 ; return (bin (toEnum i) x l r)
1612 {--------------------------------------------------------------------
1614 --------------------------------------------------------------------}
1615 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
1617 = forAll arbitrary $ \t ->
1618 -- classify (balanced t) "balanced" $
1619 classify (size t == 0) "empty" $
1620 classify (size t > 0 && size t <= 10) "small" $
1621 classify (size t > 10 && size t <= 64) "medium" $
1622 classify (size t > 64) "large" $
1625 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1629 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1635 = forValidUnitTree $ \t -> valid t
1637 {--------------------------------------------------------------------
1638 Single, Insert, Delete
1639 --------------------------------------------------------------------}
1640 prop_Single :: Int -> Int -> Bool
1642 = (insert k x empty == singleton k x)
1644 prop_InsertValid :: Int -> Property
1646 = forValidUnitTree $ \t -> valid (insert k () t)
1648 prop_InsertDelete :: Int -> Map Int () -> Property
1649 prop_InsertDelete k t
1650 = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1652 prop_DeleteValid :: Int -> Property
1654 = forValidUnitTree $ \t ->
1655 valid (delete k (insert k () t))
1657 {--------------------------------------------------------------------
1659 --------------------------------------------------------------------}
1660 prop_Join :: Int -> Property
1662 = forValidUnitTree $ \t ->
1663 let (l,r) = split k t
1664 in valid (join k () l r)
1666 prop_Merge :: Int -> Property
1668 = forValidUnitTree $ \t ->
1669 let (l,r) = split k t
1670 in valid (merge l r)
1673 {--------------------------------------------------------------------
1675 --------------------------------------------------------------------}
1676 prop_UnionValid :: Property
1678 = forValidUnitTree $ \t1 ->
1679 forValidUnitTree $ \t2 ->
1682 prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
1683 prop_UnionInsert k x t
1684 = union (singleton k x) t == insert k x t
1686 prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
1687 prop_UnionAssoc t1 t2 t3
1688 = union t1 (union t2 t3) == union (union t1 t2) t3
1690 prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
1691 prop_UnionComm t1 t2
1692 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1695 = forValidIntTree $ \t1 ->
1696 forValidIntTree $ \t2 ->
1697 valid (unionWithKey (\k x y -> x+y) t1 t2)
1699 prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
1700 prop_UnionWith xs ys
1701 = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
1702 == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
1705 = forValidUnitTree $ \t1 ->
1706 forValidUnitTree $ \t2 ->
1707 valid (difference t1 t2)
1709 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1711 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1712 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1715 = forValidUnitTree $ \t1 ->
1716 forValidUnitTree $ \t2 ->
1717 valid (intersection t1 t2)
1719 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1721 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1722 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1724 {--------------------------------------------------------------------
1726 --------------------------------------------------------------------}
1728 = forAll (choose (5,100)) $ \n ->
1729 let xs = [(x,()) | x <- [0..n::Int]]
1730 in fromAscList xs == fromList xs
1732 prop_List :: [Int] -> Bool
1734 = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])