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
157 import qualified Prelude
158 import qualified List
159 import Debug.QuickCheck
160 import List(nub,sort)
163 {--------------------------------------------------------------------
165 --------------------------------------------------------------------}
168 -- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found.
169 (!) :: Ord k => Map k a -> k -> a
172 -- | /O(n+m)/. See 'difference'.
173 (\\) :: Ord k => Map k a -> Map k b -> Map k a
174 m1 \\ m2 = difference m1 m2
176 {--------------------------------------------------------------------
178 --------------------------------------------------------------------}
179 -- | A Map from keys @k@ to values @a@.
181 | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
185 {--------------------------------------------------------------------
187 --------------------------------------------------------------------}
188 -- | /O(1)/. Is the map empty?
189 null :: Map k a -> Bool
193 Bin sz k x l r -> False
195 -- | /O(1)/. The number of elements in the map.
196 size :: Map k a -> Int
203 -- | /O(log n)/. Lookup the value of key in the map.
204 lookup :: Ord k => k -> Map k a -> Maybe a
209 -> case compare k kx of
214 -- | /O(log n)/. Is the key a member of the map?
215 member :: Ord k => k -> Map k a -> Bool
221 -- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found.
222 find :: Ord k => k -> Map k a -> a
225 Nothing -> error "Map.find: element not in the map"
228 -- | /O(log n)/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when
229 -- the key is not in the map.
230 findWithDefault :: Ord k => a -> k -> Map k a -> a
231 findWithDefault def k m
238 {--------------------------------------------------------------------
240 --------------------------------------------------------------------}
241 -- | /O(1)/. The empty map.
246 -- | /O(1)/. Create a map with a single element.
247 singleton :: k -> a -> Map k a
251 {--------------------------------------------------------------------
253 [insert] is the inlined version of [insertWith (\k x y -> x)]
254 --------------------------------------------------------------------}
255 -- | /O(log n)/. Insert a new key and value in the map.
256 insert :: Ord k => k -> a -> Map k a -> Map k a
259 Tip -> singleton kx x
261 -> case compare kx ky of
262 LT -> balance ky y (insert kx x l) r
263 GT -> balance ky y l (insert kx x r)
264 EQ -> Bin sz kx x l r
266 -- | /O(log n)/. Insert with a combining function.
267 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
269 = insertWithKey (\k x y -> f x y) k x m
271 -- | /O(log n)/. Insert with a combining function.
272 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
273 insertWithKey f kx x t
275 Tip -> singleton kx x
277 -> case compare kx ky of
278 LT -> balance ky y (insertWithKey f kx x l) r
279 GT -> balance ky y l (insertWithKey f kx x r)
280 EQ -> Bin sy ky (f ky x y) l r
282 -- | /O(log n)/. The expression (@insertLookupWithKey f k x map@) is a pair where
283 -- the first element is equal to (@lookup k map@) and the second element
284 -- equal to (@insertWithKey f k x map@).
285 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
286 insertLookupWithKey f kx x t
288 Tip -> (Nothing, singleton kx x)
290 -> case compare kx ky of
291 LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
292 GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
293 EQ -> (Just y, Bin sy ky (f ky x y) l r)
295 {--------------------------------------------------------------------
297 [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
298 --------------------------------------------------------------------}
299 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
300 -- a member of the map, the original map is returned.
301 delete :: Ord k => k -> Map k a -> Map k a
306 -> case compare k kx of
307 LT -> balance kx x (delete k l) r
308 GT -> balance kx x l (delete k r)
311 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
312 -- a member of the map, the original map is returned.
313 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
315 = adjustWithKey (\k x -> f x) k m
317 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
318 -- a member of the map, the original map is returned.
319 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
321 = updateWithKey (\k x -> Just (f k x)) k m
323 -- | /O(log n)/. The expression (@update f k map@) updates the value @x@
324 -- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is
325 -- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
326 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
328 = updateWithKey (\k x -> f x) k m
330 -- | /O(log n)/. The expression (@update f k map@) updates the value @x@
331 -- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is
332 -- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
333 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
338 -> case compare k kx of
339 LT -> balance kx x (updateWithKey f k l) r
340 GT -> balance kx x l (updateWithKey f k r)
342 Just x' -> Bin sx kx x' l r
345 -- | /O(log n)/. Lookup and update.
346 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
347 updateLookupWithKey f k t
351 -> case compare k kx of
352 LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
353 GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
355 Just x' -> (Just x',Bin sx kx x' l r)
356 Nothing -> (Just x,glue l r)
358 {--------------------------------------------------------------------
360 --------------------------------------------------------------------}
361 -- | /O(log n)/. Return the /index/ of a key. The index is a number from
362 -- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
363 -- the key is not a 'member' of the map.
364 findIndex :: Ord k => k -> Map k a -> Int
366 = case lookupIndex k t of
367 Nothing -> error "Map.findIndex: element is not in the map"
370 -- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
371 -- /0/ up to, but not including, the 'size' of the map.
372 lookupIndex :: Ord k => k -> Map k a -> Maybe Int
376 lookup idx Tip = Nothing
377 lookup idx (Bin _ kx x l r)
378 = case compare k kx of
380 GT -> lookup (idx + size l + 1) r
381 EQ -> Just (idx + size l)
383 -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
384 -- invalid index is used.
385 elemAt :: Int -> Map k a -> (k,a)
386 elemAt i Tip = error "Map.elemAt: index out of range"
387 elemAt i (Bin _ kx x l r)
388 = case compare i sizeL of
390 GT -> elemAt (i-sizeL-1) r
395 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
396 -- invalid index is used.
397 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
398 updateAt f i Tip = error "Map.updateAt: index out of range"
399 updateAt f i (Bin sx kx x l r)
400 = case compare i sizeL of
402 GT -> updateAt f (i-sizeL-1) r
404 Just x' -> Bin sx kx x' l r
409 -- | /O(log n)/. Delete the element at /index/. Defined as (@deleteAt i map = updateAt (\k x -> Nothing) i map@).
410 deleteAt :: Int -> Map k a -> Map k a
412 = updateAt (\k x -> Nothing) i map
415 {--------------------------------------------------------------------
417 --------------------------------------------------------------------}
418 -- | /O(log n)/. The minimal key of the map.
419 findMin :: Map k a -> (k,a)
420 findMin (Bin _ kx x Tip r) = (kx,x)
421 findMin (Bin _ kx x l r) = findMin l
422 findMin Tip = error "Map.findMin: empty tree has no minimal element"
424 -- | /O(log n)/. The maximal key of the map.
425 findMax :: Map k a -> (k,a)
426 findMax (Bin _ kx x l Tip) = (kx,x)
427 findMax (Bin _ kx x l r) = findMax r
428 findMax Tip = error "Map.findMax: empty tree has no maximal element"
430 -- | /O(log n)/. Delete the minimal key.
431 deleteMin :: Map k a -> Map k a
432 deleteMin (Bin _ kx x Tip r) = r
433 deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
436 -- | /O(log n)/. Delete the maximal key.
437 deleteMax :: Map k a -> Map k a
438 deleteMax (Bin _ kx x l Tip) = l
439 deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
442 -- | /O(log n)/. Update the minimal key.
443 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
445 = updateMinWithKey (\k x -> f x) m
447 -- | /O(log n)/. Update the maximal key.
448 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
450 = updateMaxWithKey (\k x -> f x) m
453 -- | /O(log n)/. Update the minimal key.
454 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
457 Bin sx kx x Tip r -> case f kx x of
459 Just x' -> Bin sx kx x' Tip r
460 Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
463 -- | /O(log n)/. Update the maximal key.
464 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
467 Bin sx kx x l Tip -> case f kx x of
469 Just x' -> Bin sx kx x' l Tip
470 Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
474 {--------------------------------------------------------------------
476 --------------------------------------------------------------------}
477 -- | The union of a list of maps: (@unions == foldl union empty@).
478 unions :: Ord k => [Map k a] -> Map k a
480 = foldlStrict union empty ts
482 -- | The union of a list of maps, with a combining operation:
483 -- (@unionsWith f == foldl (unionWith f) empty@).
484 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
486 = foldlStrict (unionWith f) empty ts
489 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
490 -- It prefers @t1@ when duplicate keys are encountered, ie. (@union == unionWith const@).
491 -- The implementation uses the efficient /hedge-union/ algorithm.
492 -- Hedge-union is more efficient on (bigset `union` smallset)?
493 union :: Ord k => Map k a -> Map k a -> Map k a
497 | size t1 >= size t2 = hedgeUnionL (const LT) (const GT) t1 t2
498 | otherwise = hedgeUnionR (const LT) (const GT) t2 t1
500 -- left-biased hedge union
501 hedgeUnionL cmplo cmphi t1 Tip
503 hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
504 = join kx x (filterGt cmplo l) (filterLt cmphi r)
505 hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
506 = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
507 (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
509 cmpkx k = compare kx k
511 -- right-biased hedge union
512 hedgeUnionR cmplo cmphi t1 Tip
514 hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
515 = join kx x (filterGt cmplo l) (filterLt cmphi r)
516 hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
517 = join kx newx (hedgeUnionR cmplo cmpkx l lt)
518 (hedgeUnionR cmpkx cmphi r gt)
520 cmpkx k = compare kx k
521 lt = trim cmplo cmpkx t2
522 (found,gt) = trimLookupLo kx cmphi t2
527 {--------------------------------------------------------------------
528 Union with a combining function
529 --------------------------------------------------------------------}
530 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
531 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
533 = unionWithKey (\k x y -> f x y) m1 m2
536 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
537 -- Hedge-union is more efficient on (bigset `union` smallset).
538 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
539 unionWithKey f Tip t2 = t2
540 unionWithKey f t1 Tip = t1
542 | size t1 >= size t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
543 | otherwise = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1
545 flipf k x y = f k y x
547 hedgeUnionWithKey f cmplo cmphi t1 Tip
549 hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
550 = join kx x (filterGt cmplo l) (filterLt cmphi r)
551 hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
552 = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
553 (hedgeUnionWithKey f cmpkx cmphi r gt)
555 cmpkx k = compare kx k
556 lt = trim cmplo cmpkx t2
557 (found,gt) = trimLookupLo kx cmphi t2
562 {--------------------------------------------------------------------
564 --------------------------------------------------------------------}
565 -- | /O(n+m)/. Difference of two maps.
566 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
567 difference :: Ord k => Map k a -> Map k b -> Map k a
568 difference Tip t2 = Tip
569 difference t1 Tip = t1
570 difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
572 hedgeDiff cmplo cmphi Tip t
574 hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
575 = join kx x (filterGt cmplo l) (filterLt cmphi r)
576 hedgeDiff cmplo cmphi t (Bin _ kx x l r)
577 = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
578 (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
580 cmpkx k = compare kx k
582 -- | /O(n+m)/. Difference with a combining function.
583 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
584 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
585 differenceWith f m1 m2
586 = differenceWithKey (\k x y -> f x y) m1 m2
588 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
589 -- encountered, the combining function is applied to the key and both values.
590 -- If it returns @Nothing@, the element is discarded (proper set difference). If
591 -- it returns (@Just y@), the element is updated with a new value @y@.
592 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
593 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
594 differenceWithKey f Tip t2 = Tip
595 differenceWithKey f t1 Tip = t1
596 differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
598 hedgeDiffWithKey f cmplo cmphi Tip t
600 hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
601 = join kx x (filterGt cmplo l) (filterLt cmphi r)
602 hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
604 Nothing -> merge tl tr
605 Just y -> case f kx y x of
606 Nothing -> merge tl tr
607 Just z -> join kx z tl tr
609 cmpkx k = compare kx k
610 lt = trim cmplo cmpkx t
611 (found,gt) = trimLookupLo kx cmphi t
612 tl = hedgeDiffWithKey f cmplo cmpkx lt l
613 tr = hedgeDiffWithKey f cmpkx cmphi gt r
617 {--------------------------------------------------------------------
619 --------------------------------------------------------------------}
620 -- | /O(n+m)/. Intersection of two maps. The values in the first
621 -- map are returned, i.e. (@intersection m1 m2 == intersectionWith const m1 m2@).
622 intersection :: Ord k => Map k a -> Map k b -> Map k a
624 = intersectionWithKey (\k x y -> x) m1 m2
626 -- | /O(n+m)/. Intersection with a combining function.
627 intersectionWith :: Ord k => (a -> b -> a) -> Map k a -> Map k b -> Map k a
628 intersectionWith f m1 m2
629 = intersectionWithKey (\k x y -> f x y) m1 m2
631 -- | /O(n+m)/. Intersection with a combining function.
632 -- Intersection is more efficient on (bigset `intersection` smallset)
633 intersectionWithKey :: Ord k => (k -> a -> b -> a) -> Map k a -> Map k b -> Map k a
634 intersectionWithKey f Tip t = Tip
635 intersectionWithKey f t Tip = Tip
636 intersectionWithKey f t1 t2
637 | size t1 >= size t2 = intersectWithKey f t1 t2
638 | otherwise = intersectWithKey flipf t2 t1
640 flipf k x y = f k y x
642 intersectWithKey f Tip t = Tip
643 intersectWithKey f t Tip = Tip
644 intersectWithKey f t (Bin _ kx x l r)
646 Nothing -> merge tl tr
647 Just y -> join kx (f kx y x) tl tr
649 (found,lt,gt) = splitLookup kx t
650 tl = intersectWithKey f lt l
651 tr = intersectWithKey f gt r
655 {--------------------------------------------------------------------
657 --------------------------------------------------------------------}
659 -- This function is defined as (@submap = submapBy (==)@).
660 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
662 = isSubmapOfBy (==) m1 m2
665 The expression (@isSubmapOfBy f t1 t2@) returns @True@ if
666 all keys in @t1@ are in tree @t2@, and when @f@ returns @True@ when
667 applied to their respective values. For example, the following
668 expressions are all @True@.
670 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
671 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
672 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
674 But the following are all @False@:
676 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
677 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
678 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
680 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
682 = (size t1 <= size t2) && (submap' f t1 t2)
684 submap' f Tip t = True
685 submap' f t Tip = False
686 submap' f (Bin _ kx x l r) t
689 Just y -> f x y && submap' f l lt && submap' f r gt
691 (found,lt,gt) = splitLookup kx t
693 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
694 -- Defined as (@isProperSubmapOf = isProperSubmapOfBy (==)@).
695 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
696 isProperSubmapOf m1 m2
697 = isProperSubmapOfBy (==) m1 m2
699 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
700 The expression (@isProperSubmapOfBy f m1 m2@) returns @True@ when
701 @m1@ and @m2@ are not equal,
702 all keys in @m1@ are in @m2@, and when @f@ returns @True@ when
703 applied to their respective values. For example, the following
704 expressions are all @True@.
706 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
707 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
709 But the following are all @False@:
711 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
712 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
713 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
715 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
716 isProperSubmapOfBy f t1 t2
717 = (size t1 < size t2) && (submap' f t1 t2)
719 {--------------------------------------------------------------------
721 --------------------------------------------------------------------}
722 -- | /O(n)/. Filter all values that satisfy the predicate.
723 filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
725 = filterWithKey (\k x -> p x) m
727 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
728 filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
729 filterWithKey p Tip = Tip
730 filterWithKey p (Bin _ kx x l r)
731 | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
732 | otherwise = merge (filterWithKey p l) (filterWithKey p r)
735 -- | /O(n)/. partition the map according to a predicate. The first
736 -- map contains all elements that satisfy the predicate, the second all
737 -- elements that fail the predicate. See also 'split'.
738 partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
740 = partitionWithKey (\k x -> p x) m
742 -- | /O(n)/. partition the map according to a predicate. The first
743 -- map contains all elements that satisfy the predicate, the second all
744 -- elements that fail the predicate. See also 'split'.
745 partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
746 partitionWithKey p Tip = (Tip,Tip)
747 partitionWithKey p (Bin _ kx x l r)
748 | p kx x = (join kx x l1 r1,merge l2 r2)
749 | otherwise = (merge l1 r1,join kx x l2 r2)
751 (l1,l2) = partitionWithKey p l
752 (r1,r2) = partitionWithKey p r
755 {--------------------------------------------------------------------
757 --------------------------------------------------------------------}
758 -- | /O(n)/. Map a function over all values in the map.
759 map :: (a -> b) -> Map k a -> Map k b
761 = mapWithKey (\k x -> f x) m
763 -- | /O(n)/. Map a function over all values in the map.
764 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
765 mapWithKey f Tip = Tip
766 mapWithKey f (Bin sx kx x l r)
767 = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
769 -- | /O(n)/. The function @mapAccum@ threads an accumulating
770 -- argument through the map in an unspecified order.
771 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
773 = mapAccumWithKey (\a k x -> f a x) a m
775 -- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating
776 -- argument through the map in unspecified order. (= ascending pre-order)
777 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
778 mapAccumWithKey f a t
781 -- | /O(n)/. The function @mapAccumL@ threads an accumulating
782 -- argument throught the map in (ascending) pre-order.
783 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
788 -> let (a1,l') = mapAccumL f a l
790 (a3,r') = mapAccumL f a2 r
791 in (a3,Bin sx kx x' l' r')
793 -- | /O(n)/. The function @mapAccumR@ threads an accumulating
794 -- argument throught the map in (descending) post-order.
795 mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
800 -> let (a1,r') = mapAccumR f a r
802 (a3,l') = mapAccumR f a2 l
803 in (a3,Bin sx kx x' l' r')
806 -- @mapKeys f s@ is the map obtained by applying @f@ to each key of @s@.
808 -- It's worth noting that the size of the result may be smaller if,
809 -- for some @(x,y)@, @x \/= y && f x == f y@
811 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
812 mapKeys = mapKeysWith (\x y->x)
815 -- @mapKeysWith c f s@ is the map obtained by applying @f@ to each key of @s@.
817 -- It's worth noting that the size of the result may be smaller if,
818 -- for some @(x,y)@, @x \/= y && f x == f y@
819 -- In such a case, the values will be combined using @c@
821 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
822 mapKeysWith c f = fromListWith c . List.map fFirst . toList
823 where fFirst (x,y) = (f x, y)
828 -- @mapMonotonic f s == 'map' f s@, but works only when @f@ is monotonic.
829 -- /The precondition is not checked./
830 -- Semi-formally, we have:
832 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
833 -- > ==> mapMonotonic f s == map f s
834 -- > where ls = keys s
836 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
837 mapKeysMonotonic f Tip = Tip
838 mapKeysMonotonic f (Bin sz k x l r) =
839 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
841 {--------------------------------------------------------------------
843 --------------------------------------------------------------------}
844 -- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).
845 fold :: (a -> b -> b) -> b -> Map k a -> b
847 = foldWithKey (\k x z -> f x z) z m
849 -- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).
850 foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
854 -- | /O(n)/. In-order fold.
855 foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
857 foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
859 -- | /O(n)/. Post-order fold.
860 foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
862 foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
864 -- | /O(n)/. Pre-order fold.
865 foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
867 foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
869 {--------------------------------------------------------------------
871 --------------------------------------------------------------------}
872 -- | /O(n)/. Return all elements of the map.
873 elems :: Map k a -> [a]
875 = [x | (k,x) <- assocs m]
877 -- | /O(n)/. Return all keys of the map.
878 keys :: Map k a -> [k]
880 = [k | (k,x) <- assocs m]
882 -- | /O(n)/. The set of all keys of the map.
883 keysSet :: Map k a -> Set.Set k
884 keysSet m = Set.fromDistinctAscList (keys m)
886 -- | /O(n)/. Return all key\/value pairs in the map.
887 assocs :: Map k a -> [(k,a)]
891 {--------------------------------------------------------------------
893 use [foldlStrict] to reduce demand on the control-stack
894 --------------------------------------------------------------------}
895 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
896 fromList :: Ord k => [(k,a)] -> Map k a
898 = foldlStrict ins empty xs
900 ins t (k,x) = insert k x t
902 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
903 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
905 = fromListWithKey (\k x y -> f x y) xs
907 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
908 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
910 = foldlStrict ins empty xs
912 ins t (k,x) = insertWithKey f k x t
914 -- | /O(n)/. Convert to a list of key\/value pairs.
915 toList :: Map k a -> [(k,a)]
916 toList t = toAscList t
918 -- | /O(n)/. Convert to an ascending list.
919 toAscList :: Map k a -> [(k,a)]
920 toAscList t = foldr (\k x xs -> (k,x):xs) [] t
923 toDescList :: Map k a -> [(k,a)]
924 toDescList t = foldl (\xs k x -> (k,x):xs) [] t
927 {--------------------------------------------------------------------
928 Building trees from ascending/descending lists can be done in linear time.
930 Note that if [xs] is ascending that:
931 fromAscList xs == fromList xs
932 fromAscListWith f xs == fromListWith f xs
933 --------------------------------------------------------------------}
934 -- | /O(n)/. Build a map from an ascending list in linear time.
935 -- /The precondition (input list is ascending) is not checked./
936 fromAscList :: Eq k => [(k,a)] -> Map k a
938 = fromAscListWithKey (\k x y -> x) xs
940 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
941 -- /The precondition (input list is ascending) is not checked./
942 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
944 = fromAscListWithKey (\k x y -> f x y) xs
946 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys
947 -- /The precondition (input list is ascending) is not checked./
948 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
949 fromAscListWithKey f xs
950 = fromDistinctAscList (combineEq f xs)
952 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
957 (x:xx) -> combineEq' x xx
959 combineEq' z [] = [z]
960 combineEq' z@(kz,zz) (x@(kx,xx):xs)
961 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
962 | otherwise = z:combineEq' x xs
965 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
967 -- /The precondition is not checked./
968 fromDistinctAscList :: [(k,a)] -> Map k a
969 fromDistinctAscList xs
970 = build const (length xs) xs
972 -- 1) use continutations so that we use heap space instead of stack space.
973 -- 2) special case for n==5 to build bushier trees.
974 build c 0 xs = c Tip xs
975 build c 5 xs = case xs of
976 ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
977 -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
978 build c n xs = seq nr $ build (buildR nr c) nl xs
983 buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
984 buildB l k x c r zs = c (bin k x l r) zs
988 {--------------------------------------------------------------------
989 Utility functions that return sub-ranges of the original
990 tree. Some functions take a comparison function as argument to
991 allow comparisons against infinite values. A function [cmplo k]
992 should be read as [compare lo k].
994 [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
995 and [cmphi k == GT] for the key [k] of the root.
996 [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
997 [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
999 [split k t] Returns two trees [l] and [r] where all keys
1000 in [l] are <[k] and all keys in [r] are >[k].
1001 [splitLookup k t] Just like [split] but also returns whether [k]
1002 was found in the tree.
1003 --------------------------------------------------------------------}
1005 {--------------------------------------------------------------------
1006 [trim lo hi t] trims away all subtrees that surely contain no
1007 values between the range [lo] to [hi]. The returned tree is either
1008 empty or the key of the root is between @lo@ and @hi@.
1009 --------------------------------------------------------------------}
1010 trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1011 trim cmplo cmphi Tip = Tip
1012 trim cmplo cmphi t@(Bin sx kx x l r)
1014 LT -> case cmphi kx of
1016 le -> trim cmplo cmphi l
1017 ge -> trim cmplo cmphi r
1019 trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a)
1020 trimLookupLo lo cmphi Tip = (Nothing,Tip)
1021 trimLookupLo lo cmphi t@(Bin sx kx x l r)
1022 = case compare lo kx of
1023 LT -> case cmphi kx of
1024 GT -> (lookup lo t, t)
1025 le -> trimLookupLo lo cmphi l
1026 GT -> trimLookupLo lo cmphi r
1027 EQ -> (Just x,trim (compare lo) cmphi r)
1030 {--------------------------------------------------------------------
1031 [filterGt k t] filter all keys >[k] from tree [t]
1032 [filterLt k t] filter all keys <[k] from tree [t]
1033 --------------------------------------------------------------------}
1034 filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1035 filterGt cmp Tip = Tip
1036 filterGt cmp (Bin sx kx x l r)
1038 LT -> join kx x (filterGt cmp l) r
1039 GT -> filterGt cmp r
1042 filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1043 filterLt cmp Tip = Tip
1044 filterLt cmp (Bin sx kx x l r)
1046 LT -> filterLt cmp l
1047 GT -> join kx x l (filterLt cmp r)
1050 {--------------------------------------------------------------------
1052 --------------------------------------------------------------------}
1053 -- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@ where
1054 -- 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@.
1055 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1056 split k Tip = (Tip,Tip)
1057 split k (Bin sx kx x l r)
1058 = case compare k kx of
1059 LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1060 GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1063 -- | /O(log n)/. The expression (@splitLookup k map@) splits a map just
1064 -- like 'split' but also returns @lookup k map@.
1065 splitLookup :: Ord k => k -> Map k a -> (Maybe a,Map k a,Map k a)
1066 splitLookup k Tip = (Nothing,Tip,Tip)
1067 splitLookup k (Bin sx kx x l r)
1068 = case compare k kx of
1069 LT -> let (z,lt,gt) = splitLookup k l in (z,lt,join kx x gt r)
1070 GT -> let (z,lt,gt) = splitLookup k r in (z,join kx x l lt,gt)
1073 {--------------------------------------------------------------------
1074 Utility functions that maintain the balance properties of the tree.
1075 All constructors assume that all values in [l] < [k] and all values
1076 in [r] > [k], and that [l] and [r] are valid trees.
1078 In order of sophistication:
1079 [Bin sz k x l r] The type constructor.
1080 [bin k x l r] Maintains the correct size, assumes that both [l]
1081 and [r] are balanced with respect to each other.
1082 [balance k x l r] Restores the balance and size.
1083 Assumes that the original tree was balanced and
1084 that [l] or [r] has changed by at most one element.
1085 [join k x l r] Restores balance and size.
1087 Furthermore, we can construct a new tree from two trees. Both operations
1088 assume that all values in [l] < all values in [r] and that [l] and [r]
1090 [glue l r] Glues [l] and [r] together. Assumes that [l] and
1091 [r] are already balanced with respect to each other.
1092 [merge l r] Merges two trees and restores balance.
1094 Note: in contrast to Adam's paper, we use (<=) comparisons instead
1095 of (<) comparisons in [join], [merge] and [balance].
1096 Quickcheck (on [difference]) showed that this was necessary in order
1097 to maintain the invariants. It is quite unsatisfactory that I haven't
1098 been able to find out why this is actually the case! Fortunately, it
1099 doesn't hurt to be a bit more conservative.
1100 --------------------------------------------------------------------}
1102 {--------------------------------------------------------------------
1104 --------------------------------------------------------------------}
1105 join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1106 join kx x Tip r = insertMin kx x r
1107 join kx x l Tip = insertMax kx x l
1108 join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1109 | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
1110 | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
1111 | otherwise = bin kx x l r
1114 -- insertMin and insertMax don't perform potentially expensive comparisons.
1115 insertMax,insertMin :: k -> a -> Map k a -> Map k a
1118 Tip -> singleton kx x
1120 -> balance ky y l (insertMax kx x r)
1124 Tip -> singleton kx x
1126 -> balance ky y (insertMin kx x l) r
1128 {--------------------------------------------------------------------
1129 [merge l r]: merges two trees.
1130 --------------------------------------------------------------------}
1131 merge :: Map k a -> Map k a -> Map k a
1134 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1135 | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1136 | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1137 | otherwise = glue l r
1139 {--------------------------------------------------------------------
1140 [glue l r]: glues two trees together.
1141 Assumes that [l] and [r] are already balanced with respect to each other.
1142 --------------------------------------------------------------------}
1143 glue :: Map k a -> Map k a -> Map k a
1147 | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1148 | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
1151 -- | /O(log n)/. Delete and find the minimal element.
1152 deleteFindMin :: Map k a -> ((k,a),Map k a)
1155 Bin _ k x Tip r -> ((k,x),r)
1156 Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1157 Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1159 -- | /O(log n)/. Delete and find the maximal element.
1160 deleteFindMax :: Map k a -> ((k,a),Map k a)
1163 Bin _ k x l Tip -> ((k,x),l)
1164 Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1165 Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1168 {--------------------------------------------------------------------
1169 [balance l x r] balances two trees with value x.
1170 The sizes of the trees should balance after decreasing the
1171 size of one of them. (a rotation).
1173 [delta] is the maximal relative difference between the sizes of
1174 two trees, it corresponds with the [w] in Adams' paper.
1175 [ratio] is the ratio between an outer and inner sibling of the
1176 heavier subtree in an unbalanced setting. It determines
1177 whether a double or single rotation should be performed
1178 to restore balance. It is correspondes with the inverse
1179 of $\alpha$ in Adam's article.
1182 - [delta] should be larger than 4.646 with a [ratio] of 2.
1183 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1185 - A lower [delta] leads to a more 'perfectly' balanced tree.
1186 - A higher [delta] performs less rebalancing.
1188 - Balancing is automaic for random data and a balancing
1189 scheme is only necessary to avoid pathological worst cases.
1190 Almost any choice will do, and in practice, a rather large
1191 [delta] may perform better than smaller one.
1193 Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1194 to decide whether a single or double rotation is needed. Allthough
1195 he actually proves that this ratio is needed to maintain the
1196 invariants, his implementation uses an invalid ratio of [1].
1197 --------------------------------------------------------------------}
1202 balance :: k -> a -> Map k a -> Map k a -> Map k a
1204 | sizeL + sizeR <= 1 = Bin sizeX k x l r
1205 | sizeR >= delta*sizeL = rotateL k x l r
1206 | sizeL >= delta*sizeR = rotateR k x l r
1207 | otherwise = Bin sizeX k x l r
1211 sizeX = sizeL + sizeR + 1
1214 rotateL k x l r@(Bin _ _ _ ly ry)
1215 | size ly < ratio*size ry = singleL k x l r
1216 | otherwise = doubleL k x l r
1218 rotateR k x l@(Bin _ _ _ ly ry) r
1219 | size ry < ratio*size ly = singleR k x l r
1220 | otherwise = doubleR k x l r
1223 singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
1224 singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
1226 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)
1227 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)
1230 {--------------------------------------------------------------------
1231 The bin constructor maintains the size of the tree
1232 --------------------------------------------------------------------}
1233 bin :: k -> a -> Map k a -> Map k a -> Map k a
1235 = Bin (size l + size r + 1) k x l r
1238 {--------------------------------------------------------------------
1239 Eq converts the tree to a list. In a lazy setting, this
1240 actually seems one of the faster methods to compare two trees
1241 and it is certainly the simplest :-)
1242 --------------------------------------------------------------------}
1243 instance (Eq k,Eq a) => Eq (Map k a) where
1244 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1246 {--------------------------------------------------------------------
1248 --------------------------------------------------------------------}
1250 instance (Ord k, Ord v) => Ord (Map k v) where
1251 compare m1 m2 = compare (toList m1) (toList m2)
1253 {--------------------------------------------------------------------
1255 --------------------------------------------------------------------}
1257 instance (Ord k) => Monoid (Map k v) where
1262 {--------------------------------------------------------------------
1264 --------------------------------------------------------------------}
1265 instance Functor (Map k) where
1268 {--------------------------------------------------------------------
1270 --------------------------------------------------------------------}
1271 instance (Show k, Show a) => Show (Map k a) where
1272 showsPrec d m = showMap (toAscList m)
1274 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1278 = showChar '{' . showElem x . showTail xs
1280 showTail [] = showChar '}'
1281 showTail (x:xs) = showChar ',' . showElem x . showTail xs
1283 showElem (k,x) = shows k . showString ":=" . shows x
1286 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1287 -- in a compressed, hanging format.
1288 showTree :: (Show k,Show a) => Map k a -> String
1290 = showTreeWith showElem True False m
1292 showElem k x = show k ++ ":=" ++ show x
1295 {- | /O(n)/. The expression (@showTreeWith showelem hang wide map@) shows
1296 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1297 @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
1298 @wide@ is true, an extra wide version is shown.
1300 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1301 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1308 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
1319 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
1331 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
1332 showTreeWith showelem hang wide t
1333 | hang = (showsTreeHang showelem wide [] t) ""
1334 | otherwise = (showsTree showelem wide [] [] t) ""
1336 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
1337 showsTree showelem wide lbars rbars t
1339 Tip -> showsBars lbars . showString "|\n"
1341 -> showsBars lbars . showString (showelem kx x) . showString "\n"
1343 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
1344 showWide wide rbars .
1345 showsBars lbars . showString (showelem kx x) . showString "\n" .
1346 showWide wide lbars .
1347 showsTree showelem wide (withEmpty lbars) (withBar lbars) l
1349 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
1350 showsTreeHang showelem wide bars t
1352 Tip -> showsBars bars . showString "|\n"
1354 -> showsBars bars . showString (showelem kx x) . showString "\n"
1356 -> showsBars bars . showString (showelem kx x) . showString "\n" .
1357 showWide wide bars .
1358 showsTreeHang showelem wide (withBar bars) l .
1359 showWide wide bars .
1360 showsTreeHang showelem wide (withEmpty bars) r
1364 | wide = showString (concat (reverse bars)) . showString "|\n"
1367 showsBars :: [String] -> ShowS
1371 _ -> showString (concat (reverse (tail bars))) . showString node
1374 withBar bars = "| ":bars
1375 withEmpty bars = " ":bars
1378 {--------------------------------------------------------------------
1380 --------------------------------------------------------------------}
1381 -- | /O(n)/. Test if the internal map structure is valid.
1382 valid :: Ord k => Map k a -> Bool
1384 = balanced t && ordered t && validsize t
1387 = bounded (const True) (const True) t
1392 Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
1394 -- | Exported only for "Debug.QuickCheck"
1395 balanced :: Map k a -> Bool
1399 Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
1400 balanced l && balanced r
1404 = (realsize t == Just (size t))
1409 Bin sz kx x l r -> case (realsize l,realsize r) of
1410 (Just n,Just m) | n+m+1 == sz -> Just sz
1413 {--------------------------------------------------------------------
1415 --------------------------------------------------------------------}
1419 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1423 {--------------------------------------------------------------------
1425 --------------------------------------------------------------------}
1426 testTree xs = fromList [(x,"*") | x <- xs]
1427 test1 = testTree [1..20]
1428 test2 = testTree [30,29..10]
1429 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1431 {--------------------------------------------------------------------
1433 --------------------------------------------------------------------}
1438 { configMaxTest = 500
1439 , configMaxFail = 5000
1440 , configSize = \n -> (div n 2 + 3)
1441 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1445 {--------------------------------------------------------------------
1446 Arbitrary, reasonably balanced trees
1447 --------------------------------------------------------------------}
1448 instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
1449 arbitrary = sized (arbtree 0 maxkey)
1450 where maxkey = 10000
1452 arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
1454 | n <= 0 = return Tip
1455 | lo >= hi = return Tip
1456 | otherwise = do{ x <- arbitrary
1457 ; i <- choose (lo,hi)
1458 ; m <- choose (1,30)
1459 ; let (ml,mr) | m==(1::Int)= (1,2)
1463 ; l <- arbtree lo (i-1) (n `div` ml)
1464 ; r <- arbtree (i+1) hi (n `div` mr)
1465 ; return (bin (toEnum i) x l r)
1469 {--------------------------------------------------------------------
1471 --------------------------------------------------------------------}
1472 forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
1474 = forAll arbitrary $ \t ->
1475 -- classify (balanced t) "balanced" $
1476 classify (size t == 0) "empty" $
1477 classify (size t > 0 && size t <= 10) "small" $
1478 classify (size t > 10 && size t <= 64) "medium" $
1479 classify (size t > 64) "large" $
1482 forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
1486 forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
1492 = forValidUnitTree $ \t -> valid t
1494 {--------------------------------------------------------------------
1495 Single, Insert, Delete
1496 --------------------------------------------------------------------}
1497 prop_Single :: Int -> Int -> Bool
1499 = (insert k x empty == singleton k x)
1501 prop_InsertValid :: Int -> Property
1503 = forValidUnitTree $ \t -> valid (insert k () t)
1505 prop_InsertDelete :: Int -> Map Int () -> Property
1506 prop_InsertDelete k t
1507 = (lookup k t == Nothing) ==> delete k (insert k () t) == t
1509 prop_DeleteValid :: Int -> Property
1511 = forValidUnitTree $ \t ->
1512 valid (delete k (insert k () t))
1514 {--------------------------------------------------------------------
1516 --------------------------------------------------------------------}
1517 prop_Join :: Int -> Property
1519 = forValidUnitTree $ \t ->
1520 let (l,r) = split k t
1521 in valid (join k () l r)
1523 prop_Merge :: Int -> Property
1525 = forValidUnitTree $ \t ->
1526 let (l,r) = split k t
1527 in valid (merge l r)
1530 {--------------------------------------------------------------------
1532 --------------------------------------------------------------------}
1533 prop_UnionValid :: Property
1535 = forValidUnitTree $ \t1 ->
1536 forValidUnitTree $ \t2 ->
1539 prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
1540 prop_UnionInsert k x t
1541 = union (singleton k x) t == insert k x t
1543 prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
1544 prop_UnionAssoc t1 t2 t3
1545 = union t1 (union t2 t3) == union (union t1 t2) t3
1547 prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
1548 prop_UnionComm t1 t2
1549 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1552 = forValidIntTree $ \t1 ->
1553 forValidIntTree $ \t2 ->
1554 valid (unionWithKey (\k x y -> x+y) t1 t2)
1556 prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
1557 prop_UnionWith xs ys
1558 = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
1559 == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
1562 = forValidUnitTree $ \t1 ->
1563 forValidUnitTree $ \t2 ->
1564 valid (difference t1 t2)
1566 prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
1568 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1569 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1572 = forValidUnitTree $ \t1 ->
1573 forValidUnitTree $ \t2 ->
1574 valid (intersection t1 t2)
1576 prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
1578 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1579 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1581 {--------------------------------------------------------------------
1583 --------------------------------------------------------------------}
1585 = forAll (choose (5,100)) $ \n ->
1586 let xs = [(x,()) | x <- [0..n::Int]]
1587 in fromAscList xs == fromList xs
1589 prop_List :: [Int] -> Bool
1591 = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])