1 --------------------------------------------------------------------------------
3 Copyright : (c) Daan Leijen 2002
5 Maintainer : libraries@haskell.org
6 Stability : provisional
9 An efficient implementation of maps from keys to values (dictionaries).
11 This module is intended to be imported @qualified@, to avoid name
12 clashes with Prelude functions. eg.
14 > import Data.Map as Map
16 The implementation of "Map" is based on /size balanced/ binary trees (or
17 trees of /bounded balance/) as described by:
19 * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional
20 Programming 3(4):553-562, October 1993, <http://www.swiss.ai.mit.edu/~adams/BB>.
22 * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\",
23 SIAM journal of computing 2(1), March 1973.
25 ----------------------------------------------------------------------------------
28 Map -- instance Eq,Show
47 , insertWith, insertWithKey, insertLookupWithKey
107 , fromDistinctAscList
119 , isSubmapOf, isSubmapOfBy
120 , isProperSubmapOf, isProperSubmapOfBy
147 import Prelude hiding (lookup,map,filter,foldr,foldl,null)
149 import qualified Data.Set as Set
150 import qualified Data.List as List
154 import qualified Prelude
155 import qualified List
156 import Debug.QuickCheck
157 import List(nub,sort)
160 {--------------------------------------------------------------------
162 --------------------------------------------------------------------}
165 -- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found.
166 (!) :: Ord k => Map k a -> k -> a
169 -- | /O(n+m)/. See 'difference'.
170 (\\) :: Ord k => Map k a -> Map k b -> Map k a
171 m1 \\ m2 = difference m1 m2
173 {--------------------------------------------------------------------
175 --------------------------------------------------------------------}
176 -- | A Map from keys @k@ to values @a@.
178 | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
182 {--------------------------------------------------------------------
184 --------------------------------------------------------------------}
185 -- | /O(1)/. Is the map empty?
186 null :: Map k a -> Bool
190 Bin sz k x l r -> False
192 -- | /O(1)/. The number of elements in the map.
193 size :: Map k a -> Int
200 -- | /O(log n)/. Lookup the value of key in the map.
201 lookup :: Ord k => k -> Map k a -> Maybe a
206 -> case compare k kx of
211 -- | /O(log n)/. Is the key a member of the map?
212 member :: Ord k => k -> Map k a -> Bool
218 -- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found.
219 find :: Ord k => k -> Map k a -> a
222 Nothing -> error "Map.find: element not in the map"
225 -- | /O(log n)/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when
226 -- the key is not in the map.
227 findWithDefault :: Ord k => a -> k -> Map k a -> a
228 findWithDefault def k m
235 {--------------------------------------------------------------------
237 --------------------------------------------------------------------}
238 -- | /O(1)/. The empty map.
243 -- | /O(1)/. Create a map with a single element.
244 singleton :: k -> a -> Map k a
248 {--------------------------------------------------------------------
250 [insert] is the inlined version of [insertWith (\k x y -> x)]
251 --------------------------------------------------------------------}
252 -- | /O(log n)/. Insert a new key and value in the map.
253 insert :: Ord k => k -> a -> Map k a -> Map k a
256 Tip -> singleton kx x
258 -> case compare kx ky of
259 LT -> balance ky y (insert kx x l) r
260 GT -> balance ky y l (insert kx x r)
261 EQ -> Bin sz kx x l r
263 -- | /O(log n)/. Insert with a combining function.
264 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
266 = insertWithKey (\k x y -> f x y) k x m
268 -- | /O(log n)/. Insert with a combining function.
269 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
270 insertWithKey f kx x t
272 Tip -> singleton kx x
274 -> case compare kx ky of
275 LT -> balance ky y (insertWithKey f kx x l) r
276 GT -> balance ky y l (insertWithKey f kx x r)
277 EQ -> Bin sy ky (f ky x y) l r
279 -- | /O(log n)/. The expression (@insertLookupWithKey f k x map@) is a pair where
280 -- the first element is equal to (@lookup k map@) and the second element
281 -- equal to (@insertWithKey f k x map@).
282 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
283 insertLookupWithKey f kx x t
285 Tip -> (Nothing, singleton kx x)
287 -> case compare kx ky of
288 LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
289 GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
290 EQ -> (Just y, Bin sy ky (f ky x y) l r)
292 {--------------------------------------------------------------------
294 [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
295 --------------------------------------------------------------------}
296 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
297 -- a member of the map, the original map is returned.
298 delete :: Ord k => k -> Map k a -> Map k a
303 -> case compare k kx of
304 LT -> balance kx x (delete k l) r
305 GT -> balance kx x l (delete k r)
308 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
309 -- a member of the map, the original map is returned.
310 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
312 = adjustWithKey (\k x -> f x) k m
314 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
315 -- a member of the map, the original map is returned.
316 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
318 = updateWithKey (\k x -> Just (f k x)) k m
320 -- | /O(log n)/. The expression (@update f k map@) updates the value @x@
321 -- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is
322 -- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
323 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
325 = updateWithKey (\k x -> f x) k m
327 -- | /O(log n)/. The expression (@update f k map@) updates the value @x@
328 -- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is
329 -- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
330 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
335 -> case compare k kx of
336 LT -> balance kx x (updateWithKey f k l) r
337 GT -> balance kx x l (updateWithKey f k r)
339 Just x' -> Bin sx kx x' l r
342 -- | /O(log n)/. Lookup and update.
343 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
344 updateLookupWithKey f k t
348 -> case compare k kx of
349 LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
350 GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
352 Just x' -> (Just x',Bin sx kx x' l r)
353 Nothing -> (Just x,glue l r)
355 {--------------------------------------------------------------------
357 --------------------------------------------------------------------}
358 -- | /O(log n)/. Return the /index/ of a key. The index is a number from
359 -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
360 -- the key is not a 'member' of the map.
361 findIndex :: Ord k => k -> Map k a -> Int
363 = case lookupIndex k t of
364 Nothing -> error "Map.findIndex: element is not in the map"
367 -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
368 -- /0/ up to, but not including, the 'size' of the map.
369 lookupIndex :: Ord k => k -> Map k a -> Maybe Int
373 lookup idx Tip = Nothing
374 lookup idx (Bin _ kx x l r)
375 = case compare k kx of
377 GT -> lookup (idx + size l + 1) r
378 EQ -> Just (idx + size l)
380 -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
381 -- invalid index is used.
382 elemAt :: Int -> Map k a -> (k,a)
383 elemAt i Tip = error "Map.elemAt: index out of range"
384 elemAt i (Bin _ kx x l r)
385 = case compare i sizeL of
387 GT -> elemAt (i-sizeL-1) r
392 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
393 -- invalid index is used.
394 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
395 updateAt f i Tip = error "Map.updateAt: index out of range"
396 updateAt f i (Bin sx kx x l r)
397 = case compare i sizeL of
399 GT -> updateAt f (i-sizeL-1) r
401 Just x' -> Bin sx kx x' l r
406 -- | /O(log n)/. Delete the element at /index/. Defined as (@deleteAt i map = updateAt (\k x -> Nothing) i map@).
407 deleteAt :: Int -> Map k a -> Map k a
409 = updateAt (\k x -> Nothing) i map
412 {--------------------------------------------------------------------
414 --------------------------------------------------------------------}
415 -- | /O(log n)/. The minimal key of the map.
416 findMin :: Map k a -> (k,a)
417 findMin (Bin _ kx x Tip r) = (kx,x)
418 findMin (Bin _ kx x l r) = findMin l
419 findMin Tip = error "Map.findMin: empty tree has no minimal element"
421 -- | /O(log n)/. The maximal key of the map.
422 findMax :: Map k a -> (k,a)
423 findMax (Bin _ kx x l Tip) = (kx,x)
424 findMax (Bin _ kx x l r) = findMax r
425 findMax Tip = error "Map.findMax: empty tree has no maximal element"
427 -- | /O(log n)/. Delete the minimal key.
428 deleteMin :: Map k a -> Map k a
429 deleteMin (Bin _ kx x Tip r) = r
430 deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
433 -- | /O(log n)/. Delete the maximal key.
434 deleteMax :: Map k a -> Map k a
435 deleteMax (Bin _ kx x l Tip) = l
436 deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
439 -- | /O(log n)/. Update the minimal key.
440 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
442 = updateMinWithKey (\k x -> f x) m
444 -- | /O(log n)/. Update the maximal key.
445 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
447 = updateMaxWithKey (\k x -> f x) m
450 -- | /O(log n)/. Update the minimal key.
451 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
454 Bin sx kx x Tip r -> case f kx x of
456 Just x' -> Bin sx kx x' Tip r
457 Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
460 -- | /O(log n)/. Update the maximal key.
461 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
464 Bin sx kx x l Tip -> case f kx x of
466 Just x' -> Bin sx kx x' l Tip
467 Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
471 {--------------------------------------------------------------------
473 --------------------------------------------------------------------}
474 -- | The union of a list of maps: (@unions == foldl union empty@).
475 unions :: Ord k => [Map k a] -> Map k a
477 = foldlStrict union empty ts
479 -- | The union of a list of maps, with a combining operation:
480 -- (@unionsWith f == foldl (unionWith f) empty@).
481 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
483 = foldlStrict (unionWith f) empty ts
486 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
487 -- It prefers @t1@ when duplicate keys are encountered, ie. (@union == unionWith const@).
488 -- The implementation uses the efficient /hedge-union/ algorithm.
489 -- Hedge-union is more efficient on (bigset `union` smallset)?
490 union :: Ord k => Map k a -> Map k a -> Map k a
494 | size t1 >= size t2 = hedgeUnionL (const LT) (const GT) t1 t2
495 | otherwise = hedgeUnionR (const LT) (const GT) t2 t1
497 -- left-biased hedge union
498 hedgeUnionL cmplo cmphi t1 Tip
500 hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
501 = join kx x (filterGt cmplo l) (filterLt cmphi r)
502 hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
503 = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
504 (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
506 cmpkx k = compare kx k
508 -- right-biased hedge union
509 hedgeUnionR cmplo cmphi t1 Tip
511 hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
512 = join kx x (filterGt cmplo l) (filterLt cmphi r)
513 hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
514 = join kx newx (hedgeUnionR cmplo cmpkx l lt)
515 (hedgeUnionR cmpkx cmphi r gt)
517 cmpkx k = compare kx k
518 lt = trim cmplo cmpkx t2
519 (found,gt) = trimLookupLo kx cmphi t2
524 {--------------------------------------------------------------------
525 Union with a combining function
526 --------------------------------------------------------------------}
527 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
528 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
530 = unionWithKey (\k x y -> f x y) m1 m2
533 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
534 -- Hedge-union is more efficient on (bigset `union` smallset).
535 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
536 unionWithKey f Tip t2 = t2
537 unionWithKey f t1 Tip = t1
539 | size t1 >= size t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
540 | otherwise = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1
542 flipf k x y = f k y x
544 hedgeUnionWithKey f cmplo cmphi t1 Tip
546 hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
547 = join kx x (filterGt cmplo l) (filterLt cmphi r)
548 hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
549 = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
550 (hedgeUnionWithKey f cmpkx cmphi r gt)
552 cmpkx k = compare kx k
553 lt = trim cmplo cmpkx t2
554 (found,gt) = trimLookupLo kx cmphi t2
559 {--------------------------------------------------------------------
561 --------------------------------------------------------------------}
562 -- | /O(n+m)/. Difference of two maps.
563 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
564 difference :: Ord k => Map k a -> Map k b -> Map k a
565 difference Tip t2 = Tip
566 difference t1 Tip = t1
567 difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
569 hedgeDiff cmplo cmphi Tip t
571 hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
572 = join kx x (filterGt cmplo l) (filterLt cmphi r)
573 hedgeDiff cmplo cmphi t (Bin _ kx x l r)
574 = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
575 (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
577 cmpkx k = compare kx k
579 -- | /O(n+m)/. Difference with a combining function.
580 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
581 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
582 differenceWith f m1 m2
583 = differenceWithKey (\k x y -> f x y) m1 m2
585 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
586 -- encountered, the combining function is applied to the key and both values.
587 -- If it returns @Nothing@, the element is discarded (proper set difference). If
588 -- it returns (@Just y@), the element is updated with a new value @y@.
589 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
590 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
591 differenceWithKey f Tip t2 = Tip
592 differenceWithKey f t1 Tip = t1
593 differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
595 hedgeDiffWithKey f cmplo cmphi Tip t
597 hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
598 = join kx x (filterGt cmplo l) (filterLt cmphi r)
599 hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
601 Nothing -> merge tl tr
602 Just y -> case f kx y x of
603 Nothing -> merge tl tr
604 Just z -> join kx z tl tr
606 cmpkx k = compare kx k
607 lt = trim cmplo cmpkx t
608 (found,gt) = trimLookupLo kx cmphi t
609 tl = hedgeDiffWithKey f cmplo cmpkx lt l
610 tr = hedgeDiffWithKey f cmpkx cmphi gt r
614 {--------------------------------------------------------------------
616 --------------------------------------------------------------------}
617 -- | /O(n+m)/. Intersection of two maps. The values in the first
618 -- map are returned, i.e. (@intersection m1 m2 == intersectionWith const m1 m2@).
619 intersection :: Ord k => Map k a -> Map k b -> Map k a
621 = intersectionWithKey (\k x y -> x) m1 m2
623 -- | /O(n+m)/. Intersection with a combining function.
624 intersectionWith :: Ord k => (a -> b -> a) -> Map k a -> Map k b -> Map k a
625 intersectionWith f m1 m2
626 = intersectionWithKey (\k x y -> f x y) m1 m2
628 -- | /O(n+m)/. Intersection with a combining function.
629 -- Intersection is more efficient on (bigset `intersection` smallset)
630 intersectionWithKey :: Ord k => (k -> a -> b -> a) -> Map k a -> Map k b -> Map k a
631 intersectionWithKey f Tip t = Tip
632 intersectionWithKey f t Tip = Tip
633 intersectionWithKey f t1 t2
634 | size t1 >= size t2 = intersectWithKey f t1 t2
635 | otherwise = intersectWithKey flipf t2 t1
637 flipf k x y = f k y x
639 intersectWithKey f Tip t = Tip
640 intersectWithKey f t Tip = Tip
641 intersectWithKey f t (Bin _ kx x l r)
643 Nothing -> merge tl tr
644 Just y -> join kx (f kx y x) tl tr
646 (found,lt,gt) = splitLookup kx t
647 tl = intersectWithKey f lt l
648 tr = intersectWithKey f gt r
652 {--------------------------------------------------------------------
654 --------------------------------------------------------------------}
656 -- This function is defined as (@submap = submapBy (==)@).
657 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
659 = isSubmapOfBy (==) m1 m2
662 The expression (@isSubmapOfBy f t1 t2@) returns @True@ if
663 all keys in @t1@ are in tree @t2@, and when @f@ returns @True@ when
664 applied to their respective values. For example, the following
665 expressions are all @True@.
667 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
668 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
669 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
671 But the following are all @False@:
673 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
674 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
675 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
677 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
679 = (size t1 <= size t2) && (submap' f t1 t2)
681 submap' f Tip t = True
682 submap' f t Tip = False
683 submap' f (Bin _ kx x l r) t
686 Just y -> f x y && submap' f l lt && submap' f r gt
688 (found,lt,gt) = splitLookup kx t
690 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
691 -- Defined as (@isProperSubmapOf = isProperSubmapOfBy (==)@).
692 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
693 isProperSubmapOf m1 m2
694 = isProperSubmapOfBy (==) m1 m2
696 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
697 The expression (@isProperSubmapOfBy f m1 m2@) returns @True@ when
698 @m1@ and @m2@ are not equal,
699 all keys in @m1@ are in @m2@, and when @f@ returns @True@ when
700 applied to their respective values. For example, the following
701 expressions are all @True@.
703 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
704 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
706 But the following are all @False@:
708 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
709 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
710 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
712 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
713 isProperSubmapOfBy f t1 t2
714 = (size t1 < size t2) && (submap' f t1 t2)
716 {--------------------------------------------------------------------
718 --------------------------------------------------------------------}
719 -- | /O(n)/. Filter all values that satisfy the predicate.
720 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
722 = filterWithKey (\k x -> p x) m
724 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
725 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
726 filterWithKey p Tip = Tip
727 filterWithKey p (Bin _ kx x l r)
728 | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
729 | otherwise = merge (filterWithKey p l) (filterWithKey p r)
732 -- | /O(n)/. partition the map according to a predicate. The first
733 -- map contains all elements that satisfy the predicate, the second all
734 -- elements that fail the predicate. See also 'split'.
735 partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
737 = partitionWithKey (\k x -> p x) m
739 -- | /O(n)/. partition the map according to a predicate. The first
740 -- map contains all elements that satisfy the predicate, the second all
741 -- elements that fail the predicate. See also 'split'.
742 partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
743 partitionWithKey p Tip = (Tip,Tip)
744 partitionWithKey p (Bin _ kx x l r)
745 | p kx x = (join kx x l1 r1,merge l2 r2)
746 | otherwise = (merge l1 r1,join kx x l2 r2)
748 (l1,l2) = partitionWithKey p l
749 (r1,r2) = partitionWithKey p r
752 {--------------------------------------------------------------------
754 --------------------------------------------------------------------}
755 -- | /O(n)/. Map a function over all values in the map.
756 map :: (a -> b) -> Map k a -> Map k b
758 = mapWithKey (\k x -> f x) m
760 -- | /O(n)/. Map a function over all values in the map.
761 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
762 mapWithKey f Tip = Tip
763 mapWithKey f (Bin sx kx x l r)
764 = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
766 -- | /O(n)/. The function @mapAccum@ threads an accumulating
767 -- argument through the map in an unspecified order.
768 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
770 = mapAccumWithKey (\a k x -> f a x) a m
772 -- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating
773 -- argument through the map in unspecified order. (= ascending pre-order)
774 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
775 mapAccumWithKey f a t
778 -- | /O(n)/. The function @mapAccumL@ threads an accumulating
779 -- argument throught the map in (ascending) pre-order.
780 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
785 -> let (a1,l') = mapAccumL f a l
787 (a3,r') = mapAccumL f a2 r
788 in (a3,Bin sx kx x' l' r')
790 -- | /O(n)/. The function @mapAccumR@ threads an accumulating
791 -- argument throught the map in (descending) post-order.
792 mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
797 -> let (a1,r') = mapAccumR f a r
799 (a3,l') = mapAccumR f a2 l
800 in (a3,Bin sx kx x' l' r')
803 -- @mapKeys f s@ is the map obtained by applying @f@ to each key of @s@.
805 -- It's worth noting that the size of the result may be smaller if,
806 -- for some @(x,y)@, @x \/= y && f x == f y@
808 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
809 mapKeys = mapKeysWith (\x y->x)
812 -- @mapKeysWith c f s@ is the map obtained by applying @f@ to each key of @s@.
814 -- It's worth noting that the size of the result may be smaller if,
815 -- for some @(x,y)@, @x \/= y && f x == f y@
816 -- In such a case, the values will be combined using @c@
818 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
819 mapKeysWith c f = fromListWith c . List.map fFirst . toList
820 where fFirst (x,y) = (f x, y)
825 -- @mapMonotonic f s == 'map' f s@, but works only when @f@ is monotonic.
826 -- /The precondition is not checked./
827 -- Semi-formally, we have:
829 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
830 -- > ==> mapMonotonic f s == map f s
831 -- > where ls = keys s
833 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
834 mapKeysMonotonic f Tip = Tip
835 mapKeysMonotonic f (Bin sz k x l r) =
836 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
838 {--------------------------------------------------------------------
840 --------------------------------------------------------------------}
841 -- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).
842 fold :: (a -> b -> b) -> b -> Map k a -> b
844 = foldWithKey (\k x z -> f x z) z m
846 -- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).
847 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
851 -- | /O(n)/. In-order fold.
852 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
854 foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
856 -- | /O(n)/. Post-order fold.
857 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
859 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
861 -- | /O(n)/. Pre-order fold.
862 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
864 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
866 {--------------------------------------------------------------------
868 --------------------------------------------------------------------}
869 -- | /O(n)/. Return all elements of the map.
870 elems :: Map k a -> [a]
872 = [x | (k,x) <- assocs m]
874 -- | /O(n)/. Return all keys of the map.
875 keys :: Map k a -> [k]
877 = [k | (k,x) <- assocs m]
879 -- | /O(n)/. The set of all keys of the map.
880 keysSet :: Map k a -> Set.Set k
881 keysSet m = Set.fromDistinctAscList (keys m)
883 -- | /O(n)/. Return all key\/value pairs in the map.
884 assocs :: Map k a -> [(k,a)]
888 {--------------------------------------------------------------------
890 use [foldlStrict] to reduce demand on the control-stack
891 --------------------------------------------------------------------}
892 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
893 fromList :: Ord k => [(k,a)] -> Map k a
895 = foldlStrict ins empty xs
897 ins t (k,x) = insert k x t
899 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
900 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
902 = fromListWithKey (\k x y -> f x y) xs
904 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
905 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
907 = foldlStrict ins empty xs
909 ins t (k,x) = insertWithKey f k x t
911 -- | /O(n)/. Convert to a list of key\/value pairs.
912 toList :: Map k a -> [(k,a)]
913 toList t = toAscList t
915 -- | /O(n)/. Convert to an ascending list.
916 toAscList :: Map k a -> [(k,a)]
917 toAscList t = foldr (\k x xs -> (k,x):xs) [] t
920 toDescList :: Map k a -> [(k,a)]
921 toDescList t = foldl (\xs k x -> (k,x):xs) [] t
924 {--------------------------------------------------------------------
925 Building trees from ascending/descending lists can be done in linear time.
927 Note that if [xs] is ascending that:
928 fromAscList xs == fromList xs
929 fromAscListWith f xs == fromListWith f xs
930 --------------------------------------------------------------------}
931 -- | /O(n)/. Build a map from an ascending list in linear time.
932 -- /The precondition (input list is ascending) is not checked./
933 fromAscList :: Eq k => [(k,a)] -> Map k a
935 = fromAscListWithKey (\k x y -> x) xs
937 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
938 -- /The precondition (input list is ascending) is not checked./
939 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
941 = fromAscListWithKey (\k x y -> f x y) xs
943 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys
944 -- /The precondition (input list is ascending) is not checked./
945 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
946 fromAscListWithKey f xs
947 = fromDistinctAscList (combineEq f xs)
949 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
954 (x:xx) -> combineEq' x xx
956 combineEq' z [] = [z]
957 combineEq' z@(kz,zz) (x@(kx,xx):xs)
958 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
959 | otherwise = z:combineEq' x xs
962 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
964 -- /The precondition is not checked./
965 fromDistinctAscList :: [(k,a)] -> Map k a
966 fromDistinctAscList xs
967 = build const (length xs) xs
969 -- 1) use continutations so that we use heap space instead of stack space.
970 -- 2) special case for n==5 to build bushier trees.
971 build c 0 xs = c Tip xs
972 build c 5 xs = case xs of
973 ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
974 -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
975 build c n xs = seq nr $ build (buildR nr c) nl xs
980 buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
981 buildB l k x c r zs = c (bin k x l r) zs
985 {--------------------------------------------------------------------
986 Utility functions that return sub-ranges of the original
987 tree. Some functions take a comparison function as argument to
988 allow comparisons against infinite values. A function [cmplo k]
989 should be read as [compare lo k].
991 [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
992 and [cmphi k == GT] for the key [k] of the root.
993 [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
994 [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
996 [split k t] Returns two trees [l] and [r] where all keys
997 in [l] are <[k] and all keys in [r] are >[k].
998 [splitLookup k t] Just like [split] but also returns whether [k]
999 was found in the tree.
1000 --------------------------------------------------------------------}
1002 {--------------------------------------------------------------------
1003 [trim lo hi t] trims away all subtrees that surely contain no
1004 values between the range [lo] to [hi]. The returned tree is either
1005 empty or the key of the root is between @lo@ and @hi@.
1006 --------------------------------------------------------------------}
1007 trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1008 trim cmplo cmphi Tip = Tip
1009 trim cmplo cmphi t@(Bin sx kx x l r)
1011 LT -> case cmphi kx of
1013 le -> trim cmplo cmphi l
1014 ge -> trim cmplo cmphi r
1016 trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a)
1017 trimLookupLo lo cmphi Tip = (Nothing,Tip)
1018 trimLookupLo lo cmphi t@(Bin sx kx x l r)
1019 = case compare lo kx of
1020 LT -> case cmphi kx of
1021 GT -> (lookup lo t, t)
1022 le -> trimLookupLo lo cmphi l
1023 GT -> trimLookupLo lo cmphi r
1024 EQ -> (Just x,trim (compare lo) cmphi r)
1027 {--------------------------------------------------------------------
1028 [filterGt k t] filter all keys >[k] from tree [t]
1029 [filterLt k t] filter all keys <[k] from tree [t]
1030 --------------------------------------------------------------------}
1031 filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1032 filterGt cmp Tip = Tip
1033 filterGt cmp (Bin sx kx x l r)
1035 LT -> join kx x (filterGt cmp l) r
1036 GT -> filterGt cmp r
1039 filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1040 filterLt cmp Tip = Tip
1041 filterLt cmp (Bin sx kx x l r)
1043 LT -> filterLt cmp l
1044 GT -> join kx x l (filterLt cmp r)
1047 {--------------------------------------------------------------------
1049 --------------------------------------------------------------------}
1050 -- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@ where
1051 -- 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@.
1052 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1053 split k Tip = (Tip,Tip)
1054 split k (Bin sx kx x l r)
1055 = case compare k kx of
1056 LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1057 GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1060 -- | /O(log n)/. The expression (@splitLookup k map@) splits a map just
1061 -- like 'split' but also returns @lookup k map@.
1062 splitLookup :: Ord k => k -> Map k a -> (Maybe a,Map k a,Map k a)
1063 splitLookup k Tip = (Nothing,Tip,Tip)
1064 splitLookup k (Bin sx kx x l r)
1065 = case compare k kx of
1066 LT -> let (z,lt,gt) = splitLookup k l in (z,lt,join kx x gt r)
1067 GT -> let (z,lt,gt) = splitLookup k r in (z,join kx x l lt,gt)
1070 {--------------------------------------------------------------------
1071 Utility functions that maintain the balance properties of the tree.
1072 All constructors assume that all values in [l] < [k] and all values
1073 in [r] > [k], and that [l] and [r] are valid trees.
1075 In order of sophistication:
1076 [Bin sz k x l r] The type constructor.
1077 [bin k x l r] Maintains the correct size, assumes that both [l]
1078 and [r] are balanced with respect to each other.
1079 [balance k x l r] Restores the balance and size.
1080 Assumes that the original tree was balanced and
1081 that [l] or [r] has changed by at most one element.
1082 [join k x l r] Restores balance and size.
1084 Furthermore, we can construct a new tree from two trees. Both operations
1085 assume that all values in [l] < all values in [r] and that [l] and [r]
1087 [glue l r] Glues [l] and [r] together. Assumes that [l] and
1088 [r] are already balanced with respect to each other.
1089 [merge l r] Merges two trees and restores balance.
1091 Note: in contrast to Adam's paper, we use (<=) comparisons instead
1092 of (<) comparisons in [join], [merge] and [balance].
1093 Quickcheck (on [difference]) showed that this was necessary in order
1094 to maintain the invariants. It is quite unsatisfactory that I haven't
1095 been able to find out why this is actually the case! Fortunately, it
1096 doesn't hurt to be a bit more conservative.
1097 --------------------------------------------------------------------}
1099 {--------------------------------------------------------------------
1101 --------------------------------------------------------------------}
1102 join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1103 join kx x Tip r = insertMin kx x r
1104 join kx x l Tip = insertMax kx x l
1105 join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1106 | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
1107 | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
1108 | otherwise = bin kx x l r
1111 -- insertMin and insertMax don't perform potentially expensive comparisons.
1112 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1115 Tip -> singleton kx x
1117 -> balance ky y l (insertMax kx x r)
1121 Tip -> singleton kx x
1123 -> balance ky y (insertMin kx x l) r
1125 {--------------------------------------------------------------------
1126 [merge l r]: merges two trees.
1127 --------------------------------------------------------------------}
1128 merge :: Map k a -> Map k a -> Map k a
1131 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1132 | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1133 | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1134 | otherwise = glue l r
1136 {--------------------------------------------------------------------
1137 [glue l r]: glues two trees together.
1138 Assumes that [l] and [r] are already balanced with respect to each other.
1139 --------------------------------------------------------------------}
1140 glue :: Map k a -> Map k a -> Map k a
1144 | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1145 | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
1148 -- | /O(log n)/. Delete and find the minimal element.
1149 deleteFindMin :: Map k a -> ((k,a),Map k a)
1152 Bin _ k x Tip r -> ((k,x),r)
1153 Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1154 Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1156 -- | /O(log n)/. Delete and find the maximal element.
1157 deleteFindMax :: Map k a -> ((k,a),Map k a)
1160 Bin _ k x l Tip -> ((k,x),l)
1161 Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1162 Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1165 {--------------------------------------------------------------------
1166 [balance l x r] balances two trees with value x.
1167 The sizes of the trees should balance after decreasing the
1168 size of one of them. (a rotation).
1170 [delta] is the maximal relative difference between the sizes of
1171 two trees, it corresponds with the [w] in Adams' paper.
1172 [ratio] is the ratio between an outer and inner sibling of the
1173 heavier subtree in an unbalanced setting. It determines
1174 whether a double or single rotation should be performed
1175 to restore balance. It is correspondes with the inverse
1176 of $\alpha$ in Adam's article.
1179 - [delta] should be larger than 4.646 with a [ratio] of 2.
1180 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1182 - A lower [delta] leads to a more 'perfectly' balanced tree.
1183 - A higher [delta] performs less rebalancing.
1185 - Balancing is automaic for random data and a balancing
1186 scheme is only necessary to avoid pathological worst cases.
1187 Almost any choice will do, and in practice, a rather large
1188 [delta] may perform better than smaller one.
1190 Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1191 to decide whether a single or double rotation is needed. Allthough
1192 he actually proves that this ratio is needed to maintain the
1193 invariants, his implementation uses an invalid ratio of [1].
1194 --------------------------------------------------------------------}
1199 balance :: k -> a -> Map k a -> Map k a -> Map k a
1201 | sizeL + sizeR <= 1 = Bin sizeX k x l r
1202 | sizeR >= delta*sizeL = rotateL k x l r
1203 | sizeL >= delta*sizeR = rotateR k x l r
1204 | otherwise = Bin sizeX k x l r
1208 sizeX = sizeL + sizeR + 1
1211 rotateL k x l r@(Bin _ _ _ ly ry)
1212 | size ly < ratio*size ry = singleL k x l r
1213 | otherwise = doubleL k x l r
1215 rotateR k x l@(Bin _ _ _ ly ry) r
1216 | size ry < ratio*size ly = singleR k x l r
1217 | otherwise = doubleR k x l r
1220 singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
1221 singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
1223 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)
1224 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)
1227 {--------------------------------------------------------------------
1228 The bin constructor maintains the size of the tree
1229 --------------------------------------------------------------------}
1230 bin :: k -> a -> Map k a -> Map k a -> Map k a
1232 = Bin (size l + size r + 1) k x l r
1235 {--------------------------------------------------------------------
1236 Eq converts the tree to a list. In a lazy setting, this
1237 actually seems one of the faster methods to compare two trees
1238 and it is certainly the simplest :-)
1239 --------------------------------------------------------------------}
1240 instance (Eq k,Eq a) => Eq (Map k a) where
1241 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1243 {--------------------------------------------------------------------
1245 --------------------------------------------------------------------}
1247 instance (Ord k, Ord v) => Ord (Map k v) where
1248 compare m1 m2 = compare (toList m1) (toList m2)
1250 {--------------------------------------------------------------------
1252 --------------------------------------------------------------------}
1254 instance (Ord k) => Monoid (Map k v) where
1259 {--------------------------------------------------------------------
1261 --------------------------------------------------------------------}
1262 instance Functor (Map k) where
1265 {--------------------------------------------------------------------
1267 --------------------------------------------------------------------}
1268 instance (Show k, Show a) => Show (Map k a) where
1269 showsPrec d m = showMap (toAscList m)
1271 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1275 = showChar '{' . showElem x . showTail xs
1277 showTail [] = showChar '}'
1278 showTail (x:xs) = showChar ',' . showElem x . showTail xs
1280 showElem (k,x) = shows k . showString ":=" . shows x
1283 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1284 -- in a compressed, hanging format.
1285 showTree :: (Show k,Show a) => Map k a -> String
1287 = showTreeWith showElem True False m
1289 showElem k x = show k ++ ":=" ++ show x
1292 {- | /O(n)/. The expression (@showTreeWith showelem hang wide map@) shows
1293 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1294 @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
1295 @wide@ is true, an extra wide version is shown.
1297 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1298 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1305 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1316 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
1328 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
1329 showTreeWith showelem hang wide t
1330 | hang = (showsTreeHang showelem wide [] t) ""
1331 | otherwise = (showsTree showelem wide [] [] t) ""
1333 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1334 showsTree showelem wide lbars rbars t
1336 Tip -> showsBars lbars . showString "|\n"
1338 -> showsBars lbars . showString (showelem kx x) . showString "\n"
1340 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
1341 showWide wide rbars .
1342 showsBars lbars . showString (showelem kx x) . showString "\n" .
1343 showWide wide lbars .
1344 showsTree showelem wide (withEmpty lbars) (withBar lbars) l
1346 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1347 showsTreeHang showelem wide bars t
1349 Tip -> showsBars bars . showString "|\n"
1351 -> showsBars bars . showString (showelem kx x) . showString "\n"
1353 -> showsBars bars . showString (showelem kx x) . showString "\n" .
1354 showWide wide bars .
1355 showsTreeHang showelem wide (withBar bars) l .
1356 showWide wide bars .
1357 showsTreeHang showelem wide (withEmpty bars) r
1361 | wide = showString (concat (reverse bars)) . showString "|\n"
1364 showsBars :: [String] -> ShowS
1368 _ -> showString (concat (reverse (tail bars))) . showString node
1371 withBar bars = "| ":bars
1372 withEmpty bars = " ":bars
1375 {--------------------------------------------------------------------
1377 --------------------------------------------------------------------}
1378 -- | /O(n)/. Test if the internal map structure is valid.
1379 valid :: Ord k => Map k a -> Bool
1381 = balanced t && ordered t && validsize t
1384 = bounded (const True) (const True) t
1389 Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1391 -- | Exported only for "Debug.QuickCheck"
1392 balanced :: Map k a -> Bool
1396 Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1397 balanced l && balanced r
1401 = (realsize t == Just (size t))
1406 Bin sz kx x l r -> case (realsize l,realsize r) of
1407 (Just n,Just m) | n+m+1 == sz -> Just sz
1410 {--------------------------------------------------------------------
1412 --------------------------------------------------------------------}
1416 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1420 {--------------------------------------------------------------------
1422 --------------------------------------------------------------------}
1423 testTree xs = fromList [(x,"*") | x <- xs]
1424 test1 = testTree [1..20]
1425 test2 = testTree [30,29..10]
1426 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1428 {--------------------------------------------------------------------
1430 --------------------------------------------------------------------}
1435 { configMaxTest = 500
1436 , configMaxFail = 5000
1437 , configSize = \n -> (div n 2 + 3)
1438 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1442 {--------------------------------------------------------------------
1443 Arbitrary, reasonably balanced trees
1444 --------------------------------------------------------------------}
1445 instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
1446 arbitrary = sized (arbtree 0 maxkey)
1447 where maxkey = 10000
1449 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
1451 | n <= 0 = return Tip
1452 | lo >= hi = return Tip
1453 | otherwise = do{ x <- arbitrary
1454 ; i <- choose (lo,hi)
1455 ; m <- choose (1,30)
1456 ; let (ml,mr) | m==(1::Int)= (1,2)
1460 ; l <- arbtree lo (i-1) (n `div` ml)
1461 ; r <- arbtree (i+1) hi (n `div` mr)
1462 ; return (bin (toEnum i) x l r)
1466 {--------------------------------------------------------------------
1468 --------------------------------------------------------------------}
1469 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
1471 = forAll arbitrary $ \t ->
1472 -- classify (balanced t) "balanced" $
1473 classify (size t == 0) "empty" $
1474 classify (size t > 0 && size t <= 10) "small" $
1475 classify (size t > 10 && size t <= 64) "medium" $
1476 classify (size t > 64) "large" $
1479 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1483 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1489 = forValidUnitTree $ \t -> valid t
1491 {--------------------------------------------------------------------
1492 Single, Insert, Delete
1493 --------------------------------------------------------------------}
1494 prop_Single :: Int -> Int -> Bool
1496 = (insert k x empty == singleton k x)
1498 prop_InsertValid :: Int -> Property
1500 = forValidUnitTree $ \t -> valid (insert k () t)
1502 prop_InsertDelete :: Int -> Map Int () -> Property
1503 prop_InsertDelete k t
1504 = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1506 prop_DeleteValid :: Int -> Property
1508 = forValidUnitTree $ \t ->
1509 valid (delete k (insert k () t))
1511 {--------------------------------------------------------------------
1513 --------------------------------------------------------------------}
1514 prop_Join :: Int -> Property
1516 = forValidUnitTree $ \t ->
1517 let (l,r) = split k t
1518 in valid (join k () l r)
1520 prop_Merge :: Int -> Property
1522 = forValidUnitTree $ \t ->
1523 let (l,r) = split k t
1524 in valid (merge l r)
1527 {--------------------------------------------------------------------
1529 --------------------------------------------------------------------}
1530 prop_UnionValid :: Property
1532 = forValidUnitTree $ \t1 ->
1533 forValidUnitTree $ \t2 ->
1536 prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
1537 prop_UnionInsert k x t
1538 = union (singleton k x) t == insert k x t
1540 prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
1541 prop_UnionAssoc t1 t2 t3
1542 = union t1 (union t2 t3) == union (union t1 t2) t3
1544 prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
1545 prop_UnionComm t1 t2
1546 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1549 = forValidIntTree $ \t1 ->
1550 forValidIntTree $ \t2 ->
1551 valid (unionWithKey (\k x y -> x+y) t1 t2)
1553 prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
1554 prop_UnionWith xs ys
1555 = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
1556 == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
1559 = forValidUnitTree $ \t1 ->
1560 forValidUnitTree $ \t2 ->
1561 valid (difference t1 t2)
1563 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1565 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1566 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1569 = forValidUnitTree $ \t1 ->
1570 forValidUnitTree $ \t2 ->
1571 valid (intersection t1 t2)
1573 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1575 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1576 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1578 {--------------------------------------------------------------------
1580 --------------------------------------------------------------------}
1582 = forAll (choose (5,100)) $ \n ->
1583 let xs = [(x,()) | x <- [0..n::Int]]
1584 in fromAscList xs == fromList xs
1586 prop_List :: [Int] -> Bool
1588 = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])