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
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
157 import qualified Prelude
158 import qualified List
159 import Debug.QuickCheck
160 import List(nub,sort)
163 #if __GLASGOW_HASKELL__
164 import Data.Generics.Basics
165 import Data.Generics.Instances
168 {--------------------------------------------------------------------
170 --------------------------------------------------------------------}
173 -- | /O(log n)/. Find the value at a key.
174 -- Calls 'error' when the element can not be found.
175 (!) :: Ord k => Map k a -> k -> a
178 -- | /O(n+m)/. See 'difference'.
179 (\\) :: Ord k => Map k a -> Map k b -> Map k a
180 m1 \\ m2 = difference m1 m2
182 {--------------------------------------------------------------------
184 --------------------------------------------------------------------}
185 -- | A Map from keys @k@ to values @a@.
187 | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
191 #if __GLASGOW_HASKELL__
193 {--------------------------------------------------------------------
195 --------------------------------------------------------------------}
197 -- This instance preserves data abstraction at the cost of inefficiency.
198 -- We omit reflection services for the sake of data abstraction.
200 instance (Data k, Data a, Ord k) => Data (Map k a) where
201 gfoldl f z map = z fromList `f` (toList map)
202 toConstr _ = error "toConstr"
203 gunfold _ _ = error "gunfold"
204 dataTypeOf _ = mkNorepType "Data.Map.Map"
208 {--------------------------------------------------------------------
210 --------------------------------------------------------------------}
211 -- | /O(1)/. Is the map empty?
212 null :: Map k a -> Bool
216 Bin sz k x l r -> False
218 -- | /O(1)/. The number of elements in the map.
219 size :: Map k a -> Int
226 -- | /O(log n)/. Lookup the value at a key in the map.
227 lookup :: (Monad m,Ord k) => k -> Map k a -> m a
228 lookup k t = case lookup' k t of
230 Nothing -> fail "Data.Map.lookup: Key not found"
231 lookup' :: Ord k => k -> Map k a -> Maybe a
236 -> case compare k kx of
241 -- | /O(log n)/. Is the key a member of the map?
242 member :: Ord k => k -> Map k a -> Bool
248 -- | /O(log n)/. Find the value at a key.
249 -- Calls 'error' when the element can not be found.
250 find :: Ord k => k -> Map k a -> a
253 Nothing -> error "Map.find: element not in the map"
256 -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
257 -- the value at key @k@ or returns @def@ when the key is not in the map.
258 findWithDefault :: Ord k => a -> k -> Map k a -> a
259 findWithDefault def k m
266 {--------------------------------------------------------------------
268 --------------------------------------------------------------------}
269 -- | /O(1)/. The empty map.
274 -- | /O(1)/. A map with a single element.
275 singleton :: k -> a -> Map k a
279 {--------------------------------------------------------------------
281 [insert] is the inlined version of [insertWith (\k x y -> x)]
282 --------------------------------------------------------------------}
283 -- | /O(log n)/. Insert a new key and value in the map.
284 insert :: Ord k => k -> a -> Map k a -> Map k a
287 Tip -> singleton kx x
289 -> case compare kx ky of
290 LT -> balance ky y (insert kx x l) r
291 GT -> balance ky y l (insert kx x r)
292 EQ -> Bin sz kx x l r
294 -- | /O(log n)/. Insert with a combining function.
295 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
297 = insertWithKey (\k x y -> f x y) k x m
299 -- | /O(log n)/. Insert with a combining function.
300 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
301 insertWithKey f kx x t
303 Tip -> singleton kx x
305 -> case compare kx ky of
306 LT -> balance ky y (insertWithKey f kx x l) r
307 GT -> balance ky y l (insertWithKey f kx x r)
308 EQ -> Bin sy ky (f ky x y) l r
310 -- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@)
311 -- is a pair where the first element is equal to (@'lookup' k map@)
312 -- and the second element equal to (@'insertWithKey' f k x map@).
313 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
314 insertLookupWithKey f kx x t
316 Tip -> (Nothing, singleton kx x)
318 -> case compare kx ky of
319 LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
320 GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
321 EQ -> (Just y, Bin sy ky (f ky x y) l r)
323 {--------------------------------------------------------------------
325 [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
326 --------------------------------------------------------------------}
327 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
328 -- a member of the map, the original map is returned.
329 delete :: Ord k => k -> Map k a -> Map k a
334 -> case compare k kx of
335 LT -> balance kx x (delete k l) r
336 GT -> balance kx x l (delete k r)
339 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
340 -- a member of the map, the original map is returned.
341 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
343 = adjustWithKey (\k x -> f x) k m
345 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
346 -- a member of the map, the original map is returned.
347 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
349 = updateWithKey (\k x -> Just (f k x)) k m
351 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
352 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
353 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
354 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
356 = updateWithKey (\k x -> f x) k m
358 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
359 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
360 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
361 -- to the new value @y@.
362 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
367 -> case compare k kx of
368 LT -> balance kx x (updateWithKey f k l) r
369 GT -> balance kx x l (updateWithKey f k r)
371 Just x' -> Bin sx kx x' l r
374 -- | /O(log n)/. Lookup and update.
375 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
376 updateLookupWithKey f k t
380 -> case compare k kx of
381 LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
382 GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
384 Just x' -> (Just x',Bin sx kx x' l r)
385 Nothing -> (Just x,glue l r)
387 {--------------------------------------------------------------------
389 --------------------------------------------------------------------}
390 -- | /O(log n)/. Return the /index/ of a key. The index is a number from
391 -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
392 -- the key is not a 'member' of the map.
393 findIndex :: Ord k => k -> Map k a -> Int
395 = case lookupIndex k t of
396 Nothing -> error "Map.findIndex: element is not in the map"
399 -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
400 -- /0/ up to, but not including, the 'size' of the map.
401 lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
402 lookupIndex k t = case lookup 0 t of
403 Nothing -> fail "Data.Map.lookupIndex: Key not found."
406 lookup idx Tip = Nothing
407 lookup idx (Bin _ kx x l r)
408 = case compare k kx of
410 GT -> lookup (idx + size l + 1) r
411 EQ -> Just (idx + size l)
413 -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
414 -- invalid index is used.
415 elemAt :: Int -> Map k a -> (k,a)
416 elemAt i Tip = error "Map.elemAt: index out of range"
417 elemAt i (Bin _ kx x l r)
418 = case compare i sizeL of
420 GT -> elemAt (i-sizeL-1) r
425 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
426 -- invalid index is used.
427 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
428 updateAt f i Tip = error "Map.updateAt: index out of range"
429 updateAt f i (Bin sx kx x l r)
430 = case compare i sizeL of
432 GT -> updateAt f (i-sizeL-1) r
434 Just x' -> Bin sx kx x' l r
439 -- | /O(log n)/. Delete the element at /index/.
440 -- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
441 deleteAt :: Int -> Map k a -> Map k a
443 = updateAt (\k x -> Nothing) i map
446 {--------------------------------------------------------------------
448 --------------------------------------------------------------------}
449 -- | /O(log n)/. The minimal key of the map.
450 findMin :: Map k a -> (k,a)
451 findMin (Bin _ kx x Tip r) = (kx,x)
452 findMin (Bin _ kx x l r) = findMin l
453 findMin Tip = error "Map.findMin: empty tree has no minimal element"
455 -- | /O(log n)/. The maximal key of the map.
456 findMax :: Map k a -> (k,a)
457 findMax (Bin _ kx x l Tip) = (kx,x)
458 findMax (Bin _ kx x l r) = findMax r
459 findMax Tip = error "Map.findMax: empty tree has no maximal element"
461 -- | /O(log n)/. Delete the minimal key.
462 deleteMin :: Map k a -> Map k a
463 deleteMin (Bin _ kx x Tip r) = r
464 deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
467 -- | /O(log n)/. Delete the maximal key.
468 deleteMax :: Map k a -> Map k a
469 deleteMax (Bin _ kx x l Tip) = l
470 deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
473 -- | /O(log n)/. Update the value at the minimal key.
474 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
476 = updateMinWithKey (\k x -> f x) m
478 -- | /O(log n)/. Update the value at the maximal key.
479 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
481 = updateMaxWithKey (\k x -> f x) m
484 -- | /O(log n)/. Update the value at the minimal key.
485 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
488 Bin sx kx x Tip r -> case f kx x of
490 Just x' -> Bin sx kx x' Tip r
491 Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
494 -- | /O(log n)/. Update the value at the maximal key.
495 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
498 Bin sx kx x l Tip -> case f kx x of
500 Just x' -> Bin sx kx x' l Tip
501 Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
505 {--------------------------------------------------------------------
507 --------------------------------------------------------------------}
508 -- | The union of a list of maps:
509 -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
510 unions :: Ord k => [Map k a] -> Map k a
512 = foldlStrict union empty ts
514 -- | The union of a list of maps, with a combining operation:
515 -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
516 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
518 = foldlStrict (unionWith f) empty ts
521 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
522 -- It prefers @t1@ when duplicate keys are encountered,
523 -- i.e. (@'union' == 'unionWith' 'const'@).
524 -- The implementation uses the efficient /hedge-union/ algorithm.
525 -- Hedge-union is more efficient on (bigset `union` smallset)?
526 union :: Ord k => Map k a -> Map k a -> Map k a
530 | size t1 >= size t2 = hedgeUnionL (const LT) (const GT) t1 t2
531 | otherwise = hedgeUnionR (const LT) (const GT) t2 t1
533 -- left-biased hedge union
534 hedgeUnionL cmplo cmphi t1 Tip
536 hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
537 = join kx x (filterGt cmplo l) (filterLt cmphi r)
538 hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
539 = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
540 (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
542 cmpkx k = compare kx k
544 -- right-biased hedge union
545 hedgeUnionR cmplo cmphi t1 Tip
547 hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
548 = join kx x (filterGt cmplo l) (filterLt cmphi r)
549 hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
550 = join kx newx (hedgeUnionR cmplo cmpkx l lt)
551 (hedgeUnionR cmpkx cmphi r gt)
553 cmpkx k = compare kx k
554 lt = trim cmplo cmpkx t2
555 (found,gt) = trimLookupLo kx cmphi t2
560 {--------------------------------------------------------------------
561 Union with a combining function
562 --------------------------------------------------------------------}
563 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
564 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
566 = unionWithKey (\k x y -> f x y) m1 m2
569 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
570 -- Hedge-union is more efficient on (bigset `union` smallset).
571 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
572 unionWithKey f Tip t2 = t2
573 unionWithKey f t1 Tip = t1
575 | size t1 >= size t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
576 | otherwise = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1
578 flipf k x y = f k y x
580 hedgeUnionWithKey f cmplo cmphi t1 Tip
582 hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
583 = join kx x (filterGt cmplo l) (filterLt cmphi r)
584 hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
585 = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
586 (hedgeUnionWithKey f cmpkx cmphi r gt)
588 cmpkx k = compare kx k
589 lt = trim cmplo cmpkx t2
590 (found,gt) = trimLookupLo kx cmphi t2
595 {--------------------------------------------------------------------
597 --------------------------------------------------------------------}
598 -- | /O(n+m)/. Difference of two maps.
599 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
600 difference :: Ord k => Map k a -> Map k b -> Map k a
601 difference Tip t2 = Tip
602 difference t1 Tip = t1
603 difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
605 hedgeDiff cmplo cmphi Tip t
607 hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
608 = join kx x (filterGt cmplo l) (filterLt cmphi r)
609 hedgeDiff cmplo cmphi t (Bin _ kx x l r)
610 = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
611 (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
613 cmpkx k = compare kx k
615 -- | /O(n+m)/. Difference with a combining function.
616 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
617 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
618 differenceWith f m1 m2
619 = differenceWithKey (\k x y -> f x y) m1 m2
621 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
622 -- encountered, the combining function is applied to the key and both values.
623 -- If it returns 'Nothing', the element is discarded (proper set difference). If
624 -- it returns (@'Just' y@), the element is updated with a new value @y@.
625 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
626 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
627 differenceWithKey f Tip t2 = Tip
628 differenceWithKey f t1 Tip = t1
629 differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
631 hedgeDiffWithKey f cmplo cmphi Tip t
633 hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
634 = join kx x (filterGt cmplo l) (filterLt cmphi r)
635 hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
637 Nothing -> merge tl tr
638 Just y -> case f kx y x of
639 Nothing -> merge tl tr
640 Just z -> join kx z tl tr
642 cmpkx k = compare kx k
643 lt = trim cmplo cmpkx t
644 (found,gt) = trimLookupLo kx cmphi t
645 tl = hedgeDiffWithKey f cmplo cmpkx lt l
646 tr = hedgeDiffWithKey f cmpkx cmphi gt r
650 {--------------------------------------------------------------------
652 --------------------------------------------------------------------}
653 -- | /O(n+m)/. Intersection of two maps. The values in the first
654 -- map are returned, i.e. (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
655 intersection :: Ord k => Map k a -> Map k b -> Map k a
657 = intersectionWithKey (\k x y -> x) m1 m2
659 -- | /O(n+m)/. Intersection with a combining function.
660 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
661 intersectionWith f m1 m2
662 = intersectionWithKey (\k x y -> f x y) m1 m2
664 -- | /O(n+m)/. Intersection with a combining function.
665 -- Intersection is more efficient on (bigset `intersection` smallset)
666 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
667 intersectionWithKey f Tip t = Tip
668 intersectionWithKey f t Tip = Tip
669 intersectionWithKey f t1 t2
670 | size t1 >= size t2 = intersectWithKey f t1 t2
671 | otherwise = intersectWithKey flipf t2 t1
673 flipf k x y = f k y x
675 intersectWithKey f Tip t = Tip
676 intersectWithKey f t Tip = Tip
677 intersectWithKey f t (Bin _ kx x l r)
679 Nothing -> merge tl tr
680 Just y -> join kx (f kx y x) tl tr
682 (lt,found,gt) = splitLookup kx t
683 tl = intersectWithKey f lt l
684 tr = intersectWithKey f gt r
688 {--------------------------------------------------------------------
690 --------------------------------------------------------------------}
692 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
693 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
695 = isSubmapOfBy (==) m1 m2
698 The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
699 all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
700 applied to their respective values. For example, the following
701 expressions are all 'True':
703 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
704 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
705 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
707 But the following are all 'False':
709 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
710 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
711 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
713 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
715 = (size t1 <= size t2) && (submap' f t1 t2)
717 submap' f Tip t = True
718 submap' f t Tip = False
719 submap' f (Bin _ kx x l r) t
722 Just y -> f x y && submap' f l lt && submap' f r gt
724 (lt,found,gt) = splitLookup kx t
726 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
727 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
728 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
729 isProperSubmapOf m1 m2
730 = isProperSubmapOfBy (==) m1 m2
732 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
733 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
734 @m1@ and @m2@ are not equal,
735 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
736 applied to their respective values. For example, the following
737 expressions are all 'True':
739 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
740 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
742 But the following are all 'False':
744 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
745 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
746 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
748 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
749 isProperSubmapOfBy f t1 t2
750 = (size t1 < size t2) && (submap' f t1 t2)
752 {--------------------------------------------------------------------
754 --------------------------------------------------------------------}
755 -- | /O(n)/. Filter all values that satisfy the predicate.
756 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
758 = filterWithKey (\k x -> p x) m
760 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
761 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
762 filterWithKey p Tip = Tip
763 filterWithKey p (Bin _ kx x l r)
764 | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
765 | otherwise = merge (filterWithKey p l) (filterWithKey p r)
768 -- | /O(n)/. partition the map according to a predicate. The first
769 -- map contains all elements that satisfy the predicate, the second all
770 -- elements that fail the predicate. See also 'split'.
771 partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
773 = partitionWithKey (\k x -> p x) m
775 -- | /O(n)/. partition the map according to a predicate. The first
776 -- map contains all elements that satisfy the predicate, the second all
777 -- elements that fail the predicate. See also 'split'.
778 partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
779 partitionWithKey p Tip = (Tip,Tip)
780 partitionWithKey p (Bin _ kx x l r)
781 | p kx x = (join kx x l1 r1,merge l2 r2)
782 | otherwise = (merge l1 r1,join kx x l2 r2)
784 (l1,l2) = partitionWithKey p l
785 (r1,r2) = partitionWithKey p r
788 {--------------------------------------------------------------------
790 --------------------------------------------------------------------}
791 -- | /O(n)/. Map a function over all values in the map.
792 map :: (a -> b) -> Map k a -> Map k b
794 = mapWithKey (\k x -> f x) m
796 -- | /O(n)/. Map a function over all values in the map.
797 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
798 mapWithKey f Tip = Tip
799 mapWithKey f (Bin sx kx x l r)
800 = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
802 -- | /O(n)/. The function 'mapAccum' threads an accumulating
803 -- argument through the map in ascending order of keys.
804 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
806 = mapAccumWithKey (\a k x -> f a x) a m
808 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
809 -- argument through the map in ascending order of keys.
810 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
811 mapAccumWithKey f a t
814 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
815 -- argument throught the map in ascending order of keys.
816 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
821 -> let (a1,l') = mapAccumL f a l
823 (a3,r') = mapAccumL f a2 r
824 in (a3,Bin sx kx x' l' r')
826 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
827 -- argument throught the map in descending order of keys.
828 mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
833 -> let (a1,r') = mapAccumR f a r
835 (a3,l') = mapAccumR f a2 l
836 in (a3,Bin sx kx x' l' r')
839 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
841 -- The size of the result may be smaller if @f@ maps two or more distinct
842 -- keys to the same new key. In this case the value at the smallest of
843 -- these keys is retained.
845 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
846 mapKeys = mapKeysWith (\x y->x)
849 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
851 -- The size of the result may be smaller if @f@ maps two or more distinct
852 -- keys to the same new key. In this case the associated values will be
853 -- combined using @c@.
855 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
856 mapKeysWith c f = fromListWith c . List.map fFirst . toList
857 where fFirst (x,y) = (f x, y)
861 -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
862 -- is strictly monotonic.
863 -- /The precondition is not checked./
864 -- Semi-formally, we have:
866 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
867 -- > ==> mapKeysMonotonic f s == mapKeys f s
868 -- > where ls = keys s
870 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
871 mapKeysMonotonic f Tip = Tip
872 mapKeysMonotonic f (Bin sz k x l r) =
873 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
875 {--------------------------------------------------------------------
877 --------------------------------------------------------------------}
879 -- | /O(n)/. Fold the values in the map, such that
880 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
883 -- > elems map = fold (:) [] map
885 fold :: (a -> b -> b) -> b -> Map k a -> b
887 = foldWithKey (\k x z -> f x z) z m
889 -- | /O(n)/. Fold the keys and values in the map, such that
890 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
893 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
895 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
899 -- | /O(n)/. In-order fold.
900 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
902 foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
904 -- | /O(n)/. Post-order fold.
905 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
907 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
909 -- | /O(n)/. Pre-order fold.
910 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
912 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
914 {--------------------------------------------------------------------
916 --------------------------------------------------------------------}
918 -- Return all elements of the map in the ascending order of their keys.
919 elems :: Map k a -> [a]
921 = [x | (k,x) <- assocs m]
923 -- | /O(n)/. Return all keys of the map in ascending order.
924 keys :: Map k a -> [k]
926 = [k | (k,x) <- assocs m]
928 -- | /O(n)/. The set of all keys of the map.
929 keysSet :: Map k a -> Set.Set k
930 keysSet m = Set.fromDistinctAscList (keys m)
932 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
933 assocs :: Map k a -> [(k,a)]
937 {--------------------------------------------------------------------
939 use [foldlStrict] to reduce demand on the control-stack
940 --------------------------------------------------------------------}
941 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
942 fromList :: Ord k => [(k,a)] -> Map k a
944 = foldlStrict ins empty xs
946 ins t (k,x) = insert k x t
948 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
949 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
951 = fromListWithKey (\k x y -> f x y) xs
953 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
954 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
956 = foldlStrict ins empty xs
958 ins t (k,x) = insertWithKey f k x t
960 -- | /O(n)/. Convert to a list of key\/value pairs.
961 toList :: Map k a -> [(k,a)]
962 toList t = toAscList t
964 -- | /O(n)/. Convert to an ascending list.
965 toAscList :: Map k a -> [(k,a)]
966 toAscList t = foldr (\k x xs -> (k,x):xs) [] t
969 toDescList :: Map k a -> [(k,a)]
970 toDescList t = foldl (\xs k x -> (k,x):xs) [] t
973 {--------------------------------------------------------------------
974 Building trees from ascending/descending lists can be done in linear time.
976 Note that if [xs] is ascending that:
977 fromAscList xs == fromList xs
978 fromAscListWith f xs == fromListWith f xs
979 --------------------------------------------------------------------}
980 -- | /O(n)/. Build a map from an ascending list in linear time.
981 -- /The precondition (input list is ascending) is not checked./
982 fromAscList :: Eq k => [(k,a)] -> Map k a
984 = fromAscListWithKey (\k x y -> x) xs
986 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
987 -- /The precondition (input list is ascending) is not checked./
988 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
990 = fromAscListWithKey (\k x y -> f x y) xs
992 -- | /O(n)/. Build a map from an ascending list in linear time with a
993 -- combining function for equal keys.
994 -- /The precondition (input list is ascending) is not checked./
995 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
996 fromAscListWithKey f xs
997 = fromDistinctAscList (combineEq f xs)
999 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1004 (x:xx) -> combineEq' x xx
1006 combineEq' z [] = [z]
1007 combineEq' z@(kz,zz) (x@(kx,xx):xs)
1008 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
1009 | otherwise = z:combineEq' x xs
1012 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
1013 -- /The precondition is not checked./
1014 fromDistinctAscList :: [(k,a)] -> Map k a
1015 fromDistinctAscList xs
1016 = build const (length xs) xs
1018 -- 1) use continutations so that we use heap space instead of stack space.
1019 -- 2) special case for n==5 to build bushier trees.
1020 build c 0 xs = c Tip xs
1021 build c 5 xs = case xs of
1022 ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
1023 -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
1024 build c n xs = seq nr $ build (buildR nr c) nl xs
1029 buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
1030 buildB l k x c r zs = c (bin k x l r) zs
1034 {--------------------------------------------------------------------
1035 Utility functions that return sub-ranges of the original
1036 tree. Some functions take a comparison function as argument to
1037 allow comparisons against infinite values. A function [cmplo k]
1038 should be read as [compare lo k].
1040 [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
1041 and [cmphi k == GT] for the key [k] of the root.
1042 [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
1043 [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
1045 [split k t] Returns two trees [l] and [r] where all keys
1046 in [l] are <[k] and all keys in [r] are >[k].
1047 [splitLookup k t] Just like [split] but also returns whether [k]
1048 was found in the tree.
1049 --------------------------------------------------------------------}
1051 {--------------------------------------------------------------------
1052 [trim lo hi t] trims away all subtrees that surely contain no
1053 values between the range [lo] to [hi]. The returned tree is either
1054 empty or the key of the root is between @lo@ and @hi@.
1055 --------------------------------------------------------------------}
1056 trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1057 trim cmplo cmphi Tip = Tip
1058 trim cmplo cmphi t@(Bin sx kx x l r)
1060 LT -> case cmphi kx of
1062 le -> trim cmplo cmphi l
1063 ge -> trim cmplo cmphi r
1065 trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a)
1066 trimLookupLo lo cmphi Tip = (Nothing,Tip)
1067 trimLookupLo lo cmphi t@(Bin sx kx x l r)
1068 = case compare lo kx of
1069 LT -> case cmphi kx of
1070 GT -> (lookup lo t, t)
1071 le -> trimLookupLo lo cmphi l
1072 GT -> trimLookupLo lo cmphi r
1073 EQ -> (Just x,trim (compare lo) cmphi r)
1076 {--------------------------------------------------------------------
1077 [filterGt k t] filter all keys >[k] from tree [t]
1078 [filterLt k t] filter all keys <[k] from tree [t]
1079 --------------------------------------------------------------------}
1080 filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1081 filterGt cmp Tip = Tip
1082 filterGt cmp (Bin sx kx x l r)
1084 LT -> join kx x (filterGt cmp l) r
1085 GT -> filterGt cmp r
1088 filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1089 filterLt cmp Tip = Tip
1090 filterLt cmp (Bin sx kx x l r)
1092 LT -> filterLt cmp l
1093 GT -> join kx x l (filterLt cmp r)
1096 {--------------------------------------------------------------------
1098 --------------------------------------------------------------------}
1099 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
1100 -- 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@.
1101 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1102 split k Tip = (Tip,Tip)
1103 split k (Bin sx kx x l r)
1104 = case compare k kx of
1105 LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1106 GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1109 -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
1110 -- like 'split' but also returns @'lookup' k map@.
1111 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
1112 splitLookup k Tip = (Tip,Nothing,Tip)
1113 splitLookup k (Bin sx kx x l r)
1114 = case compare k kx of
1115 LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
1116 GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
1119 {--------------------------------------------------------------------
1120 Utility functions that maintain the balance properties of the tree.
1121 All constructors assume that all values in [l] < [k] and all values
1122 in [r] > [k], and that [l] and [r] are valid trees.
1124 In order of sophistication:
1125 [Bin sz k x l r] The type constructor.
1126 [bin k x l r] Maintains the correct size, assumes that both [l]
1127 and [r] are balanced with respect to each other.
1128 [balance k x l r] Restores the balance and size.
1129 Assumes that the original tree was balanced and
1130 that [l] or [r] has changed by at most one element.
1131 [join k x l r] Restores balance and size.
1133 Furthermore, we can construct a new tree from two trees. Both operations
1134 assume that all values in [l] < all values in [r] and that [l] and [r]
1136 [glue l r] Glues [l] and [r] together. Assumes that [l] and
1137 [r] are already balanced with respect to each other.
1138 [merge l r] Merges two trees and restores balance.
1140 Note: in contrast to Adam's paper, we use (<=) comparisons instead
1141 of (<) comparisons in [join], [merge] and [balance].
1142 Quickcheck (on [difference]) showed that this was necessary in order
1143 to maintain the invariants. It is quite unsatisfactory that I haven't
1144 been able to find out why this is actually the case! Fortunately, it
1145 doesn't hurt to be a bit more conservative.
1146 --------------------------------------------------------------------}
1148 {--------------------------------------------------------------------
1150 --------------------------------------------------------------------}
1151 join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1152 join kx x Tip r = insertMin kx x r
1153 join kx x l Tip = insertMax kx x l
1154 join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1155 | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
1156 | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
1157 | otherwise = bin kx x l r
1160 -- insertMin and insertMax don't perform potentially expensive comparisons.
1161 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1164 Tip -> singleton kx x
1166 -> balance ky y l (insertMax kx x r)
1170 Tip -> singleton kx x
1172 -> balance ky y (insertMin kx x l) r
1174 {--------------------------------------------------------------------
1175 [merge l r]: merges two trees.
1176 --------------------------------------------------------------------}
1177 merge :: Map k a -> Map k a -> Map k a
1180 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1181 | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1182 | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1183 | otherwise = glue l r
1185 {--------------------------------------------------------------------
1186 [glue l r]: glues two trees together.
1187 Assumes that [l] and [r] are already balanced with respect to each other.
1188 --------------------------------------------------------------------}
1189 glue :: Map k a -> Map k a -> Map k a
1193 | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1194 | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
1197 -- | /O(log n)/. Delete and find the minimal element.
1198 deleteFindMin :: Map k a -> ((k,a),Map k a)
1201 Bin _ k x Tip r -> ((k,x),r)
1202 Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1203 Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1205 -- | /O(log n)/. Delete and find the maximal element.
1206 deleteFindMax :: Map k a -> ((k,a),Map k a)
1209 Bin _ k x l Tip -> ((k,x),l)
1210 Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1211 Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1214 {--------------------------------------------------------------------
1215 [balance l x r] balances two trees with value x.
1216 The sizes of the trees should balance after decreasing the
1217 size of one of them. (a rotation).
1219 [delta] is the maximal relative difference between the sizes of
1220 two trees, it corresponds with the [w] in Adams' paper.
1221 [ratio] is the ratio between an outer and inner sibling of the
1222 heavier subtree in an unbalanced setting. It determines
1223 whether a double or single rotation should be performed
1224 to restore balance. It is correspondes with the inverse
1225 of $\alpha$ in Adam's article.
1228 - [delta] should be larger than 4.646 with a [ratio] of 2.
1229 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1231 - A lower [delta] leads to a more 'perfectly' balanced tree.
1232 - A higher [delta] performs less rebalancing.
1234 - Balancing is automatic for random data and a balancing
1235 scheme is only necessary to avoid pathological worst cases.
1236 Almost any choice will do, and in practice, a rather large
1237 [delta] may perform better than smaller one.
1239 Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1240 to decide whether a single or double rotation is needed. Allthough
1241 he actually proves that this ratio is needed to maintain the
1242 invariants, his implementation uses an invalid ratio of [1].
1243 --------------------------------------------------------------------}
1248 balance :: k -> a -> Map k a -> Map k a -> Map k a
1250 | sizeL + sizeR <= 1 = Bin sizeX k x l r
1251 | sizeR >= delta*sizeL = rotateL k x l r
1252 | sizeL >= delta*sizeR = rotateR k x l r
1253 | otherwise = Bin sizeX k x l r
1257 sizeX = sizeL + sizeR + 1
1260 rotateL k x l r@(Bin _ _ _ ly ry)
1261 | size ly < ratio*size ry = singleL k x l r
1262 | otherwise = doubleL k x l r
1264 rotateR k x l@(Bin _ _ _ ly ry) r
1265 | size ry < ratio*size ly = singleR k x l r
1266 | otherwise = doubleR k x l r
1269 singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
1270 singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
1272 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)
1273 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)
1276 {--------------------------------------------------------------------
1277 The bin constructor maintains the size of the tree
1278 --------------------------------------------------------------------}
1279 bin :: k -> a -> Map k a -> Map k a -> Map k a
1281 = Bin (size l + size r + 1) k x l r
1284 {--------------------------------------------------------------------
1285 Eq converts the tree to a list. In a lazy setting, this
1286 actually seems one of the faster methods to compare two trees
1287 and it is certainly the simplest :-)
1288 --------------------------------------------------------------------}
1289 instance (Eq k,Eq a) => Eq (Map k a) where
1290 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1292 {--------------------------------------------------------------------
1294 --------------------------------------------------------------------}
1296 instance (Ord k, Ord v) => Ord (Map k v) where
1297 compare m1 m2 = compare (toList m1) (toList m2)
1299 {--------------------------------------------------------------------
1301 --------------------------------------------------------------------}
1302 instance Functor (Map k) where
1305 {--------------------------------------------------------------------
1307 --------------------------------------------------------------------}
1308 instance (Show k, Show a) => Show (Map k a) where
1309 showsPrec d m = showMap (toAscList m)
1311 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1315 = showChar '{' . showElem x . showTail xs
1317 showTail [] = showChar '}'
1318 showTail (x:xs) = showChar ',' . showElem x . showTail xs
1320 showElem (k,x) = shows k . showString ":=" . shows x
1323 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1324 -- in a compressed, hanging format.
1325 showTree :: (Show k,Show a) => Map k a -> String
1327 = showTreeWith showElem True False m
1329 showElem k x = show k ++ ":=" ++ show x
1332 {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
1333 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1334 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1335 @wide@ is 'True', an extra wide version is shown.
1337 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1338 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1345 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1356 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
1368 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
1369 showTreeWith showelem hang wide t
1370 | hang = (showsTreeHang showelem wide [] t) ""
1371 | otherwise = (showsTree showelem wide [] [] t) ""
1373 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1374 showsTree showelem wide lbars rbars t
1376 Tip -> showsBars lbars . showString "|\n"
1378 -> showsBars lbars . showString (showelem kx x) . showString "\n"
1380 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
1381 showWide wide rbars .
1382 showsBars lbars . showString (showelem kx x) . showString "\n" .
1383 showWide wide lbars .
1384 showsTree showelem wide (withEmpty lbars) (withBar lbars) l
1386 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1387 showsTreeHang showelem wide bars t
1389 Tip -> showsBars bars . showString "|\n"
1391 -> showsBars bars . showString (showelem kx x) . showString "\n"
1393 -> showsBars bars . showString (showelem kx x) . showString "\n" .
1394 showWide wide bars .
1395 showsTreeHang showelem wide (withBar bars) l .
1396 showWide wide bars .
1397 showsTreeHang showelem wide (withEmpty bars) r
1401 | wide = showString (concat (reverse bars)) . showString "|\n"
1404 showsBars :: [String] -> ShowS
1408 _ -> showString (concat (reverse (tail bars))) . showString node
1411 withBar bars = "| ":bars
1412 withEmpty bars = " ":bars
1414 {--------------------------------------------------------------------
1416 --------------------------------------------------------------------}
1418 #include "Typeable.h"
1419 INSTANCE_TYPEABLE2(Map,mapTc,"Map")
1421 {--------------------------------------------------------------------
1423 --------------------------------------------------------------------}
1424 -- | /O(n)/. Test if the internal map structure is valid.
1425 valid :: Ord k => Map k a -> Bool
1427 = balanced t && ordered t && validsize t
1430 = bounded (const True) (const True) t
1435 Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1437 -- | Exported only for "Debug.QuickCheck"
1438 balanced :: Map k a -> Bool
1442 Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1443 balanced l && balanced r
1447 = (realsize t == Just (size t))
1452 Bin sz kx x l r -> case (realsize l,realsize r) of
1453 (Just n,Just m) | n+m+1 == sz -> Just sz
1456 {--------------------------------------------------------------------
1458 --------------------------------------------------------------------}
1462 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1466 {--------------------------------------------------------------------
1468 --------------------------------------------------------------------}
1469 testTree xs = fromList [(x,"*") | x <- xs]
1470 test1 = testTree [1..20]
1471 test2 = testTree [30,29..10]
1472 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1474 {--------------------------------------------------------------------
1476 --------------------------------------------------------------------}
1481 { configMaxTest = 500
1482 , configMaxFail = 5000
1483 , configSize = \n -> (div n 2 + 3)
1484 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1488 {--------------------------------------------------------------------
1489 Arbitrary, reasonably balanced trees
1490 --------------------------------------------------------------------}
1491 instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
1492 arbitrary = sized (arbtree 0 maxkey)
1493 where maxkey = 10000
1495 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
1497 | n <= 0 = return Tip
1498 | lo >= hi = return Tip
1499 | otherwise = do{ x <- arbitrary
1500 ; i <- choose (lo,hi)
1501 ; m <- choose (1,30)
1502 ; let (ml,mr) | m==(1::Int)= (1,2)
1506 ; l <- arbtree lo (i-1) (n `div` ml)
1507 ; r <- arbtree (i+1) hi (n `div` mr)
1508 ; return (bin (toEnum i) x l r)
1512 {--------------------------------------------------------------------
1514 --------------------------------------------------------------------}
1515 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
1517 = forAll arbitrary $ \t ->
1518 -- classify (balanced t) "balanced" $
1519 classify (size t == 0) "empty" $
1520 classify (size t > 0 && size t <= 10) "small" $
1521 classify (size t > 10 && size t <= 64) "medium" $
1522 classify (size t > 64) "large" $
1525 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1529 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1535 = forValidUnitTree $ \t -> valid t
1537 {--------------------------------------------------------------------
1538 Single, Insert, Delete
1539 --------------------------------------------------------------------}
1540 prop_Single :: Int -> Int -> Bool
1542 = (insert k x empty == singleton k x)
1544 prop_InsertValid :: Int -> Property
1546 = forValidUnitTree $ \t -> valid (insert k () t)
1548 prop_InsertDelete :: Int -> Map Int () -> Property
1549 prop_InsertDelete k t
1550 = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1552 prop_DeleteValid :: Int -> Property
1554 = forValidUnitTree $ \t ->
1555 valid (delete k (insert k () t))
1557 {--------------------------------------------------------------------
1559 --------------------------------------------------------------------}
1560 prop_Join :: Int -> Property
1562 = forValidUnitTree $ \t ->
1563 let (l,r) = split k t
1564 in valid (join k () l r)
1566 prop_Merge :: Int -> Property
1568 = forValidUnitTree $ \t ->
1569 let (l,r) = split k t
1570 in valid (merge l r)
1573 {--------------------------------------------------------------------
1575 --------------------------------------------------------------------}
1576 prop_UnionValid :: Property
1578 = forValidUnitTree $ \t1 ->
1579 forValidUnitTree $ \t2 ->
1582 prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
1583 prop_UnionInsert k x t
1584 = union (singleton k x) t == insert k x t
1586 prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
1587 prop_UnionAssoc t1 t2 t3
1588 = union t1 (union t2 t3) == union (union t1 t2) t3
1590 prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
1591 prop_UnionComm t1 t2
1592 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1595 = forValidIntTree $ \t1 ->
1596 forValidIntTree $ \t2 ->
1597 valid (unionWithKey (\k x y -> x+y) t1 t2)
1599 prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
1600 prop_UnionWith xs ys
1601 = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
1602 == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
1605 = forValidUnitTree $ \t1 ->
1606 forValidUnitTree $ \t2 ->
1607 valid (difference t1 t2)
1609 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1611 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1612 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1615 = forValidUnitTree $ \t1 ->
1616 forValidUnitTree $ \t2 ->
1617 valid (intersection t1 t2)
1619 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1621 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1622 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1624 {--------------------------------------------------------------------
1626 --------------------------------------------------------------------}
1628 = forAll (choose (5,100)) $ \n ->
1629 let xs = [(x,()) | x <- [0..n::Int]]
1630 in fromAscList xs == fromList xs
1632 prop_List :: [Int] -> Bool
1634 = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])