Ticket #1611: Map.2.hs

File Map.2.hs, 84.1 KB (added by guest, 6 years ago)
Line 
1{-# OPTIONS_GHC -fno-bang-patterns #-}
2
3-----------------------------------------------------------------------------
4-- |
5-- Module      :  Data.Map
6-- Copyright   :  (c) Daan Leijen 2002
7--                (c) Andriy Palamarchuk 2007
8-- License     :  BSD-style
9-- Maintainer  :  libraries@haskell.org
10-- Stability   :  provisional
11-- Portability :  portable
12--
13-- An efficient implementation of maps from keys to values (dictionaries).
14--
15-- Since many function names (but not the type name) clash with
16-- "Prelude" names, this module is usually imported @qualified@, e.g.
17--
18-- >  import Data.Map (Map)
19-- >  import qualified Data.Map as Map
20--
21-- The implementation of 'Map' is based on /size balanced/ binary trees (or
22-- trees of /bounded balance/) as described by:
23--
24--    * Stephen Adams, \"/Efficient sets: a balancing act/\",
25--      Journal of Functional Programming 3(4):553-562, October 1993,
26--      <http://www.swiss.ai.mit.edu/~adams/BB>.
27--
28--    * J. Nievergelt and E.M. Reingold,
29--      \"/Binary search trees of bounded balance/\",
30--      SIAM journal of computing 2(1), March 1973.
31--
32-- Note that the implementation is /left-biased/ -- the elements of a
33-- first argument are always preferred to the second, for example in
34-- 'union' or 'insert'.
35--
36-- Operation comments contain the operation time complexity in
37-- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.
38-----------------------------------------------------------------------------
39
40module Data.Map  ( 
41            -- * Map type
42              Map          -- instance Eq,Show,Read
43
44            -- * Operators
45            , (!), (\\)
46
47
48            -- * Query
49            , null
50            , size
51            , member
52            , notMember
53            , lookup
54            , findWithDefault
55           
56            -- * Construction
57            , empty
58            , singleton
59
60            -- ** Insertion
61            , insert
62            , insertWith, insertWithKey, insertLookupWithKey
63            , insertWith', insertWithKey'
64           
65            -- ** Delete\/Update
66            , delete
67            , adjust
68            , adjustWithKey
69            , update
70            , updateWithKey
71            , updateLookupWithKey
72            , alter
73
74            -- * Combine
75
76            -- ** Union
77            , union         
78            , unionWith         
79            , unionWithKey
80            , unions
81            , unionsWith
82
83            -- ** Difference
84            , difference
85            , differenceWith
86            , differenceWithKey
87           
88            -- ** Intersection
89            , intersection           
90            , intersectionWith
91            , intersectionWithKey
92
93            -- * Traversal
94            -- ** Map
95            , map
96            , mapWithKey
97            , mapAccum
98            , mapAccumWithKey
99            , mapKeys
100            , mapKeysWith
101            , mapKeysMonotonic
102
103            -- ** Fold
104            , fold
105            , foldWithKey
106
107            -- * Conversion
108            , elems
109            , keys
110            , keysSet
111            , assocs
112           
113            -- ** Lists
114            , toList
115            , fromList
116            , fromListWith
117            , fromListWithKey
118
119            -- ** Ordered lists
120            , toAscList
121            , fromAscList
122            , fromAscListWith
123            , fromAscListWithKey
124            , fromDistinctAscList
125
126            -- * Filter
127            , filter
128            , filterWithKey
129            , partition
130            , partitionWithKey
131
132            , mapMaybe
133            , mapMaybeWithKey
134            , mapEither
135            , mapEitherWithKey
136
137            , split         
138            , splitLookup   
139
140            -- * Submap
141            , isSubmapOf, isSubmapOfBy
142            , isProperSubmapOf, isProperSubmapOfBy
143
144            -- * Indexed
145            , lookupIndex
146            , findIndex
147            , elemAt
148            , updateAt
149            , deleteAt
150
151            -- * Min\/Max
152            , findMin
153            , findMax
154            , deleteMin
155            , deleteMax
156            , deleteFindMin
157            , deleteFindMax
158            , updateMin
159            , updateMax
160            , updateMinWithKey
161            , updateMaxWithKey
162            , minView
163            , maxView
164            , minViewWithKey
165            , maxViewWithKey
166           
167            -- * Debugging
168            , showTree
169            , showTreeWith
170            , valid
171            ) where
172
173import Prelude hiding (lookup,map,filter,foldr,foldl,null)
174import qualified Data.Set as Set
175import qualified Data.List as List
176import Data.Monoid (Monoid(..))
177import Data.Typeable
178import Control.Applicative (Applicative(..), (<$>))
179import Data.Traversable (Traversable(traverse))
180import Data.Foldable (Foldable(foldMap))
181
182{-
183-- for quick check
184import qualified Prelude
185import qualified List
186import Debug.QuickCheck       
187import List(nub,sort)   
188-}
189
190#if __GLASGOW_HASKELL__
191import Text.Read
192import Data.Generics.Basics
193import Data.Generics.Instances
194#endif
195
196{--------------------------------------------------------------------
197  Operators
198--------------------------------------------------------------------}
199infixl 9 !,\\ --
200
201-- | /O(log n)/. Find the value at a key.
202-- Calls 'error' when the element can not be found.
203--
204-- > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map
205-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
206
207(!) :: Ord k => Map k a -> k -> a
208m ! k    = find k m
209
210-- | Same as 'difference'.
211(\\) :: Ord k => Map k a -> Map k b -> Map k a
212m1 \\ m2 = difference m1 m2
213
214{--------------------------------------------------------------------
215  Size balanced trees.
216--------------------------------------------------------------------}
217-- | A Map from keys @k@ to values @a@.
218data Map k a  = Tip 
219              | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a) 
220
221type Size     = Int
222
223instance (Ord k) => Monoid (Map k v) where
224    mempty  = empty
225    mappend = union
226    mconcat = unions
227
228#if __GLASGOW_HASKELL__
229
230{--------------------------------------------------------------------
231  A Data instance 
232--------------------------------------------------------------------}
233
234-- This instance preserves data abstraction at the cost of inefficiency.
235-- We omit reflection services for the sake of data abstraction.
236
237instance (Data k, Data a, Ord k) => Data (Map k a) where
238  gfoldl f z map = z fromList `f` (toList map)
239  toConstr _     = error "toConstr"
240  gunfold _ _    = error "gunfold"
241  dataTypeOf _   = mkNorepType "Data.Map.Map"
242  dataCast2 f    = gcast2 f
243
244#endif
245
246{--------------------------------------------------------------------
247  Query
248--------------------------------------------------------------------}
249-- | /O(1)/. Is the map empty?
250--
251-- > Data.Map.null (empty)           == True
252-- > Data.Map.null (singleton 1 'a') == False
253
254null :: Map k a -> Bool
255null t
256  = case t of
257      Tip             -> True
258      Bin sz k x l r  -> False
259
260-- | /O(1)/. The number of elements in the map.
261--
262-- > size empty                                   == 0
263-- > size (singleton 1 'a')                       == 1
264-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3
265
266size :: Map k a -> Int
267size t
268  = case t of
269      Tip             -> 0
270      Bin sz k x l r  -> sz
271
272
273-- | /O(log n)/. Lookup the value at a key in the map.
274--
275-- The function will
276-- @return@ the result in the monad or @fail@ in it the key isn't in the
277-- map. Often, the monad to use is 'Maybe', so you get either
278-- @('Just' result)@ or @'Nothing'@.
279--
280-- > let m = fromList [(5,'a'), (3,'b'), (7,'c')]
281-- > value1 <- Data.Map.lookup 5 m
282-- > value1
283-- >   'a'
284-- > value2 <- Data.Map.lookup 1 m
285-- >   Error: Key not found
286--
287-- An example of using @lookup@ with @Maybe@ monad:
288--
289-- > import Prelude hiding (lookup)
290-- > import Data.Map
291-- >
292-- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])
293-- > deptCountry = fromList([("IT","USA"), ("Sales","France")])
294-- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])
295-- >
296-- > employeeCurrency :: String -> Maybe String
297-- > employeeCurrency name = do
298-- >     dept <- lookup name employeeDept
299-- >     country <- lookup dept deptCountry
300-- >     lookup country countryCurrency
301-- >
302-- > main = do
303-- >     putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))
304-- >     putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))
305--
306-- The output of this program:
307--
308-- >   John's currency: Just "Euro"
309-- >   Pete's currency: Nothing
310
311lookup :: (Monad m,Ord k) => k -> Map k a -> m a
312lookup k t = case lookup' k t of
313    Just x -> return x
314    Nothing -> fail "Data.Map.lookup: Key not found"
315lookup' :: Ord k => k -> Map k a -> Maybe a
316lookup' k t
317  = case t of
318      Tip -> Nothing
319      Bin sz kx x l r
320          -> case compare k kx of
321               LT -> lookup' k l
322               GT -> lookup' k r
323               EQ -> Just x       
324
325lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)
326lookupAssoc  k t
327  = case t of
328      Tip -> Nothing
329      Bin sz kx x l r
330          -> case compare k kx of
331               LT -> lookupAssoc k l
332               GT -> lookupAssoc k r
333               EQ -> Just (kx,x)
334
335-- | /O(log n)/. Is the key a member of the map? See also 'notMember'.
336--
337-- > member 5 (fromList [(5,'a'), (3,'b')]) == True
338-- > member 1 (fromList [(5,'a'), (3,'b')]) == False
339
340member :: Ord k => k -> Map k a -> Bool
341member k m
342  = case lookup k m of
343      Nothing -> False
344      Just x  -> True
345
346-- | /O(log n)/. Is the key not a member of the map? See also 'member'.
347--
348-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False
349-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True
350
351notMember :: Ord k => k -> Map k a -> Bool
352notMember k m = not $ member k m
353
354-- | /O(log n)/. Find the value at a key.
355-- Calls 'error' when the element can not be found.
356find :: Ord k => k -> Map k a -> a
357find k m
358  = case lookup k m of
359      Nothing -> error "Map.find: element not in the map"
360      Just x  -> x
361
362-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
363-- the value at key @k@ or returns default value @def@
364-- when the key is not in the map.
365--
366-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
367-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
368
369findWithDefault :: Ord k => a -> k -> Map k a -> a
370findWithDefault def k m
371  = case lookup k m of
372      Nothing -> def
373      Just x  -> x
374
375
376
377{--------------------------------------------------------------------
378  Construction
379--------------------------------------------------------------------}
380-- | /O(1)/. The empty map.
381--
382-- > empty      == fromList []
383-- > size empty == 0
384
385empty :: Map k a
386empty 
387  = Tip
388
389-- | /O(1)/. A map with a single element.
390--
391-- > singleton 1 'a'        == fromList [(1, 'a')]
392-- > size (singleton 1 'a') == 1
393
394singleton :: k -> a -> Map k a
395singleton k x 
396  = Bin 1 k x Tip Tip
397
398{--------------------------------------------------------------------
399  Insertion
400--------------------------------------------------------------------}
401-- | /O(log n)/. Insert a new key and value in the map.
402-- If the key is already present in the map, the associated value is
403-- replaced with the supplied value. 'insert' is equivalent to
404-- @'insertWith' 'const'@.
405--
406-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
407-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
408-- > insert 5 'x' empty                         == singleton 5 'x'
409
410insert :: Ord k => k -> a -> Map k a -> Map k a
411insert kx x t
412  = case t of
413      Tip -> singleton kx x
414      Bin sz ky y l r
415          -> case compare kx ky of
416               LT -> balance ky y (insert kx x l) r
417               GT -> balance ky y l (insert kx x r)
418               EQ -> Bin sz kx x l r
419
420-- | /O(log n)/. Insert with a function, combining new value and old value.
421-- @'insertWith' f key value mp@
422-- will insert the pair (key, value) into @mp@ if key does
423-- not exist in the map. If the key does exist, the function will
424-- insert the pair @(key, f new_value old_value)@.
425--
426-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
427-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
428-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"
429
430insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
431insertWith f k x m         
432  = insertWithKey (\k x y -> f x y) k x m
433
434-- | Same as 'insertWith', but the combining function is applied strictly.
435insertWith' :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
436insertWith' f k x m         
437  = insertWithKey' (\k x y -> f x y) k x m
438
439
440-- | /O(log n)/. Insert with a function, combining key, new value and old value.
441-- @'insertWithKey' f key value mp@
442-- will insert the pair (key, value) into @mp@ if key does
443-- not exist in the map. If the key does exist, the function will
444-- insert the pair @(key,f key new_value old_value)@.
445-- Note that the key passed to f is the same key passed to 'insertWithKey'.
446--
447-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
448-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
449-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
450-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"
451
452insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
453insertWithKey f kx x t
454  = case t of
455      Tip -> singleton kx x
456      Bin sy ky y l r
457          -> case compare kx ky of
458               LT -> balance ky y (insertWithKey f kx x l) r
459               GT -> balance ky y l (insertWithKey f kx x r)
460               EQ -> Bin sy kx (f kx x y) l r
461
462-- | Same as 'insertWithKey', but the combining function is applied strictly.
463insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
464insertWithKey' f kx x t
465  = case t of
466      Tip -> singleton kx x
467      Bin sy ky y l r
468          -> case compare kx ky of
469               LT -> balance ky y (insertWithKey' f kx x l) r
470               GT -> balance ky y l (insertWithKey' f kx x r)
471               EQ -> let x' = f kx x y in seq x' (Bin sy kx x' l r)
472
473
474-- | /O(log n)/. Combines insert operation with old value retrieval.
475-- The expression (@'insertLookupWithKey' f k x map@)
476-- is a pair where the first element is equal to (@'lookup' k map@)
477-- and the second element equal to (@'insertWithKey' f k x map@).
478--
479-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
480-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
481-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])
482-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")
483--
484-- This is how to define @insertLookup@ using @insertLookupWithKey@:
485--
486-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
487-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])
488-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])
489
490insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
491insertLookupWithKey f kx x t
492  = case t of
493      Tip -> (Nothing, singleton kx x)
494      Bin sy ky y l r
495          -> case compare kx ky of
496               LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
497               GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
498               EQ -> (Just y, Bin sy kx (f kx x y) l r)
499
500{--------------------------------------------------------------------
501  Deletion
502  [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
503--------------------------------------------------------------------}
504-- | /O(log n)/. Delete a key and its value from the map. When the key is not
505-- a member of the map, the original map is returned.
506--
507-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
508-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
509-- > delete 5 empty                         == empty
510
511delete :: Ord k => k -> Map k a -> Map k a
512delete k t
513  = case t of
514      Tip -> Tip
515      Bin sx kx x l r
516          -> case compare k kx of
517               LT -> balance kx x (delete k l) r
518               GT -> balance kx x l (delete k r)
519               EQ -> glue l r
520
521-- | /O(log n)/. Update a value at a specific key with the result of the provided function.
522-- When the key is not
523-- a member of the map, the original map is returned.
524--
525-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
526-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
527-- > adjust ("new " ++) 7 empty                         == empty
528
529adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
530adjust f k m
531  = adjustWithKey (\k x -> f x) k m
532
533-- | /O(log n)/. Adjust a value at a specific key. When the key is not
534-- a member of the map, the original map is returned.
535--
536-- > let f key x = (show key) ++ ":new " ++ x
537-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
538-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
539-- > adjustWithKey f 7 empty                         == empty
540
541adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
542adjustWithKey f k m
543  = updateWithKey (\k x -> Just (f k x)) k m
544
545-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
546-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
547-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
548--
549-- > let f x = if x == "a" then Just "new a" else Nothing
550-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
551-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
552-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
553
554update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
555update f k m
556  = updateWithKey (\k x -> f x) k m
557
558-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
559-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
560-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
561-- to the new value @y@.
562--
563-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
564-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
565-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
566-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
567
568updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
569updateWithKey f k t
570  = case t of
571      Tip -> Tip
572      Bin sx kx x l r
573          -> case compare k kx of
574               LT -> balance kx x (updateWithKey f k l) r
575               GT -> balance kx x l (updateWithKey f k r)
576               EQ -> case f kx x of
577                       Just x' -> Bin sx kx x' l r
578                       Nothing -> glue l r
579
580-- | /O(log n)/. Lookup and update. See also 'updateWithKey'.
581-- The function returns changed value, if it is updated.
582-- Returns the original key value if the map entry is deleted.
583--
584-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
585-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])
586-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])
587-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
588
589updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
590updateLookupWithKey f k t
591  = case t of
592      Tip -> (Nothing,Tip)
593      Bin sx kx x l r
594          -> case compare k kx of
595               LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
596               GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r') 
597               EQ -> case f kx x of
598                       Just x' -> (Just x',Bin sx kx x' l r)
599                       Nothing -> (Just x,glue l r)
600
601-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
602-- 'alter' can be used to insert, delete, or update a value in a 'Map'.
603-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
604--
605-- > let f _ = Nothing
606-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
607-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
608-- >
609-- > let f _ = Just "c"
610-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]
611-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]
612
613alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
614alter f k t
615  = case t of
616      Tip -> case f Nothing of
617               Nothing -> Tip
618               Just x -> singleton k x
619      Bin sx kx x l r
620          -> case compare k kx of
621               LT -> balance kx x (alter f k l) r
622               GT -> balance kx x l (alter f k r)
623               EQ -> case f (Just x) of
624                       Just x' -> Bin sx kx x' l r
625                       Nothing -> glue l r
626
627{--------------------------------------------------------------------
628  Indexing
629--------------------------------------------------------------------}
630-- | /O(log n)/. Return the /index/ of a key. The index is a number from
631-- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
632-- the key is not a 'member' of the map.
633--
634-- > findIndex 2 (fromList [(5,"a"), (3,"b")])    Error: element is not in the map
635-- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0
636-- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1
637-- > findIndex 6 (fromList [(5,"a"), (3,"b")])    Error: element is not in the map
638
639findIndex :: Ord k => k -> Map k a -> Int
640findIndex k t
641  = case lookupIndex k t of
642      Nothing  -> error "Map.findIndex: element is not in the map"
643      Just idx -> idx
644
645-- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
646-- /0/ up to, but not including, the 'size' of the map.
647--
648-- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")]))   == False
649-- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0
650-- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1
651-- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")]))   == False
652
653lookupIndex :: (Monad m,Ord k) => k -> Map k a -> m Int
654lookupIndex k t = case lookup 0 t of
655    Nothing -> fail "Data.Map.lookupIndex: Key not found."
656    Just x -> return x
657  where
658    lookup idx Tip  = Nothing
659    lookup idx (Bin _ kx x l r)
660      = case compare k kx of
661          LT -> lookup idx l
662          GT -> lookup (idx + size l + 1) r
663          EQ -> Just (idx + size l)
664
665-- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
666-- invalid index is used.
667--
668-- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")
669-- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")
670-- > elemAt 2 (fromList [(5,"a"), (3,"b")])    Error: index out of range
671
672elemAt :: Int -> Map k a -> (k,a)
673elemAt i Tip = error "Map.elemAt: index out of range"
674elemAt i (Bin _ kx x l r)
675  = case compare i sizeL of
676      LT -> elemAt i l
677      GT -> elemAt (i-sizeL-1) r
678      EQ -> (kx,x)
679  where
680    sizeL = size l
681
682-- | /O(log n)/. Update the element at /index/. Calls 'error' when an
683-- invalid index is used.
684--
685-- > updateAt (\ _ _ -> Just "x") 0    (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]
686-- > updateAt (\ _ _ -> Just "x") 1    (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]
687-- > updateAt (\ _ _ -> Just "x") 2    (fromList [(5,"a"), (3,"b")])    Error: index out of range
688-- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range
689-- > updateAt (\_ _  -> Nothing)  0    (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
690-- > updateAt (\_ _  -> Nothing)  1    (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
691-- > updateAt (\_ _  -> Nothing)  2    (fromList [(5,"a"), (3,"b")])    Error: index out of range
692-- > updateAt (\_ _  -> Nothing)  (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range
693
694updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
695updateAt f i Tip  = error "Map.updateAt: index out of range"
696updateAt f i (Bin sx kx x l r)
697  = case compare i sizeL of
698      LT -> balance kx x (updateAt f i l) r
699      GT -> balance kx x l (updateAt f (i-sizeL-1) r)
700      EQ -> case f kx x of
701              Just x' -> Bin sx kx x' l r
702              Nothing -> glue l r
703  where
704    sizeL = size l
705
706-- | /O(log n)/. Delete the element at /index/.
707-- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).
708--
709-- > deleteAt 0  (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
710-- > deleteAt 1  (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
711-- > deleteAt 2 (fromList [(5,"a"), (3,"b")])     Error: index out of range
712-- > deleteAt (-1) (fromList [(5,"a"), (3,"b")])  Error: index out of range
713
714deleteAt :: Int -> Map k a -> Map k a
715deleteAt i map
716  = updateAt (\k x -> Nothing) i map
717
718
719{--------------------------------------------------------------------
720  Minimal, Maximal
721--------------------------------------------------------------------}
722-- | /O(log n)/. The minimal key of the map. Calls 'error' is the map is empty.
723--
724-- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")
725-- > findMin empty                            Error: empty map has no minimal element
726
727findMin :: Map k a -> (k,a)
728findMin (Bin _ kx x Tip r)  = (kx,x)
729findMin (Bin _ kx x l r)    = findMin l
730findMin Tip                 = error "Map.findMin: empty map has no minimal element"
731
732-- | /O(log n)/. The maximal key of the map. Calls 'error' is the map is empty.
733--
734-- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")
735-- > findMax empty                            Error: empty map has no maximal element
736
737findMax :: Map k a -> (k,a)
738findMax (Bin _ kx x l Tip)  = (kx,x)
739findMax (Bin _ kx x l r)    = findMax r
740findMax Tip                 = error "Map.findMax: empty map has no maximal element"
741
742-- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.
743--
744-- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]
745-- > deleteMin empty == empty
746
747deleteMin :: Map k a -> Map k a
748deleteMin (Bin _ kx x Tip r)  = r
749deleteMin (Bin _ kx x l r)    = balance kx x (deleteMin l) r
750deleteMin Tip                 = Tip
751
752-- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.
753--
754-- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]
755-- > deleteMax empty == empty
756
757deleteMax :: Map k a -> Map k a
758deleteMax (Bin _ kx x l Tip)  = l
759deleteMax (Bin _ kx x l r)    = balance kx x l (deleteMax r)
760deleteMax Tip                 = Tip
761
762-- | /O(log n)/. Update the value at the minimal key.
763--
764-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
765-- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
766
767updateMin :: (a -> Maybe a) -> Map k a -> Map k a
768updateMin f m
769  = updateMinWithKey (\k x -> f x) m
770
771-- | /O(log n)/. Update the value at the maximal key.
772--
773-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
774-- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
775
776updateMax :: (a -> Maybe a) -> Map k a -> Map k a
777updateMax f m
778  = updateMaxWithKey (\k x -> f x) m
779
780
781-- | /O(log n)/. Update the value at the minimal key.
782--
783-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
784-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
785
786updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
787updateMinWithKey f t
788  = case t of
789      Bin sx kx x Tip r  -> case f kx x of
790                              Nothing -> r
791                              Just x' -> Bin sx kx x' Tip r
792      Bin sx kx x l r    -> balance kx x (updateMinWithKey f l) r
793      Tip                -> Tip
794
795-- | /O(log n)/. Update the value at the maximal key.
796--
797-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
798-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
799
800updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
801updateMaxWithKey f t
802  = case t of
803      Bin sx kx x l Tip  -> case f kx x of
804                              Nothing -> l
805                              Just x' -> Bin sx kx x' l Tip
806      Bin sx kx x l r    -> balance kx x l (updateMaxWithKey f r)
807      Tip                -> Tip
808
809-- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and the map stripped from that element
810-- @fail@s (in the monad) when passed an empty map.
811--
812-- > v <- minViewWithKey (fromList [(5,"a"), (3,"b")])
813-- > v ==  ((3,"b"), singleton 5 "a")
814-- > minViewWithKey empty              Error: empty map
815
816minViewWithKey :: Monad m => Map k a -> m ((k,a), Map k a)
817minViewWithKey Tip = fail "Map.minViewWithKey: empty map"
818minViewWithKey x = return (deleteFindMin x)
819
820-- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and the map stripped from that element
821-- @fail@s (in the monad) when passed an empty map.
822--
823-- > v <- maxViewWithKey (fromList [(5,"a"), (3,"b")])
824-- > v == ((5,"a"), singleton 3 "b")
825-- > maxViewWithKey empty              Error: empty map
826
827maxViewWithKey :: Monad m => Map k a -> m ((k,a), Map k a)
828maxViewWithKey Tip = fail "Map.maxViewWithKey: empty map"
829maxViewWithKey x = return (deleteFindMax x)
830
831-- | /O(log n)/. Retrieves the minimal key\'s value of the map, and the map stripped from that element
832-- @fail@s (in the monad) when passed an empty map.
833--
834-- > v <- minView (fromList [(5,"a"), (3,"b")])
835-- > v == ("b", singleton 5 "a")
836-- > minView empty                     Error: empty map
837
838minView :: Monad m => Map k a -> m (a, Map k a)
839minView Tip = fail "Map.minView: empty map"
840minView x = return (first snd $ deleteFindMin x)
841
842-- | /O(log n)/. Retrieves the maximal key\'s value of the map, and the map stripped from that element
843-- @fail@s (in the monad) when passed an empty map.
844--
845-- > v <- maxView (fromList [(5,"a"), (3,"b")])
846-- > v == ("a", singleton 3 "b")
847-- > maxView empty                     Error: empty map
848
849maxView :: Monad m => Map k a -> m (a, Map k a)
850maxView Tip = fail "Map.maxView: empty map"
851maxView x = return (first snd $ deleteFindMax x)
852
853-- Update the 1st component of a tuple (special case of Control.Arrow.first)
854first :: (a -> b) -> (a,c) -> (b,c)
855first f (x,y) = (f x, y)
856
857{--------------------------------------------------------------------
858  Union.
859--------------------------------------------------------------------}
860-- | The union of a list of maps:
861--   (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
862--
863-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
864-- >     == fromList [(3, "b"), (5, "a"), (7, "C")]
865-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
866-- >     == fromList [(3, "B3"), (5, "A3"), (7, "C")]
867
868unions :: Ord k => [Map k a] -> Map k a
869unions ts
870  = foldlStrict union empty ts
871
872-- | The union of a list of maps, with a combining operation:
873--   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
874--
875-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
876-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
877
878unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
879unionsWith f ts
880  = foldlStrict (unionWith f) empty ts
881
882-- | /O(n+m)/.
883-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
884-- It prefers @t1@ when duplicate keys are encountered,
885-- i.e. (@'union' == 'unionWith' 'const'@).
886-- The implementation uses the efficient /hedge-union/ algorithm.
887-- Hedge-union is more efficient on (bigset \``union`\` smallset).
888--
889-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
890
891union :: Ord k => Map k a -> Map k a -> Map k a
892union Tip t2  = t2
893union t1 Tip  = t1
894union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2
895
896-- left-biased hedge union
897hedgeUnionL cmplo cmphi t1 Tip 
898  = t1
899hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
900  = join kx x (filterGt cmplo l) (filterLt cmphi r)
901hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
902  = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2)) 
903              (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
904  where
905    cmpkx k  = compare kx k
906
907-- right-biased hedge union
908hedgeUnionR cmplo cmphi t1 Tip 
909  = t1
910hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
911  = join kx x (filterGt cmplo l) (filterLt cmphi r)
912hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
913  = join kx newx (hedgeUnionR cmplo cmpkx l lt) 
914                 (hedgeUnionR cmpkx cmphi r gt)
915  where
916    cmpkx k     = compare kx k
917    lt          = trim cmplo cmpkx t2
918    (found,gt)  = trimLookupLo kx cmphi t2
919    newx        = case found of
920                    Nothing -> x
921                    Just (_,y) -> y
922
923{--------------------------------------------------------------------
924  Union with a combining function
925--------------------------------------------------------------------}
926-- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
927--
928-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
929
930unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
931unionWith f m1 m2
932  = unionWithKey (\k x y -> f x y) m1 m2
933
934-- | /O(n+m)/.
935-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
936-- Hedge-union is more efficient on (bigset \``union`\` smallset).
937--
938-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
939-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
940
941unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
942unionWithKey f Tip t2  = t2
943unionWithKey f t1 Tip  = t1
944unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
945
946hedgeUnionWithKey f cmplo cmphi t1 Tip 
947  = t1
948hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
949  = join kx x (filterGt cmplo l) (filterLt cmphi r)
950hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
951  = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt) 
952                 (hedgeUnionWithKey f cmpkx cmphi r gt)
953  where
954    cmpkx k     = compare kx k
955    lt          = trim cmplo cmpkx t2
956    (found,gt)  = trimLookupLo kx cmphi t2
957    newx        = case found of
958                    Nothing -> x
959                    Just (_,y) -> f kx x y
960
961{--------------------------------------------------------------------
962  Difference
963--------------------------------------------------------------------}
964-- | /O(n+m)/. Difference of two maps.
965-- Return elements of the first map not existing in the second map.
966-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
967--
968-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
969
970difference :: Ord k => Map k a -> Map k b -> Map k a
971difference Tip t2  = Tip
972difference t1 Tip  = t1
973difference t1 t2   = hedgeDiff (const LT) (const GT) t1 t2
974
975hedgeDiff cmplo cmphi Tip t     
976  = Tip
977hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip 
978  = join kx x (filterGt cmplo l) (filterLt cmphi r)
979hedgeDiff cmplo cmphi t (Bin _ kx x l r) 
980  = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l) 
981          (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
982  where
983    cmpkx k = compare kx k   
984
985-- | /O(n+m)/. Difference with a combining function.
986-- When two equal keys are
987-- encountered, the combining function is applied to the values of these keys.
988-- If it returns 'Nothing', the element is discarded (proper set difference). If
989-- it returns (@'Just' y@), the element is updated with a new value @y@.
990-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
991--
992-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
993-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
994-- >     == singleton 3 "b:B"
995
996differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
997differenceWith f m1 m2
998  = differenceWithKey (\k x y -> f x y) m1 m2
999
1000-- | /O(n+m)/. Difference with a combining function. When two equal keys are
1001-- encountered, the combining function is applied to the key and both values.
1002-- If it returns 'Nothing', the element is discarded (proper set difference). If
1003-- it returns (@'Just' y@), the element is updated with a new value @y@.
1004-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
1005--
1006-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
1007-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
1008-- >     == singleton 3 "3:b|B"
1009
1010differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
1011differenceWithKey f Tip t2  = Tip
1012differenceWithKey f t1 Tip  = t1
1013differenceWithKey f t1 t2   = hedgeDiffWithKey f (const LT) (const GT) t1 t2
1014
1015hedgeDiffWithKey f cmplo cmphi Tip t     
1016  = Tip
1017hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip 
1018  = join kx x (filterGt cmplo l) (filterLt cmphi r)
1019hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r) 
1020  = case found of
1021      Nothing -> merge tl tr
1022      Just (ky,y) -> 
1023          case f ky y x of
1024            Nothing -> merge tl tr
1025            Just z  -> join ky z tl tr
1026  where
1027    cmpkx k     = compare kx k   
1028    lt          = trim cmplo cmpkx t
1029    (found,gt)  = trimLookupLo kx cmphi t
1030    tl          = hedgeDiffWithKey f cmplo cmpkx lt l
1031    tr          = hedgeDiffWithKey f cmpkx cmphi gt r
1032
1033
1034
1035{--------------------------------------------------------------------
1036  Intersection
1037--------------------------------------------------------------------}
1038-- | /O(n+m)/. Intersection of two maps.
1039-- Return data in the first map for the keys existing in both maps.
1040-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
1041--
1042-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
1043
1044intersection :: Ord k => Map k a -> Map k b -> Map k a
1045intersection m1 m2
1046  = intersectionWithKey (\k x y -> x) m1 m2
1047
1048-- | /O(n+m)/. Intersection with a combining function.
1049--
1050-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
1051
1052intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
1053intersectionWith f m1 m2
1054  = intersectionWithKey (\k x y -> f x y) m1 m2
1055
1056-- | /O(n+m)/. Intersection with a combining function.
1057-- Intersection is more efficient on (bigset \``intersection`\` smallset).
1058--
1059-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
1060-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
1061
1062--intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
1063--intersectionWithKey f Tip t = Tip
1064--intersectionWithKey f t Tip = Tip
1065--intersectionWithKey f t1 t2 = intersectWithKey f t1 t2
1066--
1067--intersectWithKey f Tip t = Tip
1068--intersectWithKey f t Tip = Tip
1069--intersectWithKey f t (Bin _ kx x l r)
1070--  = case found of
1071--      Nothing -> merge tl tr
1072--      Just y  -> join kx (f kx y x) tl tr
1073--  where
1074--    (lt,found,gt) = splitLookup kx t
1075--    tl            = intersectWithKey f lt l
1076--    tr            = intersectWithKey f gt r
1077
1078intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
1079intersectionWithKey f Tip t = Tip
1080intersectionWithKey f t Tip = Tip
1081intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =
1082   if s1 >= s2 then
1083      let (lt,found,gt) = splitLookupWithKey k2 t1
1084          tl            = intersectionWithKey f lt l2
1085          tr            = intersectionWithKey f gt r2
1086      in case found of
1087      Just (k,x) -> join k (f k x x2) tl tr
1088      Nothing -> merge tl tr
1089   else let (lt,found,gt) = splitLookup k1 t2
1090            tl            = intersectionWithKey f l1 lt
1091            tr            = intersectionWithKey f r1 gt
1092      in case found of
1093      Just x -> join k1 (f k1 x1 x) tl tr
1094      Nothing -> merge tl tr
1095
1096
1097
1098{--------------------------------------------------------------------
1099  Submap
1100--------------------------------------------------------------------}
1101-- | /O(n+m)/.
1102-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
1103--
1104isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
1105isSubmapOf m1 m2
1106  = isSubmapOfBy (==) m1 m2
1107
1108{- | /O(n+m)/.
1109 The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
1110 all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
1111 applied to their respective values. For example, the following
1112 expressions are all 'True':
1113 
1114 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
1115 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
1116 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
1117
1118 But the following are all 'False':
1119 
1120 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
1121 > isSubmapOfBy (<)  (fromList [('a',1)]) (fromList [('a',1),('b',2)])
1122 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
1123 
1124
1125-}
1126isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
1127isSubmapOfBy f t1 t2
1128  = (size t1 <= size t2) && (submap' f t1 t2)
1129
1130submap' f Tip t = True
1131submap' f t Tip = False
1132submap' f (Bin _ kx x l r) t
1133  = case found of
1134      Nothing -> False
1135      Just y  -> f x y && submap' f l lt && submap' f r gt
1136  where
1137    (lt,found,gt) = splitLookup kx t
1138
1139-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
1140-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
1141isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
1142isProperSubmapOf m1 m2
1143  = isProperSubmapOfBy (==) m1 m2
1144
1145{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
1146 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
1147 @m1@ and @m2@ are not equal,
1148 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
1149 applied to their respective values. For example, the following
1150 expressions are all 'True':
1151 
1152  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
1153  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
1154
1155 But the following are all 'False':
1156 
1157  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
1158  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
1159  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])
1160 
1161 
1162-}
1163isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
1164isProperSubmapOfBy f t1 t2
1165  = (size t1 < size t2) && (submap' f t1 t2)
1166
1167{--------------------------------------------------------------------
1168  Filter and partition
1169--------------------------------------------------------------------}
1170-- | /O(n)/. Filter all values that satisfy the predicate.
1171--
1172-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1173-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty
1174-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty
1175
1176filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
1177filter p m
1178  = filterWithKey (\k x -> p x) m
1179
1180-- | /O(n)/. Filter all keys\/values that satisfy the predicate.
1181--
1182-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1183
1184filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
1185filterWithKey p Tip = Tip
1186filterWithKey p (Bin _ kx x l r)
1187  | p kx x    = join kx x (filterWithKey p l) (filterWithKey p r)
1188  | otherwise = merge (filterWithKey p l) (filterWithKey p r)
1189
1190
1191-- | /O(n)/. Partition the map according to a predicate. The first
1192-- map contains all elements that satisfy the predicate, the second all
1193-- elements that fail the predicate. See also 'split'.
1194--
1195-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
1196-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
1197-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
1198
1199partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
1200partition p m
1201  = partitionWithKey (\k x -> p x) m
1202
1203-- | /O(n)/. Partition the map according to a predicate. The first
1204-- map contains all elements that satisfy the predicate, the second all
1205-- elements that fail the predicate. See also 'split'.
1206--
1207-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")
1208-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
1209-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
1210
1211partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
1212partitionWithKey p Tip = (Tip,Tip)
1213partitionWithKey p (Bin _ kx x l r)
1214  | p kx x    = (join kx x l1 r1,merge l2 r2)
1215  | otherwise = (merge l1 r1,join kx x l2 r2)
1216  where
1217    (l1,l2) = partitionWithKey p l
1218    (r1,r2) = partitionWithKey p r
1219
1220-- | /O(n)/. Map values and collect the 'Just' results.
1221--
1222-- > let f x = if x == "a" then Just "new a" else Nothing
1223-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
1224
1225mapMaybe :: Ord k => (a -> Maybe b) -> Map k a -> Map k b
1226mapMaybe f m
1227  = mapMaybeWithKey (\k x -> f x) m
1228
1229-- | /O(n)/. Map keys\/values and collect the 'Just' results.
1230--
1231-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
1232-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
1233
1234mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b
1235mapMaybeWithKey f Tip = Tip
1236mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of
1237  Just y  -> join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)
1238  Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r)
1239
1240-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
1241--
1242-- > let f a = if a < "c" then Left a else Right a
1243-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1244-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
1245-- >
1246-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1247-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1248
1249mapEither :: Ord k => (a -> Either b c) -> Map k a -> (Map k b, Map k c)
1250mapEither f m
1251  = mapEitherWithKey (\k x -> f x) m
1252
1253-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
1254--
1255-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
1256-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1257-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
1258-- >
1259-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1260-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
1261
1262mapEitherWithKey :: Ord k =>
1263  (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
1264mapEitherWithKey f Tip = (Tip, Tip)
1265mapEitherWithKey f (Bin _ kx x l r) = case f kx x of
1266  Left y  -> (join kx y l1 r1, merge l2 r2)
1267  Right z -> (merge l1 r1, join kx z l2 r2)
1268  where
1269    (l1,l2) = mapEitherWithKey f l
1270    (r1,r2) = mapEitherWithKey f r
1271
1272{--------------------------------------------------------------------
1273  Mapping
1274--------------------------------------------------------------------}
1275-- | /O(n)/. Map a function over all values in the map.
1276--
1277-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
1278
1279map :: (a -> b) -> Map k a -> Map k b
1280map f m
1281  = mapWithKey (\k x -> f x) m
1282
1283-- | /O(n)/. Map a function over all values in the map.
1284--
1285-- > let f key x = (show key) ++ ":" ++ x
1286-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
1287
1288mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
1289mapWithKey f Tip = Tip
1290mapWithKey f (Bin sx kx x l r) 
1291  = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
1292
1293-- | /O(n)/. The function 'mapAccum' threads an accumulating
1294-- argument through the map in ascending order of keys.
1295--
1296-- > let f a b = (a ++ b, b ++ "X")
1297-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
1298
1299mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1300mapAccum f a m
1301  = mapAccumWithKey (\a k x -> f a x) a m
1302
1303-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
1304-- argument through the map in ascending order of keys.
1305--
1306-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
1307-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
1308
1309mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1310mapAccumWithKey f a t
1311  = mapAccumL f a t
1312
1313-- | /O(n)/. The function 'mapAccumL' threads an accumulating
1314-- argument throught the map in ascending order of keys.
1315mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1316mapAccumL f a t
1317  = case t of
1318      Tip -> (a,Tip)
1319      Bin sx kx x l r
1320          -> let (a1,l') = mapAccumL f a l
1321                 (a2,x') = f a1 kx x
1322                 (a3,r') = mapAccumL f a2 r
1323             in (a3,Bin sx kx x' l' r')
1324
1325-- | /O(n)/. The function 'mapAccumR' threads an accumulating
1326-- argument throught the map in descending order of keys.
1327mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1328mapAccumR f a t
1329  = case t of
1330      Tip -> (a,Tip)
1331      Bin sx kx x l r
1332          -> let (a1,r') = mapAccumR f a r
1333                 (a2,x') = f a1 kx x
1334                 (a3,l') = mapAccumR f a2 l
1335             in (a3,Bin sx kx x' l' r')
1336
1337-- | /O(n*log n)/.
1338-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
1339--
1340-- The size of the result may be smaller if @f@ maps two or more distinct
1341-- keys to the same new key.  In this case the value at the smallest of
1342-- these keys is retained.
1343--
1344-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])                        == fromList [(4, "b"), (6, "a")]
1345-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"
1346-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"
1347
1348mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
1349mapKeys = mapKeysWith (\x y->x)
1350
1351-- | /O(n*log n)/.
1352-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
1353--
1354-- The size of the result may be smaller if @f@ maps two or more distinct
1355-- keys to the same new key.  In this case the associated values will be
1356-- combined using @c@.
1357--
1358-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
1359-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
1360
1361mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
1362mapKeysWith c f = fromListWith c . List.map fFirst . toList
1363    where fFirst (x,y) = (f x, y)
1364
1365
1366-- | /O(n)/.
1367-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
1368-- is strictly monotonic.
1369-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.
1370-- /The precondition is not checked./
1371-- Semi-formally, we have:
1372--
1373-- > and [x < y ==> f x < f y | x <- ls, y <- ls]
1374-- >                     ==> mapKeysMonotonic f s == mapKeys f s
1375-- >     where ls = keys s
1376--
1377-- This means that @f@ maps distinct original keys to distinct resulting keys.
1378-- This function has better performance than 'mapKeys'.
1379--
1380-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]
1381-- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True
1382-- > valid (mapKeysMonotonic (\ _ -> 1)     (fromList [(5,"a"), (3,"b")])) == False
1383
1384mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
1385mapKeysMonotonic f Tip = Tip
1386mapKeysMonotonic f (Bin sz k x l r) =
1387    Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
1388
1389{--------------------------------------------------------------------
1390  Folds 
1391--------------------------------------------------------------------}
1392
1393-- | /O(n)/. Fold the values in the map, such that
1394-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
1395-- For example,
1396--
1397-- > elems map = fold (:) [] map
1398--
1399-- > let f a len = len + (length a)
1400-- > fold f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
1401
1402fold :: (a -> b -> b) -> b -> Map k a -> b
1403fold f z m
1404  = foldWithKey (\k x z -> f x z) z m
1405
1406-- | /O(n)/. Fold the keys and values in the map, such that
1407-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
1408-- For example,
1409--
1410-- > keys map = foldWithKey (\k x ks -> k:ks) [] map
1411--
1412-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
1413-- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
1414
1415foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
1416foldWithKey f z t
1417  = foldr f z t
1418
1419-- | /O(n)/. In-order fold.
1420foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
1421foldi f z Tip               = z
1422foldi f z (Bin _ kx x l r)  = f kx x (foldi f z l) (foldi f z r)
1423
1424-- | /O(n)/. Post-order fold.
1425foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
1426foldr f z Tip              = z
1427foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
1428
1429-- | /O(n)/. Pre-order fold.
1430foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
1431foldl f z Tip              = z
1432foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
1433
1434{--------------------------------------------------------------------
1435  List variations
1436--------------------------------------------------------------------}
1437-- | /O(n)/.
1438-- Return all elements of the map in the ascending order of their keys.
1439--
1440-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]
1441-- > elems empty == []
1442
1443elems :: Map k a -> [a]
1444elems m
1445  = [x | (k,x) <- assocs m]
1446
1447-- | /O(n)/. Return all keys of the map in ascending order.
1448--
1449-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
1450-- > keys empty == []
1451
1452keys  :: Map k a -> [k]
1453keys m
1454  = [k | (k,x) <- assocs m]
1455
1456-- | /O(n)/. The set of all keys of the map.
1457--
1458-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]
1459-- > keysSet empty == Data.Set.empty
1460
1461keysSet :: Map k a -> Set.Set k
1462keysSet m = Set.fromDistinctAscList (keys m)
1463
1464-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
1465--
1466-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
1467-- > assocs empty == []
1468
1469assocs :: Map k a -> [(k,a)]
1470assocs m
1471  = toList m
1472
1473{--------------------------------------------------------------------
1474  Lists
1475  use [foldlStrict] to reduce demand on the control-stack
1476--------------------------------------------------------------------}
1477-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
1478-- If the list contains more than one value for the same key, the last value
1479-- for the key is retained.
1480--
1481-- > fromList [] == empty
1482-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
1483-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
1484
1485fromList :: Ord k => [(k,a)] -> Map k a
1486fromList xs       
1487  = foldlStrict ins empty xs
1488  where
1489    ins t (k,x) = insert k x t
1490
1491-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
1492--
1493-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
1494-- > fromListWith (++) [] == empty
1495
1496fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
1497fromListWith f xs
1498  = fromListWithKey (\k x y -> f x y) xs
1499
1500-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
1501--
1502-- > let f k a1 a2 = (show k) ++ a1 ++ a2
1503-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]
1504-- > fromListWithKey f [] == empty
1505
1506fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1507fromListWithKey f xs
1508  = foldlStrict ins empty xs
1509  where
1510    ins t (k,x) = insertWithKey f k x t
1511
1512-- | /O(n)/. Convert to a list of key\/value pairs.
1513--
1514-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
1515-- > toList empty == []
1516
1517toList :: Map k a -> [(k,a)]
1518toList t      = toAscList t
1519
1520-- | /O(n)/. Convert to an ascending list.
1521--
1522-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
1523
1524toAscList :: Map k a -> [(k,a)]
1525toAscList t   = foldr (\k x xs -> (k,x):xs) [] t
1526
1527-- | /O(n)/.
1528toDescList :: Map k a -> [(k,a)]
1529toDescList t  = foldl (\xs k x -> (k,x):xs) [] t
1530
1531
1532{--------------------------------------------------------------------
1533  Building trees from ascending/descending lists can be done in linear time.
1534 
1535  Note that if [xs] is ascending that:
1536    fromAscList xs       == fromList xs
1537    fromAscListWith f xs == fromListWith f xs
1538--------------------------------------------------------------------}
1539-- | /O(n)/. Build a map from an ascending list in linear time.
1540-- /The precondition (input list is ascending) is not checked./
1541--
1542-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]
1543-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
1544-- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True
1545-- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False
1546
1547fromAscList :: Eq k => [(k,a)] -> Map k a
1548fromAscList xs
1549  = fromAscListWithKey (\k x y -> x) xs
1550
1551-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
1552-- /The precondition (input list is ascending) is not checked./
1553--
1554-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
1555-- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True
1556-- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False
1557
1558fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
1559fromAscListWith f xs
1560  = fromAscListWithKey (\k x y -> f x y) xs
1561
1562-- | /O(n)/. Build a map from an ascending list in linear time with a
1563-- combining function for equal keys.
1564-- /The precondition (input list is ascending) is not checked./
1565--
1566-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
1567-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
1568-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True
1569-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False
1570
1571fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1572fromAscListWithKey f xs
1573  = fromDistinctAscList (combineEq f xs)
1574  where
1575  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1576  combineEq f xs
1577    = case xs of
1578        []     -> []
1579        [x]    -> [x]
1580        (x:xx) -> combineEq' x xx
1581
1582  combineEq' z [] = [z]
1583  combineEq' z@(kz,zz) (x@(kx,xx):xs)
1584    | kx==kz    = let yy = f kx xx zz in combineEq' (kx,yy) xs
1585    | otherwise = z:combineEq' x xs
1586
1587
1588-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
1589-- /The precondition is not checked./
1590--
1591-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
1592-- > valid (fromDistinctAscList [(3,"b"), (5,"a")])          == True
1593-- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False
1594
1595fromDistinctAscList :: [(k,a)] -> Map k a
1596fromDistinctAscList xs
1597  = build const (length xs) xs
1598  where
1599    -- 1) use continutations so that we use heap space instead of stack space.
1600    -- 2) special case for n==5 to build bushier trees.
1601    build c 0 xs   = c Tip xs
1602    build c 5 xs   = case xs of
1603                       ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx) 
1604                            -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
1605    build c n xs   = seq nr $ build (buildR nr c) nl xs
1606                   where
1607                     nl = n `div` 2
1608                     nr = n - nl - 1
1609
1610    buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
1611    buildB l k x c r zs     = c (bin k x l r) zs
1612                     
1613
1614
1615{--------------------------------------------------------------------
1616  Utility functions that return sub-ranges of the original
1617  tree. Some functions take a comparison function as argument to
1618  allow comparisons against infinite values. A function [cmplo k]
1619  should be read as [compare lo k].
1620
1621  [trim cmplo cmphi t]  A tree that is either empty or where [cmplo k == LT]
1622                        and [cmphi k == GT] for the key [k] of the root.
1623  [filterGt cmp t]      A tree where for all keys [k]. [cmp k == LT]
1624  [filterLt cmp t]      A tree where for all keys [k]. [cmp k == GT]
1625
1626  [split k t]           Returns two trees [l] and [r] where all keys
1627                        in [l] are <[k] and all keys in [r] are >[k].
1628  [splitLookup k t]     Just like [split] but also returns whether [k]
1629                        was found in the tree.
1630--------------------------------------------------------------------}
1631
1632{--------------------------------------------------------------------
1633  [trim lo hi t] trims away all subtrees that surely contain no
1634  values between the range [lo] to [hi]. The returned tree is either
1635  empty or the key of the root is between @lo@ and @hi@.
1636--------------------------------------------------------------------}
1637trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
1638trim cmplo cmphi Tip = Tip
1639trim cmplo cmphi t@(Bin sx kx x l r)
1640  = case cmplo kx of
1641      LT -> case cmphi kx of
1642              GT -> t
1643              le -> trim cmplo cmphi l
1644      ge -> trim cmplo cmphi r
1645             
1646trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe (k,a), Map k a)
1647trimLookupLo lo cmphi Tip = (Nothing,Tip)
1648trimLookupLo lo cmphi t@(Bin sx kx x l r)
1649  = case compare lo kx of
1650      LT -> case cmphi kx of
1651              GT -> (lookupAssoc lo t, t)
1652              le -> trimLookupLo lo cmphi l
1653      GT -> trimLookupLo lo cmphi r
1654      EQ -> (Just (kx,x),trim (compare lo) cmphi r)
1655
1656
1657{--------------------------------------------------------------------
1658  [filterGt k t] filter all keys >[k] from tree [t]
1659  [filterLt k t] filter all keys <[k] from tree [t]
1660--------------------------------------------------------------------}
1661filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1662filterGt cmp Tip = Tip
1663filterGt cmp (Bin sx kx x l r)
1664  = case cmp kx of
1665      LT -> join kx x (filterGt cmp l) r
1666      GT -> filterGt cmp r
1667      EQ -> r
1668     
1669filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
1670filterLt cmp Tip = Tip
1671filterLt cmp (Bin sx kx x l r)
1672  = case cmp kx of
1673      LT -> filterLt cmp l
1674      GT -> join kx x l (filterLt cmp r)
1675      EQ -> l
1676
1677{--------------------------------------------------------------------
1678  Split
1679--------------------------------------------------------------------}
1680-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
1681-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.
1682-- Any key equal to @k@ is found in neither @map1@ nor @map2@.
1683--
1684-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])
1685-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")
1686-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
1687-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)
1688-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
1689
1690split :: Ord k => k -> Map k a -> (Map k a,Map k a)
1691split k Tip = (Tip,Tip)
1692split k (Bin sx kx x l r)
1693  = case compare k kx of
1694      LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
1695      GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
1696      EQ -> (l,r)
1697
1698-- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
1699-- like 'split' but also returns @'lookup' k map@.
1700--
1701-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])
1702-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")
1703-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")
1704-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)
1705-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)
1706
1707splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
1708splitLookup k Tip = (Tip,Nothing,Tip)
1709splitLookup k (Bin sx kx x l r)
1710  = case compare k kx of
1711      LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)
1712      GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)
1713      EQ -> (l,Just x,r)
1714
1715-- | /O(log n)/.
1716splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)
1717splitLookupWithKey k Tip = (Tip,Nothing,Tip)
1718splitLookupWithKey k (Bin sx kx x l r)
1719  = case compare k kx of
1720      LT -> let (lt,z,gt) = splitLookupWithKey k l in (lt,z,join kx x gt r)
1721      GT -> let (lt,z,gt) = splitLookupWithKey k r in (join kx x l lt,z,gt)
1722      EQ -> (l,Just (kx, x),r)
1723
1724-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
1725-- element was found in the original set.
1726splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)
1727splitMember x t = let (l,m,r) = splitLookup x t in
1728     (l,maybe False (const True) m,r)
1729
1730
1731{--------------------------------------------------------------------
1732  Utility functions that maintain the balance properties of the tree.
1733  All constructors assume that all values in [l] < [k] and all values
1734  in [r] > [k], and that [l] and [r] are valid trees.
1735 
1736  In order of sophistication:
1737    [Bin sz k x l r]  The type constructor.
1738    [bin k x l r]     Maintains the correct size, assumes that both [l]
1739                      and [r] are balanced with respect to each other.
1740    [balance k x l r] Restores the balance and size.
1741                      Assumes that the original tree was balanced and
1742                      that [l] or [r] has changed by at most one element.
1743    [join k x l r]    Restores balance and size.
1744
1745  Furthermore, we can construct a new tree from two trees. Both operations
1746  assume that all values in [l] < all values in [r] and that [l] and [r]
1747  are valid:
1748    [glue l r]        Glues [l] and [r] together. Assumes that [l] and
1749                      [r] are already balanced with respect to each other.
1750    [merge l r]       Merges two trees and restores balance.
1751
1752  Note: in contrast to Adam's paper, we use (<=) comparisons instead
1753  of (<) comparisons in [join], [merge] and [balance].
1754  Quickcheck (on [difference]) showed that this was necessary in order
1755  to maintain the invariants. It is quite unsatisfactory that I haven't
1756  been able to find out why this is actually the case! Fortunately, it
1757  doesn't hurt to be a bit more conservative.
1758--------------------------------------------------------------------}
1759
1760{--------------------------------------------------------------------
1761  Join
1762--------------------------------------------------------------------}
1763join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
1764join kx x Tip r  = insertMin kx x r
1765join kx x l Tip  = insertMax kx x l
1766join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
1767  | delta*sizeL <= sizeR  = balance kz z (join kx x l lz) rz
1768  | delta*sizeR <= sizeL  = balance ky y ly (join kx x ry r)
1769  | otherwise             = bin kx x l r
1770
1771
1772-- insertMin and insertMax don't perform potentially expensive comparisons.
1773insertMax,insertMin :: k -> a -> Map k a -> Map k a
1774insertMax kx x t
1775  = case t of
1776      Tip -> singleton kx x
1777      Bin sz ky y l r
1778          -> balance ky y l (insertMax kx x r)
1779             
1780insertMin kx x t
1781  = case t of
1782      Tip -> singleton kx x
1783      Bin sz ky y l r
1784          -> balance ky y (insertMin kx x l) r
1785             
1786{--------------------------------------------------------------------
1787  [merge l r]: merges two trees.
1788--------------------------------------------------------------------}
1789merge :: Map k a -> Map k a -> Map k a
1790merge Tip r   = r
1791merge l Tip   = l
1792merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
1793  | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
1794  | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
1795  | otherwise            = glue l r
1796
1797{--------------------------------------------------------------------
1798  [glue l r]: glues two trees together.
1799  Assumes that [l] and [r] are already balanced with respect to each other.
1800--------------------------------------------------------------------}
1801glue :: Map k a -> Map k a -> Map k a
1802glue Tip r = r
1803glue l Tip = l
1804glue l r   
1805  | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
1806  | otherwise       = let ((km,m),r') = deleteFindMin r in balance km m l r'
1807
1808
1809-- | /O(log n)/. Delete and find the minimal element.
1810--
1811-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])
1812-- > deleteFindMin                                            Error: can not return the minimal element of an empty map
1813
1814deleteFindMin :: Map k a -> ((k,a),Map k a)
1815deleteFindMin t
1816  = case t of
1817      Bin _ k x Tip r -> ((k,x),r)
1818      Bin _ k x l r   -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
1819      Tip             -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
1820
1821-- | /O(log n)/. Delete and find the maximal element.
1822--
1823-- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])
1824-- > deleteFindMax empty                                      Error: can not return the maximal element of an empty map
1825
1826deleteFindMax :: Map k a -> ((k,a),Map k a)
1827deleteFindMax t
1828  = case t of
1829      Bin _ k x l Tip -> ((k,x),l)
1830      Bin _ k x l r   -> let (km,r') = deleteFindMax r in (km,balance k x l r')
1831      Tip             -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
1832
1833
1834{--------------------------------------------------------------------
1835  [balance l x r] balances two trees with value x.
1836  The sizes of the trees should balance after decreasing the
1837  size of one of them. (a rotation).
1838
1839  [delta] is the maximal relative difference between the sizes of
1840          two trees, it corresponds with the [w] in Adams' paper.
1841  [ratio] is the ratio between an outer and inner sibling of the
1842          heavier subtree in an unbalanced setting. It determines
1843          whether a double or single rotation should be performed
1844          to restore balance. It is correspondes with the inverse
1845          of $\alpha$ in Adam's article.
1846
1847  Note that:
1848  - [delta] should be larger than 4.646 with a [ratio] of 2.
1849  - [delta] should be larger than 3.745 with a [ratio] of 1.534.
1850 
1851  - A lower [delta] leads to a more 'perfectly' balanced tree.
1852  - A higher [delta] performs less rebalancing.
1853
1854  - Balancing is automatic for random data and a balancing
1855    scheme is only necessary to avoid pathological worst cases.
1856    Almost any choice will do, and in practice, a rather large
1857    [delta] may perform better than smaller one.
1858
1859  Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
1860  to decide whether a single or double rotation is needed. Allthough
1861  he actually proves that this ratio is needed to maintain the
1862  invariants, his implementation uses an invalid ratio of [1].
1863--------------------------------------------------------------------}
1864delta,ratio :: Int
1865delta = 5
1866ratio = 2
1867
1868balance :: k -> a -> Map k a -> Map k a -> Map k a
1869balance k x l r
1870  | sizeL + sizeR <= 1    = Bin sizeX k x l r
1871  | sizeR >= delta*sizeL  = rotateL k x l r
1872  | sizeL >= delta*sizeR  = rotateR k x l r
1873  | otherwise             = Bin sizeX k x l r
1874  where
1875    sizeL = size l
1876    sizeR = size r
1877    sizeX = sizeL + sizeR + 1
1878
1879-- rotate
1880rotateL k x l r@(Bin _ _ _ ly ry)
1881  | size ly < ratio*size ry = singleL k x l r
1882  | otherwise               = doubleL k x l r
1883
1884rotateR k x l@(Bin _ _ _ ly ry) r
1885  | size ry < ratio*size ly = singleR k x l r
1886  | otherwise               = doubleR k x l r
1887
1888-- basic rotations
1889singleL k1 x1 t1 (Bin _ k2 x2 t2 t3)  = bin k2 x2 (bin k1 x1 t1 t2) t3
1890singleR k1 x1 (Bin _ k2 x2 t1 t2) t3  = bin k2 x2 t1 (bin k1 x1 t2 t3)
1891
1892doubleL 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)
1893doubleR 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)
1894
1895
1896{--------------------------------------------------------------------
1897  The bin constructor maintains the size of the tree
1898--------------------------------------------------------------------}
1899bin :: k -> a -> Map k a -> Map k a -> Map k a
1900bin k x l r
1901  = Bin (size l + size r + 1) k x l r
1902
1903
1904{--------------------------------------------------------------------
1905  Eq converts the tree to a list. In a lazy setting, this
1906  actually seems one of the faster methods to compare two trees
1907  and it is certainly the simplest :-)
1908--------------------------------------------------------------------}
1909instance (Eq k,Eq a) => Eq (Map k a) where
1910  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)
1911
1912{--------------------------------------------------------------------
1913  Ord
1914--------------------------------------------------------------------}
1915
1916instance (Ord k, Ord v) => Ord (Map k v) where
1917    compare m1 m2 = compare (toAscList m1) (toAscList m2)
1918
1919{--------------------------------------------------------------------
1920  Functor
1921--------------------------------------------------------------------}
1922instance Functor (Map k) where
1923  fmap f m  = map f m
1924
1925instance Traversable (Map k) where
1926  traverse f Tip = pure Tip
1927  traverse f (Bin s k v l r)
1928    = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
1929
1930instance Foldable (Map k) where
1931  foldMap _f Tip = mempty
1932  foldMap f (Bin _s _k v l r)
1933    = foldMap f l `mappend` f v `mappend` foldMap f r
1934
1935{--------------------------------------------------------------------
1936  Read
1937--------------------------------------------------------------------}
1938instance (Ord k, Read k, Read e) => Read (Map k e) where
1939#ifdef __GLASGOW_HASKELL__
1940  readPrec = parens $ prec 10 $ do
1941    Ident "fromList" <- lexP
1942    xs <- readPrec
1943    return (fromList xs)
1944
1945  readListPrec = readListPrecDefault
1946#else
1947  readsPrec p = readParen (p > 10) $ \ r -> do
1948    ("fromList",s) <- lex r
1949    (xs,t) <- reads s
1950    return (fromList xs,t)
1951#endif
1952
1953-- parses a pair of things with the syntax a:=b
1954readPair :: (Read a, Read b) => ReadS (a,b)
1955readPair s = do (a, ct1)    <- reads s
1956                (":=", ct2) <- lex ct1
1957                (b, ct3)    <- reads ct2
1958                return ((a,b), ct3)
1959
1960{--------------------------------------------------------------------
1961  Show
1962--------------------------------------------------------------------}
1963instance (Show k, Show a) => Show (Map k a) where
1964  showsPrec d m  = showParen (d > 10) $
1965    showString "fromList " . shows (toList m)
1966
1967showMap :: (Show k,Show a) => [(k,a)] -> ShowS
1968showMap []     
1969  = showString "{}" 
1970showMap (x:xs) 
1971  = showChar '{' . showElem x . showTail xs
1972  where
1973    showTail []     = showChar '}'
1974    showTail (x:xs) = showString ", " . showElem x . showTail xs
1975   
1976    showElem (k,x)  = shows k . showString " := " . shows x
1977 
1978
1979-- | /O(n)/. Show the tree that implements the map. The tree is shown
1980-- in a compressed, hanging format. See 'showTreeWith'.
1981showTree :: (Show k,Show a) => Map k a -> String
1982showTree m
1983  = showTreeWith showElem True False m
1984  where
1985    showElem k x  = show k ++ ":=" ++ show x
1986
1987
1988{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
1989 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
1990 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1991 @wide@ is 'True', an extra wide version is shown.
1992
1993>  Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
1994>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
1995>  (4,())
1996>  +--(2,())
1997>  |  +--(1,())
1998>  |  +--(3,())
1999>  +--(5,())
2000>
2001>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
2002>  (4,())
2003>  |
2004>  +--(2,())
2005>  |  |
2006>  |  +--(1,())
2007>  |  |
2008>  |  +--(3,())
2009>  |
2010>  +--(5,())
2011>
2012>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
2013>  +--(5,())
2014>  |
2015>  (4,())
2016>  |
2017>  |  +--(3,())
2018>  |  |
2019>  +--(2,())
2020>     |
2021>     +--(1,())
2022
2023-}
2024showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
2025showTreeWith showelem hang wide t
2026  | hang      = (showsTreeHang showelem wide [] t) ""
2027  | otherwise = (showsTree showelem wide [] [] t) ""
2028
2029showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
2030showsTree showelem wide lbars rbars t
2031  = case t of
2032      Tip -> showsBars lbars . showString "|\n"
2033      Bin sz kx x Tip Tip
2034          -> showsBars lbars . showString (showelem kx x) . showString "\n" 
2035      Bin sz kx x l r
2036          -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
2037             showWide wide rbars .
2038             showsBars lbars . showString (showelem kx x) . showString "\n" .
2039             showWide wide lbars .
2040             showsTree showelem wide (withEmpty lbars) (withBar lbars) l
2041
2042showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
2043showsTreeHang showelem wide bars t
2044  = case t of
2045      Tip -> showsBars bars . showString "|\n" 
2046      Bin sz kx x Tip Tip
2047          -> showsBars bars . showString (showelem kx x) . showString "\n" 
2048      Bin sz kx x l r
2049          -> showsBars bars . showString (showelem kx x) . showString "\n" . 
2050             showWide wide bars .
2051             showsTreeHang showelem wide (withBar bars) l .
2052             showWide wide bars .
2053             showsTreeHang showelem wide (withEmpty bars) r
2054
2055
2056showWide wide bars
2057  | wide      = showString (concat (reverse bars)) . showString "|\n" 
2058  | otherwise = id
2059
2060showsBars :: [String] -> ShowS
2061showsBars bars
2062  = case bars of
2063      [] -> id
2064      _  -> showString (concat (reverse (tail bars))) . showString node
2065
2066node           = "+--"
2067withBar bars   = "|  ":bars
2068withEmpty bars = "   ":bars
2069
2070{--------------------------------------------------------------------
2071  Typeable
2072--------------------------------------------------------------------}
2073
2074#include "Typeable.h"
2075INSTANCE_TYPEABLE2(Map,mapTc,"Map")
2076
2077{--------------------------------------------------------------------
2078  Assertions
2079--------------------------------------------------------------------}
2080-- | /O(n)/. Test if the internal map structure is valid.
2081--
2082-- > valid (fromAscList [(3,"b"), (5,"a")]) == True
2083-- > valid (fromAscList [(5,"a"), (3,"b")]) == False
2084
2085valid :: Ord k => Map k a -> Bool
2086valid t
2087  = balanced t && ordered t && validsize t
2088
2089ordered t
2090  = bounded (const True) (const True) t
2091  where
2092    bounded lo hi t
2093      = case t of
2094          Tip              -> True
2095          Bin sz kx x l r  -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
2096
2097-- | Exported only for "Debug.QuickCheck"
2098balanced :: Map k a -> Bool
2099balanced t
2100  = case t of
2101      Tip              -> True
2102      Bin sz kx x l r  -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
2103                          balanced l && balanced r
2104
2105
2106validsize t
2107  = (realsize t == Just (size t))
2108  where
2109    realsize t
2110      = case t of
2111          Tip             -> Just 0
2112          Bin sz kx x l r -> case (realsize l,realsize r) of
2113                              (Just n,Just m)  | n+m+1 == sz  -> Just sz
2114                              other            -> Nothing
2115
2116{--------------------------------------------------------------------
2117  Utilities
2118--------------------------------------------------------------------}
2119foldlStrict f z xs
2120  = case xs of
2121      []     -> z
2122      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
2123
2124
2125{-
2126{--------------------------------------------------------------------
2127  Testing
2128--------------------------------------------------------------------}
2129testTree xs   = fromList [(x,"*") | x <- xs]
2130test1 = testTree [1..20]
2131test2 = testTree [30,29..10]
2132test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
2133
2134{--------------------------------------------------------------------
2135  QuickCheck
2136--------------------------------------------------------------------}
2137qcheck prop
2138  = check config prop
2139  where
2140    config = Config
2141      { configMaxTest = 500
2142      , configMaxFail = 5000
2143      , configSize    = \n -> (div n 2 + 3)
2144      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
2145      }
2146
2147
2148{--------------------------------------------------------------------
2149  Arbitrary, reasonably balanced trees
2150--------------------------------------------------------------------}
2151instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
2152  arbitrary = sized (arbtree 0 maxkey)
2153            where maxkey  = 10000
2154
2155arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
2156arbtree lo hi n
2157  | n <= 0        = return Tip
2158  | lo >= hi      = return Tip
2159  | otherwise     = do{ x  <- arbitrary
2160                      ; i  <- choose (lo,hi)
2161                      ; m  <- choose (1,30)
2162                      ; let (ml,mr)  | m==(1::Int)= (1,2)
2163                                     | m==2       = (2,1)
2164                                     | m==3       = (1,1)
2165                                     | otherwise  = (2,2)
2166                      ; l  <- arbtree lo (i-1) (n `div` ml)
2167                      ; r  <- arbtree (i+1) hi (n `div` mr)
2168                      ; return (bin (toEnum i) x l r)
2169                      } 
2170
2171
2172{--------------------------------------------------------------------
2173  Valid tree's
2174--------------------------------------------------------------------}
2175forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
2176forValid f
2177  = forAll arbitrary $ \t ->
2178--    classify (balanced t) "balanced" $
2179    classify (size t == 0) "empty" $
2180    classify (size t > 0  && size t <= 10) "small" $
2181    classify (size t > 10 && size t <= 64) "medium" $
2182    classify (size t > 64) "large" $
2183    balanced t ==> f t
2184
2185forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
2186forValidIntTree f
2187  = forValid f
2188
2189forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
2190forValidUnitTree f
2191  = forValid f
2192
2193
2194prop_Valid
2195  = forValidUnitTree $ \t -> valid t
2196
2197{--------------------------------------------------------------------
2198  Single, Insert, Delete
2199--------------------------------------------------------------------}
2200prop_Single :: Int -> Int -> Bool
2201prop_Single k x
2202  = (insert k x empty == singleton k x)
2203
2204prop_InsertValid :: Int -> Property
2205prop_InsertValid k
2206  = forValidUnitTree $ \t -> valid (insert k () t)
2207
2208prop_InsertDelete :: Int -> Map Int () -> Property
2209prop_InsertDelete k t
2210  = (lookup k t == Nothing) ==> delete k (insert k () t) == t
2211
2212prop_DeleteValid :: Int -> Property
2213prop_DeleteValid k
2214  = forValidUnitTree $ \t ->
2215    valid (delete k (insert k () t))
2216
2217{--------------------------------------------------------------------
2218  Balance
2219--------------------------------------------------------------------}
2220prop_Join :: Int -> Property
2221prop_Join k
2222  = forValidUnitTree $ \t ->
2223    let (l,r) = split k t
2224    in valid (join k () l r)
2225
2226prop_Merge :: Int -> Property
2227prop_Merge k
2228  = forValidUnitTree $ \t ->
2229    let (l,r) = split k t
2230    in valid (merge l r)
2231
2232
2233{--------------------------------------------------------------------
2234  Union
2235--------------------------------------------------------------------}
2236prop_UnionValid :: Property
2237prop_UnionValid
2238  = forValidUnitTree $ \t1 ->
2239    forValidUnitTree $ \t2 ->
2240    valid (union t1 t2)
2241
2242prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
2243prop_UnionInsert k x t
2244  = union (singleton k x) t == insert k x t
2245
2246prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
2247prop_UnionAssoc t1 t2 t3
2248  = union t1 (union t2 t3) == union (union t1 t2) t3
2249
2250prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
2251prop_UnionComm t1 t2
2252  = (union t1 t2 == unionWith (\x y -> y) t2 t1)
2253
2254prop_UnionWithValid
2255  = forValidIntTree $ \t1 ->
2256    forValidIntTree $ \t2 ->
2257    valid (unionWithKey (\k x y -> x+y) t1 t2)
2258
2259prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
2260prop_UnionWith xs ys
2261  = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
2262    == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
2263
2264prop_DiffValid
2265  = forValidUnitTree $ \t1 ->
2266    forValidUnitTree $ \t2 ->
2267    valid (difference t1 t2)
2268
2269prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
2270prop_Diff xs ys
2271  =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
2272    == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))
2273
2274prop_IntValid
2275  = forValidUnitTree $ \t1 ->
2276    forValidUnitTree $ \t2 ->
2277    valid (intersection t1 t2)
2278
2279prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
2280prop_Int xs ys
2281  =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
2282    == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))
2283
2284{--------------------------------------------------------------------
2285  Lists
2286--------------------------------------------------------------------}
2287prop_Ordered
2288  = forAll (choose (5,100)) $ \n ->
2289    let xs = [(x,()) | x <- [0..n::Int]]
2290    in fromAscList xs == fromList xs
2291
2292prop_List :: [Int] -> Bool
2293prop_List xs
2294  = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])
2295-}