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)
152 import qualified Data.Set as Set
153 import qualified Data.List as List
158 import qualified Prelude
159 import qualified List
160 import Debug.QuickCheck
161 import List(nub,sort)
164 #if __GLASGOW_HASKELL__
165 import Data.Generics.Basics
166 import Data.Generics.Instances
169 {--------------------------------------------------------------------
171 --------------------------------------------------------------------}
174 -- | /O(log n)/. Find the value at a key.
175 -- Calls 'error' when the element can not be found.
176 (!) :: Ord k => Map k a -> k -> a
179 -- | /O(n+m)/. See 'difference'.
180 (\\) :: Ord k => Map k a -> Map k b -> Map k a
181 m1 \\ m2 = difference m1 m2
183 {--------------------------------------------------------------------
185 --------------------------------------------------------------------}
186 -- | A Map from keys @k@ to values @a@.
188 | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
192 #if __GLASGOW_HASKELL__
194 {--------------------------------------------------------------------
196 --------------------------------------------------------------------}
198 -- This instance preserves data abstraction at the cost of inefficiency.
199 -- We omit reflection services for the sake of data abstraction.
201 instance (Data k, Data a, Ord k) => Data (Map k a) where
202 gfoldl f z map = z fromList `f` (toList map)
203 toConstr _ = error "toConstr"
204 gunfold _ _ = error "gunfold"
205 dataTypeOf _ = mkNorepType "Data.Map.Map"
209 {--------------------------------------------------------------------
211 --------------------------------------------------------------------}
212 -- | /O(1)/. Is the map empty?
213 null :: Map k a -> Bool
217 Bin sz k x l r -> False
219 -- | /O(1)/. The number of elements in the map.
220 size :: Map k a -> Int
227 -- | /O(log n)/. Lookup the value at a key in the map.
228 lookup :: (Monad m,Ord k) => k -> Map k a -> m a
229 lookup k t = case lookup' k t of
231 Nothing -> fail "Data.Map.lookup: Key not found"
232 lookup' :: Ord k => k -> Map k a -> Maybe a
237 -> case compare k kx of
242 -- | /O(log n)/. Is the key a member of the map?
243 member :: Ord k => k -> Map k a -> Bool
249 -- | /O(log n)/. Find the value at a key.
250 -- Calls 'error' when the element can not be found.
251 find :: Ord k => k -> Map k a -> a
254 Nothing -> error "Map.find: element not in the map"
257 -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
258 -- the value at key @k@ or returns @def@ when the key is not in the map.
259 findWithDefault :: Ord k => a -> k -> Map k a -> a
260 findWithDefault def k m
267 {--------------------------------------------------------------------
269 --------------------------------------------------------------------}
270 -- | /O(1)/. The empty map.
275 -- | /O(1)/. A map with a single element.
276 singleton :: k -> a -> Map k a
280 {--------------------------------------------------------------------
282 [insert] is the inlined version of [insertWith (\k x y -> x)]
283 --------------------------------------------------------------------}
284 -- | /O(log n)/. Insert a new key and value in the map.
285 insert :: Ord k => k -> a -> Map k a -> Map k a
288 Tip -> singleton kx x
290 -> case compare kx ky of
291 LT -> balance ky y (insert kx x l) r
292 GT -> balance ky y l (insert kx x r)
293 EQ -> Bin sz kx x l r
295 -- | /O(log n)/. Insert with a combining function.
296 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
298 = insertWithKey (\k x y -> f x y) k x m
300 -- | /O(log n)/. Insert with a combining function.
301 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
302 insertWithKey f kx x t
304 Tip -> singleton kx x
306 -> case compare kx ky of
307 LT -> balance ky y (insertWithKey f kx x l) r
308 GT -> balance ky y l (insertWithKey f kx x r)
309 EQ -> Bin sy ky (f ky x y) l r
311 -- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@)
312 -- is a pair where the first element is equal to (@'lookup' k map@)
313 -- and the second element equal to (@'insertWithKey' f k x map@).
314 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
315 insertLookupWithKey f kx x t
317 Tip -> (Nothing, singleton kx x)
319 -> case compare kx ky of
320 LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
321 GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
322 EQ -> (Just y, Bin sy ky (f ky x y) l r)
324 {--------------------------------------------------------------------
326 [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
327 --------------------------------------------------------------------}
328 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
329 -- a member of the map, the original map is returned.
330 delete :: Ord k => k -> Map k a -> Map k a
335 -> case compare k kx of
336 LT -> balance kx x (delete k l) r
337 GT -> balance kx x l (delete k r)
340 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
341 -- a member of the map, the original map is returned.
342 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
344 = adjustWithKey (\k x -> f x) k m
346 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
347 -- a member of the map, the original map is returned.
348 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
350 = updateWithKey (\k x -> Just (f k x)) k m
352 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
353 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
354 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
355 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
357 = updateWithKey (\k x -> f x) k m
359 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
360 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
361 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
362 -- to the new value @y@.
363 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
368 -> case compare k kx of
369 LT -> balance kx x (updateWithKey f k l) r
370 GT -> balance kx x l (updateWithKey f k r)
372 Just x' -> Bin sx kx x' l r
375 -- | /O(log n)/. Lookup and update.
376 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
377 updateLookupWithKey f k t
381 -> case compare k kx of
382 LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
383 GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
385 Just x' -> (Just x',Bin sx kx x' l r)
386 Nothing -> (Just x,glue l r)
388 {--------------------------------------------------------------------
390 --------------------------------------------------------------------}
391 -- | /O(log n)/. Return the /index/ of a key. The index is a number from
392 -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
393 -- the key is not a 'member' of the map.
394 findIndex :: Ord k => k -> Map k a -> Int
396 = case lookupIndex k t of
397 Nothing -> error "Map.findIndex: element is not in the map"
400 -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
401 -- /0/ up to, but not including, the 'size' of the map.
402 lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
403 lookupIndex k t = case lookup 0 t of
404 Nothing -> fail "Data.Map.lookupIndex: Key not found."
407 lookup idx Tip = Nothing
408 lookup idx (Bin _ kx x l r)
409 = case compare k kx of
411 GT -> lookup (idx + size l + 1) r
412 EQ -> Just (idx + size l)
414 -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
415 -- invalid index is used.
416 elemAt :: Int -> Map k a -> (k,a)
417 elemAt i Tip = error "Map.elemAt: index out of range"
418 elemAt i (Bin _ kx x l r)
419 = case compare i sizeL of
421 GT -> elemAt (i-sizeL-1) r
426 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
427 -- invalid index is used.
428 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
429 updateAt f i Tip = error "Map.updateAt: index out of range"
430 updateAt f i (Bin sx kx x l r)
431 = case compare i sizeL of
433 GT -> updateAt f (i-sizeL-1) r
435 Just x' -> Bin sx kx x' l r
440 -- | /O(log n)/. Delete the element at /index/.
441 -- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
442 deleteAt :: Int -> Map k a -> Map k a
444 = updateAt (\k x -> Nothing) i map
447 {--------------------------------------------------------------------
449 --------------------------------------------------------------------}
450 -- | /O(log n)/. The minimal key of the map.
451 findMin :: Map k a -> (k,a)
452 findMin (Bin _ kx x Tip r) = (kx,x)
453 findMin (Bin _ kx x l r) = findMin l
454 findMin Tip = error "Map.findMin: empty tree has no minimal element"
456 -- | /O(log n)/. The maximal key of the map.
457 findMax :: Map k a -> (k,a)
458 findMax (Bin _ kx x l Tip) = (kx,x)
459 findMax (Bin _ kx x l r) = findMax r
460 findMax Tip = error "Map.findMax: empty tree has no maximal element"
462 -- | /O(log n)/. Delete the minimal key.
463 deleteMin :: Map k a -> Map k a
464 deleteMin (Bin _ kx x Tip r) = r
465 deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
468 -- | /O(log n)/. Delete the maximal key.
469 deleteMax :: Map k a -> Map k a
470 deleteMax (Bin _ kx x l Tip) = l
471 deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
474 -- | /O(log n)/. Update the value at the minimal key.
475 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
477 = updateMinWithKey (\k x -> f x) m
479 -- | /O(log n)/. Update the value at the maximal key.
480 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
482 = updateMaxWithKey (\k x -> f x) m
485 -- | /O(log n)/. Update the value at the minimal key.
486 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
489 Bin sx kx x Tip r -> case f kx x of
491 Just x' -> Bin sx kx x' Tip r
492 Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
495 -- | /O(log n)/. Update the value at the maximal key.
496 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
499 Bin sx kx x l Tip -> case f kx x of
501 Just x' -> Bin sx kx x' l Tip
502 Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
506 {--------------------------------------------------------------------
508 --------------------------------------------------------------------}
509 -- | The union of a list of maps:
510 -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
511 unions :: Ord k => [Map k a] -> Map k a
513 = foldlStrict union empty ts
515 -- | The union of a list of maps, with a combining operation:
516 -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
517 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
519 = foldlStrict (unionWith f) empty ts
522 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
523 -- It prefers @t1@ when duplicate keys are encountered,
524 -- i.e. (@'union' == 'unionWith' 'const'@).
525 -- The implementation uses the efficient /hedge-union/ algorithm.
526 -- Hedge-union is more efficient on (bigset `union` smallset)?
527 union :: Ord k => Map k a -> Map k a -> Map k a
531 | size t1 >= size t2 = hedgeUnionL (const LT) (const GT) t1 t2
532 | otherwise = hedgeUnionR (const LT) (const GT) t2 t1
534 -- left-biased hedge union
535 hedgeUnionL cmplo cmphi t1 Tip
537 hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
538 = join kx x (filterGt cmplo l) (filterLt cmphi r)
539 hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
540 = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
541 (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
543 cmpkx k = compare kx k
545 -- right-biased hedge union
546 hedgeUnionR cmplo cmphi t1 Tip
548 hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
549 = join kx x (filterGt cmplo l) (filterLt cmphi r)
550 hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
551 = join kx newx (hedgeUnionR cmplo cmpkx l lt)
552 (hedgeUnionR cmpkx cmphi r gt)
554 cmpkx k = compare kx k
555 lt = trim cmplo cmpkx t2
556 (found,gt) = trimLookupLo kx cmphi t2
561 {--------------------------------------------------------------------
562 Union with a combining function
563 --------------------------------------------------------------------}
564 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
565 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
567 = unionWithKey (\k x y -> f x y) m1 m2
570 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
571 -- Hedge-union is more efficient on (bigset `union` smallset).
572 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
573 unionWithKey f Tip t2 = t2
574 unionWithKey f t1 Tip = t1
576 | size t1 >= size t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
577 | otherwise = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1
579 flipf k x y = f k y x
581 hedgeUnionWithKey f cmplo cmphi t1 Tip
583 hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
584 = join kx x (filterGt cmplo l) (filterLt cmphi r)
585 hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
586 = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
587 (hedgeUnionWithKey f cmpkx cmphi r gt)
589 cmpkx k = compare kx k
590 lt = trim cmplo cmpkx t2
591 (found,gt) = trimLookupLo kx cmphi t2
596 {--------------------------------------------------------------------
598 --------------------------------------------------------------------}
599 -- | /O(n+m)/. Difference of two maps.
600 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
601 difference :: Ord k => Map k a -> Map k b -> Map k a
602 difference Tip t2 = Tip
603 difference t1 Tip = t1
604 difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
606 hedgeDiff cmplo cmphi Tip t
608 hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
609 = join kx x (filterGt cmplo l) (filterLt cmphi r)
610 hedgeDiff cmplo cmphi t (Bin _ kx x l r)
611 = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
612 (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
614 cmpkx k = compare kx k
616 -- | /O(n+m)/. Difference with a combining function.
617 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
618 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
619 differenceWith f m1 m2
620 = differenceWithKey (\k x y -> f x y) m1 m2
622 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
623 -- encountered, the combining function is applied to the key and both values.
624 -- If it returns 'Nothing', the element is discarded (proper set difference). If
625 -- it returns (@'Just' y@), the element is updated with a new value @y@.
626 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
627 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
628 differenceWithKey f Tip t2 = Tip
629 differenceWithKey f t1 Tip = t1
630 differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
632 hedgeDiffWithKey f cmplo cmphi Tip t
634 hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
635 = join kx x (filterGt cmplo l) (filterLt cmphi r)
636 hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
638 Nothing -> merge tl tr
639 Just y -> case f kx y x of
640 Nothing -> merge tl tr
641 Just z -> join kx z tl tr
643 cmpkx k = compare kx k
644 lt = trim cmplo cmpkx t
645 (found,gt) = trimLookupLo kx cmphi t
646 tl = hedgeDiffWithKey f cmplo cmpkx lt l
647 tr = hedgeDiffWithKey f cmpkx cmphi gt r
651 {--------------------------------------------------------------------
653 --------------------------------------------------------------------}
654 -- | /O(n+m)/. Intersection of two maps. The values in the first
655 -- map are returned, i.e. (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
656 intersection :: Ord k => Map k a -> Map k b -> Map k a
658 = intersectionWithKey (\k x y -> x) m1 m2
660 -- | /O(n+m)/. Intersection with a combining function.
661 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
662 intersectionWith f m1 m2
663 = intersectionWithKey (\k x y -> f x y) m1 m2
665 -- | /O(n+m)/. Intersection with a combining function.
666 -- Intersection is more efficient on (bigset `intersection` smallset)
667 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
668 intersectionWithKey f Tip t = Tip
669 intersectionWithKey f t Tip = Tip
670 intersectionWithKey f t1 t2
671 | size t1 >= size t2 = intersectWithKey f t1 t2
672 | otherwise = intersectWithKey flipf t2 t1
674 flipf k x y = f k y x
676 intersectWithKey f Tip t = Tip
677 intersectWithKey f t Tip = Tip
678 intersectWithKey f t (Bin _ kx x l r)
680 Nothing -> merge tl tr
681 Just y -> join kx (f kx y x) tl tr
683 (lt,found,gt) = splitLookup kx t
684 tl = intersectWithKey f lt l
685 tr = intersectWithKey f gt r
689 {--------------------------------------------------------------------
691 --------------------------------------------------------------------}
693 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
694 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
696 = isSubmapOfBy (==) m1 m2
699 The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
700 all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
701 applied to their respective values. For example, the following
702 expressions are all 'True':
704 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
705 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
706 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
708 But the following are all 'False':
710 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
711 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
712 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
714 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
716 = (size t1 <= size t2) && (submap' f t1 t2)
718 submap' f Tip t = True
719 submap' f t Tip = False
720 submap' f (Bin _ kx x l r) t
723 Just y -> f x y && submap' f l lt && submap' f r gt
725 (lt,found,gt) = splitLookup kx t
727 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
728 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
729 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
730 isProperSubmapOf m1 m2
731 = isProperSubmapOfBy (==) m1 m2
733 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
734 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
735 @m1@ and @m2@ are not equal,
736 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
737 applied to their respective values. For example, the following
738 expressions are all 'True':
740 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
741 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
743 But the following are all 'False':
745 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
746 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
747 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
749 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
750 isProperSubmapOfBy f t1 t2
751 = (size t1 < size t2) && (submap' f t1 t2)
753 {--------------------------------------------------------------------
755 --------------------------------------------------------------------}
756 -- | /O(n)/. Filter all values that satisfy the predicate.
757 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
759 = filterWithKey (\k x -> p x) m
761 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
762 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
763 filterWithKey p Tip = Tip
764 filterWithKey p (Bin _ kx x l r)
765 | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
766 | otherwise = merge (filterWithKey p l) (filterWithKey p r)
769 -- | /O(n)/. partition the map according to a predicate. The first
770 -- map contains all elements that satisfy the predicate, the second all
771 -- elements that fail the predicate. See also 'split'.
772 partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
774 = partitionWithKey (\k x -> p x) m
776 -- | /O(n)/. partition the map according to a predicate. The first
777 -- map contains all elements that satisfy the predicate, the second all
778 -- elements that fail the predicate. See also 'split'.
779 partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
780 partitionWithKey p Tip = (Tip,Tip)
781 partitionWithKey p (Bin _ kx x l r)
782 | p kx x = (join kx x l1 r1,merge l2 r2)
783 | otherwise = (merge l1 r1,join kx x l2 r2)
785 (l1,l2) = partitionWithKey p l
786 (r1,r2) = partitionWithKey p r
789 {--------------------------------------------------------------------
791 --------------------------------------------------------------------}
792 -- | /O(n)/. Map a function over all values in the map.
793 map :: (a -> b) -> Map k a -> Map k b
795 = mapWithKey (\k x -> f x) m
797 -- | /O(n)/. Map a function over all values in the map.
798 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
799 mapWithKey f Tip = Tip
800 mapWithKey f (Bin sx kx x l r)
801 = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
803 -- | /O(n)/. The function 'mapAccum' threads an accumulating
804 -- argument through the map in ascending order of keys.
805 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
807 = mapAccumWithKey (\a k x -> f a x) a m
809 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
810 -- argument through the map in ascending order of keys.
811 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
812 mapAccumWithKey f a t
815 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
816 -- argument throught the map in ascending order of keys.
817 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
822 -> let (a1,l') = mapAccumL f a l
824 (a3,r') = mapAccumL f a2 r
825 in (a3,Bin sx kx x' l' r')
827 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
828 -- argument throught the map in descending order of keys.
829 mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
834 -> let (a1,r') = mapAccumR f a r
836 (a3,l') = mapAccumR f a2 l
837 in (a3,Bin sx kx x' l' r')
840 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
842 -- The size of the result may be smaller if @f@ maps two or more distinct
843 -- keys to the same new key. In this case the value at the smallest of
844 -- these keys is retained.
846 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
847 mapKeys = mapKeysWith (\x y->x)
850 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
852 -- The size of the result may be smaller if @f@ maps two or more distinct
853 -- keys to the same new key. In this case the associated values will be
854 -- combined using @c@.
856 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
857 mapKeysWith c f = fromListWith c . List.map fFirst . toList
858 where fFirst (x,y) = (f x, y)
862 -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
863 -- is strictly monotonic.
864 -- /The precondition is not checked./
865 -- Semi-formally, we have:
867 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
868 -- > ==> mapKeysMonotonic f s == mapKeys f s
869 -- > where ls = keys s
871 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
872 mapKeysMonotonic f Tip = Tip
873 mapKeysMonotonic f (Bin sz k x l r) =
874 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
876 {--------------------------------------------------------------------
878 --------------------------------------------------------------------}
880 -- | /O(n)/. Fold the values in the map, such that
881 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
884 -- > elems map = fold (:) [] map
886 fold :: (a -> b -> b) -> b -> Map k a -> b
888 = foldWithKey (\k x z -> f x z) z m
890 -- | /O(n)/. Fold the keys and values in the map, such that
891 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
894 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
896 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
900 -- | /O(n)/. In-order fold.
901 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
903 foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
905 -- | /O(n)/. Post-order fold.
906 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
908 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
910 -- | /O(n)/. Pre-order fold.
911 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
913 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
915 {--------------------------------------------------------------------
917 --------------------------------------------------------------------}
919 -- Return all elements of the map in the ascending order of their keys.
920 elems :: Map k a -> [a]
922 = [x | (k,x) <- assocs m]
924 -- | /O(n)/. Return all keys of the map in ascending order.
925 keys :: Map k a -> [k]
927 = [k | (k,x) <- assocs m]
929 -- | /O(n)/. The set of all keys of the map.
930 keysSet :: Map k a -> Set.Set k
931 keysSet m = Set.fromDistinctAscList (keys m)
933 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
934 assocs :: Map k a -> [(k,a)]
938 {--------------------------------------------------------------------
940 use [foldlStrict] to reduce demand on the control-stack
941 --------------------------------------------------------------------}
942 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
943 fromList :: Ord k => [(k,a)] -> Map k a
945 = foldlStrict ins empty xs
947 ins t (k,x) = insert k x t
949 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
950 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
952 = fromListWithKey (\k x y -> f x y) xs
954 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
955 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
957 = foldlStrict ins empty xs
959 ins t (k,x) = insertWithKey f k x t
961 -- | /O(n)/. Convert to a list of key\/value pairs.
962 toList :: Map k a -> [(k,a)]
963 toList t = toAscList t
965 -- | /O(n)/. Convert to an ascending list.
966 toAscList :: Map k a -> [(k,a)]
967 toAscList t = foldr (\k x xs -> (k,x):xs) [] t
970 toDescList :: Map k a -> [(k,a)]
971 toDescList t = foldl (\xs k x -> (k,x):xs) [] t
974 {--------------------------------------------------------------------
975 Building trees from ascending/descending lists can be done in linear time.
977 Note that if [xs] is ascending that:
978 fromAscList xs == fromList xs
979 fromAscListWith f xs == fromListWith f xs
980 --------------------------------------------------------------------}
981 -- | /O(n)/. Build a map from an ascending list in linear time.
982 -- /The precondition (input list is ascending) is not checked./
983 fromAscList :: Eq k => [(k,a)] -> Map k a
985 = fromAscListWithKey (\k x y -> x) xs
987 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
988 -- /The precondition (input list is ascending) is not checked./
989 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
991 = fromAscListWithKey (\k x y -> f x y) xs
993 -- | /O(n)/. Build a map from an ascending list in linear time with a
994 -- combining function for equal keys.
995 -- /The precondition (input list is ascending) is not checked./
996 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
997 fromAscListWithKey f xs
998 = fromDistinctAscList (combineEq f xs)
1000 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1005 (x:xx) -> combineEq' x xx
1007 combineEq' z [] = [z]
1008 combineEq' z@(kz,zz) (x@(kx,xx):xs)
1009 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
1010 | otherwise = z:combineEq' x xs
1013 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
1014 -- /The precondition is not checked./
1015 fromDistinctAscList :: [(k,a)] -> Map k a
1016 fromDistinctAscList xs
1017 = build const (length xs) xs
1019 -- 1) use continutations so that we use heap space instead of stack space.
1020 -- 2) special case for n==5 to build bushier trees.
1021 build c 0 xs = c Tip xs
1022 build c 5 xs = case xs of
1023 ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
1024 -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
1025 build c n xs = seq nr $ build (buildR nr c) nl xs
1030 buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
1031 buildB l k x c r zs = c (bin k x l r) zs
1035 {--------------------------------------------------------------------
1036 Utility functions that return sub-ranges of the original
1037 tree. Some functions take a comparison function as argument to
1038 allow comparisons against infinite values. A function [cmplo k]
1039 should be read as [compare lo k].
1041 [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
1042 and [cmphi k == GT] for the key [k] of the root.
1043 [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
1044 [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
1046 [split k t] Returns two trees [l] and [r] where all keys
1047 in [l] are <[k] and all keys in [r] are >[k].
1048 [splitLookup k t] Just like [split] but also returns whether [k]
1049 was found in the tree.
1050 --------------------------------------------------------------------}
1052 {--------------------------------------------------------------------
1053 [trim lo hi t] trims away all subtrees that surely contain no
1054 values between the range [lo] to [hi]. The returned tree is either
1055 empty or the key of the root is between @lo@ and @hi@.
1056 --------------------------------------------------------------------}
1057 trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1058 trim cmplo cmphi Tip = Tip
1059 trim cmplo cmphi t@(Bin sx kx x l r)
1061 LT -> case cmphi kx of
1063 le -> trim cmplo cmphi l
1064 ge -> trim cmplo cmphi r
1066 trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a)
1067 trimLookupLo lo cmphi Tip = (Nothing,Tip)
1068 trimLookupLo lo cmphi t@(Bin sx kx x l r)
1069 = case compare lo kx of
1070 LT -> case cmphi kx of
1071 GT -> (lookup lo t, t)
1072 le -> trimLookupLo lo cmphi l
1073 GT -> trimLookupLo lo cmphi r
1074 EQ -> (Just x,trim (compare lo) cmphi r)
1077 {--------------------------------------------------------------------
1078 [filterGt k t] filter all keys >[k] from tree [t]
1079 [filterLt k t] filter all keys <[k] from tree [t]
1080 --------------------------------------------------------------------}
1081 filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1082 filterGt cmp Tip = Tip
1083 filterGt cmp (Bin sx kx x l r)
1085 LT -> join kx x (filterGt cmp l) r
1086 GT -> filterGt cmp r
1089 filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1090 filterLt cmp Tip = Tip
1091 filterLt cmp (Bin sx kx x l r)
1093 LT -> filterLt cmp l
1094 GT -> join kx x l (filterLt cmp r)
1097 {--------------------------------------------------------------------
1099 --------------------------------------------------------------------}
1100 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
1101 -- 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@.
1102 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1103 split k Tip = (Tip,Tip)
1104 split k (Bin sx kx x l r)
1105 = case compare k kx of
1106 LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1107 GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1110 -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
1111 -- like 'split' but also returns @'lookup' k map@.
1112 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
1113 splitLookup k Tip = (Tip,Nothing,Tip)
1114 splitLookup k (Bin sx kx x l r)
1115 = case compare k kx of
1116 LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
1117 GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
1120 {--------------------------------------------------------------------
1121 Utility functions that maintain the balance properties of the tree.
1122 All constructors assume that all values in [l] < [k] and all values
1123 in [r] > [k], and that [l] and [r] are valid trees.
1125 In order of sophistication:
1126 [Bin sz k x l r] The type constructor.
1127 [bin k x l r] Maintains the correct size, assumes that both [l]
1128 and [r] are balanced with respect to each other.
1129 [balance k x l r] Restores the balance and size.
1130 Assumes that the original tree was balanced and
1131 that [l] or [r] has changed by at most one element.
1132 [join k x l r] Restores balance and size.
1134 Furthermore, we can construct a new tree from two trees. Both operations
1135 assume that all values in [l] < all values in [r] and that [l] and [r]
1137 [glue l r] Glues [l] and [r] together. Assumes that [l] and
1138 [r] are already balanced with respect to each other.
1139 [merge l r] Merges two trees and restores balance.
1141 Note: in contrast to Adam's paper, we use (<=) comparisons instead
1142 of (<) comparisons in [join], [merge] and [balance].
1143 Quickcheck (on [difference]) showed that this was necessary in order
1144 to maintain the invariants. It is quite unsatisfactory that I haven't
1145 been able to find out why this is actually the case! Fortunately, it
1146 doesn't hurt to be a bit more conservative.
1147 --------------------------------------------------------------------}
1149 {--------------------------------------------------------------------
1151 --------------------------------------------------------------------}
1152 join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1153 join kx x Tip r = insertMin kx x r
1154 join kx x l Tip = insertMax kx x l
1155 join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1156 | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
1157 | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
1158 | otherwise = bin kx x l r
1161 -- insertMin and insertMax don't perform potentially expensive comparisons.
1162 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1165 Tip -> singleton kx x
1167 -> balance ky y l (insertMax kx x r)
1171 Tip -> singleton kx x
1173 -> balance ky y (insertMin kx x l) r
1175 {--------------------------------------------------------------------
1176 [merge l r]: merges two trees.
1177 --------------------------------------------------------------------}
1178 merge :: Map k a -> Map k a -> Map k a
1181 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1182 | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1183 | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1184 | otherwise = glue l r
1186 {--------------------------------------------------------------------
1187 [glue l r]: glues two trees together.
1188 Assumes that [l] and [r] are already balanced with respect to each other.
1189 --------------------------------------------------------------------}
1190 glue :: Map k a -> Map k a -> Map k a
1194 | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1195 | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
1198 -- | /O(log n)/. Delete and find the minimal element.
1199 deleteFindMin :: Map k a -> ((k,a),Map k a)
1202 Bin _ k x Tip r -> ((k,x),r)
1203 Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1204 Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1206 -- | /O(log n)/. Delete and find the maximal element.
1207 deleteFindMax :: Map k a -> ((k,a),Map k a)
1210 Bin _ k x l Tip -> ((k,x),l)
1211 Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1212 Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1215 {--------------------------------------------------------------------
1216 [balance l x r] balances two trees with value x.
1217 The sizes of the trees should balance after decreasing the
1218 size of one of them. (a rotation).
1220 [delta] is the maximal relative difference between the sizes of
1221 two trees, it corresponds with the [w] in Adams' paper.
1222 [ratio] is the ratio between an outer and inner sibling of the
1223 heavier subtree in an unbalanced setting. It determines
1224 whether a double or single rotation should be performed
1225 to restore balance. It is correspondes with the inverse
1226 of $\alpha$ in Adam's article.
1229 - [delta] should be larger than 4.646 with a [ratio] of 2.
1230 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1232 - A lower [delta] leads to a more 'perfectly' balanced tree.
1233 - A higher [delta] performs less rebalancing.
1235 - Balancing is automaic for random data and a balancing
1236 scheme is only necessary to avoid pathological worst cases.
1237 Almost any choice will do, and in practice, a rather large
1238 [delta] may perform better than smaller one.
1240 Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1241 to decide whether a single or double rotation is needed. Allthough
1242 he actually proves that this ratio is needed to maintain the
1243 invariants, his implementation uses an invalid ratio of [1].
1244 --------------------------------------------------------------------}
1249 balance :: k -> a -> Map k a -> Map k a -> Map k a
1251 | sizeL + sizeR <= 1 = Bin sizeX k x l r
1252 | sizeR >= delta*sizeL = rotateL k x l r
1253 | sizeL >= delta*sizeR = rotateR k x l r
1254 | otherwise = Bin sizeX k x l r
1258 sizeX = sizeL + sizeR + 1
1261 rotateL k x l r@(Bin _ _ _ ly ry)
1262 | size ly < ratio*size ry = singleL k x l r
1263 | otherwise = doubleL k x l r
1265 rotateR k x l@(Bin _ _ _ ly ry) r
1266 | size ry < ratio*size ly = singleR k x l r
1267 | otherwise = doubleR k x l r
1270 singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
1271 singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
1273 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)
1274 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)
1277 {--------------------------------------------------------------------
1278 The bin constructor maintains the size of the tree
1279 --------------------------------------------------------------------}
1280 bin :: k -> a -> Map k a -> Map k a -> Map k a
1282 = Bin (size l + size r + 1) k x l r
1285 {--------------------------------------------------------------------
1286 Eq converts the tree to a list. In a lazy setting, this
1287 actually seems one of the faster methods to compare two trees
1288 and it is certainly the simplest :-)
1289 --------------------------------------------------------------------}
1290 instance (Eq k,Eq a) => Eq (Map k a) where
1291 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1293 {--------------------------------------------------------------------
1295 --------------------------------------------------------------------}
1297 instance (Ord k, Ord v) => Ord (Map k v) where
1298 compare m1 m2 = compare (toList m1) (toList m2)
1300 {--------------------------------------------------------------------
1302 --------------------------------------------------------------------}
1304 instance (Ord k) => Monoid (Map k v) where
1309 {--------------------------------------------------------------------
1311 --------------------------------------------------------------------}
1312 instance Functor (Map k) where
1315 {--------------------------------------------------------------------
1317 --------------------------------------------------------------------}
1318 instance (Show k, Show a) => Show (Map k a) where
1319 showsPrec d m = showMap (toAscList m)
1321 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1325 = showChar '{' . showElem x . showTail xs
1327 showTail [] = showChar '}'
1328 showTail (x:xs) = showChar ',' . showElem x . showTail xs
1330 showElem (k,x) = shows k . showString ":=" . shows x
1333 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1334 -- in a compressed, hanging format.
1335 showTree :: (Show k,Show a) => Map k a -> String
1337 = showTreeWith showElem True False m
1339 showElem k x = show k ++ ":=" ++ show x
1342 {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
1343 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1344 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1345 @wide@ is 'True', an extra wide version is shown.
1347 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1348 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1355 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1366 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
1378 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
1379 showTreeWith showelem hang wide t
1380 | hang = (showsTreeHang showelem wide [] t) ""
1381 | otherwise = (showsTree showelem wide [] [] t) ""
1383 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1384 showsTree showelem wide lbars rbars t
1386 Tip -> showsBars lbars . showString "|\n"
1388 -> showsBars lbars . showString (showelem kx x) . showString "\n"
1390 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
1391 showWide wide rbars .
1392 showsBars lbars . showString (showelem kx x) . showString "\n" .
1393 showWide wide lbars .
1394 showsTree showelem wide (withEmpty lbars) (withBar lbars) l
1396 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1397 showsTreeHang showelem wide bars t
1399 Tip -> showsBars bars . showString "|\n"
1401 -> showsBars bars . showString (showelem kx x) . showString "\n"
1403 -> showsBars bars . showString (showelem kx x) . showString "\n" .
1404 showWide wide bars .
1405 showsTreeHang showelem wide (withBar bars) l .
1406 showWide wide bars .
1407 showsTreeHang showelem wide (withEmpty bars) r
1411 | wide = showString (concat (reverse bars)) . showString "|\n"
1414 showsBars :: [String] -> ShowS
1418 _ -> showString (concat (reverse (tail bars))) . showString node
1421 withBar bars = "| ":bars
1422 withEmpty bars = " ":bars
1424 {--------------------------------------------------------------------
1426 --------------------------------------------------------------------}
1428 #include "Typeable.h"
1429 INSTANCE_TYPEABLE2(Map,mapTc,"Map")
1431 {--------------------------------------------------------------------
1433 --------------------------------------------------------------------}
1434 -- | /O(n)/. Test if the internal map structure is valid.
1435 valid :: Ord k => Map k a -> Bool
1437 = balanced t && ordered t && validsize t
1440 = bounded (const True) (const True) t
1445 Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1447 -- | Exported only for "Debug.QuickCheck"
1448 balanced :: Map k a -> Bool
1452 Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1453 balanced l && balanced r
1457 = (realsize t == Just (size t))
1462 Bin sz kx x l r -> case (realsize l,realsize r) of
1463 (Just n,Just m) | n+m+1 == sz -> Just sz
1466 {--------------------------------------------------------------------
1468 --------------------------------------------------------------------}
1472 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1476 {--------------------------------------------------------------------
1478 --------------------------------------------------------------------}
1479 testTree xs = fromList [(x,"*") | x <- xs]
1480 test1 = testTree [1..20]
1481 test2 = testTree [30,29..10]
1482 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1484 {--------------------------------------------------------------------
1486 --------------------------------------------------------------------}
1491 { configMaxTest = 500
1492 , configMaxFail = 5000
1493 , configSize = \n -> (div n 2 + 3)
1494 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1498 {--------------------------------------------------------------------
1499 Arbitrary, reasonably balanced trees
1500 --------------------------------------------------------------------}
1501 instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
1502 arbitrary = sized (arbtree 0 maxkey)
1503 where maxkey = 10000
1505 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
1507 | n <= 0 = return Tip
1508 | lo >= hi = return Tip
1509 | otherwise = do{ x <- arbitrary
1510 ; i <- choose (lo,hi)
1511 ; m <- choose (1,30)
1512 ; let (ml,mr) | m==(1::Int)= (1,2)
1516 ; l <- arbtree lo (i-1) (n `div` ml)
1517 ; r <- arbtree (i+1) hi (n `div` mr)
1518 ; return (bin (toEnum i) x l r)
1522 {--------------------------------------------------------------------
1524 --------------------------------------------------------------------}
1525 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
1527 = forAll arbitrary $ \t ->
1528 -- classify (balanced t) "balanced" $
1529 classify (size t == 0) "empty" $
1530 classify (size t > 0 && size t <= 10) "small" $
1531 classify (size t > 10 && size t <= 64) "medium" $
1532 classify (size t > 64) "large" $
1535 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1539 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1545 = forValidUnitTree $ \t -> valid t
1547 {--------------------------------------------------------------------
1548 Single, Insert, Delete
1549 --------------------------------------------------------------------}
1550 prop_Single :: Int -> Int -> Bool
1552 = (insert k x empty == singleton k x)
1554 prop_InsertValid :: Int -> Property
1556 = forValidUnitTree $ \t -> valid (insert k () t)
1558 prop_InsertDelete :: Int -> Map Int () -> Property
1559 prop_InsertDelete k t
1560 = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1562 prop_DeleteValid :: Int -> Property
1564 = forValidUnitTree $ \t ->
1565 valid (delete k (insert k () t))
1567 {--------------------------------------------------------------------
1569 --------------------------------------------------------------------}
1570 prop_Join :: Int -> Property
1572 = forValidUnitTree $ \t ->
1573 let (l,r) = split k t
1574 in valid (join k () l r)
1576 prop_Merge :: Int -> Property
1578 = forValidUnitTree $ \t ->
1579 let (l,r) = split k t
1580 in valid (merge l r)
1583 {--------------------------------------------------------------------
1585 --------------------------------------------------------------------}
1586 prop_UnionValid :: Property
1588 = forValidUnitTree $ \t1 ->
1589 forValidUnitTree $ \t2 ->
1592 prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
1593 prop_UnionInsert k x t
1594 = union (singleton k x) t == insert k x t
1596 prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
1597 prop_UnionAssoc t1 t2 t3
1598 = union t1 (union t2 t3) == union (union t1 t2) t3
1600 prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
1601 prop_UnionComm t1 t2
1602 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1605 = forValidIntTree $ \t1 ->
1606 forValidIntTree $ \t2 ->
1607 valid (unionWithKey (\k x y -> x+y) t1 t2)
1609 prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
1610 prop_UnionWith xs ys
1611 = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
1612 == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
1615 = forValidUnitTree $ \t1 ->
1616 forValidUnitTree $ \t2 ->
1617 valid (difference t1 t2)
1619 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1621 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1622 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1625 = forValidUnitTree $ \t1 ->
1626 forValidUnitTree $ \t2 ->
1627 valid (intersection t1 t2)
1629 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1631 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1632 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1634 {--------------------------------------------------------------------
1636 --------------------------------------------------------------------}
1638 = forAll (choose (5,100)) $ \n ->
1639 let xs = [(x,()) | x <- [0..n::Int]]
1640 in fromAscList xs == fromList xs
1642 prop_List :: [Int] -> Bool
1644 = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])