1 {-# OPTIONS_GHC -fno-bang-patterns #-}
3 -----------------------------------------------------------------------------
6 -- Copyright : (c) Daan Leijen 2002
8 -- Maintainer : libraries@haskell.org
9 -- Stability : provisional
10 -- Portability : portable
12 -- An efficient implementation of maps from keys to values (dictionaries).
14 -- This module is intended to be imported @qualified@, to avoid name
15 -- clashes with Prelude functions. eg.
17 -- > import Data.Map as Map
19 -- The implementation of 'Map' is based on /size balanced/ binary trees (or
20 -- trees of /bounded balance/) as described by:
22 -- * Stephen Adams, \"/Efficient sets: a balancing act/\",
23 -- Journal of Functional Programming 3(4):553-562, October 1993,
24 -- <http://www.swiss.ai.mit.edu/~adams/BB>.
26 -- * J. Nievergelt and E.M. Reingold,
27 -- \"/Binary search trees of bounded balance/\",
28 -- SIAM journal of computing 2(1), March 1973.
30 -- Note that the implementation is /left-biased/ -- the elements of a
31 -- first argument are always preferred to the second, for example in
32 -- 'union' or 'insert'.
33 -----------------------------------------------------------------------------
37 Map -- instance Eq,Show,Read
57 , insertWith, insertWithKey, insertLookupWithKey
118 , fromDistinctAscList
130 , isSubmapOf, isSubmapOfBy
131 , isProperSubmapOf, isProperSubmapOfBy
158 import Prelude hiding (lookup,map,filter,foldr,foldl,null)
159 import qualified Data.Set as Set
160 import qualified Data.List as List
161 import Data.Monoid (Monoid(..))
163 import Control.Applicative (Applicative(..))
164 import Data.Traversable (Traversable(traverse))
165 import Data.Foldable (Foldable(foldMap))
169 import qualified Prelude
170 import qualified List
171 import Debug.QuickCheck
172 import List(nub,sort)
175 #if __GLASGOW_HASKELL__
177 import Data.Generics.Basics
178 import Data.Generics.Instances
181 {--------------------------------------------------------------------
183 --------------------------------------------------------------------}
186 -- | /O(log n)/. Find the value at a key.
187 -- Calls 'error' when the element can not be found.
188 (!) :: Ord k => Map k a -> k -> a
191 -- | /O(n+m)/. See 'difference'.
192 (\\) :: Ord k => Map k a -> Map k b -> Map k a
193 m1 \\ m2 = difference m1 m2
195 {--------------------------------------------------------------------
197 --------------------------------------------------------------------}
198 -- | A Map from keys @k@ to values @a@.
200 | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
204 instance (Ord k) => Monoid (Map k v) where
209 #if __GLASGOW_HASKELL__
211 {--------------------------------------------------------------------
213 --------------------------------------------------------------------}
215 -- This instance preserves data abstraction at the cost of inefficiency.
216 -- We omit reflection services for the sake of data abstraction.
218 instance (Data k, Data a, Ord k) => Data (Map k a) where
219 gfoldl f z map = z fromList `f` (toList map)
220 toConstr _ = error "toConstr"
221 gunfold _ _ = error "gunfold"
222 dataTypeOf _ = mkNorepType "Data.Map.Map"
223 dataCast2 f = gcast2 f
227 {--------------------------------------------------------------------
229 --------------------------------------------------------------------}
230 -- | /O(1)/. Is the map empty?
231 null :: Map k a -> Bool
235 Bin sz k x l r -> False
237 -- | /O(1)/. The number of elements in the map.
238 size :: Map k a -> Int
245 -- | /O(log n)/. Lookup the value at a key in the map.
246 lookup :: (Monad m,Ord k) => k -> Map k a -> m a
247 lookup k t = case lookup' k t of
249 Nothing -> fail "Data.Map.lookup: Key not found"
250 lookup' :: Ord k => k -> Map k a -> Maybe a
255 -> case compare k kx of
260 lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
265 -> case compare k kx of
266 LT -> lookupAssoc k l
267 GT -> lookupAssoc k r
270 -- | /O(log n)/. Is the key a member of the map?
271 member :: Ord k => k -> Map k a -> Bool
277 -- | /O(log n)/. Is the key not a member of the map?
278 notMember :: Ord k => k -> Map k a -> Bool
279 notMember k m = not $ member k m
281 -- | /O(log n)/. Find the value at a key.
282 -- Calls 'error' when the element can not be found.
283 find :: Ord k => k -> Map k a -> a
286 Nothing -> error "Map.find: element not in the map"
289 -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
290 -- the value at key @k@ or returns @def@ when the key is not in the map.
291 findWithDefault :: Ord k => a -> k -> Map k a -> a
292 findWithDefault def k m
299 {--------------------------------------------------------------------
301 --------------------------------------------------------------------}
302 -- | /O(1)/. The empty map.
307 -- | /O(1)/. A map with a single element.
308 singleton :: k -> a -> Map k a
312 {--------------------------------------------------------------------
314 --------------------------------------------------------------------}
315 -- | /O(log n)/. Insert a new key and value in the map.
316 -- If the key is already present in the map, the associated value is
317 -- replaced with the supplied value, i.e. 'insert' is equivalent to
318 -- @'insertWith' 'const'@.
319 insert :: Ord k => k -> a -> Map k a -> Map k a
322 Tip -> singleton kx x
324 -> case compare kx ky of
325 LT -> balance ky y (insert kx x l) r
326 GT -> balance ky y l (insert kx x r)
327 EQ -> Bin sz kx x l r
329 -- | /O(log n)/. Insert with a combining function.
330 -- @'insertWith' f key value mp@
331 -- will insert the pair (key, value) into @mp@ if key does
332 -- not exist in the map. If the key does exist, the function will
333 -- insert the pair @(key, f new_value old_value)@.
334 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
336 = insertWithKey (\k x y -> f x y) k x m
338 -- | /O(log n)/. Insert with a combining function.
339 -- @'insertWithKey' f key value mp@
340 -- will insert the pair (key, value) into @mp@ if key does
341 -- not exist in the map. If the key does exist, the function will
342 -- insert the pair @(key,f key new_value old_value)@.
343 -- Note that the key passed to f is the same key passed to 'insertWithKey'.
344 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
345 insertWithKey f kx x t
347 Tip -> singleton kx x
349 -> case compare kx ky of
350 LT -> balance ky y (insertWithKey f kx x l) r
351 GT -> balance ky y l (insertWithKey f kx x r)
352 EQ -> Bin sy kx (f kx x y) l r
354 -- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@)
355 -- is a pair where the first element is equal to (@'lookup' k map@)
356 -- and the second element equal to (@'insertWithKey' f k x map@).
357 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
358 insertLookupWithKey f kx x t
360 Tip -> (Nothing, singleton kx x)
362 -> case compare kx ky of
363 LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
364 GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
365 EQ -> (Just y, Bin sy kx (f kx x y) l r)
367 {--------------------------------------------------------------------
369 [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
370 --------------------------------------------------------------------}
371 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
372 -- a member of the map, the original map is returned.
373 delete :: Ord k => k -> Map k a -> Map k a
378 -> case compare k kx of
379 LT -> balance kx x (delete k l) r
380 GT -> balance kx x l (delete k r)
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 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
387 = adjustWithKey (\k x -> f x) k m
389 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
390 -- a member of the map, the original map is returned.
391 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
393 = updateWithKey (\k x -> Just (f k x)) k m
395 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
396 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
397 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
398 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
400 = updateWithKey (\k x -> f x) k m
402 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
403 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
404 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
405 -- to the new value @y@.
406 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
411 -> case compare k kx of
412 LT -> balance kx x (updateWithKey f k l) r
413 GT -> balance kx x l (updateWithKey f k r)
415 Just x' -> Bin sx kx x' l r
418 -- | /O(log n)/. Lookup and update.
419 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
420 updateLookupWithKey f k t
424 -> case compare k kx of
425 LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
426 GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
428 Just x' -> (Just x',Bin sx kx x' l r)
429 Nothing -> (Just x,glue l r)
431 -- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
432 -- 'alter' can be used to insert, delete, or update a value in a 'Map'.
433 -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@
434 alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
437 Tip -> case f Nothing of
439 Just x -> singleton k x
441 -> case compare k kx of
442 LT -> balance kx x (alter f k l) r
443 GT -> balance kx x l (alter f k r)
444 EQ -> case f (Just x) of
445 Just x' -> Bin sx kx x' l r
448 {--------------------------------------------------------------------
450 --------------------------------------------------------------------}
451 -- | /O(log n)/. Return the /index/ of a key. The index is a number from
452 -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
453 -- the key is not a 'member' of the map.
454 findIndex :: Ord k => k -> Map k a -> Int
456 = case lookupIndex k t of
457 Nothing -> error "Map.findIndex: element is not in the map"
460 -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
461 -- /0/ up to, but not including, the 'size' of the map.
462 lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
463 lookupIndex k t = case lookup 0 t of
464 Nothing -> fail "Data.Map.lookupIndex: Key not found."
467 lookup idx Tip = Nothing
468 lookup idx (Bin _ kx x l r)
469 = case compare k kx of
471 GT -> lookup (idx + size l + 1) r
472 EQ -> Just (idx + size l)
474 -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
475 -- invalid index is used.
476 elemAt :: Int -> Map k a -> (k,a)
477 elemAt i Tip = error "Map.elemAt: index out of range"
478 elemAt i (Bin _ kx x l r)
479 = case compare i sizeL of
481 GT -> elemAt (i-sizeL-1) r
486 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
487 -- invalid index is used.
488 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
489 updateAt f i Tip = error "Map.updateAt: index out of range"
490 updateAt f i (Bin sx kx x l r)
491 = case compare i sizeL of
493 GT -> updateAt f (i-sizeL-1) r
495 Just x' -> Bin sx kx x' l r
500 -- | /O(log n)/. Delete the element at /index/.
501 -- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
502 deleteAt :: Int -> Map k a -> Map k a
504 = updateAt (\k x -> Nothing) i map
507 {--------------------------------------------------------------------
509 --------------------------------------------------------------------}
510 -- | /O(log n)/. The minimal key of the map.
511 findMin :: Map k a -> (k,a)
512 findMin (Bin _ kx x Tip r) = (kx,x)
513 findMin (Bin _ kx x l r) = findMin l
514 findMin Tip = error "Map.findMin: empty tree has no minimal element"
516 -- | /O(log n)/. The maximal key of the map.
517 findMax :: Map k a -> (k,a)
518 findMax (Bin _ kx x l Tip) = (kx,x)
519 findMax (Bin _ kx x l r) = findMax r
520 findMax Tip = error "Map.findMax: empty tree has no maximal element"
522 -- | /O(log n)/. Delete the minimal key.
523 deleteMin :: Map k a -> Map k a
524 deleteMin (Bin _ kx x Tip r) = r
525 deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
528 -- | /O(log n)/. Delete the maximal key.
529 deleteMax :: Map k a -> Map k a
530 deleteMax (Bin _ kx x l Tip) = l
531 deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
534 -- | /O(log n)/. Update the value at the minimal key.
535 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
537 = updateMinWithKey (\k x -> f x) m
539 -- | /O(log n)/. Update the value at the maximal key.
540 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
542 = updateMaxWithKey (\k x -> f x) m
545 -- | /O(log n)/. Update the value at the minimal key.
546 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
549 Bin sx kx x Tip r -> case f kx x of
551 Just x' -> Bin sx kx x' Tip r
552 Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
555 -- | /O(log n)/. Update the value at the maximal key.
556 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
559 Bin sx kx x l Tip -> case f kx x of
561 Just x' -> Bin sx kx x' l Tip
562 Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
566 {--------------------------------------------------------------------
568 --------------------------------------------------------------------}
569 -- | The union of a list of maps:
570 -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
571 unions :: Ord k => [Map k a] -> Map k a
573 = foldlStrict union empty ts
575 -- | The union of a list of maps, with a combining operation:
576 -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
577 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
579 = foldlStrict (unionWith f) empty ts
582 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
583 -- It prefers @t1@ when duplicate keys are encountered,
584 -- i.e. (@'union' == 'unionWith' 'const'@).
585 -- The implementation uses the efficient /hedge-union/ algorithm.
586 -- Hedge-union is more efficient on (bigset `union` smallset)
587 union :: Ord k => Map k a -> Map k a -> Map k a
590 union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2
592 -- left-biased hedge union
593 hedgeUnionL cmplo cmphi t1 Tip
595 hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
596 = join kx x (filterGt cmplo l) (filterLt cmphi r)
597 hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
598 = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
599 (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
601 cmpkx k = compare kx k
603 -- right-biased hedge union
604 hedgeUnionR cmplo cmphi t1 Tip
606 hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
607 = join kx x (filterGt cmplo l) (filterLt cmphi r)
608 hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
609 = join kx newx (hedgeUnionR cmplo cmpkx l lt)
610 (hedgeUnionR cmpkx cmphi r gt)
612 cmpkx k = compare kx k
613 lt = trim cmplo cmpkx t2
614 (found,gt) = trimLookupLo kx cmphi t2
619 {--------------------------------------------------------------------
620 Union with a combining function
621 --------------------------------------------------------------------}
622 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
623 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
625 = unionWithKey (\k x y -> f x y) m1 m2
628 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
629 -- Hedge-union is more efficient on (bigset `union` smallset).
630 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
631 unionWithKey f Tip t2 = t2
632 unionWithKey f t1 Tip = t1
633 unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
635 hedgeUnionWithKey f cmplo cmphi t1 Tip
637 hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
638 = join kx x (filterGt cmplo l) (filterLt cmphi r)
639 hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
640 = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
641 (hedgeUnionWithKey f cmpkx cmphi r gt)
643 cmpkx k = compare kx k
644 lt = trim cmplo cmpkx t2
645 (found,gt) = trimLookupLo kx cmphi t2
648 Just (_,y) -> f kx x y
650 {--------------------------------------------------------------------
652 --------------------------------------------------------------------}
653 -- | /O(n+m)/. Difference of two maps.
654 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
655 difference :: Ord k => Map k a -> Map k b -> Map k a
656 difference Tip t2 = Tip
657 difference t1 Tip = t1
658 difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
660 hedgeDiff cmplo cmphi Tip t
662 hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
663 = join kx x (filterGt cmplo l) (filterLt cmphi r)
664 hedgeDiff cmplo cmphi t (Bin _ kx x l r)
665 = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
666 (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
668 cmpkx k = compare kx k
670 -- | /O(n+m)/. Difference with a combining function.
671 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
672 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
673 differenceWith f m1 m2
674 = differenceWithKey (\k x y -> f x y) m1 m2
676 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
677 -- encountered, the combining function is applied to the key and both values.
678 -- If it returns 'Nothing', the element is discarded (proper set difference). If
679 -- it returns (@'Just' y@), the element is updated with a new value @y@.
680 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
681 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
682 differenceWithKey f Tip t2 = Tip
683 differenceWithKey f t1 Tip = t1
684 differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
686 hedgeDiffWithKey f cmplo cmphi Tip t
688 hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
689 = join kx x (filterGt cmplo l) (filterLt cmphi r)
690 hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
692 Nothing -> merge tl tr
695 Nothing -> merge tl tr
696 Just z -> join ky z tl tr
698 cmpkx k = compare kx k
699 lt = trim cmplo cmpkx t
700 (found,gt) = trimLookupLo kx cmphi t
701 tl = hedgeDiffWithKey f cmplo cmpkx lt l
702 tr = hedgeDiffWithKey f cmpkx cmphi gt r
706 {--------------------------------------------------------------------
708 --------------------------------------------------------------------}
709 -- | /O(n+m)/. Intersection of two maps. The values in the first
710 -- map are returned, i.e. (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
711 intersection :: Ord k => Map k a -> Map k b -> Map k a
713 = intersectionWithKey (\k x y -> x) m1 m2
715 -- | /O(n+m)/. Intersection with a combining function.
716 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
717 intersectionWith f m1 m2
718 = intersectionWithKey (\k x y -> f x y) m1 m2
720 -- | /O(n+m)/. Intersection with a combining function.
721 -- Intersection is more efficient on (bigset `intersection` smallset)
722 --intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
723 --intersectionWithKey f Tip t = Tip
724 --intersectionWithKey f t Tip = Tip
725 --intersectionWithKey f t1 t2 = intersectWithKey f t1 t2
727 --intersectWithKey f Tip t = Tip
728 --intersectWithKey f t Tip = Tip
729 --intersectWithKey f t (Bin _ kx x l r)
731 -- Nothing -> merge tl tr
732 -- Just y -> join kx (f kx y x) tl tr
734 -- (lt,found,gt) = splitLookup kx t
735 -- tl = intersectWithKey f lt l
736 -- tr = intersectWithKey f gt r
739 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
740 intersectionWithKey f Tip t = Tip
741 intersectionWithKey f t Tip = Tip
742 intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =
744 let (lt,found,gt) = splitLookupWithKey k2 t1
745 tl = intersectionWithKey f lt l2
746 tr = intersectionWithKey f gt r2
748 Just (k,x) -> join k (f k x x2) tl tr
749 Nothing -> merge tl tr
750 else let (lt,found,gt) = splitLookup k1 t2
751 tl = intersectionWithKey f l1 lt
752 tr = intersectionWithKey f r1 gt
754 Just x -> join k1 (f k1 x1 x) tl tr
755 Nothing -> merge tl tr
759 {--------------------------------------------------------------------
761 --------------------------------------------------------------------}
763 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
764 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
766 = isSubmapOfBy (==) m1 m2
769 The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
770 all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
771 applied to their respective values. For example, the following
772 expressions are all 'True':
774 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
775 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
776 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
778 But the following are all 'False':
780 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
781 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
782 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
784 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
786 = (size t1 <= size t2) && (submap' f t1 t2)
788 submap' f Tip t = True
789 submap' f t Tip = False
790 submap' f (Bin _ kx x l r) t
793 Just y -> f x y && submap' f l lt && submap' f r gt
795 (lt,found,gt) = splitLookup kx t
797 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
798 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
799 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
800 isProperSubmapOf m1 m2
801 = isProperSubmapOfBy (==) m1 m2
803 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
804 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
805 @m1@ and @m2@ are not equal,
806 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
807 applied to their respective values. For example, the following
808 expressions are all 'True':
810 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
811 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
813 But the following are all 'False':
815 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
816 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
817 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
819 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
820 isProperSubmapOfBy f t1 t2
821 = (size t1 < size t2) && (submap' f t1 t2)
823 {--------------------------------------------------------------------
825 --------------------------------------------------------------------}
826 -- | /O(n)/. Filter all values that satisfy the predicate.
827 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
829 = filterWithKey (\k x -> p x) m
831 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
832 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
833 filterWithKey p Tip = Tip
834 filterWithKey p (Bin _ kx x l r)
835 | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
836 | otherwise = merge (filterWithKey p l) (filterWithKey p r)
839 -- | /O(n)/. partition the map according to a predicate. The first
840 -- map contains all elements that satisfy the predicate, the second all
841 -- elements that fail the predicate. See also 'split'.
842 partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
844 = partitionWithKey (\k x -> p x) m
846 -- | /O(n)/. partition the map according to a predicate. The first
847 -- map contains all elements that satisfy the predicate, the second all
848 -- elements that fail the predicate. See also 'split'.
849 partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
850 partitionWithKey p Tip = (Tip,Tip)
851 partitionWithKey p (Bin _ kx x l r)
852 | p kx x = (join kx x l1 r1,merge l2 r2)
853 | otherwise = (merge l1 r1,join kx x l2 r2)
855 (l1,l2) = partitionWithKey p l
856 (r1,r2) = partitionWithKey p r
859 {--------------------------------------------------------------------
861 --------------------------------------------------------------------}
862 -- | /O(n)/. Map a function over all values in the map.
863 map :: (a -> b) -> Map k a -> Map k b
865 = mapWithKey (\k x -> f x) m
867 -- | /O(n)/. Map a function over all values in the map.
868 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
869 mapWithKey f Tip = Tip
870 mapWithKey f (Bin sx kx x l r)
871 = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
873 -- | /O(n)/. The function 'mapAccum' threads an accumulating
874 -- argument through the map in ascending order of keys.
875 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
877 = mapAccumWithKey (\a k x -> f a x) a m
879 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
880 -- argument through the map in ascending order of keys.
881 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
882 mapAccumWithKey f a t
885 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
886 -- argument throught the map in ascending order of keys.
887 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
892 -> let (a1,l') = mapAccumL f a l
894 (a3,r') = mapAccumL f a2 r
895 in (a3,Bin sx kx x' l' r')
897 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
898 -- argument throught the map in descending order of keys.
899 mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
904 -> let (a1,r') = mapAccumR f a r
906 (a3,l') = mapAccumR f a2 l
907 in (a3,Bin sx kx x' l' r')
910 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
912 -- The size of the result may be smaller if @f@ maps two or more distinct
913 -- keys to the same new key. In this case the value at the smallest of
914 -- these keys is retained.
916 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
917 mapKeys = mapKeysWith (\x y->x)
920 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
922 -- The size of the result may be smaller if @f@ maps two or more distinct
923 -- keys to the same new key. In this case the associated values will be
924 -- combined using @c@.
926 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
927 mapKeysWith c f = fromListWith c . List.map fFirst . toList
928 where fFirst (x,y) = (f x, y)
932 -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
933 -- is strictly monotonic.
934 -- /The precondition is not checked./
935 -- Semi-formally, we have:
937 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
938 -- > ==> mapKeysMonotonic f s == mapKeys f s
939 -- > where ls = keys s
941 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
942 mapKeysMonotonic f Tip = Tip
943 mapKeysMonotonic f (Bin sz k x l r) =
944 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
946 {--------------------------------------------------------------------
948 --------------------------------------------------------------------}
950 -- | /O(n)/. Fold the values in the map, such that
951 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
954 -- > elems map = fold (:) [] map
956 fold :: (a -> b -> b) -> b -> Map k a -> b
958 = foldWithKey (\k x z -> f x z) z m
960 -- | /O(n)/. Fold the keys and values in the map, such that
961 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
964 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
966 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
970 -- | /O(n)/. In-order fold.
971 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
973 foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
975 -- | /O(n)/. Post-order fold.
976 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
978 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
980 -- | /O(n)/. Pre-order fold.
981 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
983 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
985 {--------------------------------------------------------------------
987 --------------------------------------------------------------------}
989 -- Return all elements of the map in the ascending order of their keys.
990 elems :: Map k a -> [a]
992 = [x | (k,x) <- assocs m]
994 -- | /O(n)/. Return all keys of the map in ascending order.
995 keys :: Map k a -> [k]
997 = [k | (k,x) <- assocs m]
999 -- | /O(n)/. The set of all keys of the map.
1000 keysSet :: Map k a -> Set.Set k
1001 keysSet m = Set.fromDistinctAscList (keys m)
1003 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
1004 assocs :: Map k a -> [(k,a)]
1008 {--------------------------------------------------------------------
1010 use [foldlStrict] to reduce demand on the control-stack
1011 --------------------------------------------------------------------}
1012 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
1013 fromList :: Ord k => [(k,a)] -> Map k a
1015 = foldlStrict ins empty xs
1017 ins t (k,x) = insert k x t
1019 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
1020 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
1022 = fromListWithKey (\k x y -> f x y) xs
1024 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
1025 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1026 fromListWithKey f xs
1027 = foldlStrict ins empty xs
1029 ins t (k,x) = insertWithKey f k x t
1031 -- | /O(n)/. Convert to a list of key\/value pairs.
1032 toList :: Map k a -> [(k,a)]
1033 toList t = toAscList t
1035 -- | /O(n)/. Convert to an ascending list.
1036 toAscList :: Map k a -> [(k,a)]
1037 toAscList t = foldr (\k x xs -> (k,x):xs) [] t
1040 toDescList :: Map k a -> [(k,a)]
1041 toDescList t = foldl (\xs k x -> (k,x):xs) [] t
1044 {--------------------------------------------------------------------
1045 Building trees from ascending/descending lists can be done in linear time.
1047 Note that if [xs] is ascending that:
1048 fromAscList xs == fromList xs
1049 fromAscListWith f xs == fromListWith f xs
1050 --------------------------------------------------------------------}
1051 -- | /O(n)/. Build a map from an ascending list in linear time.
1052 -- /The precondition (input list is ascending) is not checked./
1053 fromAscList :: Eq k => [(k,a)] -> Map k a
1055 = fromAscListWithKey (\k x y -> x) xs
1057 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
1058 -- /The precondition (input list is ascending) is not checked./
1059 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
1060 fromAscListWith f xs
1061 = fromAscListWithKey (\k x y -> f x y) xs
1063 -- | /O(n)/. Build a map from an ascending list in linear time with a
1064 -- combining function for equal keys.
1065 -- /The precondition (input list is ascending) is not checked./
1066 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1067 fromAscListWithKey f xs
1068 = fromDistinctAscList (combineEq f xs)
1070 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1075 (x:xx) -> combineEq' x xx
1077 combineEq' z [] = [z]
1078 combineEq' z@(kz,zz) (x@(kx,xx):xs)
1079 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
1080 | otherwise = z:combineEq' x xs
1083 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
1084 -- /The precondition is not checked./
1085 fromDistinctAscList :: [(k,a)] -> Map k a
1086 fromDistinctAscList xs
1087 = build const (length xs) xs
1089 -- 1) use continutations so that we use heap space instead of stack space.
1090 -- 2) special case for n==5 to build bushier trees.
1091 build c 0 xs = c Tip xs
1092 build c 5 xs = case xs of
1093 ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
1094 -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
1095 build c n xs = seq nr $ build (buildR nr c) nl xs
1100 buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
1101 buildB l k x c r zs = c (bin k x l r) zs
1105 {--------------------------------------------------------------------
1106 Utility functions that return sub-ranges of the original
1107 tree. Some functions take a comparison function as argument to
1108 allow comparisons against infinite values. A function [cmplo k]
1109 should be read as [compare lo k].
1111 [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
1112 and [cmphi k == GT] for the key [k] of the root.
1113 [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
1114 [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
1116 [split k t] Returns two trees [l] and [r] where all keys
1117 in [l] are <[k] and all keys in [r] are >[k].
1118 [splitLookup k t] Just like [split] but also returns whether [k]
1119 was found in the tree.
1120 --------------------------------------------------------------------}
1122 {--------------------------------------------------------------------
1123 [trim lo hi t] trims away all subtrees that surely contain no
1124 values between the range [lo] to [hi]. The returned tree is either
1125 empty or the key of the root is between @lo@ and @hi@.
1126 --------------------------------------------------------------------}
1127 trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1128 trim cmplo cmphi Tip = Tip
1129 trim cmplo cmphi t@(Bin sx kx x l r)
1131 LT -> case cmphi kx of
1133 le -> trim cmplo cmphi l
1134 ge -> trim cmplo cmphi r
1136 trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe (k,a), Map k a)
1137 trimLookupLo lo cmphi Tip = (Nothing,Tip)
1138 trimLookupLo lo cmphi t@(Bin sx kx x l r)
1139 = case compare lo kx of
1140 LT -> case cmphi kx of
1141 GT -> (lookupAssoc lo t, t)
1142 le -> trimLookupLo lo cmphi l
1143 GT -> trimLookupLo lo cmphi r
1144 EQ -> (Just (kx,x),trim (compare lo) cmphi r)
1147 {--------------------------------------------------------------------
1148 [filterGt k t] filter all keys >[k] from tree [t]
1149 [filterLt k t] filter all keys <[k] from tree [t]
1150 --------------------------------------------------------------------}
1151 filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1152 filterGt cmp Tip = Tip
1153 filterGt cmp (Bin sx kx x l r)
1155 LT -> join kx x (filterGt cmp l) r
1156 GT -> filterGt cmp r
1159 filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1160 filterLt cmp Tip = Tip
1161 filterLt cmp (Bin sx kx x l r)
1163 LT -> filterLt cmp l
1164 GT -> join kx x l (filterLt cmp r)
1167 {--------------------------------------------------------------------
1169 --------------------------------------------------------------------}
1170 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
1171 -- 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@.
1172 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1173 split k Tip = (Tip,Tip)
1174 split k (Bin sx kx x l r)
1175 = case compare k kx of
1176 LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1177 GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1180 -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
1181 -- like 'split' but also returns @'lookup' k map@.
1182 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
1183 splitLookup k Tip = (Tip,Nothing,Tip)
1184 splitLookup k (Bin sx kx x l r)
1185 = case compare k kx of
1186 LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
1187 GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
1191 splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)
1192 splitLookupWithKey k Tip = (Tip,Nothing,Tip)
1193 splitLookupWithKey k (Bin sx kx x l r)
1194 = case compare k kx of
1195 LT -> let (lt,z,gt) = splitLookupWithKey k l in (lt,z,join kx x gt r)
1196 GT -> let (lt,z,gt) = splitLookupWithKey k r in (join kx x l lt,z,gt)
1197 EQ -> (l,Just (kx, x),r)
1199 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
1200 -- element was found in the original set.
1201 splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)
1202 splitMember x t = let (l,m,r) = splitLookup x t in
1203 (l,maybe False (const True) m,r)
1206 {--------------------------------------------------------------------
1207 Utility functions that maintain the balance properties of the tree.
1208 All constructors assume that all values in [l] < [k] and all values
1209 in [r] > [k], and that [l] and [r] are valid trees.
1211 In order of sophistication:
1212 [Bin sz k x l r] The type constructor.
1213 [bin k x l r] Maintains the correct size, assumes that both [l]
1214 and [r] are balanced with respect to each other.
1215 [balance k x l r] Restores the balance and size.
1216 Assumes that the original tree was balanced and
1217 that [l] or [r] has changed by at most one element.
1218 [join k x l r] Restores balance and size.
1220 Furthermore, we can construct a new tree from two trees. Both operations
1221 assume that all values in [l] < all values in [r] and that [l] and [r]
1223 [glue l r] Glues [l] and [r] together. Assumes that [l] and
1224 [r] are already balanced with respect to each other.
1225 [merge l r] Merges two trees and restores balance.
1227 Note: in contrast to Adam's paper, we use (<=) comparisons instead
1228 of (<) comparisons in [join], [merge] and [balance].
1229 Quickcheck (on [difference]) showed that this was necessary in order
1230 to maintain the invariants. It is quite unsatisfactory that I haven't
1231 been able to find out why this is actually the case! Fortunately, it
1232 doesn't hurt to be a bit more conservative.
1233 --------------------------------------------------------------------}
1235 {--------------------------------------------------------------------
1237 --------------------------------------------------------------------}
1238 join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1239 join kx x Tip r = insertMin kx x r
1240 join kx x l Tip = insertMax kx x l
1241 join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1242 | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
1243 | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
1244 | otherwise = bin kx x l r
1247 -- insertMin and insertMax don't perform potentially expensive comparisons.
1248 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1251 Tip -> singleton kx x
1253 -> balance ky y l (insertMax kx x r)
1257 Tip -> singleton kx x
1259 -> balance ky y (insertMin kx x l) r
1261 {--------------------------------------------------------------------
1262 [merge l r]: merges two trees.
1263 --------------------------------------------------------------------}
1264 merge :: Map k a -> Map k a -> Map k a
1267 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1268 | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1269 | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1270 | otherwise = glue l r
1272 {--------------------------------------------------------------------
1273 [glue l r]: glues two trees together.
1274 Assumes that [l] and [r] are already balanced with respect to each other.
1275 --------------------------------------------------------------------}
1276 glue :: Map k a -> Map k a -> Map k a
1280 | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1281 | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
1284 -- | /O(log n)/. Delete and find the minimal element.
1285 deleteFindMin :: Map k a -> ((k,a),Map k a)
1288 Bin _ k x Tip r -> ((k,x),r)
1289 Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1290 Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1292 -- | /O(log n)/. Delete and find the maximal element.
1293 deleteFindMax :: Map k a -> ((k,a),Map k a)
1296 Bin _ k x l Tip -> ((k,x),l)
1297 Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1298 Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1301 {--------------------------------------------------------------------
1302 [balance l x r] balances two trees with value x.
1303 The sizes of the trees should balance after decreasing the
1304 size of one of them. (a rotation).
1306 [delta] is the maximal relative difference between the sizes of
1307 two trees, it corresponds with the [w] in Adams' paper.
1308 [ratio] is the ratio between an outer and inner sibling of the
1309 heavier subtree in an unbalanced setting. It determines
1310 whether a double or single rotation should be performed
1311 to restore balance. It is correspondes with the inverse
1312 of $\alpha$ in Adam's article.
1315 - [delta] should be larger than 4.646 with a [ratio] of 2.
1316 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1318 - A lower [delta] leads to a more 'perfectly' balanced tree.
1319 - A higher [delta] performs less rebalancing.
1321 - Balancing is automatic for random data and a balancing
1322 scheme is only necessary to avoid pathological worst cases.
1323 Almost any choice will do, and in practice, a rather large
1324 [delta] may perform better than smaller one.
1326 Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1327 to decide whether a single or double rotation is needed. Allthough
1328 he actually proves that this ratio is needed to maintain the
1329 invariants, his implementation uses an invalid ratio of [1].
1330 --------------------------------------------------------------------}
1335 balance :: k -> a -> Map k a -> Map k a -> Map k a
1337 | sizeL + sizeR <= 1 = Bin sizeX k x l r
1338 | sizeR >= delta*sizeL = rotateL k x l r
1339 | sizeL >= delta*sizeR = rotateR k x l r
1340 | otherwise = Bin sizeX k x l r
1344 sizeX = sizeL + sizeR + 1
1347 rotateL k x l r@(Bin _ _ _ ly ry)
1348 | size ly < ratio*size ry = singleL k x l r
1349 | otherwise = doubleL k x l r
1351 rotateR k x l@(Bin _ _ _ ly ry) r
1352 | size ry < ratio*size ly = singleR k x l r
1353 | otherwise = doubleR k x l r
1356 singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
1357 singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
1359 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)
1360 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)
1363 {--------------------------------------------------------------------
1364 The bin constructor maintains the size of the tree
1365 --------------------------------------------------------------------}
1366 bin :: k -> a -> Map k a -> Map k a -> Map k a
1368 = Bin (size l + size r + 1) k x l r
1371 {--------------------------------------------------------------------
1372 Eq converts the tree to a list. In a lazy setting, this
1373 actually seems one of the faster methods to compare two trees
1374 and it is certainly the simplest :-)
1375 --------------------------------------------------------------------}
1376 instance (Eq k,Eq a) => Eq (Map k a) where
1377 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1379 {--------------------------------------------------------------------
1381 --------------------------------------------------------------------}
1383 instance (Ord k, Ord v) => Ord (Map k v) where
1384 compare m1 m2 = compare (toAscList m1) (toAscList m2)
1386 {--------------------------------------------------------------------
1388 --------------------------------------------------------------------}
1389 instance Functor (Map k) where
1392 instance Traversable (Map k) where
1393 traverse f Tip = pure Tip
1394 traverse f (Bin s k v l r)
1395 = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
1397 instance Foldable (Map k) where
1398 foldMap _f Tip = mempty
1399 foldMap f (Bin _s _k v l r)
1400 = foldMap f l `mappend` f v `mappend` foldMap f r
1402 {--------------------------------------------------------------------
1404 --------------------------------------------------------------------}
1405 instance (Ord k, Read k, Read e) => Read (Map k e) where
1406 #ifdef __GLASGOW_HASKELL__
1407 readPrec = parens $ prec 10 $ do
1408 Ident "fromList" <- lexP
1410 return (fromList xs)
1412 readListPrec = readListPrecDefault
1414 readsPrec p = readParen (p > 10) $ \ r -> do
1415 ("fromList",s) <- lex r
1417 return (fromList xs,t)
1420 -- parses a pair of things with the syntax a:=b
1421 readPair :: (Read a, Read b) => ReadS (a,b)
1422 readPair s = do (a, ct1) <- reads s
1423 (":=", ct2) <- lex ct1
1424 (b, ct3) <- reads ct2
1427 {--------------------------------------------------------------------
1429 --------------------------------------------------------------------}
1430 instance (Show k, Show a) => Show (Map k a) where
1431 showsPrec d m = showParen (d > 10) $
1432 showString "fromList " . shows (toList m)
1434 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1438 = showChar '{' . showElem x . showTail xs
1440 showTail [] = showChar '}'
1441 showTail (x:xs) = showString ", " . showElem x . showTail xs
1443 showElem (k,x) = shows k . showString " := " . shows x
1446 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1447 -- in a compressed, hanging format.
1448 showTree :: (Show k,Show a) => Map k a -> String
1450 = showTreeWith showElem True False m
1452 showElem k x = show k ++ ":=" ++ show x
1455 {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
1456 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1457 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1458 @wide@ is 'True', an extra wide version is shown.
1460 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1461 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1468 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1479 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
1491 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
1492 showTreeWith showelem hang wide t
1493 | hang = (showsTreeHang showelem wide [] t) ""
1494 | otherwise = (showsTree showelem wide [] [] t) ""
1496 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1497 showsTree showelem wide lbars rbars t
1499 Tip -> showsBars lbars . showString "|\n"
1501 -> showsBars lbars . showString (showelem kx x) . showString "\n"
1503 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
1504 showWide wide rbars .
1505 showsBars lbars . showString (showelem kx x) . showString "\n" .
1506 showWide wide lbars .
1507 showsTree showelem wide (withEmpty lbars) (withBar lbars) l
1509 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1510 showsTreeHang showelem wide bars t
1512 Tip -> showsBars bars . showString "|\n"
1514 -> showsBars bars . showString (showelem kx x) . showString "\n"
1516 -> showsBars bars . showString (showelem kx x) . showString "\n" .
1517 showWide wide bars .
1518 showsTreeHang showelem wide (withBar bars) l .
1519 showWide wide bars .
1520 showsTreeHang showelem wide (withEmpty bars) r
1524 | wide = showString (concat (reverse bars)) . showString "|\n"
1527 showsBars :: [String] -> ShowS
1531 _ -> showString (concat (reverse (tail bars))) . showString node
1534 withBar bars = "| ":bars
1535 withEmpty bars = " ":bars
1537 {--------------------------------------------------------------------
1539 --------------------------------------------------------------------}
1541 #include "Typeable.h"
1542 INSTANCE_TYPEABLE2(Map,mapTc,"Map")
1544 {--------------------------------------------------------------------
1546 --------------------------------------------------------------------}
1547 -- | /O(n)/. Test if the internal map structure is valid.
1548 valid :: Ord k => Map k a -> Bool
1550 = balanced t && ordered t && validsize t
1553 = bounded (const True) (const True) t
1558 Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1560 -- | Exported only for "Debug.QuickCheck"
1561 balanced :: Map k a -> Bool
1565 Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1566 balanced l && balanced r
1570 = (realsize t == Just (size t))
1575 Bin sz kx x l r -> case (realsize l,realsize r) of
1576 (Just n,Just m) | n+m+1 == sz -> Just sz
1579 {--------------------------------------------------------------------
1581 --------------------------------------------------------------------}
1585 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1589 {--------------------------------------------------------------------
1591 --------------------------------------------------------------------}
1592 testTree xs = fromList [(x,"*") | x <- xs]
1593 test1 = testTree [1..20]
1594 test2 = testTree [30,29..10]
1595 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1597 {--------------------------------------------------------------------
1599 --------------------------------------------------------------------}
1604 { configMaxTest = 500
1605 , configMaxFail = 5000
1606 , configSize = \n -> (div n 2 + 3)
1607 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1611 {--------------------------------------------------------------------
1612 Arbitrary, reasonably balanced trees
1613 --------------------------------------------------------------------}
1614 instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
1615 arbitrary = sized (arbtree 0 maxkey)
1616 where maxkey = 10000
1618 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
1620 | n <= 0 = return Tip
1621 | lo >= hi = return Tip
1622 | otherwise = do{ x <- arbitrary
1623 ; i <- choose (lo,hi)
1624 ; m <- choose (1,30)
1625 ; let (ml,mr) | m==(1::Int)= (1,2)
1629 ; l <- arbtree lo (i-1) (n `div` ml)
1630 ; r <- arbtree (i+1) hi (n `div` mr)
1631 ; return (bin (toEnum i) x l r)
1635 {--------------------------------------------------------------------
1637 --------------------------------------------------------------------}
1638 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
1640 = forAll arbitrary $ \t ->
1641 -- classify (balanced t) "balanced" $
1642 classify (size t == 0) "empty" $
1643 classify (size t > 0 && size t <= 10) "small" $
1644 classify (size t > 10 && size t <= 64) "medium" $
1645 classify (size t > 64) "large" $
1648 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1652 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1658 = forValidUnitTree $ \t -> valid t
1660 {--------------------------------------------------------------------
1661 Single, Insert, Delete
1662 --------------------------------------------------------------------}
1663 prop_Single :: Int -> Int -> Bool
1665 = (insert k x empty == singleton k x)
1667 prop_InsertValid :: Int -> Property
1669 = forValidUnitTree $ \t -> valid (insert k () t)
1671 prop_InsertDelete :: Int -> Map Int () -> Property
1672 prop_InsertDelete k t
1673 = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1675 prop_DeleteValid :: Int -> Property
1677 = forValidUnitTree $ \t ->
1678 valid (delete k (insert k () t))
1680 {--------------------------------------------------------------------
1682 --------------------------------------------------------------------}
1683 prop_Join :: Int -> Property
1685 = forValidUnitTree $ \t ->
1686 let (l,r) = split k t
1687 in valid (join k () l r)
1689 prop_Merge :: Int -> Property
1691 = forValidUnitTree $ \t ->
1692 let (l,r) = split k t
1693 in valid (merge l r)
1696 {--------------------------------------------------------------------
1698 --------------------------------------------------------------------}
1699 prop_UnionValid :: Property
1701 = forValidUnitTree $ \t1 ->
1702 forValidUnitTree $ \t2 ->
1705 prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
1706 prop_UnionInsert k x t
1707 = union (singleton k x) t == insert k x t
1709 prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
1710 prop_UnionAssoc t1 t2 t3
1711 = union t1 (union t2 t3) == union (union t1 t2) t3
1713 prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
1714 prop_UnionComm t1 t2
1715 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1718 = forValidIntTree $ \t1 ->
1719 forValidIntTree $ \t2 ->
1720 valid (unionWithKey (\k x y -> x+y) t1 t2)
1722 prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
1723 prop_UnionWith xs ys
1724 = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
1725 == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
1728 = forValidUnitTree $ \t1 ->
1729 forValidUnitTree $ \t2 ->
1730 valid (difference t1 t2)
1732 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1734 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1735 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1738 = forValidUnitTree $ \t1 ->
1739 forValidUnitTree $ \t2 ->
1740 valid (intersection t1 t2)
1742 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1744 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1745 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1747 {--------------------------------------------------------------------
1749 --------------------------------------------------------------------}
1751 = forAll (choose (5,100)) $ \n ->
1752 let xs = [(x,()) | x <- [0..n::Int]]
1753 in fromAscList xs == fromList xs
1755 prop_List :: [Int] -> Bool
1757 = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])