1 -----------------------------------------------------------------------------
4 -- Copyright : (c) Daan Leijen 2002
6 -- Maintainer : libraries@haskell.org
7 -- Stability : provisional
8 -- Portability : portable
10 -- An efficient implementation of maps from keys to values (dictionaries).
12 -- This module is intended to be imported @qualified@, to avoid name
13 -- clashes with Prelude functions. eg.
15 -- > import Data.Map as Map
17 -- The implementation of 'Map' is based on /size balanced/ binary trees (or
18 -- trees of /bounded balance/) as described by:
20 -- * Stephen Adams, \"/Efficient sets: a balancing act/\",
21 -- Journal of Functional Programming 3(4):553-562, October 1993,
22 -- <http://www.swiss.ai.mit.edu/~adams/BB>.
24 -- * J. Nievergelt and E.M. Reingold,
25 -- \"/Binary search trees of bounded balance/\",
26 -- SIAM journal of computing 2(1), March 1973.
28 -- Note that the implementation is /left-biased/ -- the elements of a
29 -- first argument are always preferred to the second, for example in
30 -- 'union' or 'insert'.
31 -----------------------------------------------------------------------------
35 Map -- instance Eq,Show,Read
54 , insertWith, insertWithKey, insertLookupWithKey
114 , fromDistinctAscList
126 , isSubmapOf, isSubmapOfBy
127 , isProperSubmapOf, isProperSubmapOfBy
154 import Prelude hiding (lookup,map,filter,foldr,foldl,null)
155 import qualified Data.Set as Set
156 import qualified Data.List as List
157 import Data.Monoid (Monoid(..))
159 import Control.Applicative (Applicative(..))
160 import Data.Traversable (Traversable(traverse))
161 import Data.Foldable (Foldable(foldMap))
165 import qualified Prelude
166 import qualified List
167 import Debug.QuickCheck
168 import List(nub,sort)
171 #if __GLASGOW_HASKELL__
173 import Data.Generics.Basics
174 import Data.Generics.Instances
177 {--------------------------------------------------------------------
179 --------------------------------------------------------------------}
182 -- | /O(log n)/. Find the value at a key.
183 -- Calls 'error' when the element can not be found.
184 (!) :: Ord k => Map k a -> k -> a
187 -- | /O(n+m)/. See 'difference'.
188 (\\) :: Ord k => Map k a -> Map k b -> Map k a
189 m1 \\ m2 = difference m1 m2
191 {--------------------------------------------------------------------
193 --------------------------------------------------------------------}
194 -- | A Map from keys @k@ to values @a@.
196 | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
200 instance (Ord k) => Monoid (Map k v) where
205 #if __GLASGOW_HASKELL__
207 {--------------------------------------------------------------------
209 --------------------------------------------------------------------}
211 -- This instance preserves data abstraction at the cost of inefficiency.
212 -- We omit reflection services for the sake of data abstraction.
214 instance (Data k, Data a, Ord k) => Data (Map k a) where
215 gfoldl f z map = z fromList `f` (toList map)
216 toConstr _ = error "toConstr"
217 gunfold _ _ = error "gunfold"
218 dataTypeOf _ = mkNorepType "Data.Map.Map"
223 {--------------------------------------------------------------------
225 --------------------------------------------------------------------}
226 -- | /O(1)/. Is the map empty?
227 null :: Map k a -> Bool
231 Bin sz k x l r -> False
233 -- | /O(1)/. The number of elements in the map.
234 size :: Map k a -> Int
241 -- | /O(log n)/. Lookup the value at a key in the map.
242 lookup :: (Monad m,Ord k) => k -> Map k a -> m a
243 lookup k t = case lookup' k t of
245 Nothing -> fail "Data.Map.lookup: Key not found"
246 lookup' :: Ord k => k -> Map k a -> Maybe a
251 -> case compare k kx of
256 lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
261 -> case compare k kx of
262 LT -> lookupAssoc k l
263 GT -> lookupAssoc k r
266 -- | /O(log n)/. Is the key a member of the map?
267 member :: Ord k => k -> Map k a -> Bool
273 -- | /O(log n)/. Find the value at a key.
274 -- Calls 'error' when the element can not be found.
275 find :: Ord k => k -> Map k a -> a
278 Nothing -> error "Map.find: element not in the map"
281 -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
282 -- the value at key @k@ or returns @def@ when the key is not in the map.
283 findWithDefault :: Ord k => a -> k -> Map k a -> a
284 findWithDefault def k m
291 {--------------------------------------------------------------------
293 --------------------------------------------------------------------}
294 -- | /O(1)/. The empty map.
299 -- | /O(1)/. A map with a single element.
300 singleton :: k -> a -> Map k a
304 {--------------------------------------------------------------------
306 --------------------------------------------------------------------}
307 -- | /O(log n)/. Insert a new key and value in the map.
308 -- If the key is already present in the map, the associated value is
309 -- replaced with the supplied value, i.e. 'insert' is equivalent to
310 -- @'insertWith' 'const'@.
311 insert :: Ord k => k -> a -> Map k a -> Map k a
314 Tip -> singleton kx x
316 -> case compare kx ky of
317 LT -> balance ky y (insert kx x l) r
318 GT -> balance ky y l (insert kx x r)
319 EQ -> Bin sz kx x l r
321 -- | /O(log n)/. Insert with a combining function.
322 -- @'insertWith' f key value mp@
323 -- will insert the pair (key, value) into @mp@ if key does
324 -- not exist in the map. If the key does exist, the function will
325 -- insert the pair @(key, f new_value old_value)@.
326 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
328 = insertWithKey (\k x y -> f x y) k x m
330 -- | /O(log n)/. Insert with a combining function.
331 -- @'insertWithKey' f key value mp@
332 -- will insert the pair (key, value) into @mp@ if key does
333 -- not exist in the map. If the key does exist, the function will
334 -- insert the pair @(key,f key new_value old_value)@.
335 -- Note that the key passed to f is the same key passed to 'insertWithKey'.
336 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
337 insertWithKey f kx x t
339 Tip -> singleton kx x
341 -> case compare kx ky of
342 LT -> balance ky y (insertWithKey f kx x l) r
343 GT -> balance ky y l (insertWithKey f kx x r)
344 EQ -> Bin sy kx (f kx x y) l r
346 -- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@)
347 -- is a pair where the first element is equal to (@'lookup' k map@)
348 -- and the second element equal to (@'insertWithKey' f k x map@).
349 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
350 insertLookupWithKey f kx x t
352 Tip -> (Nothing, singleton kx x)
354 -> case compare kx ky of
355 LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
356 GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
357 EQ -> (Just y, Bin sy kx (f kx x y) l r)
359 {--------------------------------------------------------------------
361 [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
362 --------------------------------------------------------------------}
363 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
364 -- a member of the map, the original map is returned.
365 delete :: Ord k => k -> Map k a -> Map k a
370 -> case compare k kx of
371 LT -> balance kx x (delete k l) r
372 GT -> balance kx x l (delete k r)
375 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
376 -- a member of the map, the original map is returned.
377 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
379 = adjustWithKey (\k x -> f x) k m
381 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
382 -- a member of the map, the original map is returned.
383 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
385 = updateWithKey (\k x -> Just (f k x)) k m
387 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
388 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
389 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
390 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
392 = updateWithKey (\k x -> f x) k m
394 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
395 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
396 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
397 -- to the new value @y@.
398 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
403 -> case compare k kx of
404 LT -> balance kx x (updateWithKey f k l) r
405 GT -> balance kx x l (updateWithKey f k r)
407 Just x' -> Bin sx kx x' l r
410 -- | /O(log n)/. Lookup and update.
411 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
412 updateLookupWithKey f k t
416 -> case compare k kx of
417 LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
418 GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
420 Just x' -> (Just x',Bin sx kx x' l r)
421 Nothing -> (Just x,glue l r)
423 {--------------------------------------------------------------------
425 --------------------------------------------------------------------}
426 -- | /O(log n)/. Return the /index/ of a key. The index is a number from
427 -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
428 -- the key is not a 'member' of the map.
429 findIndex :: Ord k => k -> Map k a -> Int
431 = case lookupIndex k t of
432 Nothing -> error "Map.findIndex: element is not in the map"
435 -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
436 -- /0/ up to, but not including, the 'size' of the map.
437 lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
438 lookupIndex k t = case lookup 0 t of
439 Nothing -> fail "Data.Map.lookupIndex: Key not found."
442 lookup idx Tip = Nothing
443 lookup idx (Bin _ kx x l r)
444 = case compare k kx of
446 GT -> lookup (idx + size l + 1) r
447 EQ -> Just (idx + size l)
449 -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
450 -- invalid index is used.
451 elemAt :: Int -> Map k a -> (k,a)
452 elemAt i Tip = error "Map.elemAt: index out of range"
453 elemAt i (Bin _ kx x l r)
454 = case compare i sizeL of
456 GT -> elemAt (i-sizeL-1) r
461 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
462 -- invalid index is used.
463 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
464 updateAt f i Tip = error "Map.updateAt: index out of range"
465 updateAt f i (Bin sx kx x l r)
466 = case compare i sizeL of
468 GT -> updateAt f (i-sizeL-1) r
470 Just x' -> Bin sx kx x' l r
475 -- | /O(log n)/. Delete the element at /index/.
476 -- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
477 deleteAt :: Int -> Map k a -> Map k a
479 = updateAt (\k x -> Nothing) i map
482 {--------------------------------------------------------------------
484 --------------------------------------------------------------------}
485 -- | /O(log n)/. The minimal key of the map.
486 findMin :: Map k a -> (k,a)
487 findMin (Bin _ kx x Tip r) = (kx,x)
488 findMin (Bin _ kx x l r) = findMin l
489 findMin Tip = error "Map.findMin: empty tree has no minimal element"
491 -- | /O(log n)/. The maximal key of the map.
492 findMax :: Map k a -> (k,a)
493 findMax (Bin _ kx x l Tip) = (kx,x)
494 findMax (Bin _ kx x l r) = findMax r
495 findMax Tip = error "Map.findMax: empty tree has no maximal element"
497 -- | /O(log n)/. Delete the minimal key.
498 deleteMin :: Map k a -> Map k a
499 deleteMin (Bin _ kx x Tip r) = r
500 deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
503 -- | /O(log n)/. Delete the maximal key.
504 deleteMax :: Map k a -> Map k a
505 deleteMax (Bin _ kx x l Tip) = l
506 deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
509 -- | /O(log n)/. Update the value at the minimal key.
510 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
512 = updateMinWithKey (\k x -> f x) m
514 -- | /O(log n)/. Update the value at the maximal key.
515 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
517 = updateMaxWithKey (\k x -> f x) m
520 -- | /O(log n)/. Update the value at the minimal key.
521 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
524 Bin sx kx x Tip r -> case f kx x of
526 Just x' -> Bin sx kx x' Tip r
527 Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
530 -- | /O(log n)/. Update the value at the maximal key.
531 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
534 Bin sx kx x l Tip -> case f kx x of
536 Just x' -> Bin sx kx x' l Tip
537 Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
541 {--------------------------------------------------------------------
543 --------------------------------------------------------------------}
544 -- | The union of a list of maps:
545 -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
546 unions :: Ord k => [Map k a] -> Map k a
548 = foldlStrict union empty ts
550 -- | The union of a list of maps, with a combining operation:
551 -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
552 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
554 = foldlStrict (unionWith f) empty ts
557 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
558 -- It prefers @t1@ when duplicate keys are encountered,
559 -- i.e. (@'union' == 'unionWith' 'const'@).
560 -- The implementation uses the efficient /hedge-union/ algorithm.
561 -- Hedge-union is more efficient on (bigset `union` smallset)
562 union :: Ord k => Map k a -> Map k a -> Map k a
565 union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2
567 -- left-biased hedge union
568 hedgeUnionL cmplo cmphi t1 Tip
570 hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
571 = join kx x (filterGt cmplo l) (filterLt cmphi r)
572 hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
573 = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
574 (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
576 cmpkx k = compare kx k
578 -- right-biased hedge union
579 hedgeUnionR cmplo cmphi t1 Tip
581 hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
582 = join kx x (filterGt cmplo l) (filterLt cmphi r)
583 hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
584 = join kx newx (hedgeUnionR cmplo cmpkx l lt)
585 (hedgeUnionR cmpkx cmphi r gt)
587 cmpkx k = compare kx k
588 lt = trim cmplo cmpkx t2
589 (found,gt) = trimLookupLo kx cmphi t2
594 {--------------------------------------------------------------------
595 Union with a combining function
596 --------------------------------------------------------------------}
597 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
598 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
600 = unionWithKey (\k x y -> f x y) m1 m2
603 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
604 -- Hedge-union is more efficient on (bigset `union` smallset).
605 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
606 unionWithKey f Tip t2 = t2
607 unionWithKey f t1 Tip = t1
608 unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
610 hedgeUnionWithKey f cmplo cmphi t1 Tip
612 hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
613 = join kx x (filterGt cmplo l) (filterLt cmphi r)
614 hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
615 = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
616 (hedgeUnionWithKey f cmpkx cmphi r gt)
618 cmpkx k = compare kx k
619 lt = trim cmplo cmpkx t2
620 (found,gt) = trimLookupLo kx cmphi t2
623 Just (_,y) -> f kx x y
625 {--------------------------------------------------------------------
627 --------------------------------------------------------------------}
628 -- | /O(n+m)/. Difference of two maps.
629 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
630 difference :: Ord k => Map k a -> Map k b -> Map k a
631 difference Tip t2 = Tip
632 difference t1 Tip = t1
633 difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
635 hedgeDiff cmplo cmphi Tip t
637 hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
638 = join kx x (filterGt cmplo l) (filterLt cmphi r)
639 hedgeDiff cmplo cmphi t (Bin _ kx x l r)
640 = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
641 (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
643 cmpkx k = compare kx k
645 -- | /O(n+m)/. Difference with a combining function.
646 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
647 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
648 differenceWith f m1 m2
649 = differenceWithKey (\k x y -> f x y) m1 m2
651 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
652 -- encountered, the combining function is applied to the key and both values.
653 -- If it returns 'Nothing', the element is discarded (proper set difference). If
654 -- it returns (@'Just' y@), the element is updated with a new value @y@.
655 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
656 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
657 differenceWithKey f Tip t2 = Tip
658 differenceWithKey f t1 Tip = t1
659 differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
661 hedgeDiffWithKey f cmplo cmphi Tip t
663 hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
664 = join kx x (filterGt cmplo l) (filterLt cmphi r)
665 hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
667 Nothing -> merge tl tr
670 Nothing -> merge tl tr
671 Just z -> join ky z tl tr
673 cmpkx k = compare kx k
674 lt = trim cmplo cmpkx t
675 (found,gt) = trimLookupLo kx cmphi t
676 tl = hedgeDiffWithKey f cmplo cmpkx lt l
677 tr = hedgeDiffWithKey f cmpkx cmphi gt r
681 {--------------------------------------------------------------------
683 --------------------------------------------------------------------}
684 -- | /O(n+m)/. Intersection of two maps. The values in the first
685 -- map are returned, i.e. (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
686 intersection :: Ord k => Map k a -> Map k b -> Map k a
688 = intersectionWithKey (\k x y -> x) m1 m2
690 -- | /O(n+m)/. Intersection with a combining function.
691 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
692 intersectionWith f m1 m2
693 = intersectionWithKey (\k x y -> f x y) m1 m2
695 -- | /O(n+m)/. Intersection with a combining function.
696 -- Intersection is more efficient on (bigset `intersection` smallset)
697 --intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
698 --intersectionWithKey f Tip t = Tip
699 --intersectionWithKey f t Tip = Tip
700 --intersectionWithKey f t1 t2 = intersectWithKey f t1 t2
702 --intersectWithKey f Tip t = Tip
703 --intersectWithKey f t Tip = Tip
704 --intersectWithKey f t (Bin _ kx x l r)
706 -- Nothing -> merge tl tr
707 -- Just y -> join kx (f kx y x) tl tr
709 -- (lt,found,gt) = splitLookup kx t
710 -- tl = intersectWithKey f lt l
711 -- tr = intersectWithKey f gt r
714 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
715 intersectionWithKey f Tip t = Tip
716 intersectionWithKey f t Tip = Tip
717 intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =
719 let (lt,found,gt) = splitLookupWithKey k2 t1
720 tl = intersectionWithKey f lt l2
721 tr = intersectionWithKey f gt r2
723 Just (k,x) -> join k (f k x x2) tl tr
724 Nothing -> merge tl tr
725 else let (lt,found,gt) = splitLookup k1 t2
726 tl = intersectionWithKey f l1 lt
727 tr = intersectionWithKey f r1 gt
729 Just x -> join k1 (f k1 x1 x) tl tr
730 Nothing -> merge tl tr
734 {--------------------------------------------------------------------
736 --------------------------------------------------------------------}
738 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
739 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
741 = isSubmapOfBy (==) m1 m2
744 The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
745 all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
746 applied to their respective values. For example, the following
747 expressions are all 'True':
749 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
750 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
751 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
753 But the following are all 'False':
755 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
756 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
757 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
759 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
761 = (size t1 <= size t2) && (submap' f t1 t2)
763 submap' f Tip t = True
764 submap' f t Tip = False
765 submap' f (Bin _ kx x l r) t
768 Just y -> f x y && submap' f l lt && submap' f r gt
770 (lt,found,gt) = splitLookup kx t
772 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
773 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
774 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
775 isProperSubmapOf m1 m2
776 = isProperSubmapOfBy (==) m1 m2
778 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
779 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
780 @m1@ and @m2@ are not equal,
781 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
782 applied to their respective values. For example, the following
783 expressions are all 'True':
785 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
786 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
788 But the following are all 'False':
790 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
791 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
792 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
794 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
795 isProperSubmapOfBy f t1 t2
796 = (size t1 < size t2) && (submap' f t1 t2)
798 {--------------------------------------------------------------------
800 --------------------------------------------------------------------}
801 -- | /O(n)/. Filter all values that satisfy the predicate.
802 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
804 = filterWithKey (\k x -> p x) m
806 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
807 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
808 filterWithKey p Tip = Tip
809 filterWithKey p (Bin _ kx x l r)
810 | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
811 | otherwise = merge (filterWithKey p l) (filterWithKey p r)
814 -- | /O(n)/. partition the map according to a predicate. The first
815 -- map contains all elements that satisfy the predicate, the second all
816 -- elements that fail the predicate. See also 'split'.
817 partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
819 = partitionWithKey (\k x -> p x) m
821 -- | /O(n)/. partition the map according to a predicate. The first
822 -- map contains all elements that satisfy the predicate, the second all
823 -- elements that fail the predicate. See also 'split'.
824 partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
825 partitionWithKey p Tip = (Tip,Tip)
826 partitionWithKey p (Bin _ kx x l r)
827 | p kx x = (join kx x l1 r1,merge l2 r2)
828 | otherwise = (merge l1 r1,join kx x l2 r2)
830 (l1,l2) = partitionWithKey p l
831 (r1,r2) = partitionWithKey p r
834 {--------------------------------------------------------------------
836 --------------------------------------------------------------------}
837 -- | /O(n)/. Map a function over all values in the map.
838 map :: (a -> b) -> Map k a -> Map k b
840 = mapWithKey (\k x -> f x) m
842 -- | /O(n)/. Map a function over all values in the map.
843 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
844 mapWithKey f Tip = Tip
845 mapWithKey f (Bin sx kx x l r)
846 = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
848 -- | /O(n)/. The function 'mapAccum' threads an accumulating
849 -- argument through the map in ascending order of keys.
850 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
852 = mapAccumWithKey (\a k x -> f a x) a m
854 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
855 -- argument through the map in ascending order of keys.
856 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
857 mapAccumWithKey f a t
860 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
861 -- argument throught the map in ascending order of keys.
862 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
867 -> let (a1,l') = mapAccumL f a l
869 (a3,r') = mapAccumL f a2 r
870 in (a3,Bin sx kx x' l' r')
872 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
873 -- argument throught the map in descending order of keys.
874 mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
879 -> let (a1,r') = mapAccumR f a r
881 (a3,l') = mapAccumR f a2 l
882 in (a3,Bin sx kx x' l' r')
885 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
887 -- The size of the result may be smaller if @f@ maps two or more distinct
888 -- keys to the same new key. In this case the value at the smallest of
889 -- these keys is retained.
891 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
892 mapKeys = mapKeysWith (\x y->x)
895 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
897 -- The size of the result may be smaller if @f@ maps two or more distinct
898 -- keys to the same new key. In this case the associated values will be
899 -- combined using @c@.
901 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
902 mapKeysWith c f = fromListWith c . List.map fFirst . toList
903 where fFirst (x,y) = (f x, y)
907 -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
908 -- is strictly monotonic.
909 -- /The precondition is not checked./
910 -- Semi-formally, we have:
912 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
913 -- > ==> mapKeysMonotonic f s == mapKeys f s
914 -- > where ls = keys s
916 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
917 mapKeysMonotonic f Tip = Tip
918 mapKeysMonotonic f (Bin sz k x l r) =
919 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
921 {--------------------------------------------------------------------
923 --------------------------------------------------------------------}
925 -- | /O(n)/. Fold the values in the map, such that
926 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
929 -- > elems map = fold (:) [] map
931 fold :: (a -> b -> b) -> b -> Map k a -> b
933 = foldWithKey (\k x z -> f x z) z m
935 -- | /O(n)/. Fold the keys and values in the map, such that
936 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
939 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
941 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
945 -- | /O(n)/. In-order fold.
946 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
948 foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
950 -- | /O(n)/. Post-order fold.
951 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
953 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
955 -- | /O(n)/. Pre-order fold.
956 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
958 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
960 {--------------------------------------------------------------------
962 --------------------------------------------------------------------}
964 -- Return all elements of the map in the ascending order of their keys.
965 elems :: Map k a -> [a]
967 = [x | (k,x) <- assocs m]
969 -- | /O(n)/. Return all keys of the map in ascending order.
970 keys :: Map k a -> [k]
972 = [k | (k,x) <- assocs m]
974 -- | /O(n)/. The set of all keys of the map.
975 keysSet :: Map k a -> Set.Set k
976 keysSet m = Set.fromDistinctAscList (keys m)
978 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
979 assocs :: Map k a -> [(k,a)]
983 {--------------------------------------------------------------------
985 use [foldlStrict] to reduce demand on the control-stack
986 --------------------------------------------------------------------}
987 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
988 fromList :: Ord k => [(k,a)] -> Map k a
990 = foldlStrict ins empty xs
992 ins t (k,x) = insert k x t
994 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
995 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
997 = fromListWithKey (\k x y -> f x y) xs
999 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
1000 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1001 fromListWithKey f xs
1002 = foldlStrict ins empty xs
1004 ins t (k,x) = insertWithKey f k x t
1006 -- | /O(n)/. Convert to a list of key\/value pairs.
1007 toList :: Map k a -> [(k,a)]
1008 toList t = toAscList t
1010 -- | /O(n)/. Convert to an ascending list.
1011 toAscList :: Map k a -> [(k,a)]
1012 toAscList t = foldr (\k x xs -> (k,x):xs) [] t
1015 toDescList :: Map k a -> [(k,a)]
1016 toDescList t = foldl (\xs k x -> (k,x):xs) [] t
1019 {--------------------------------------------------------------------
1020 Building trees from ascending/descending lists can be done in linear time.
1022 Note that if [xs] is ascending that:
1023 fromAscList xs == fromList xs
1024 fromAscListWith f xs == fromListWith f xs
1025 --------------------------------------------------------------------}
1026 -- | /O(n)/. Build a map from an ascending list in linear time.
1027 -- /The precondition (input list is ascending) is not checked./
1028 fromAscList :: Eq k => [(k,a)] -> Map k a
1030 = fromAscListWithKey (\k x y -> x) xs
1032 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
1033 -- /The precondition (input list is ascending) is not checked./
1034 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
1035 fromAscListWith f xs
1036 = fromAscListWithKey (\k x y -> f x y) xs
1038 -- | /O(n)/. Build a map from an ascending list in linear time with a
1039 -- combining function for equal keys.
1040 -- /The precondition (input list is ascending) is not checked./
1041 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1042 fromAscListWithKey f xs
1043 = fromDistinctAscList (combineEq f xs)
1045 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1050 (x:xx) -> combineEq' x xx
1052 combineEq' z [] = [z]
1053 combineEq' z@(kz,zz) (x@(kx,xx):xs)
1054 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
1055 | otherwise = z:combineEq' x xs
1058 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
1059 -- /The precondition is not checked./
1060 fromDistinctAscList :: [(k,a)] -> Map k a
1061 fromDistinctAscList xs
1062 = build const (length xs) xs
1064 -- 1) use continutations so that we use heap space instead of stack space.
1065 -- 2) special case for n==5 to build bushier trees.
1066 build c 0 xs = c Tip xs
1067 build c 5 xs = case xs of
1068 ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
1069 -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
1070 build c n xs = seq nr $ build (buildR nr c) nl xs
1075 buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
1076 buildB l k x c r zs = c (bin k x l r) zs
1080 {--------------------------------------------------------------------
1081 Utility functions that return sub-ranges of the original
1082 tree. Some functions take a comparison function as argument to
1083 allow comparisons against infinite values. A function [cmplo k]
1084 should be read as [compare lo k].
1086 [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
1087 and [cmphi k == GT] for the key [k] of the root.
1088 [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
1089 [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
1091 [split k t] Returns two trees [l] and [r] where all keys
1092 in [l] are <[k] and all keys in [r] are >[k].
1093 [splitLookup k t] Just like [split] but also returns whether [k]
1094 was found in the tree.
1095 --------------------------------------------------------------------}
1097 {--------------------------------------------------------------------
1098 [trim lo hi t] trims away all subtrees that surely contain no
1099 values between the range [lo] to [hi]. The returned tree is either
1100 empty or the key of the root is between @lo@ and @hi@.
1101 --------------------------------------------------------------------}
1102 trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1103 trim cmplo cmphi Tip = Tip
1104 trim cmplo cmphi t@(Bin sx kx x l r)
1106 LT -> case cmphi kx of
1108 le -> trim cmplo cmphi l
1109 ge -> trim cmplo cmphi r
1111 trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe (k,a), Map k a)
1112 trimLookupLo lo cmphi Tip = (Nothing,Tip)
1113 trimLookupLo lo cmphi t@(Bin sx kx x l r)
1114 = case compare lo kx of
1115 LT -> case cmphi kx of
1116 GT -> (lookupAssoc lo t, t)
1117 le -> trimLookupLo lo cmphi l
1118 GT -> trimLookupLo lo cmphi r
1119 EQ -> (Just (kx,x),trim (compare lo) cmphi r)
1122 {--------------------------------------------------------------------
1123 [filterGt k t] filter all keys >[k] from tree [t]
1124 [filterLt k t] filter all keys <[k] from tree [t]
1125 --------------------------------------------------------------------}
1126 filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1127 filterGt cmp Tip = Tip
1128 filterGt cmp (Bin sx kx x l r)
1130 LT -> join kx x (filterGt cmp l) r
1131 GT -> filterGt cmp r
1134 filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1135 filterLt cmp Tip = Tip
1136 filterLt cmp (Bin sx kx x l r)
1138 LT -> filterLt cmp l
1139 GT -> join kx x l (filterLt cmp r)
1142 {--------------------------------------------------------------------
1144 --------------------------------------------------------------------}
1145 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
1146 -- 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@.
1147 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1148 split k Tip = (Tip,Tip)
1149 split k (Bin sx kx x l r)
1150 = case compare k kx of
1151 LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1152 GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1155 -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
1156 -- like 'split' but also returns @'lookup' k map@.
1157 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
1158 splitLookup k Tip = (Tip,Nothing,Tip)
1159 splitLookup k (Bin sx kx x l r)
1160 = case compare k kx of
1161 LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
1162 GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
1166 splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)
1167 splitLookupWithKey k Tip = (Tip,Nothing,Tip)
1168 splitLookupWithKey k (Bin sx kx x l r)
1169 = case compare k kx of
1170 LT -> let (lt,z,gt) = splitLookupWithKey k l in (lt,z,join kx x gt r)
1171 GT -> let (lt,z,gt) = splitLookupWithKey k r in (join kx x l lt,z,gt)
1172 EQ -> (l,Just (kx, x),r)
1174 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
1175 -- element was found in the original set.
1176 splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)
1177 splitMember x t = let (l,m,r) = splitLookup x t in
1178 (l,maybe False (const True) m,r)
1181 {--------------------------------------------------------------------
1182 Utility functions that maintain the balance properties of the tree.
1183 All constructors assume that all values in [l] < [k] and all values
1184 in [r] > [k], and that [l] and [r] are valid trees.
1186 In order of sophistication:
1187 [Bin sz k x l r] The type constructor.
1188 [bin k x l r] Maintains the correct size, assumes that both [l]
1189 and [r] are balanced with respect to each other.
1190 [balance k x l r] Restores the balance and size.
1191 Assumes that the original tree was balanced and
1192 that [l] or [r] has changed by at most one element.
1193 [join k x l r] Restores balance and size.
1195 Furthermore, we can construct a new tree from two trees. Both operations
1196 assume that all values in [l] < all values in [r] and that [l] and [r]
1198 [glue l r] Glues [l] and [r] together. Assumes that [l] and
1199 [r] are already balanced with respect to each other.
1200 [merge l r] Merges two trees and restores balance.
1202 Note: in contrast to Adam's paper, we use (<=) comparisons instead
1203 of (<) comparisons in [join], [merge] and [balance].
1204 Quickcheck (on [difference]) showed that this was necessary in order
1205 to maintain the invariants. It is quite unsatisfactory that I haven't
1206 been able to find out why this is actually the case! Fortunately, it
1207 doesn't hurt to be a bit more conservative.
1208 --------------------------------------------------------------------}
1210 {--------------------------------------------------------------------
1212 --------------------------------------------------------------------}
1213 join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1214 join kx x Tip r = insertMin kx x r
1215 join kx x l Tip = insertMax kx x l
1216 join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1217 | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
1218 | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
1219 | otherwise = bin kx x l r
1222 -- insertMin and insertMax don't perform potentially expensive comparisons.
1223 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1226 Tip -> singleton kx x
1228 -> balance ky y l (insertMax kx x r)
1232 Tip -> singleton kx x
1234 -> balance ky y (insertMin kx x l) r
1236 {--------------------------------------------------------------------
1237 [merge l r]: merges two trees.
1238 --------------------------------------------------------------------}
1239 merge :: Map k a -> Map k a -> Map k a
1242 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1243 | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1244 | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1245 | otherwise = glue l r
1247 {--------------------------------------------------------------------
1248 [glue l r]: glues two trees together.
1249 Assumes that [l] and [r] are already balanced with respect to each other.
1250 --------------------------------------------------------------------}
1251 glue :: Map k a -> Map k a -> Map k a
1255 | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1256 | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
1259 -- | /O(log n)/. Delete and find the minimal element.
1260 deleteFindMin :: Map k a -> ((k,a),Map k a)
1263 Bin _ k x Tip r -> ((k,x),r)
1264 Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1265 Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1267 -- | /O(log n)/. Delete and find the maximal element.
1268 deleteFindMax :: Map k a -> ((k,a),Map k a)
1271 Bin _ k x l Tip -> ((k,x),l)
1272 Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1273 Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1276 {--------------------------------------------------------------------
1277 [balance l x r] balances two trees with value x.
1278 The sizes of the trees should balance after decreasing the
1279 size of one of them. (a rotation).
1281 [delta] is the maximal relative difference between the sizes of
1282 two trees, it corresponds with the [w] in Adams' paper.
1283 [ratio] is the ratio between an outer and inner sibling of the
1284 heavier subtree in an unbalanced setting. It determines
1285 whether a double or single rotation should be performed
1286 to restore balance. It is correspondes with the inverse
1287 of $\alpha$ in Adam's article.
1290 - [delta] should be larger than 4.646 with a [ratio] of 2.
1291 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1293 - A lower [delta] leads to a more 'perfectly' balanced tree.
1294 - A higher [delta] performs less rebalancing.
1296 - Balancing is automatic for random data and a balancing
1297 scheme is only necessary to avoid pathological worst cases.
1298 Almost any choice will do, and in practice, a rather large
1299 [delta] may perform better than smaller one.
1301 Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1302 to decide whether a single or double rotation is needed. Allthough
1303 he actually proves that this ratio is needed to maintain the
1304 invariants, his implementation uses an invalid ratio of [1].
1305 --------------------------------------------------------------------}
1310 balance :: k -> a -> Map k a -> Map k a -> Map k a
1312 | sizeL + sizeR <= 1 = Bin sizeX k x l r
1313 | sizeR >= delta*sizeL = rotateL k x l r
1314 | sizeL >= delta*sizeR = rotateR k x l r
1315 | otherwise = Bin sizeX k x l r
1319 sizeX = sizeL + sizeR + 1
1322 rotateL k x l r@(Bin _ _ _ ly ry)
1323 | size ly < ratio*size ry = singleL k x l r
1324 | otherwise = doubleL k x l r
1326 rotateR k x l@(Bin _ _ _ ly ry) r
1327 | size ry < ratio*size ly = singleR k x l r
1328 | otherwise = doubleR k x l r
1331 singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
1332 singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
1334 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)
1335 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)
1338 {--------------------------------------------------------------------
1339 The bin constructor maintains the size of the tree
1340 --------------------------------------------------------------------}
1341 bin :: k -> a -> Map k a -> Map k a -> Map k a
1343 = Bin (size l + size r + 1) k x l r
1346 {--------------------------------------------------------------------
1347 Eq converts the tree to a list. In a lazy setting, this
1348 actually seems one of the faster methods to compare two trees
1349 and it is certainly the simplest :-)
1350 --------------------------------------------------------------------}
1351 instance (Eq k,Eq a) => Eq (Map k a) where
1352 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1354 {--------------------------------------------------------------------
1356 --------------------------------------------------------------------}
1358 instance (Ord k, Ord v) => Ord (Map k v) where
1359 compare m1 m2 = compare (toAscList m1) (toAscList m2)
1361 {--------------------------------------------------------------------
1363 --------------------------------------------------------------------}
1364 instance Functor (Map k) where
1367 instance Traversable (Map k) where
1368 traverse f Tip = pure Tip
1369 traverse f (Bin s k v l r)
1370 = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
1372 instance Foldable (Map k) where
1373 foldMap _f Tip = mempty
1374 foldMap f (Bin _s _k v l r)
1375 = foldMap f l `mappend` f v `mappend` foldMap f r
1377 {--------------------------------------------------------------------
1379 --------------------------------------------------------------------}
1380 instance (Ord k, Read k, Read e) => Read (Map k e) where
1381 #ifdef __GLASGOW_HASKELL__
1382 readPrec = parens $ prec 10 $ do
1383 Ident "fromList" <- lexP
1385 return (fromList xs)
1387 readListPrec = readListPrecDefault
1389 readsPrec p = readParen (p > 10) $ \ r -> do
1390 ("fromList",s) <- lex r
1392 return (fromList xs,t)
1395 -- parses a pair of things with the syntax a:=b
1396 readPair :: (Read a, Read b) => ReadS (a,b)
1397 readPair s = do (a, ct1) <- reads s
1398 (":=", ct2) <- lex ct1
1399 (b, ct3) <- reads ct2
1402 {--------------------------------------------------------------------
1404 --------------------------------------------------------------------}
1405 instance (Show k, Show a) => Show (Map k a) where
1406 showsPrec d m = showParen (d > 10) $
1407 showString "fromList " . shows (toList m)
1409 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1413 = showChar '{' . showElem x . showTail xs
1415 showTail [] = showChar '}'
1416 showTail (x:xs) = showString ", " . showElem x . showTail xs
1418 showElem (k,x) = shows k . showString " := " . shows x
1421 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1422 -- in a compressed, hanging format.
1423 showTree :: (Show k,Show a) => Map k a -> String
1425 = showTreeWith showElem True False m
1427 showElem k x = show k ++ ":=" ++ show x
1430 {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
1431 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1432 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1433 @wide@ is 'True', an extra wide version is shown.
1435 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1436 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1443 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1454 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
1466 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
1467 showTreeWith showelem hang wide t
1468 | hang = (showsTreeHang showelem wide [] t) ""
1469 | otherwise = (showsTree showelem wide [] [] t) ""
1471 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1472 showsTree showelem wide lbars rbars t
1474 Tip -> showsBars lbars . showString "|\n"
1476 -> showsBars lbars . showString (showelem kx x) . showString "\n"
1478 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
1479 showWide wide rbars .
1480 showsBars lbars . showString (showelem kx x) . showString "\n" .
1481 showWide wide lbars .
1482 showsTree showelem wide (withEmpty lbars) (withBar lbars) l
1484 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1485 showsTreeHang showelem wide bars t
1487 Tip -> showsBars bars . showString "|\n"
1489 -> showsBars bars . showString (showelem kx x) . showString "\n"
1491 -> showsBars bars . showString (showelem kx x) . showString "\n" .
1492 showWide wide bars .
1493 showsTreeHang showelem wide (withBar bars) l .
1494 showWide wide bars .
1495 showsTreeHang showelem wide (withEmpty bars) r
1499 | wide = showString (concat (reverse bars)) . showString "|\n"
1502 showsBars :: [String] -> ShowS
1506 _ -> showString (concat (reverse (tail bars))) . showString node
1509 withBar bars = "| ":bars
1510 withEmpty bars = " ":bars
1512 {--------------------------------------------------------------------
1514 --------------------------------------------------------------------}
1516 #include "Typeable.h"
1517 INSTANCE_TYPEABLE2(Map,mapTc,"Map")
1519 {--------------------------------------------------------------------
1521 --------------------------------------------------------------------}
1522 -- | /O(n)/. Test if the internal map structure is valid.
1523 valid :: Ord k => Map k a -> Bool
1525 = balanced t && ordered t && validsize t
1528 = bounded (const True) (const True) t
1533 Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1535 -- | Exported only for "Debug.QuickCheck"
1536 balanced :: Map k a -> Bool
1540 Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1541 balanced l && balanced r
1545 = (realsize t == Just (size t))
1550 Bin sz kx x l r -> case (realsize l,realsize r) of
1551 (Just n,Just m) | n+m+1 == sz -> Just sz
1554 {--------------------------------------------------------------------
1556 --------------------------------------------------------------------}
1560 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1564 {--------------------------------------------------------------------
1566 --------------------------------------------------------------------}
1567 testTree xs = fromList [(x,"*") | x <- xs]
1568 test1 = testTree [1..20]
1569 test2 = testTree [30,29..10]
1570 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1572 {--------------------------------------------------------------------
1574 --------------------------------------------------------------------}
1579 { configMaxTest = 500
1580 , configMaxFail = 5000
1581 , configSize = \n -> (div n 2 + 3)
1582 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1586 {--------------------------------------------------------------------
1587 Arbitrary, reasonably balanced trees
1588 --------------------------------------------------------------------}
1589 instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
1590 arbitrary = sized (arbtree 0 maxkey)
1591 where maxkey = 10000
1593 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
1595 | n <= 0 = return Tip
1596 | lo >= hi = return Tip
1597 | otherwise = do{ x <- arbitrary
1598 ; i <- choose (lo,hi)
1599 ; m <- choose (1,30)
1600 ; let (ml,mr) | m==(1::Int)= (1,2)
1604 ; l <- arbtree lo (i-1) (n `div` ml)
1605 ; r <- arbtree (i+1) hi (n `div` mr)
1606 ; return (bin (toEnum i) x l r)
1610 {--------------------------------------------------------------------
1612 --------------------------------------------------------------------}
1613 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
1615 = forAll arbitrary $ \t ->
1616 -- classify (balanced t) "balanced" $
1617 classify (size t == 0) "empty" $
1618 classify (size t > 0 && size t <= 10) "small" $
1619 classify (size t > 10 && size t <= 64) "medium" $
1620 classify (size t > 64) "large" $
1623 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1627 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1633 = forValidUnitTree $ \t -> valid t
1635 {--------------------------------------------------------------------
1636 Single, Insert, Delete
1637 --------------------------------------------------------------------}
1638 prop_Single :: Int -> Int -> Bool
1640 = (insert k x empty == singleton k x)
1642 prop_InsertValid :: Int -> Property
1644 = forValidUnitTree $ \t -> valid (insert k () t)
1646 prop_InsertDelete :: Int -> Map Int () -> Property
1647 prop_InsertDelete k t
1648 = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1650 prop_DeleteValid :: Int -> Property
1652 = forValidUnitTree $ \t ->
1653 valid (delete k (insert k () t))
1655 {--------------------------------------------------------------------
1657 --------------------------------------------------------------------}
1658 prop_Join :: Int -> Property
1660 = forValidUnitTree $ \t ->
1661 let (l,r) = split k t
1662 in valid (join k () l r)
1664 prop_Merge :: Int -> Property
1666 = forValidUnitTree $ \t ->
1667 let (l,r) = split k t
1668 in valid (merge l r)
1671 {--------------------------------------------------------------------
1673 --------------------------------------------------------------------}
1674 prop_UnionValid :: Property
1676 = forValidUnitTree $ \t1 ->
1677 forValidUnitTree $ \t2 ->
1680 prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
1681 prop_UnionInsert k x t
1682 = union (singleton k x) t == insert k x t
1684 prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
1685 prop_UnionAssoc t1 t2 t3
1686 = union t1 (union t2 t3) == union (union t1 t2) t3
1688 prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
1689 prop_UnionComm t1 t2
1690 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1693 = forValidIntTree $ \t1 ->
1694 forValidIntTree $ \t2 ->
1695 valid (unionWithKey (\k x y -> x+y) t1 t2)
1697 prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
1698 prop_UnionWith xs ys
1699 = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
1700 == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
1703 = forValidUnitTree $ \t1 ->
1704 forValidUnitTree $ \t2 ->
1705 valid (difference t1 t2)
1707 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1709 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1710 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1713 = forValidUnitTree $ \t1 ->
1714 forValidUnitTree $ \t2 ->
1715 valid (intersection t1 t2)
1717 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1719 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1720 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1722 {--------------------------------------------------------------------
1724 --------------------------------------------------------------------}
1726 = forAll (choose (5,100)) $ \n ->
1727 let xs = [(x,()) | x <- [0..n::Int]]
1728 in fromAscList xs == fromList xs
1730 prop_List :: [Int] -> Bool
1732 = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])