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' f key value mp@
305 -- will insert the pair (key, value) into @mp@ if key does
306 -- not exist in the map. If the key does exist, the function will
307 -- insert @f new_value old_value@.
308 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
310 = insertWithKey (\k x y -> f x y) k x m
312 -- | /O(log n)/. Insert with a combining function.
313 -- @'insertWithKey' f key value mp@
314 -- will insert the pair (key, value) into @mp@ if key does
315 -- not exist in the map. If the key does exist, the function will
316 -- insert @f key new_value old_value@.
317 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
318 insertWithKey f kx x t
320 Tip -> singleton kx x
322 -> case compare kx ky of
323 LT -> balance ky y (insertWithKey f kx x l) r
324 GT -> balance ky y l (insertWithKey f kx x r)
325 EQ -> Bin sy ky (f ky x y) l r
327 -- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@)
328 -- is a pair where the first element is equal to (@'lookup' k map@)
329 -- and the second element equal to (@'insertWithKey' f k x map@).
330 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
331 insertLookupWithKey f kx x t
333 Tip -> (Nothing, singleton kx x)
335 -> case compare kx ky of
336 LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
337 GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
338 EQ -> (Just y, Bin sy ky (f ky x y) l r)
340 {--------------------------------------------------------------------
342 [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
343 --------------------------------------------------------------------}
344 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
345 -- a member of the map, the original map is returned.
346 delete :: Ord k => k -> Map k a -> Map k a
351 -> case compare k kx of
352 LT -> balance kx x (delete k l) r
353 GT -> balance kx x l (delete k r)
356 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
357 -- a member of the map, the original map is returned.
358 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
360 = adjustWithKey (\k x -> f x) k m
362 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
363 -- a member of the map, the original map is returned.
364 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
366 = updateWithKey (\k x -> Just (f k x)) k m
368 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
369 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
370 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
371 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
373 = updateWithKey (\k x -> f x) k m
375 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
376 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
377 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
378 -- to the new value @y@.
379 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
384 -> case compare k kx of
385 LT -> balance kx x (updateWithKey f k l) r
386 GT -> balance kx x l (updateWithKey f k r)
388 Just x' -> Bin sx kx x' l r
391 -- | /O(log n)/. Lookup and update.
392 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
393 updateLookupWithKey f k t
397 -> case compare k kx of
398 LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
399 GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
401 Just x' -> (Just x',Bin sx kx x' l r)
402 Nothing -> (Just x,glue l r)
404 {--------------------------------------------------------------------
406 --------------------------------------------------------------------}
407 -- | /O(log n)/. Return the /index/ of a key. The index is a number from
408 -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
409 -- the key is not a 'member' of the map.
410 findIndex :: Ord k => k -> Map k a -> Int
412 = case lookupIndex k t of
413 Nothing -> error "Map.findIndex: element is not in the map"
416 -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
417 -- /0/ up to, but not including, the 'size' of the map.
418 lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
419 lookupIndex k t = case lookup 0 t of
420 Nothing -> fail "Data.Map.lookupIndex: Key not found."
423 lookup idx Tip = Nothing
424 lookup idx (Bin _ kx x l r)
425 = case compare k kx of
427 GT -> lookup (idx + size l + 1) r
428 EQ -> Just (idx + size l)
430 -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
431 -- invalid index is used.
432 elemAt :: Int -> Map k a -> (k,a)
433 elemAt i Tip = error "Map.elemAt: index out of range"
434 elemAt i (Bin _ kx x l r)
435 = case compare i sizeL of
437 GT -> elemAt (i-sizeL-1) r
442 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
443 -- invalid index is used.
444 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
445 updateAt f i Tip = error "Map.updateAt: index out of range"
446 updateAt f i (Bin sx kx x l r)
447 = case compare i sizeL of
449 GT -> updateAt f (i-sizeL-1) r
451 Just x' -> Bin sx kx x' l r
456 -- | /O(log n)/. Delete the element at /index/.
457 -- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
458 deleteAt :: Int -> Map k a -> Map k a
460 = updateAt (\k x -> Nothing) i map
463 {--------------------------------------------------------------------
465 --------------------------------------------------------------------}
466 -- | /O(log n)/. The minimal key of the map.
467 findMin :: Map k a -> (k,a)
468 findMin (Bin _ kx x Tip r) = (kx,x)
469 findMin (Bin _ kx x l r) = findMin l
470 findMin Tip = error "Map.findMin: empty tree has no minimal element"
472 -- | /O(log n)/. The maximal key of the map.
473 findMax :: Map k a -> (k,a)
474 findMax (Bin _ kx x l Tip) = (kx,x)
475 findMax (Bin _ kx x l r) = findMax r
476 findMax Tip = error "Map.findMax: empty tree has no maximal element"
478 -- | /O(log n)/. Delete the minimal key.
479 deleteMin :: Map k a -> Map k a
480 deleteMin (Bin _ kx x Tip r) = r
481 deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
484 -- | /O(log n)/. Delete the maximal key.
485 deleteMax :: Map k a -> Map k a
486 deleteMax (Bin _ kx x l Tip) = l
487 deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
490 -- | /O(log n)/. Update the value at the minimal key.
491 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
493 = updateMinWithKey (\k x -> f x) m
495 -- | /O(log n)/. Update the value at the maximal key.
496 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
498 = updateMaxWithKey (\k x -> f x) m
501 -- | /O(log n)/. Update the value at the minimal key.
502 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
505 Bin sx kx x Tip r -> case f kx x of
507 Just x' -> Bin sx kx x' Tip r
508 Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
511 -- | /O(log n)/. Update the value at the maximal key.
512 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
515 Bin sx kx x l Tip -> case f kx x of
517 Just x' -> Bin sx kx x' l Tip
518 Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
522 {--------------------------------------------------------------------
524 --------------------------------------------------------------------}
525 -- | The union of a list of maps:
526 -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
527 unions :: Ord k => [Map k a] -> Map k a
529 = foldlStrict union empty ts
531 -- | The union of a list of maps, with a combining operation:
532 -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
533 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
535 = foldlStrict (unionWith f) empty ts
538 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
539 -- It prefers @t1@ when duplicate keys are encountered,
540 -- i.e. (@'union' == 'unionWith' 'const'@).
541 -- The implementation uses the efficient /hedge-union/ algorithm.
542 -- Hedge-union is more efficient on (bigset `union` smallset)?
543 union :: Ord k => Map k a -> Map k a -> Map k a
547 | size t1 >= size t2 = hedgeUnionL (const LT) (const GT) t1 t2
548 | otherwise = hedgeUnionR (const LT) (const GT) t2 t1
550 -- left-biased hedge union
551 hedgeUnionL cmplo cmphi t1 Tip
553 hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
554 = join kx x (filterGt cmplo l) (filterLt cmphi r)
555 hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
556 = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
557 (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
559 cmpkx k = compare kx k
561 -- right-biased hedge union
562 hedgeUnionR cmplo cmphi t1 Tip
564 hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
565 = join kx x (filterGt cmplo l) (filterLt cmphi r)
566 hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
567 = join kx newx (hedgeUnionR cmplo cmpkx l lt)
568 (hedgeUnionR cmpkx cmphi r gt)
570 cmpkx k = compare kx k
571 lt = trim cmplo cmpkx t2
572 (found,gt) = trimLookupLo kx cmphi t2
577 {--------------------------------------------------------------------
578 Union with a combining function
579 --------------------------------------------------------------------}
580 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
581 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
583 = unionWithKey (\k x y -> f x y) m1 m2
586 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
587 -- Hedge-union is more efficient on (bigset `union` smallset).
588 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
589 unionWithKey f Tip t2 = t2
590 unionWithKey f t1 Tip = t1
592 | size t1 >= size t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
593 | otherwise = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1
595 flipf k x y = f k y x
597 hedgeUnionWithKey f cmplo cmphi t1 Tip
599 hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
600 = join kx x (filterGt cmplo l) (filterLt cmphi r)
601 hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
602 = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
603 (hedgeUnionWithKey f cmpkx cmphi r gt)
605 cmpkx k = compare kx k
606 lt = trim cmplo cmpkx t2
607 (found,gt) = trimLookupLo kx cmphi t2
612 {--------------------------------------------------------------------
614 --------------------------------------------------------------------}
615 -- | /O(n+m)/. Difference of two maps.
616 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
617 difference :: Ord k => Map k a -> Map k b -> Map k a
618 difference Tip t2 = Tip
619 difference t1 Tip = t1
620 difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
622 hedgeDiff cmplo cmphi Tip t
624 hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
625 = join kx x (filterGt cmplo l) (filterLt cmphi r)
626 hedgeDiff cmplo cmphi t (Bin _ kx x l r)
627 = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
628 (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
630 cmpkx k = compare kx k
632 -- | /O(n+m)/. Difference with a combining function.
633 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
634 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
635 differenceWith f m1 m2
636 = differenceWithKey (\k x y -> f x y) m1 m2
638 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
639 -- encountered, the combining function is applied to the key and both values.
640 -- If it returns 'Nothing', the element is discarded (proper set difference). If
641 -- it returns (@'Just' y@), the element is updated with a new value @y@.
642 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
643 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
644 differenceWithKey f Tip t2 = Tip
645 differenceWithKey f t1 Tip = t1
646 differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
648 hedgeDiffWithKey f cmplo cmphi Tip t
650 hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
651 = join kx x (filterGt cmplo l) (filterLt cmphi r)
652 hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
654 Nothing -> merge tl tr
655 Just y -> case f kx y x of
656 Nothing -> merge tl tr
657 Just z -> join kx z tl tr
659 cmpkx k = compare kx k
660 lt = trim cmplo cmpkx t
661 (found,gt) = trimLookupLo kx cmphi t
662 tl = hedgeDiffWithKey f cmplo cmpkx lt l
663 tr = hedgeDiffWithKey f cmpkx cmphi gt r
667 {--------------------------------------------------------------------
669 --------------------------------------------------------------------}
670 -- | /O(n+m)/. Intersection of two maps. The values in the first
671 -- map are returned, i.e. (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
672 intersection :: Ord k => Map k a -> Map k b -> Map k a
674 = intersectionWithKey (\k x y -> x) m1 m2
676 -- | /O(n+m)/. Intersection with a combining function.
677 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
678 intersectionWith f m1 m2
679 = intersectionWithKey (\k x y -> f x y) m1 m2
681 -- | /O(n+m)/. Intersection with a combining function.
682 -- Intersection is more efficient on (bigset `intersection` smallset)
683 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
684 intersectionWithKey f Tip t = Tip
685 intersectionWithKey f t Tip = Tip
686 intersectionWithKey f t1 t2
687 | size t1 >= size t2 = intersectWithKey f t1 t2
688 | otherwise = intersectWithKey flipf t2 t1
690 flipf k x y = f k y x
692 intersectWithKey f Tip t = Tip
693 intersectWithKey f t Tip = Tip
694 intersectWithKey f t (Bin _ kx x l r)
696 Nothing -> merge tl tr
697 Just y -> join kx (f kx y x) tl tr
699 (lt,found,gt) = splitLookup kx t
700 tl = intersectWithKey f lt l
701 tr = intersectWithKey f gt r
705 {--------------------------------------------------------------------
707 --------------------------------------------------------------------}
709 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
710 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
712 = isSubmapOfBy (==) m1 m2
715 The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
716 all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
717 applied to their respective values. For example, the following
718 expressions are all 'True':
720 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
721 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
722 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
724 But the following are all 'False':
726 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
727 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
728 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
730 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
732 = (size t1 <= size t2) && (submap' f t1 t2)
734 submap' f Tip t = True
735 submap' f t Tip = False
736 submap' f (Bin _ kx x l r) t
739 Just y -> f x y && submap' f l lt && submap' f r gt
741 (lt,found,gt) = splitLookup kx t
743 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
744 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
745 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
746 isProperSubmapOf m1 m2
747 = isProperSubmapOfBy (==) m1 m2
749 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
750 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
751 @m1@ and @m2@ are not equal,
752 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
753 applied to their respective values. For example, the following
754 expressions are all 'True':
756 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
757 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
759 But the following are all 'False':
761 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
762 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
763 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
765 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
766 isProperSubmapOfBy f t1 t2
767 = (size t1 < size t2) && (submap' f t1 t2)
769 {--------------------------------------------------------------------
771 --------------------------------------------------------------------}
772 -- | /O(n)/. Filter all values that satisfy the predicate.
773 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
775 = filterWithKey (\k x -> p x) m
777 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
778 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
779 filterWithKey p Tip = Tip
780 filterWithKey p (Bin _ kx x l r)
781 | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
782 | otherwise = merge (filterWithKey p l) (filterWithKey p r)
785 -- | /O(n)/. partition the map according to a predicate. The first
786 -- map contains all elements that satisfy the predicate, the second all
787 -- elements that fail the predicate. See also 'split'.
788 partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
790 = partitionWithKey (\k x -> p x) m
792 -- | /O(n)/. partition the map according to a predicate. The first
793 -- map contains all elements that satisfy the predicate, the second all
794 -- elements that fail the predicate. See also 'split'.
795 partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
796 partitionWithKey p Tip = (Tip,Tip)
797 partitionWithKey p (Bin _ kx x l r)
798 | p kx x = (join kx x l1 r1,merge l2 r2)
799 | otherwise = (merge l1 r1,join kx x l2 r2)
801 (l1,l2) = partitionWithKey p l
802 (r1,r2) = partitionWithKey p r
805 {--------------------------------------------------------------------
807 --------------------------------------------------------------------}
808 -- | /O(n)/. Map a function over all values in the map.
809 map :: (a -> b) -> Map k a -> Map k b
811 = mapWithKey (\k x -> f x) m
813 -- | /O(n)/. Map a function over all values in the map.
814 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
815 mapWithKey f Tip = Tip
816 mapWithKey f (Bin sx kx x l r)
817 = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
819 -- | /O(n)/. The function 'mapAccum' threads an accumulating
820 -- argument through the map in ascending order of keys.
821 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
823 = mapAccumWithKey (\a k x -> f a x) a m
825 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
826 -- argument through the map in ascending order of keys.
827 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
828 mapAccumWithKey f a t
831 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
832 -- argument throught the map in ascending order of keys.
833 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
838 -> let (a1,l') = mapAccumL f a l
840 (a3,r') = mapAccumL f a2 r
841 in (a3,Bin sx kx x' l' r')
843 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
844 -- argument throught the map in descending order of keys.
845 mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
850 -> let (a1,r') = mapAccumR f a r
852 (a3,l') = mapAccumR f a2 l
853 in (a3,Bin sx kx x' l' r')
856 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
858 -- The size of the result may be smaller if @f@ maps two or more distinct
859 -- keys to the same new key. In this case the value at the smallest of
860 -- these keys is retained.
862 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
863 mapKeys = mapKeysWith (\x y->x)
866 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
868 -- The size of the result may be smaller if @f@ maps two or more distinct
869 -- keys to the same new key. In this case the associated values will be
870 -- combined using @c@.
872 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
873 mapKeysWith c f = fromListWith c . List.map fFirst . toList
874 where fFirst (x,y) = (f x, y)
878 -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
879 -- is strictly monotonic.
880 -- /The precondition is not checked./
881 -- Semi-formally, we have:
883 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
884 -- > ==> mapKeysMonotonic f s == mapKeys f s
885 -- > where ls = keys s
887 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
888 mapKeysMonotonic f Tip = Tip
889 mapKeysMonotonic f (Bin sz k x l r) =
890 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
892 {--------------------------------------------------------------------
894 --------------------------------------------------------------------}
896 -- | /O(n)/. Fold the values in the map, such that
897 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
900 -- > elems map = fold (:) [] map
902 fold :: (a -> b -> b) -> b -> Map k a -> b
904 = foldWithKey (\k x z -> f x z) z m
906 -- | /O(n)/. Fold the keys and values in the map, such that
907 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
910 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
912 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
916 -- | /O(n)/. In-order fold.
917 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
919 foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
921 -- | /O(n)/. Post-order fold.
922 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
924 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
926 -- | /O(n)/. Pre-order fold.
927 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
929 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
931 {--------------------------------------------------------------------
933 --------------------------------------------------------------------}
935 -- Return all elements of the map in the ascending order of their keys.
936 elems :: Map k a -> [a]
938 = [x | (k,x) <- assocs m]
940 -- | /O(n)/. Return all keys of the map in ascending order.
941 keys :: Map k a -> [k]
943 = [k | (k,x) <- assocs m]
945 -- | /O(n)/. The set of all keys of the map.
946 keysSet :: Map k a -> Set.Set k
947 keysSet m = Set.fromDistinctAscList (keys m)
949 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
950 assocs :: Map k a -> [(k,a)]
954 {--------------------------------------------------------------------
956 use [foldlStrict] to reduce demand on the control-stack
957 --------------------------------------------------------------------}
958 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
959 fromList :: Ord k => [(k,a)] -> Map k a
961 = foldlStrict ins empty xs
963 ins t (k,x) = insert k x t
965 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
966 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
968 = fromListWithKey (\k x y -> f x y) xs
970 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
971 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
973 = foldlStrict ins empty xs
975 ins t (k,x) = insertWithKey f k x t
977 -- | /O(n)/. Convert to a list of key\/value pairs.
978 toList :: Map k a -> [(k,a)]
979 toList t = toAscList t
981 -- | /O(n)/. Convert to an ascending list.
982 toAscList :: Map k a -> [(k,a)]
983 toAscList t = foldr (\k x xs -> (k,x):xs) [] t
986 toDescList :: Map k a -> [(k,a)]
987 toDescList t = foldl (\xs k x -> (k,x):xs) [] t
990 {--------------------------------------------------------------------
991 Building trees from ascending/descending lists can be done in linear time.
993 Note that if [xs] is ascending that:
994 fromAscList xs == fromList xs
995 fromAscListWith f xs == fromListWith f xs
996 --------------------------------------------------------------------}
997 -- | /O(n)/. Build a map from an ascending list in linear time.
998 -- /The precondition (input list is ascending) is not checked./
999 fromAscList :: Eq k => [(k,a)] -> Map k a
1001 = fromAscListWithKey (\k x y -> x) xs
1003 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
1004 -- /The precondition (input list is ascending) is not checked./
1005 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
1006 fromAscListWith f xs
1007 = fromAscListWithKey (\k x y -> f x y) xs
1009 -- | /O(n)/. Build a map from an ascending list in linear time with a
1010 -- combining function for equal keys.
1011 -- /The precondition (input list is ascending) is not checked./
1012 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1013 fromAscListWithKey f xs
1014 = fromDistinctAscList (combineEq f xs)
1016 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1021 (x:xx) -> combineEq' x xx
1023 combineEq' z [] = [z]
1024 combineEq' z@(kz,zz) (x@(kx,xx):xs)
1025 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
1026 | otherwise = z:combineEq' x xs
1029 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
1030 -- /The precondition is not checked./
1031 fromDistinctAscList :: [(k,a)] -> Map k a
1032 fromDistinctAscList xs
1033 = build const (length xs) xs
1035 -- 1) use continutations so that we use heap space instead of stack space.
1036 -- 2) special case for n==5 to build bushier trees.
1037 build c 0 xs = c Tip xs
1038 build c 5 xs = case xs of
1039 ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
1040 -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
1041 build c n xs = seq nr $ build (buildR nr c) nl xs
1046 buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
1047 buildB l k x c r zs = c (bin k x l r) zs
1051 {--------------------------------------------------------------------
1052 Utility functions that return sub-ranges of the original
1053 tree. Some functions take a comparison function as argument to
1054 allow comparisons against infinite values. A function [cmplo k]
1055 should be read as [compare lo k].
1057 [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
1058 and [cmphi k == GT] for the key [k] of the root.
1059 [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
1060 [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
1062 [split k t] Returns two trees [l] and [r] where all keys
1063 in [l] are <[k] and all keys in [r] are >[k].
1064 [splitLookup k t] Just like [split] but also returns whether [k]
1065 was found in the tree.
1066 --------------------------------------------------------------------}
1068 {--------------------------------------------------------------------
1069 [trim lo hi t] trims away all subtrees that surely contain no
1070 values between the range [lo] to [hi]. The returned tree is either
1071 empty or the key of the root is between @lo@ and @hi@.
1072 --------------------------------------------------------------------}
1073 trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1074 trim cmplo cmphi Tip = Tip
1075 trim cmplo cmphi t@(Bin sx kx x l r)
1077 LT -> case cmphi kx of
1079 le -> trim cmplo cmphi l
1080 ge -> trim cmplo cmphi r
1082 trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a)
1083 trimLookupLo lo cmphi Tip = (Nothing,Tip)
1084 trimLookupLo lo cmphi t@(Bin sx kx x l r)
1085 = case compare lo kx of
1086 LT -> case cmphi kx of
1087 GT -> (lookup lo t, t)
1088 le -> trimLookupLo lo cmphi l
1089 GT -> trimLookupLo lo cmphi r
1090 EQ -> (Just x,trim (compare lo) cmphi r)
1093 {--------------------------------------------------------------------
1094 [filterGt k t] filter all keys >[k] from tree [t]
1095 [filterLt k t] filter all keys <[k] from tree [t]
1096 --------------------------------------------------------------------}
1097 filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1098 filterGt cmp Tip = Tip
1099 filterGt cmp (Bin sx kx x l r)
1101 LT -> join kx x (filterGt cmp l) r
1102 GT -> filterGt cmp r
1105 filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1106 filterLt cmp Tip = Tip
1107 filterLt cmp (Bin sx kx x l r)
1109 LT -> filterLt cmp l
1110 GT -> join kx x l (filterLt cmp r)
1113 {--------------------------------------------------------------------
1115 --------------------------------------------------------------------}
1116 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
1117 -- 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@.
1118 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1119 split k Tip = (Tip,Tip)
1120 split k (Bin sx kx x l r)
1121 = case compare k kx of
1122 LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1123 GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1126 -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
1127 -- like 'split' but also returns @'lookup' k map@.
1128 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
1129 splitLookup k Tip = (Tip,Nothing,Tip)
1130 splitLookup k (Bin sx kx x l r)
1131 = case compare k kx of
1132 LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
1133 GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
1136 {--------------------------------------------------------------------
1137 Utility functions that maintain the balance properties of the tree.
1138 All constructors assume that all values in [l] < [k] and all values
1139 in [r] > [k], and that [l] and [r] are valid trees.
1141 In order of sophistication:
1142 [Bin sz k x l r] The type constructor.
1143 [bin k x l r] Maintains the correct size, assumes that both [l]
1144 and [r] are balanced with respect to each other.
1145 [balance k x l r] Restores the balance and size.
1146 Assumes that the original tree was balanced and
1147 that [l] or [r] has changed by at most one element.
1148 [join k x l r] Restores balance and size.
1150 Furthermore, we can construct a new tree from two trees. Both operations
1151 assume that all values in [l] < all values in [r] and that [l] and [r]
1153 [glue l r] Glues [l] and [r] together. Assumes that [l] and
1154 [r] are already balanced with respect to each other.
1155 [merge l r] Merges two trees and restores balance.
1157 Note: in contrast to Adam's paper, we use (<=) comparisons instead
1158 of (<) comparisons in [join], [merge] and [balance].
1159 Quickcheck (on [difference]) showed that this was necessary in order
1160 to maintain the invariants. It is quite unsatisfactory that I haven't
1161 been able to find out why this is actually the case! Fortunately, it
1162 doesn't hurt to be a bit more conservative.
1163 --------------------------------------------------------------------}
1165 {--------------------------------------------------------------------
1167 --------------------------------------------------------------------}
1168 join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1169 join kx x Tip r = insertMin kx x r
1170 join kx x l Tip = insertMax kx x l
1171 join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1172 | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
1173 | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
1174 | otherwise = bin kx x l r
1177 -- insertMin and insertMax don't perform potentially expensive comparisons.
1178 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1181 Tip -> singleton kx x
1183 -> balance ky y l (insertMax kx x r)
1187 Tip -> singleton kx x
1189 -> balance ky y (insertMin kx x l) r
1191 {--------------------------------------------------------------------
1192 [merge l r]: merges two trees.
1193 --------------------------------------------------------------------}
1194 merge :: Map k a -> Map k a -> Map k a
1197 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1198 | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1199 | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1200 | otherwise = glue l r
1202 {--------------------------------------------------------------------
1203 [glue l r]: glues two trees together.
1204 Assumes that [l] and [r] are already balanced with respect to each other.
1205 --------------------------------------------------------------------}
1206 glue :: Map k a -> Map k a -> Map k a
1210 | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1211 | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
1214 -- | /O(log n)/. Delete and find the minimal element.
1215 deleteFindMin :: Map k a -> ((k,a),Map k a)
1218 Bin _ k x Tip r -> ((k,x),r)
1219 Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1220 Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1222 -- | /O(log n)/. Delete and find the maximal element.
1223 deleteFindMax :: Map k a -> ((k,a),Map k a)
1226 Bin _ k x l Tip -> ((k,x),l)
1227 Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1228 Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1231 {--------------------------------------------------------------------
1232 [balance l x r] balances two trees with value x.
1233 The sizes of the trees should balance after decreasing the
1234 size of one of them. (a rotation).
1236 [delta] is the maximal relative difference between the sizes of
1237 two trees, it corresponds with the [w] in Adams' paper.
1238 [ratio] is the ratio between an outer and inner sibling of the
1239 heavier subtree in an unbalanced setting. It determines
1240 whether a double or single rotation should be performed
1241 to restore balance. It is correspondes with the inverse
1242 of $\alpha$ in Adam's article.
1245 - [delta] should be larger than 4.646 with a [ratio] of 2.
1246 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1248 - A lower [delta] leads to a more 'perfectly' balanced tree.
1249 - A higher [delta] performs less rebalancing.
1251 - Balancing is automatic for random data and a balancing
1252 scheme is only necessary to avoid pathological worst cases.
1253 Almost any choice will do, and in practice, a rather large
1254 [delta] may perform better than smaller one.
1256 Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1257 to decide whether a single or double rotation is needed. Allthough
1258 he actually proves that this ratio is needed to maintain the
1259 invariants, his implementation uses an invalid ratio of [1].
1260 --------------------------------------------------------------------}
1265 balance :: k -> a -> Map k a -> Map k a -> Map k a
1267 | sizeL + sizeR <= 1 = Bin sizeX k x l r
1268 | sizeR >= delta*sizeL = rotateL k x l r
1269 | sizeL >= delta*sizeR = rotateR k x l r
1270 | otherwise = Bin sizeX k x l r
1274 sizeX = sizeL + sizeR + 1
1277 rotateL k x l r@(Bin _ _ _ ly ry)
1278 | size ly < ratio*size ry = singleL k x l r
1279 | otherwise = doubleL k x l r
1281 rotateR k x l@(Bin _ _ _ ly ry) r
1282 | size ry < ratio*size ly = singleR k x l r
1283 | otherwise = doubleR k x l r
1286 singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
1287 singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
1289 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)
1290 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)
1293 {--------------------------------------------------------------------
1294 The bin constructor maintains the size of the tree
1295 --------------------------------------------------------------------}
1296 bin :: k -> a -> Map k a -> Map k a -> Map k a
1298 = Bin (size l + size r + 1) k x l r
1301 {--------------------------------------------------------------------
1302 Eq converts the tree to a list. In a lazy setting, this
1303 actually seems one of the faster methods to compare two trees
1304 and it is certainly the simplest :-)
1305 --------------------------------------------------------------------}
1306 instance (Eq k,Eq a) => Eq (Map k a) where
1307 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1309 {--------------------------------------------------------------------
1311 --------------------------------------------------------------------}
1313 instance (Ord k, Ord v) => Ord (Map k v) where
1314 compare m1 m2 = compare (toAscList m1) (toAscList m2)
1316 {--------------------------------------------------------------------
1318 --------------------------------------------------------------------}
1319 instance Functor (Map k) where
1322 {--------------------------------------------------------------------
1324 --------------------------------------------------------------------}
1325 instance (Ord k, Read k, Read e) => Read (Map k e) where
1326 #ifdef __GLASGOW_HASKELL__
1327 readPrec = parens $ prec 10 $ do
1328 Ident "fromList" <- lexP
1330 return (fromList xs)
1332 readListPrec = readListPrecDefault
1334 readsPrec p = readParen (p > 10) $ \ r -> do
1335 ("fromList",s) <- lex r
1337 return (fromList xs,t)
1340 -- parses a pair of things with the syntax a:=b
1341 readPair :: (Read a, Read b) => ReadS (a,b)
1342 readPair s = do (a, ct1) <- reads s
1343 (":=", ct2) <- lex ct1
1344 (b, ct3) <- reads ct2
1347 {--------------------------------------------------------------------
1349 --------------------------------------------------------------------}
1350 instance (Show k, Show a) => Show (Map k a) where
1351 showsPrec d m = showParen (d > 10) $
1352 showString "fromList " . shows (toList m)
1354 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1358 = showChar '{' . showElem x . showTail xs
1360 showTail [] = showChar '}'
1361 showTail (x:xs) = showString ", " . showElem x . showTail xs
1363 showElem (k,x) = shows k . showString " := " . shows x
1366 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1367 -- in a compressed, hanging format.
1368 showTree :: (Show k,Show a) => Map k a -> String
1370 = showTreeWith showElem True False m
1372 showElem k x = show k ++ ":=" ++ show x
1375 {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
1376 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1377 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1378 @wide@ is 'True', an extra wide version is shown.
1380 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1381 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1388 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1399 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
1411 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
1412 showTreeWith showelem hang wide t
1413 | hang = (showsTreeHang showelem wide [] t) ""
1414 | otherwise = (showsTree showelem wide [] [] t) ""
1416 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1417 showsTree showelem wide lbars rbars t
1419 Tip -> showsBars lbars . showString "|\n"
1421 -> showsBars lbars . showString (showelem kx x) . showString "\n"
1423 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
1424 showWide wide rbars .
1425 showsBars lbars . showString (showelem kx x) . showString "\n" .
1426 showWide wide lbars .
1427 showsTree showelem wide (withEmpty lbars) (withBar lbars) l
1429 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1430 showsTreeHang showelem wide bars t
1432 Tip -> showsBars bars . showString "|\n"
1434 -> showsBars bars . showString (showelem kx x) . showString "\n"
1436 -> showsBars bars . showString (showelem kx x) . showString "\n" .
1437 showWide wide bars .
1438 showsTreeHang showelem wide (withBar bars) l .
1439 showWide wide bars .
1440 showsTreeHang showelem wide (withEmpty bars) r
1444 | wide = showString (concat (reverse bars)) . showString "|\n"
1447 showsBars :: [String] -> ShowS
1451 _ -> showString (concat (reverse (tail bars))) . showString node
1454 withBar bars = "| ":bars
1455 withEmpty bars = " ":bars
1457 {--------------------------------------------------------------------
1459 --------------------------------------------------------------------}
1461 #include "Typeable.h"
1462 INSTANCE_TYPEABLE2(Map,mapTc,"Map")
1464 {--------------------------------------------------------------------
1466 --------------------------------------------------------------------}
1467 -- | /O(n)/. Test if the internal map structure is valid.
1468 valid :: Ord k => Map k a -> Bool
1470 = balanced t && ordered t && validsize t
1473 = bounded (const True) (const True) t
1478 Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1480 -- | Exported only for "Debug.QuickCheck"
1481 balanced :: Map k a -> Bool
1485 Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1486 balanced l && balanced r
1490 = (realsize t == Just (size t))
1495 Bin sz kx x l r -> case (realsize l,realsize r) of
1496 (Just n,Just m) | n+m+1 == sz -> Just sz
1499 {--------------------------------------------------------------------
1501 --------------------------------------------------------------------}
1505 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1509 {--------------------------------------------------------------------
1511 --------------------------------------------------------------------}
1512 testTree xs = fromList [(x,"*") | x <- xs]
1513 test1 = testTree [1..20]
1514 test2 = testTree [30,29..10]
1515 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1517 {--------------------------------------------------------------------
1519 --------------------------------------------------------------------}
1524 { configMaxTest = 500
1525 , configMaxFail = 5000
1526 , configSize = \n -> (div n 2 + 3)
1527 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1531 {--------------------------------------------------------------------
1532 Arbitrary, reasonably balanced trees
1533 --------------------------------------------------------------------}
1534 instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
1535 arbitrary = sized (arbtree 0 maxkey)
1536 where maxkey = 10000
1538 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
1540 | n <= 0 = return Tip
1541 | lo >= hi = return Tip
1542 | otherwise = do{ x <- arbitrary
1543 ; i <- choose (lo,hi)
1544 ; m <- choose (1,30)
1545 ; let (ml,mr) | m==(1::Int)= (1,2)
1549 ; l <- arbtree lo (i-1) (n `div` ml)
1550 ; r <- arbtree (i+1) hi (n `div` mr)
1551 ; return (bin (toEnum i) x l r)
1555 {--------------------------------------------------------------------
1557 --------------------------------------------------------------------}
1558 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
1560 = forAll arbitrary $ \t ->
1561 -- classify (balanced t) "balanced" $
1562 classify (size t == 0) "empty" $
1563 classify (size t > 0 && size t <= 10) "small" $
1564 classify (size t > 10 && size t <= 64) "medium" $
1565 classify (size t > 64) "large" $
1568 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1572 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1578 = forValidUnitTree $ \t -> valid t
1580 {--------------------------------------------------------------------
1581 Single, Insert, Delete
1582 --------------------------------------------------------------------}
1583 prop_Single :: Int -> Int -> Bool
1585 = (insert k x empty == singleton k x)
1587 prop_InsertValid :: Int -> Property
1589 = forValidUnitTree $ \t -> valid (insert k () t)
1591 prop_InsertDelete :: Int -> Map Int () -> Property
1592 prop_InsertDelete k t
1593 = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1595 prop_DeleteValid :: Int -> Property
1597 = forValidUnitTree $ \t ->
1598 valid (delete k (insert k () t))
1600 {--------------------------------------------------------------------
1602 --------------------------------------------------------------------}
1603 prop_Join :: Int -> Property
1605 = forValidUnitTree $ \t ->
1606 let (l,r) = split k t
1607 in valid (join k () l r)
1609 prop_Merge :: Int -> Property
1611 = forValidUnitTree $ \t ->
1612 let (l,r) = split k t
1613 in valid (merge l r)
1616 {--------------------------------------------------------------------
1618 --------------------------------------------------------------------}
1619 prop_UnionValid :: Property
1621 = forValidUnitTree $ \t1 ->
1622 forValidUnitTree $ \t2 ->
1625 prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
1626 prop_UnionInsert k x t
1627 = union (singleton k x) t == insert k x t
1629 prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
1630 prop_UnionAssoc t1 t2 t3
1631 = union t1 (union t2 t3) == union (union t1 t2) t3
1633 prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
1634 prop_UnionComm t1 t2
1635 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1638 = forValidIntTree $ \t1 ->
1639 forValidIntTree $ \t2 ->
1640 valid (unionWithKey (\k x y -> x+y) t1 t2)
1642 prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
1643 prop_UnionWith xs ys
1644 = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
1645 == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
1648 = forValidUnitTree $ \t1 ->
1649 forValidUnitTree $ \t2 ->
1650 valid (difference t1 t2)
1652 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1654 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1655 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1658 = forValidUnitTree $ \t1 ->
1659 forValidUnitTree $ \t2 ->
1660 valid (intersection t1 t2)
1662 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1664 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1665 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1667 {--------------------------------------------------------------------
1669 --------------------------------------------------------------------}
1671 = forAll (choose (5,100)) $ \n ->
1672 let xs = [(x,()) | x <- [0..n::Int]]
1673 in fromAscList xs == fromList xs
1675 prop_List :: [Int] -> Bool
1677 = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])