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.
27 -----------------------------------------------------------------------------
31 Map -- instance Eq,Show,Read
50 , insertWith, insertWithKey, insertLookupWithKey
110 , fromDistinctAscList
122 , isSubmapOf, isSubmapOfBy
123 , isProperSubmapOf, isProperSubmapOfBy
150 import Prelude hiding (lookup,map,filter,foldr,foldl,null)
151 import qualified Data.Set as Set
152 import qualified Data.List as List
153 import Data.Monoid (Monoid(..))
158 import qualified Prelude
159 import qualified List
160 import Debug.QuickCheck
161 import List(nub,sort)
164 #if __GLASGOW_HASKELL__
166 import Data.Generics.Basics
167 import Data.Generics.Instances
170 {--------------------------------------------------------------------
172 --------------------------------------------------------------------}
175 -- | /O(log n)/. Find the value at a key.
176 -- Calls 'error' when the element can not be found.
177 (!) :: Ord k => Map k a -> k -> a
180 -- | /O(n+m)/. See 'difference'.
181 (\\) :: Ord k => Map k a -> Map k b -> Map k a
182 m1 \\ m2 = difference m1 m2
184 {--------------------------------------------------------------------
186 --------------------------------------------------------------------}
187 -- | A Map from keys @k@ to values @a@.
189 | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
193 instance (Ord k) => Monoid (Map k v) where
198 #if __GLASGOW_HASKELL__
200 {--------------------------------------------------------------------
202 --------------------------------------------------------------------}
204 -- This instance preserves data abstraction at the cost of inefficiency.
205 -- We omit reflection services for the sake of data abstraction.
207 instance (Data k, Data a, Ord k) => Data (Map k a) where
208 gfoldl f z map = z fromList `f` (toList map)
209 toConstr _ = error "toConstr"
210 gunfold _ _ = error "gunfold"
211 dataTypeOf _ = mkNorepType "Data.Map.Map"
215 {--------------------------------------------------------------------
217 --------------------------------------------------------------------}
218 -- | /O(1)/. Is the map empty?
219 null :: Map k a -> Bool
223 Bin sz k x l r -> False
225 -- | /O(1)/. The number of elements in the map.
226 size :: Map k a -> Int
233 -- | /O(log n)/. Lookup the value at a key in the map.
234 lookup :: (Monad m,Ord k) => k -> Map k a -> m a
235 lookup k t = case lookup' k t of
237 Nothing -> fail "Data.Map.lookup: Key not found"
238 lookup' :: Ord k => k -> Map k a -> Maybe a
243 -> case compare k kx of
248 -- | /O(log n)/. Is the key a member of the map?
249 member :: Ord k => k -> Map k a -> Bool
255 -- | /O(log n)/. Find the value at a key.
256 -- Calls 'error' when the element can not be found.
257 find :: Ord k => k -> Map k a -> a
260 Nothing -> error "Map.find: element not in the map"
263 -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
264 -- the value at key @k@ or returns @def@ when the key is not in the map.
265 findWithDefault :: Ord k => a -> k -> Map k a -> a
266 findWithDefault def k m
273 {--------------------------------------------------------------------
275 --------------------------------------------------------------------}
276 -- | /O(1)/. The empty map.
281 -- | /O(1)/. A map with a single element.
282 singleton :: k -> a -> Map k a
286 {--------------------------------------------------------------------
288 --------------------------------------------------------------------}
289 -- | /O(log n)/. Insert a new key and value in the map.
290 -- If the key is already present in the map, the associated value is
291 -- replaced with the supplied value, i.e. 'insert' is equivalent to
292 -- @'insertWith' 'const'@.
293 insert :: Ord k => k -> a -> Map k a -> Map k a
296 Tip -> singleton kx x
298 -> case compare kx ky of
299 LT -> balance ky y (insert kx x l) r
300 GT -> balance ky y l (insert kx x r)
301 EQ -> Bin sz kx x l r
303 -- | /O(log n)/. Insert with a combining function.
304 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
306 = insertWithKey (\k x y -> f x y) k x m
308 -- | /O(log n)/. Insert with a combining function.
309 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
310 insertWithKey f kx x t
312 Tip -> singleton kx x
314 -> case compare kx ky of
315 LT -> balance ky y (insertWithKey f kx x l) r
316 GT -> balance ky y l (insertWithKey f kx x r)
317 EQ -> Bin sy ky (f ky x y) l r
319 -- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@)
320 -- is a pair where the first element is equal to (@'lookup' k map@)
321 -- and the second element equal to (@'insertWithKey' f k x map@).
322 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
323 insertLookupWithKey f kx x t
325 Tip -> (Nothing, singleton kx x)
327 -> case compare kx ky of
328 LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
329 GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
330 EQ -> (Just y, Bin sy ky (f ky x y) l r)
332 {--------------------------------------------------------------------
334 [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
335 --------------------------------------------------------------------}
336 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
337 -- a member of the map, the original map is returned.
338 delete :: Ord k => k -> Map k a -> Map k a
343 -> case compare k kx of
344 LT -> balance kx x (delete k l) r
345 GT -> balance kx x l (delete k r)
348 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
349 -- a member of the map, the original map is returned.
350 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
352 = adjustWithKey (\k x -> f x) k m
354 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
355 -- a member of the map, the original map is returned.
356 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
358 = updateWithKey (\k x -> Just (f k x)) k m
360 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
361 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
362 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
363 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
365 = updateWithKey (\k x -> f x) k m
367 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
368 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
369 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
370 -- to the new value @y@.
371 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
376 -> case compare k kx of
377 LT -> balance kx x (updateWithKey f k l) r
378 GT -> balance kx x l (updateWithKey f k r)
380 Just x' -> Bin sx kx x' l r
383 -- | /O(log n)/. Lookup and update.
384 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
385 updateLookupWithKey f k t
389 -> case compare k kx of
390 LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
391 GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
393 Just x' -> (Just x',Bin sx kx x' l r)
394 Nothing -> (Just x,glue l r)
396 {--------------------------------------------------------------------
398 --------------------------------------------------------------------}
399 -- | /O(log n)/. Return the /index/ of a key. The index is a number from
400 -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
401 -- the key is not a 'member' of the map.
402 findIndex :: Ord k => k -> Map k a -> Int
404 = case lookupIndex k t of
405 Nothing -> error "Map.findIndex: element is not in the map"
408 -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
409 -- /0/ up to, but not including, the 'size' of the map.
410 lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
411 lookupIndex k t = case lookup 0 t of
412 Nothing -> fail "Data.Map.lookupIndex: Key not found."
415 lookup idx Tip = Nothing
416 lookup idx (Bin _ kx x l r)
417 = case compare k kx of
419 GT -> lookup (idx + size l + 1) r
420 EQ -> Just (idx + size l)
422 -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
423 -- invalid index is used.
424 elemAt :: Int -> Map k a -> (k,a)
425 elemAt i Tip = error "Map.elemAt: index out of range"
426 elemAt i (Bin _ kx x l r)
427 = case compare i sizeL of
429 GT -> elemAt (i-sizeL-1) r
434 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
435 -- invalid index is used.
436 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
437 updateAt f i Tip = error "Map.updateAt: index out of range"
438 updateAt f i (Bin sx kx x l r)
439 = case compare i sizeL of
441 GT -> updateAt f (i-sizeL-1) r
443 Just x' -> Bin sx kx x' l r
448 -- | /O(log n)/. Delete the element at /index/.
449 -- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
450 deleteAt :: Int -> Map k a -> Map k a
452 = updateAt (\k x -> Nothing) i map
455 {--------------------------------------------------------------------
457 --------------------------------------------------------------------}
458 -- | /O(log n)/. The minimal key of the map.
459 findMin :: Map k a -> (k,a)
460 findMin (Bin _ kx x Tip r) = (kx,x)
461 findMin (Bin _ kx x l r) = findMin l
462 findMin Tip = error "Map.findMin: empty tree has no minimal element"
464 -- | /O(log n)/. The maximal key of the map.
465 findMax :: Map k a -> (k,a)
466 findMax (Bin _ kx x l Tip) = (kx,x)
467 findMax (Bin _ kx x l r) = findMax r
468 findMax Tip = error "Map.findMax: empty tree has no maximal element"
470 -- | /O(log n)/. Delete the minimal key.
471 deleteMin :: Map k a -> Map k a
472 deleteMin (Bin _ kx x Tip r) = r
473 deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
476 -- | /O(log n)/. Delete the maximal key.
477 deleteMax :: Map k a -> Map k a
478 deleteMax (Bin _ kx x l Tip) = l
479 deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
482 -- | /O(log n)/. Update the value at the minimal key.
483 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
485 = updateMinWithKey (\k x -> f x) m
487 -- | /O(log n)/. Update the value at the maximal key.
488 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
490 = updateMaxWithKey (\k x -> f x) m
493 -- | /O(log n)/. Update the value at the minimal key.
494 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
497 Bin sx kx x Tip r -> case f kx x of
499 Just x' -> Bin sx kx x' Tip r
500 Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
503 -- | /O(log n)/. Update the value at the maximal key.
504 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
507 Bin sx kx x l Tip -> case f kx x of
509 Just x' -> Bin sx kx x' l Tip
510 Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
514 {--------------------------------------------------------------------
516 --------------------------------------------------------------------}
517 -- | The union of a list of maps:
518 -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
519 unions :: Ord k => [Map k a] -> Map k a
521 = foldlStrict union empty ts
523 -- | The union of a list of maps, with a combining operation:
524 -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
525 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
527 = foldlStrict (unionWith f) empty ts
530 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
531 -- It prefers @t1@ when duplicate keys are encountered,
532 -- i.e. (@'union' == 'unionWith' 'const'@).
533 -- The implementation uses the efficient /hedge-union/ algorithm.
534 -- Hedge-union is more efficient on (bigset `union` smallset)?
535 union :: Ord k => Map k a -> Map k a -> Map k a
539 | size t1 >= size t2 = hedgeUnionL (const LT) (const GT) t1 t2
540 | otherwise = hedgeUnionR (const LT) (const GT) t2 t1
542 -- left-biased hedge union
543 hedgeUnionL cmplo cmphi t1 Tip
545 hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
546 = join kx x (filterGt cmplo l) (filterLt cmphi r)
547 hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
548 = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
549 (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
551 cmpkx k = compare kx k
553 -- right-biased hedge union
554 hedgeUnionR cmplo cmphi t1 Tip
556 hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
557 = join kx x (filterGt cmplo l) (filterLt cmphi r)
558 hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
559 = join kx newx (hedgeUnionR cmplo cmpkx l lt)
560 (hedgeUnionR cmpkx cmphi r gt)
562 cmpkx k = compare kx k
563 lt = trim cmplo cmpkx t2
564 (found,gt) = trimLookupLo kx cmphi t2
569 {--------------------------------------------------------------------
570 Union with a combining function
571 --------------------------------------------------------------------}
572 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
573 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
575 = unionWithKey (\k x y -> f x y) m1 m2
578 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
579 -- Hedge-union is more efficient on (bigset `union` smallset).
580 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
581 unionWithKey f Tip t2 = t2
582 unionWithKey f t1 Tip = t1
584 | size t1 >= size t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
585 | otherwise = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1
587 flipf k x y = f k y x
589 hedgeUnionWithKey f cmplo cmphi t1 Tip
591 hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
592 = join kx x (filterGt cmplo l) (filterLt cmphi r)
593 hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
594 = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
595 (hedgeUnionWithKey f cmpkx cmphi r gt)
597 cmpkx k = compare kx k
598 lt = trim cmplo cmpkx t2
599 (found,gt) = trimLookupLo kx cmphi t2
604 {--------------------------------------------------------------------
606 --------------------------------------------------------------------}
607 -- | /O(n+m)/. Difference of two maps.
608 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
609 difference :: Ord k => Map k a -> Map k b -> Map k a
610 difference Tip t2 = Tip
611 difference t1 Tip = t1
612 difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
614 hedgeDiff cmplo cmphi Tip t
616 hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
617 = join kx x (filterGt cmplo l) (filterLt cmphi r)
618 hedgeDiff cmplo cmphi t (Bin _ kx x l r)
619 = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
620 (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
622 cmpkx k = compare kx k
624 -- | /O(n+m)/. Difference with a combining function.
625 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
626 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
627 differenceWith f m1 m2
628 = differenceWithKey (\k x y -> f x y) m1 m2
630 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
631 -- encountered, the combining function is applied to the key and both values.
632 -- If it returns 'Nothing', the element is discarded (proper set difference). If
633 -- it returns (@'Just' y@), the element is updated with a new value @y@.
634 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
635 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
636 differenceWithKey f Tip t2 = Tip
637 differenceWithKey f t1 Tip = t1
638 differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
640 hedgeDiffWithKey f cmplo cmphi Tip t
642 hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
643 = join kx x (filterGt cmplo l) (filterLt cmphi r)
644 hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
646 Nothing -> merge tl tr
647 Just y -> case f kx y x of
648 Nothing -> merge tl tr
649 Just z -> join kx z tl tr
651 cmpkx k = compare kx k
652 lt = trim cmplo cmpkx t
653 (found,gt) = trimLookupLo kx cmphi t
654 tl = hedgeDiffWithKey f cmplo cmpkx lt l
655 tr = hedgeDiffWithKey f cmpkx cmphi gt r
659 {--------------------------------------------------------------------
661 --------------------------------------------------------------------}
662 -- | /O(n+m)/. Intersection of two maps. The values in the first
663 -- map are returned, i.e. (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
664 intersection :: Ord k => Map k a -> Map k b -> Map k a
666 = intersectionWithKey (\k x y -> x) m1 m2
668 -- | /O(n+m)/. Intersection with a combining function.
669 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
670 intersectionWith f m1 m2
671 = intersectionWithKey (\k x y -> f x y) m1 m2
673 -- | /O(n+m)/. Intersection with a combining function.
674 -- Intersection is more efficient on (bigset `intersection` smallset)
675 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
676 intersectionWithKey f Tip t = Tip
677 intersectionWithKey f t Tip = Tip
678 intersectionWithKey f t1 t2
679 | size t1 >= size t2 = intersectWithKey f t1 t2
680 | otherwise = intersectWithKey flipf t2 t1
682 flipf k x y = f k y x
684 intersectWithKey f Tip t = Tip
685 intersectWithKey f t Tip = Tip
686 intersectWithKey f t (Bin _ kx x l r)
688 Nothing -> merge tl tr
689 Just y -> join kx (f kx y x) tl tr
691 (lt,found,gt) = splitLookup kx t
692 tl = intersectWithKey f lt l
693 tr = intersectWithKey f gt r
697 {--------------------------------------------------------------------
699 --------------------------------------------------------------------}
701 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
702 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
704 = isSubmapOfBy (==) m1 m2
707 The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
708 all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
709 applied to their respective values. For example, the following
710 expressions are all 'True':
712 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
713 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
714 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
716 But the following are all 'False':
718 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
719 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
720 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
722 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
724 = (size t1 <= size t2) && (submap' f t1 t2)
726 submap' f Tip t = True
727 submap' f t Tip = False
728 submap' f (Bin _ kx x l r) t
731 Just y -> f x y && submap' f l lt && submap' f r gt
733 (lt,found,gt) = splitLookup kx t
735 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
736 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
737 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
738 isProperSubmapOf m1 m2
739 = isProperSubmapOfBy (==) m1 m2
741 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
742 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
743 @m1@ and @m2@ are not equal,
744 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
745 applied to their respective values. For example, the following
746 expressions are all 'True':
748 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
749 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
751 But the following are all 'False':
753 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
754 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
755 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
757 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
758 isProperSubmapOfBy f t1 t2
759 = (size t1 < size t2) && (submap' f t1 t2)
761 {--------------------------------------------------------------------
763 --------------------------------------------------------------------}
764 -- | /O(n)/. Filter all values that satisfy the predicate.
765 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
767 = filterWithKey (\k x -> p x) m
769 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
770 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
771 filterWithKey p Tip = Tip
772 filterWithKey p (Bin _ kx x l r)
773 | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
774 | otherwise = merge (filterWithKey p l) (filterWithKey p r)
777 -- | /O(n)/. partition the map according to a predicate. The first
778 -- map contains all elements that satisfy the predicate, the second all
779 -- elements that fail the predicate. See also 'split'.
780 partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
782 = partitionWithKey (\k x -> p x) m
784 -- | /O(n)/. partition the map according to a predicate. The first
785 -- map contains all elements that satisfy the predicate, the second all
786 -- elements that fail the predicate. See also 'split'.
787 partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
788 partitionWithKey p Tip = (Tip,Tip)
789 partitionWithKey p (Bin _ kx x l r)
790 | p kx x = (join kx x l1 r1,merge l2 r2)
791 | otherwise = (merge l1 r1,join kx x l2 r2)
793 (l1,l2) = partitionWithKey p l
794 (r1,r2) = partitionWithKey p r
797 {--------------------------------------------------------------------
799 --------------------------------------------------------------------}
800 -- | /O(n)/. Map a function over all values in the map.
801 map :: (a -> b) -> Map k a -> Map k b
803 = mapWithKey (\k x -> f x) m
805 -- | /O(n)/. Map a function over all values in the map.
806 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
807 mapWithKey f Tip = Tip
808 mapWithKey f (Bin sx kx x l r)
809 = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
811 -- | /O(n)/. The function 'mapAccum' threads an accumulating
812 -- argument through the map in ascending order of keys.
813 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
815 = mapAccumWithKey (\a k x -> f a x) a m
817 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
818 -- argument through the map in ascending order of keys.
819 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
820 mapAccumWithKey f a t
823 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
824 -- argument throught the map in ascending order of keys.
825 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
830 -> let (a1,l') = mapAccumL f a l
832 (a3,r') = mapAccumL f a2 r
833 in (a3,Bin sx kx x' l' r')
835 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
836 -- argument throught the map in descending order of keys.
837 mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
842 -> let (a1,r') = mapAccumR f a r
844 (a3,l') = mapAccumR f a2 l
845 in (a3,Bin sx kx x' l' r')
848 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
850 -- The size of the result may be smaller if @f@ maps two or more distinct
851 -- keys to the same new key. In this case the value at the smallest of
852 -- these keys is retained.
854 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
855 mapKeys = mapKeysWith (\x y->x)
858 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
860 -- The size of the result may be smaller if @f@ maps two or more distinct
861 -- keys to the same new key. In this case the associated values will be
862 -- combined using @c@.
864 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
865 mapKeysWith c f = fromListWith c . List.map fFirst . toList
866 where fFirst (x,y) = (f x, y)
870 -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
871 -- is strictly monotonic.
872 -- /The precondition is not checked./
873 -- Semi-formally, we have:
875 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
876 -- > ==> mapKeysMonotonic f s == mapKeys f s
877 -- > where ls = keys s
879 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
880 mapKeysMonotonic f Tip = Tip
881 mapKeysMonotonic f (Bin sz k x l r) =
882 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
884 {--------------------------------------------------------------------
886 --------------------------------------------------------------------}
888 -- | /O(n)/. Fold the values in the map, such that
889 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
892 -- > elems map = fold (:) [] map
894 fold :: (a -> b -> b) -> b -> Map k a -> b
896 = foldWithKey (\k x z -> f x z) z m
898 -- | /O(n)/. Fold the keys and values in the map, such that
899 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
902 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
904 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
908 -- | /O(n)/. In-order fold.
909 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
911 foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
913 -- | /O(n)/. Post-order fold.
914 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
916 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
918 -- | /O(n)/. Pre-order fold.
919 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
921 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
923 {--------------------------------------------------------------------
925 --------------------------------------------------------------------}
927 -- Return all elements of the map in the ascending order of their keys.
928 elems :: Map k a -> [a]
930 = [x | (k,x) <- assocs m]
932 -- | /O(n)/. Return all keys of the map in ascending order.
933 keys :: Map k a -> [k]
935 = [k | (k,x) <- assocs m]
937 -- | /O(n)/. The set of all keys of the map.
938 keysSet :: Map k a -> Set.Set k
939 keysSet m = Set.fromDistinctAscList (keys m)
941 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
942 assocs :: Map k a -> [(k,a)]
946 {--------------------------------------------------------------------
948 use [foldlStrict] to reduce demand on the control-stack
949 --------------------------------------------------------------------}
950 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
951 fromList :: Ord k => [(k,a)] -> Map k a
953 = foldlStrict ins empty xs
955 ins t (k,x) = insert k x t
957 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
958 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
960 = fromListWithKey (\k x y -> f x y) xs
962 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
963 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
965 = foldlStrict ins empty xs
967 ins t (k,x) = insertWithKey f k x t
969 -- | /O(n)/. Convert to a list of key\/value pairs.
970 toList :: Map k a -> [(k,a)]
971 toList t = toAscList t
973 -- | /O(n)/. Convert to an ascending list.
974 toAscList :: Map k a -> [(k,a)]
975 toAscList t = foldr (\k x xs -> (k,x):xs) [] t
978 toDescList :: Map k a -> [(k,a)]
979 toDescList t = foldl (\xs k x -> (k,x):xs) [] t
982 {--------------------------------------------------------------------
983 Building trees from ascending/descending lists can be done in linear time.
985 Note that if [xs] is ascending that:
986 fromAscList xs == fromList xs
987 fromAscListWith f xs == fromListWith f xs
988 --------------------------------------------------------------------}
989 -- | /O(n)/. Build a map from an ascending list in linear time.
990 -- /The precondition (input list is ascending) is not checked./
991 fromAscList :: Eq k => [(k,a)] -> Map k a
993 = fromAscListWithKey (\k x y -> x) xs
995 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
996 -- /The precondition (input list is ascending) is not checked./
997 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
999 = fromAscListWithKey (\k x y -> f x y) xs
1001 -- | /O(n)/. Build a map from an ascending list in linear time with a
1002 -- combining function for equal keys.
1003 -- /The precondition (input list is ascending) is not checked./
1004 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1005 fromAscListWithKey f xs
1006 = fromDistinctAscList (combineEq f xs)
1008 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1013 (x:xx) -> combineEq' x xx
1015 combineEq' z [] = [z]
1016 combineEq' z@(kz,zz) (x@(kx,xx):xs)
1017 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
1018 | otherwise = z:combineEq' x xs
1021 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
1022 -- /The precondition is not checked./
1023 fromDistinctAscList :: [(k,a)] -> Map k a
1024 fromDistinctAscList xs
1025 = build const (length xs) xs
1027 -- 1) use continutations so that we use heap space instead of stack space.
1028 -- 2) special case for n==5 to build bushier trees.
1029 build c 0 xs = c Tip xs
1030 build c 5 xs = case xs of
1031 ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
1032 -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
1033 build c n xs = seq nr $ build (buildR nr c) nl xs
1038 buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
1039 buildB l k x c r zs = c (bin k x l r) zs
1043 {--------------------------------------------------------------------
1044 Utility functions that return sub-ranges of the original
1045 tree. Some functions take a comparison function as argument to
1046 allow comparisons against infinite values. A function [cmplo k]
1047 should be read as [compare lo k].
1049 [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
1050 and [cmphi k == GT] for the key [k] of the root.
1051 [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
1052 [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
1054 [split k t] Returns two trees [l] and [r] where all keys
1055 in [l] are <[k] and all keys in [r] are >[k].
1056 [splitLookup k t] Just like [split] but also returns whether [k]
1057 was found in the tree.
1058 --------------------------------------------------------------------}
1060 {--------------------------------------------------------------------
1061 [trim lo hi t] trims away all subtrees that surely contain no
1062 values between the range [lo] to [hi]. The returned tree is either
1063 empty or the key of the root is between @lo@ and @hi@.
1064 --------------------------------------------------------------------}
1065 trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1066 trim cmplo cmphi Tip = Tip
1067 trim cmplo cmphi t@(Bin sx kx x l r)
1069 LT -> case cmphi kx of
1071 le -> trim cmplo cmphi l
1072 ge -> trim cmplo cmphi r
1074 trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a)
1075 trimLookupLo lo cmphi Tip = (Nothing,Tip)
1076 trimLookupLo lo cmphi t@(Bin sx kx x l r)
1077 = case compare lo kx of
1078 LT -> case cmphi kx of
1079 GT -> (lookup lo t, t)
1080 le -> trimLookupLo lo cmphi l
1081 GT -> trimLookupLo lo cmphi r
1082 EQ -> (Just x,trim (compare lo) cmphi r)
1085 {--------------------------------------------------------------------
1086 [filterGt k t] filter all keys >[k] from tree [t]
1087 [filterLt k t] filter all keys <[k] from tree [t]
1088 --------------------------------------------------------------------}
1089 filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1090 filterGt cmp Tip = Tip
1091 filterGt cmp (Bin sx kx x l r)
1093 LT -> join kx x (filterGt cmp l) r
1094 GT -> filterGt cmp r
1097 filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1098 filterLt cmp Tip = Tip
1099 filterLt cmp (Bin sx kx x l r)
1101 LT -> filterLt cmp l
1102 GT -> join kx x l (filterLt cmp r)
1105 {--------------------------------------------------------------------
1107 --------------------------------------------------------------------}
1108 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
1109 -- 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@.
1110 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1111 split k Tip = (Tip,Tip)
1112 split k (Bin sx kx x l r)
1113 = case compare k kx of
1114 LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1115 GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1118 -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
1119 -- like 'split' but also returns @'lookup' k map@.
1120 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
1121 splitLookup k Tip = (Tip,Nothing,Tip)
1122 splitLookup k (Bin sx kx x l r)
1123 = case compare k kx of
1124 LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
1125 GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
1128 {--------------------------------------------------------------------
1129 Utility functions that maintain the balance properties of the tree.
1130 All constructors assume that all values in [l] < [k] and all values
1131 in [r] > [k], and that [l] and [r] are valid trees.
1133 In order of sophistication:
1134 [Bin sz k x l r] The type constructor.
1135 [bin k x l r] Maintains the correct size, assumes that both [l]
1136 and [r] are balanced with respect to each other.
1137 [balance k x l r] Restores the balance and size.
1138 Assumes that the original tree was balanced and
1139 that [l] or [r] has changed by at most one element.
1140 [join k x l r] Restores balance and size.
1142 Furthermore, we can construct a new tree from two trees. Both operations
1143 assume that all values in [l] < all values in [r] and that [l] and [r]
1145 [glue l r] Glues [l] and [r] together. Assumes that [l] and
1146 [r] are already balanced with respect to each other.
1147 [merge l r] Merges two trees and restores balance.
1149 Note: in contrast to Adam's paper, we use (<=) comparisons instead
1150 of (<) comparisons in [join], [merge] and [balance].
1151 Quickcheck (on [difference]) showed that this was necessary in order
1152 to maintain the invariants. It is quite unsatisfactory that I haven't
1153 been able to find out why this is actually the case! Fortunately, it
1154 doesn't hurt to be a bit more conservative.
1155 --------------------------------------------------------------------}
1157 {--------------------------------------------------------------------
1159 --------------------------------------------------------------------}
1160 join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1161 join kx x Tip r = insertMin kx x r
1162 join kx x l Tip = insertMax kx x l
1163 join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1164 | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
1165 | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
1166 | otherwise = bin kx x l r
1169 -- insertMin and insertMax don't perform potentially expensive comparisons.
1170 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1173 Tip -> singleton kx x
1175 -> balance ky y l (insertMax kx x r)
1179 Tip -> singleton kx x
1181 -> balance ky y (insertMin kx x l) r
1183 {--------------------------------------------------------------------
1184 [merge l r]: merges two trees.
1185 --------------------------------------------------------------------}
1186 merge :: Map k a -> Map k a -> Map k a
1189 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1190 | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1191 | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1192 | otherwise = glue l r
1194 {--------------------------------------------------------------------
1195 [glue l r]: glues two trees together.
1196 Assumes that [l] and [r] are already balanced with respect to each other.
1197 --------------------------------------------------------------------}
1198 glue :: Map k a -> Map k a -> Map k a
1202 | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1203 | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
1206 -- | /O(log n)/. Delete and find the minimal element.
1207 deleteFindMin :: Map k a -> ((k,a),Map k a)
1210 Bin _ k x Tip r -> ((k,x),r)
1211 Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1212 Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1214 -- | /O(log n)/. Delete and find the maximal element.
1215 deleteFindMax :: Map k a -> ((k,a),Map k a)
1218 Bin _ k x l Tip -> ((k,x),l)
1219 Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1220 Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1223 {--------------------------------------------------------------------
1224 [balance l x r] balances two trees with value x.
1225 The sizes of the trees should balance after decreasing the
1226 size of one of them. (a rotation).
1228 [delta] is the maximal relative difference between the sizes of
1229 two trees, it corresponds with the [w] in Adams' paper.
1230 [ratio] is the ratio between an outer and inner sibling of the
1231 heavier subtree in an unbalanced setting. It determines
1232 whether a double or single rotation should be performed
1233 to restore balance. It is correspondes with the inverse
1234 of $\alpha$ in Adam's article.
1237 - [delta] should be larger than 4.646 with a [ratio] of 2.
1238 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1240 - A lower [delta] leads to a more 'perfectly' balanced tree.
1241 - A higher [delta] performs less rebalancing.
1243 - Balancing is automatic for random data and a balancing
1244 scheme is only necessary to avoid pathological worst cases.
1245 Almost any choice will do, and in practice, a rather large
1246 [delta] may perform better than smaller one.
1248 Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1249 to decide whether a single or double rotation is needed. Allthough
1250 he actually proves that this ratio is needed to maintain the
1251 invariants, his implementation uses an invalid ratio of [1].
1252 --------------------------------------------------------------------}
1257 balance :: k -> a -> Map k a -> Map k a -> Map k a
1259 | sizeL + sizeR <= 1 = Bin sizeX k x l r
1260 | sizeR >= delta*sizeL = rotateL k x l r
1261 | sizeL >= delta*sizeR = rotateR k x l r
1262 | otherwise = Bin sizeX k x l r
1266 sizeX = sizeL + sizeR + 1
1269 rotateL k x l r@(Bin _ _ _ ly ry)
1270 | size ly < ratio*size ry = singleL k x l r
1271 | otherwise = doubleL k x l r
1273 rotateR k x l@(Bin _ _ _ ly ry) r
1274 | size ry < ratio*size ly = singleR k x l r
1275 | otherwise = doubleR k x l r
1278 singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
1279 singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
1281 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)
1282 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)
1285 {--------------------------------------------------------------------
1286 The bin constructor maintains the size of the tree
1287 --------------------------------------------------------------------}
1288 bin :: k -> a -> Map k a -> Map k a -> Map k a
1290 = Bin (size l + size r + 1) k x l r
1293 {--------------------------------------------------------------------
1294 Eq converts the tree to a list. In a lazy setting, this
1295 actually seems one of the faster methods to compare two trees
1296 and it is certainly the simplest :-)
1297 --------------------------------------------------------------------}
1298 instance (Eq k,Eq a) => Eq (Map k a) where
1299 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1301 {--------------------------------------------------------------------
1303 --------------------------------------------------------------------}
1305 instance (Ord k, Ord v) => Ord (Map k v) where
1306 compare m1 m2 = compare (toAscList m1) (toAscList m2)
1308 {--------------------------------------------------------------------
1310 --------------------------------------------------------------------}
1311 instance Functor (Map k) where
1314 {--------------------------------------------------------------------
1316 --------------------------------------------------------------------}
1317 instance (Ord k, Read k, Read e) => Read (Map k e) where
1318 #ifdef __GLASGOW_HASKELL__
1319 readPrec = parens $ prec 10 $ do
1320 Ident "fromList" <- lexP
1322 return (fromList xs)
1324 readListPrec = readListPrecDefault
1326 readsPrec p = readParen (p > 10) $ \ r -> do
1327 ("fromList",s) <- lex r
1329 return (fromList xs,t)
1332 -- parses a pair of things with the syntax a:=b
1333 readPair :: (Read a, Read b) => ReadS (a,b)
1334 readPair s = do (a, ct1) <- reads s
1335 (":=", ct2) <- lex ct1
1336 (b, ct3) <- reads ct2
1339 {--------------------------------------------------------------------
1341 --------------------------------------------------------------------}
1342 instance (Show k, Show a) => Show (Map k a) where
1343 showsPrec d m = showParen (d > 10) $
1344 showString "fromList " . shows (toList m)
1346 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1350 = showChar '{' . showElem x . showTail xs
1352 showTail [] = showChar '}'
1353 showTail (x:xs) = showString ", " . showElem x . showTail xs
1355 showElem (k,x) = shows k . showString " := " . shows x
1358 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1359 -- in a compressed, hanging format.
1360 showTree :: (Show k,Show a) => Map k a -> String
1362 = showTreeWith showElem True False m
1364 showElem k x = show k ++ ":=" ++ show x
1367 {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
1368 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1369 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1370 @wide@ is 'True', an extra wide version is shown.
1372 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1373 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1380 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1391 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
1403 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
1404 showTreeWith showelem hang wide t
1405 | hang = (showsTreeHang showelem wide [] t) ""
1406 | otherwise = (showsTree showelem wide [] [] t) ""
1408 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1409 showsTree showelem wide lbars rbars t
1411 Tip -> showsBars lbars . showString "|\n"
1413 -> showsBars lbars . showString (showelem kx x) . showString "\n"
1415 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
1416 showWide wide rbars .
1417 showsBars lbars . showString (showelem kx x) . showString "\n" .
1418 showWide wide lbars .
1419 showsTree showelem wide (withEmpty lbars) (withBar lbars) l
1421 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1422 showsTreeHang showelem wide bars t
1424 Tip -> showsBars bars . showString "|\n"
1426 -> showsBars bars . showString (showelem kx x) . showString "\n"
1428 -> showsBars bars . showString (showelem kx x) . showString "\n" .
1429 showWide wide bars .
1430 showsTreeHang showelem wide (withBar bars) l .
1431 showWide wide bars .
1432 showsTreeHang showelem wide (withEmpty bars) r
1436 | wide = showString (concat (reverse bars)) . showString "|\n"
1439 showsBars :: [String] -> ShowS
1443 _ -> showString (concat (reverse (tail bars))) . showString node
1446 withBar bars = "| ":bars
1447 withEmpty bars = " ":bars
1449 {--------------------------------------------------------------------
1451 --------------------------------------------------------------------}
1453 #include "Typeable.h"
1454 INSTANCE_TYPEABLE2(Map,mapTc,"Map")
1456 {--------------------------------------------------------------------
1458 --------------------------------------------------------------------}
1459 -- | /O(n)/. Test if the internal map structure is valid.
1460 valid :: Ord k => Map k a -> Bool
1462 = balanced t && ordered t && validsize t
1465 = bounded (const True) (const True) t
1470 Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1472 -- | Exported only for "Debug.QuickCheck"
1473 balanced :: Map k a -> Bool
1477 Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1478 balanced l && balanced r
1482 = (realsize t == Just (size t))
1487 Bin sz kx x l r -> case (realsize l,realsize r) of
1488 (Just n,Just m) | n+m+1 == sz -> Just sz
1491 {--------------------------------------------------------------------
1493 --------------------------------------------------------------------}
1497 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1501 {--------------------------------------------------------------------
1503 --------------------------------------------------------------------}
1504 testTree xs = fromList [(x,"*") | x <- xs]
1505 test1 = testTree [1..20]
1506 test2 = testTree [30,29..10]
1507 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1509 {--------------------------------------------------------------------
1511 --------------------------------------------------------------------}
1516 { configMaxTest = 500
1517 , configMaxFail = 5000
1518 , configSize = \n -> (div n 2 + 3)
1519 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1523 {--------------------------------------------------------------------
1524 Arbitrary, reasonably balanced trees
1525 --------------------------------------------------------------------}
1526 instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
1527 arbitrary = sized (arbtree 0 maxkey)
1528 where maxkey = 10000
1530 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
1532 | n <= 0 = return Tip
1533 | lo >= hi = return Tip
1534 | otherwise = do{ x <- arbitrary
1535 ; i <- choose (lo,hi)
1536 ; m <- choose (1,30)
1537 ; let (ml,mr) | m==(1::Int)= (1,2)
1541 ; l <- arbtree lo (i-1) (n `div` ml)
1542 ; r <- arbtree (i+1) hi (n `div` mr)
1543 ; return (bin (toEnum i) x l r)
1547 {--------------------------------------------------------------------
1549 --------------------------------------------------------------------}
1550 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
1552 = forAll arbitrary $ \t ->
1553 -- classify (balanced t) "balanced" $
1554 classify (size t == 0) "empty" $
1555 classify (size t > 0 && size t <= 10) "small" $
1556 classify (size t > 10 && size t <= 64) "medium" $
1557 classify (size t > 64) "large" $
1560 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1564 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1570 = forValidUnitTree $ \t -> valid t
1572 {--------------------------------------------------------------------
1573 Single, Insert, Delete
1574 --------------------------------------------------------------------}
1575 prop_Single :: Int -> Int -> Bool
1577 = (insert k x empty == singleton k x)
1579 prop_InsertValid :: Int -> Property
1581 = forValidUnitTree $ \t -> valid (insert k () t)
1583 prop_InsertDelete :: Int -> Map Int () -> Property
1584 prop_InsertDelete k t
1585 = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1587 prop_DeleteValid :: Int -> Property
1589 = forValidUnitTree $ \t ->
1590 valid (delete k (insert k () t))
1592 {--------------------------------------------------------------------
1594 --------------------------------------------------------------------}
1595 prop_Join :: Int -> Property
1597 = forValidUnitTree $ \t ->
1598 let (l,r) = split k t
1599 in valid (join k () l r)
1601 prop_Merge :: Int -> Property
1603 = forValidUnitTree $ \t ->
1604 let (l,r) = split k t
1605 in valid (merge l r)
1608 {--------------------------------------------------------------------
1610 --------------------------------------------------------------------}
1611 prop_UnionValid :: Property
1613 = forValidUnitTree $ \t1 ->
1614 forValidUnitTree $ \t2 ->
1617 prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
1618 prop_UnionInsert k x t
1619 = union (singleton k x) t == insert k x t
1621 prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
1622 prop_UnionAssoc t1 t2 t3
1623 = union t1 (union t2 t3) == union (union t1 t2) t3
1625 prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
1626 prop_UnionComm t1 t2
1627 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1630 = forValidIntTree $ \t1 ->
1631 forValidIntTree $ \t2 ->
1632 valid (unionWithKey (\k x y -> x+y) t1 t2)
1634 prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
1635 prop_UnionWith xs ys
1636 = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
1637 == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
1640 = forValidUnitTree $ \t1 ->
1641 forValidUnitTree $ \t2 ->
1642 valid (difference t1 t2)
1644 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1646 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1647 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1650 = forValidUnitTree $ \t1 ->
1651 forValidUnitTree $ \t2 ->
1652 valid (intersection t1 t2)
1654 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1656 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1657 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1659 {--------------------------------------------------------------------
1661 --------------------------------------------------------------------}
1663 = forAll (choose (5,100)) $ \n ->
1664 let xs = [(x,()) | x <- [0..n::Int]]
1665 in fromAscList xs == fromList xs
1667 prop_List :: [Int] -> Bool
1669 = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])