Ticket #1611: IntMap.hs

File IntMap.hs, 65.5 KB (added by guest, 6 years ago)
Line 
1{-# OPTIONS -cpp -fglasgow-exts -fno-bang-patterns #-} 
2-----------------------------------------------------------------------------
3-- |
4-- Module      :  Data.IntMap
5-- Copyright   :  (c) Daan Leijen 2002
6--                (c) Andriy Palamarchuk 2007
7-- License     :  BSD-style
8-- Maintainer  :  libraries@haskell.org
9-- Stability   :  provisional
10-- Portability :  portable
11--
12-- An efficient implementation of maps from integer keys to values.
13--
14-- Since many function names (but not the type name) clash with
15-- "Prelude" names, this module is usually imported @qualified@, e.g.
16--
17-- >  import Data.IntMap (IntMap)
18-- >  import qualified Data.IntMap as IntMap
19--
20-- The implementation is based on /big-endian patricia trees/.  This data
21-- structure performs especially well on binary operations like 'union'
22-- and 'intersection'.  However, my benchmarks show that it is also
23-- (much) faster on insertions and deletions when compared to a generic
24-- size-balanced map implementation (see "Data.Map" and "Data.FiniteMap").
25--
26--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",
27--      Workshop on ML, September 1998, pages 77-86,
28--      <http://www.cse.ogi.edu/~andy/pub/finite.htm>
29--
30--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
31--      Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
32--      October 1968, pages 514-534.
33--
34-- Operation comments contain the operation time complexity in
35-- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.
36-- Many operations have a worst-case complexity of /O(min(n,W))/.
37-- This means that the operation can become linear in the number of
38-- elements with a maximum of /W/ -- the number of bits in an 'Int'
39-- (32 or 64).
40-----------------------------------------------------------------------------
41
42module Data.IntMap  ( 
43            -- * Map type
44              IntMap, Key          -- instance Eq,Show
45
46            -- * Operators
47            , (!), (\\)
48
49            -- * Query
50            , null
51            , size
52            , member
53            , notMember
54            , lookup
55            , findWithDefault
56           
57            -- * Construction
58            , empty
59            , singleton
60
61            -- ** Insertion
62            , insert
63            , insertWith, insertWithKey, insertLookupWithKey
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           
100            -- ** Fold
101            , fold
102            , foldWithKey
103
104            -- * Conversion
105            , elems
106            , keys
107            , keysSet
108            , assocs
109           
110            -- ** Lists
111            , toList
112            , fromList
113            , fromListWith
114            , fromListWithKey
115
116            -- ** Ordered lists
117            , toAscList
118            , fromAscList
119            , fromAscListWith
120            , fromAscListWithKey
121            , fromDistinctAscList
122
123            -- * Filter
124            , filter
125            , filterWithKey
126            , partition
127            , partitionWithKey
128
129            , mapMaybe
130            , mapMaybeWithKey
131            , mapEither
132            , mapEitherWithKey
133
134            , split         
135            , splitLookup   
136
137            -- * Submap
138            , isSubmapOf, isSubmapOfBy
139            , isProperSubmapOf, isProperSubmapOfBy
140           
141            -- * Min\/Max
142
143            , maxView
144            , minView
145            , findMin   
146            , findMax
147            , deleteMin
148            , deleteMax
149            , deleteFindMin
150            , deleteFindMax
151            , updateMin
152            , updateMax
153            , updateMinWithKey
154            , updateMaxWithKey 
155            , minViewWithKey
156            , maxViewWithKey
157
158            -- * Debugging
159            , showTree
160            , showTreeWith
161            ) where
162
163
164import Prelude hiding (lookup,map,filter,foldr,foldl,null)
165import Data.Bits 
166import qualified Data.IntSet as IntSet
167import Data.Monoid (Monoid(..))
168import Data.Typeable
169import Data.Foldable (Foldable(foldMap))
170import Control.Monad ( liftM )
171import Control.Arrow (ArrowZero)
172{-
173-- just for testing
174import qualified Prelude
175import Debug.QuickCheck
176import List (nub,sort)
177import qualified List
178-} 
179
180#if __GLASGOW_HASKELL__
181import Text.Read
182import Data.Generics.Basics (Data(..), mkNorepType)
183import Data.Generics.Instances ()
184#endif
185
186#if __GLASGOW_HASKELL__ >= 503
187import GHC.Exts ( Word(..), Int(..), shiftRL# )
188#elif __GLASGOW_HASKELL__
189import Word
190import GlaExts ( Word(..), Int(..), shiftRL# )
191#else
192import Data.Word
193#endif
194
195infixl 9 \\{-This comment teaches CPP correct behaviour -}
196
197-- A "Nat" is a natural machine word (an unsigned Int)
198type Nat = Word
199
200natFromInt :: Key -> Nat
201natFromInt i = fromIntegral i
202
203intFromNat :: Nat -> Key
204intFromNat w = fromIntegral w
205
206shiftRL :: Nat -> Key -> Nat
207#if __GLASGOW_HASKELL__
208{--------------------------------------------------------------------
209  GHC: use unboxing to get @shiftRL@ inlined.
210--------------------------------------------------------------------}
211shiftRL (W# x) (I# i)
212  = W# (shiftRL# x i)
213#else
214shiftRL x i   = shiftR x i
215#endif
216
217{--------------------------------------------------------------------
218  Operators
219--------------------------------------------------------------------}
220
221-- | /O(min(n,W))/. Find the value at a key.
222-- Calls 'error' when the element can not be found.
223--
224-- > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map
225-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
226
227(!) :: IntMap a -> Key -> a
228m ! k    = find' k m
229
230-- | Same as 'difference'.
231(\\) :: IntMap a -> IntMap b -> IntMap a
232m1 \\ m2 = difference m1 m2
233
234{--------------------------------------------------------------------
235  Types 
236--------------------------------------------------------------------}
237-- | A map of integers to values @a@.
238data IntMap a = Nil
239              | Tip {-# UNPACK #-} !Key a
240              | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a) 
241
242type Prefix = Int
243type Mask   = Int
244type Key    = Int
245
246instance Monoid (IntMap a) where
247    mempty  = empty
248    mappend = union
249    mconcat = unions
250
251instance Foldable IntMap where
252    foldMap f Nil = mempty
253    foldMap f (Tip _k v) = f v
254    foldMap f (Bin _ _ l r) = foldMap f l `mappend` foldMap f r
255
256#if __GLASGOW_HASKELL__
257
258{--------------------------------------------------------------------
259  A Data instance 
260--------------------------------------------------------------------}
261
262-- This instance preserves data abstraction at the cost of inefficiency.
263-- We omit reflection services for the sake of data abstraction.
264
265instance Data a => Data (IntMap a) where
266  gfoldl f z im = z fromList `f` (toList im)
267  toConstr _    = error "toConstr"
268  gunfold _ _   = error "gunfold"
269  dataTypeOf _  = mkNorepType "Data.IntMap.IntMap"
270  dataCast1 f   = gcast1 f
271
272#endif
273
274{--------------------------------------------------------------------
275  Query
276--------------------------------------------------------------------}
277-- | /O(1)/. Is the map empty?
278--
279-- > Data.IntMap.null (empty)           == True
280-- > Data.IntMap.null (singleton 1 'a') == False
281
282null :: IntMap a -> Bool
283null Nil   = True
284null other = False
285
286-- | /O(n)/. Number of elements in the map.
287--
288-- > size empty                                   == 0
289-- > size (singleton 1 'a')                       == 1
290-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3
291size :: IntMap a -> Int
292size t
293  = case t of
294      Bin p m l r -> size l + size r
295      Tip k x -> 1
296      Nil     -> 0
297
298-- | /O(min(n,W))/. Is the key a member of the map?
299--
300-- > member 5 (fromList [(5,'a'), (3,'b')]) == True
301-- > member 1 (fromList [(5,'a'), (3,'b')]) == False
302
303member :: Key -> IntMap a -> Bool
304member k m
305  = case lookup k m of
306      Nothing -> False
307      Just x  -> True
308   
309-- | /O(log n)/. Is the key not a member of the map?
310--
311-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False
312-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True
313
314notMember :: Key -> IntMap a -> Bool
315notMember k m = not $ member k m
316
317-- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'.
318lookup :: (Monad m) => Key -> IntMap a -> m a
319lookup k t = case lookup' k t of
320    Just x -> return x
321    Nothing -> fail "Data.IntMap.lookup: Key not found"
322
323lookup' :: Key -> IntMap a -> Maybe a
324lookup' k t
325  = let nk = natFromInt k  in seq nk (lookupN nk t)
326
327lookupN :: Nat -> IntMap a -> Maybe a
328lookupN k t
329  = case t of
330      Bin p m l r
331        | zeroN k (natFromInt m) -> lookupN k l
332        | otherwise              -> lookupN k r
333      Tip kx x
334        | (k == natFromInt kx)  -> Just x
335        | otherwise             -> Nothing
336      Nil -> Nothing
337
338find' :: Key -> IntMap a -> a
339find' k m
340  = case lookup k m of
341      Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")
342      Just x  -> x
343
344
345-- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@
346-- returns the value at key @k@ or returns @def@ when the key is not an
347-- element of the map.
348--
349-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
350-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
351
352findWithDefault :: a -> Key -> IntMap a -> a
353findWithDefault def k m
354  = case lookup k m of
355      Nothing -> def
356      Just x  -> x
357
358{--------------------------------------------------------------------
359  Construction
360--------------------------------------------------------------------}
361-- | /O(1)/. The empty map.
362--
363-- > empty      == fromList []
364-- > size empty == 0
365
366empty :: IntMap a
367empty
368  = Nil
369
370-- | /O(1)/. A map of one element.
371--
372-- > singleton 1 'a'        == fromList [(1, 'a')]
373-- > size (singleton 1 'a') == 1
374
375singleton :: Key -> a -> IntMap a
376singleton k x
377  = Tip k x
378
379{--------------------------------------------------------------------
380  Insert
381--------------------------------------------------------------------}
382-- | /O(min(n,W))/. Insert a new key\/value pair in the map.
383-- If the key is already present in the map, the associated value is
384-- replaced with the supplied value, i.e. 'insert' is equivalent to
385-- @'insertWith' 'const'@.
386--
387-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
388-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
389-- > insert 5 'x' empty                         == singleton 5 'x'
390
391insert :: Key -> a -> IntMap a -> IntMap a
392insert k x t
393  = case t of
394      Bin p m l r
395        | nomatch k p m -> join k (Tip k x) p t
396        | zero k m      -> Bin p m (insert k x l) r
397        | otherwise     -> Bin p m l (insert k x r)
398      Tip ky y
399        | k==ky         -> Tip k x
400        | otherwise     -> join k (Tip k x) ky t
401      Nil -> Tip k x
402
403-- right-biased insertion, used by 'union'
404-- | /O(min(n,W))/. Insert with a combining function.
405-- @'insertWith' f key value mp@
406-- will insert the pair (key, value) into @mp@ if key does
407-- not exist in the map. If the key does exist, the function will
408-- insert @f new_value old_value@.
409--
410-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
411-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
412-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"
413
414insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
415insertWith f k x t
416  = insertWithKey (\k x y -> f x y) k x t
417
418-- | /O(min(n,W))/. Insert with a combining function.
419-- @'insertWithKey' f key value mp@
420-- will insert the pair (key, value) into @mp@ if key does
421-- not exist in the map. If the key does exist, the function will
422-- insert @f key new_value old_value@.
423--
424-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
425-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
426-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
427-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"
428
429insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
430insertWithKey f k x t
431  = case t of
432      Bin p m l r
433        | nomatch k p m -> join k (Tip k x) p t
434        | zero k m      -> Bin p m (insertWithKey f k x l) r
435        | otherwise     -> Bin p m l (insertWithKey f k x r)
436      Tip ky y
437        | k==ky         -> Tip k (f k x y)
438        | otherwise     -> join k (Tip k x) ky t
439      Nil -> Tip k x
440
441
442-- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)
443-- is a pair where the first element is equal to (@'lookup' k map@)
444-- and the second element equal to (@'insertWithKey' f k x map@).
445--
446-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
447-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
448-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])
449-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")
450--
451-- This is how to define @insertLookup@ using @insertLookupWithKey@:
452--
453-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
454-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])
455-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])
456
457insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
458insertLookupWithKey f k x t
459  = case t of
460      Bin p m l r
461        | nomatch k p m -> (Nothing,join k (Tip k x) p t)
462        | zero k m      -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
463        | otherwise     -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
464      Tip ky y
465        | k==ky         -> (Just y,Tip k (f k x y))
466        | otherwise     -> (Nothing,join k (Tip k x) ky t)
467      Nil -> (Nothing,Tip k x)
468
469
470{--------------------------------------------------------------------
471  Deletion
472  [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
473--------------------------------------------------------------------}
474-- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not
475-- a member of the map, the original map is returned.
476--
477-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
478-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
479-- > delete 5 empty                         == empty
480
481delete :: Key -> IntMap a -> IntMap a
482delete k t
483  = case t of
484      Bin p m l r
485        | nomatch k p m -> t
486        | zero k m      -> bin p m (delete k l) r
487        | otherwise     -> bin p m l (delete k r)
488      Tip ky y
489        | k==ky         -> Nil
490        | otherwise     -> t
491      Nil -> Nil
492
493-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
494-- a member of the map, the original map is returned.
495--
496-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
497-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
498-- > adjust ("new " ++) 7 empty                         == empty
499
500adjust ::  (a -> a) -> Key -> IntMap a -> IntMap a
501adjust f k m
502  = adjustWithKey (\k x -> f x) k m
503
504-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
505-- a member of the map, the original map is returned.
506--
507-- > let f key x = (show key) ++ ":new " ++ x
508-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
509-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
510-- > adjustWithKey f 7 empty                         == empty
511
512adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a
513adjustWithKey f k m
514  = updateWithKey (\k x -> Just (f k x)) k m
515
516-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
517-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
518-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
519--
520-- > let f x = if x == "a" then Just "new a" else Nothing
521-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
522-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
523-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
524
525update ::  (a -> Maybe a) -> Key -> IntMap a -> IntMap a
526update f k m
527  = updateWithKey (\k x -> f x) k m
528
529-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
530-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is
531-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
532--
533-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
534-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
535-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
536-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
537
538updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
539updateWithKey f k t
540  = case t of
541      Bin p m l r
542        | nomatch k p m -> t
543        | zero k m      -> bin p m (updateWithKey f k l) r
544        | otherwise     -> bin p m l (updateWithKey f k r)
545      Tip ky y
546        | k==ky         -> case (f k y) of
547                             Just y' -> Tip ky y'
548                             Nothing -> Nil
549        | otherwise     -> t
550      Nil -> Nil
551
552-- | /O(min(n,W))/. Lookup and update.
553-- The function returns original value, if it is updated.
554-- This is different behavior than 'Data.Map.updateLookupWithKey'.
555-- Returns the original key value if the map entry is deleted.
556--
557-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
558-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])
559-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])
560-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
561
562updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
563updateLookupWithKey f k t
564  = case t of
565      Bin p m l r
566        | nomatch k p m -> (Nothing,t)
567        | zero k m      -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)
568        | otherwise     -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')
569      Tip ky y
570        | k==ky         -> case (f k y) of
571                             Just y' -> (Just y,Tip ky y')
572                             Nothing -> (Just y,Nil)
573        | otherwise     -> (Nothing,t)
574      Nil -> (Nothing,Nil)
575
576
577
578-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
579-- 'alter' can be used to insert, delete, or update a value in a 'Map'.
580-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
581alter f k t
582  = case t of
583      Bin p m l r
584        | nomatch k p m -> case f Nothing of 
585                             Nothing -> t
586                             Just x -> join k (Tip k x) p t
587        | zero k m      -> bin p m (alter f k l) r
588        | otherwise     -> bin p m l (alter f k r)
589      Tip ky y         
590        | k==ky         -> case f (Just y) of
591                             Just x -> Tip ky x
592                             Nothing -> Nil
593        | otherwise     -> case f Nothing of
594                             Just x -> join k (Tip k x) ky t
595                             Nothing -> Tip ky y
596      Nil               -> case f Nothing of
597                             Just x -> Tip k x
598                             Nothing -> Nil
599
600
601{--------------------------------------------------------------------
602  Union
603--------------------------------------------------------------------}
604-- | The union of a list of maps.
605--
606-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
607-- >     == fromList [(3, "b"), (5, "a"), (7, "C")]
608-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
609-- >     == fromList [(3, "B3"), (5, "A3"), (7, "C")]
610
611unions :: [IntMap a] -> IntMap a
612unions xs
613  = foldlStrict union empty xs
614
615-- | The union of a list of maps, with a combining operation.
616--
617-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
618-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
619
620unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a
621unionsWith f ts
622  = foldlStrict (unionWith f) empty ts
623
624-- | /O(n+m)/. The (left-biased) union of two maps.
625-- It prefers the first map when duplicate keys are encountered,
626-- i.e. (@'union' == 'unionWith' 'const'@).
627--
628-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
629
630union :: IntMap a -> IntMap a -> IntMap a
631union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
632  | shorter m1 m2  = union1
633  | shorter m2 m1  = union2
634  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)
635  | otherwise      = join p1 t1 p2 t2
636  where
637    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2
638            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1
639            | otherwise         = Bin p1 m1 l1 (union r1 t2)
640
641    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2
642            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2
643            | otherwise         = Bin p2 m2 l2 (union t1 r2)
644
645union (Tip k x) t = insert k x t
646union t (Tip k x) = insertWith (\x y -> y) k x t  -- right bias
647union Nil t       = t
648union t Nil       = t
649
650-- | /O(n+m)/. The union with a combining function.
651--
652-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
653
654unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
655unionWith f m1 m2
656  = unionWithKey (\k x y -> f x y) m1 m2
657
658-- | /O(n+m)/. The union with a combining function.
659--
660-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
661-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
662
663unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
664unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
665  | shorter m1 m2  = union1
666  | shorter m2 m1  = union2
667  | p1 == p2       = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)
668  | otherwise      = join p1 t1 p2 t2
669  where
670    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2
671            | zero p2 m1        = Bin p1 m1 (unionWithKey f l1 t2) r1
672            | otherwise         = Bin p1 m1 l1 (unionWithKey f r1 t2)
673
674    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2
675            | zero p1 m2        = Bin p2 m2 (unionWithKey f t1 l2) r2
676            | otherwise         = Bin p2 m2 l2 (unionWithKey f t1 r2)
677
678unionWithKey f (Tip k x) t = insertWithKey f k x t
679unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t  -- right bias
680unionWithKey f Nil t  = t
681unionWithKey f t Nil  = t
682
683{--------------------------------------------------------------------
684  Difference
685--------------------------------------------------------------------}
686-- | /O(n+m)/. Difference between two maps (based on keys).
687--
688-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
689
690difference :: IntMap a -> IntMap b -> IntMap a
691difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
692  | shorter m1 m2  = difference1
693  | shorter m2 m1  = difference2
694  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)
695  | otherwise      = t1
696  where
697    difference1 | nomatch p2 p1 m1  = t1
698                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1
699                | otherwise         = bin p1 m1 l1 (difference r1 t2)
700
701    difference2 | nomatch p1 p2 m2  = t1
702                | zero p1 m2        = difference t1 l2
703                | otherwise         = difference t1 r2
704
705difference t1@(Tip k x) t2
706  | member k t2  = Nil
707  | otherwise    = t1
708
709difference Nil t       = Nil
710difference t (Tip k x) = delete k t
711difference t Nil       = t
712
713-- | /O(n+m)/. Difference with a combining function.
714--
715-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
716-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
717-- >     == singleton 3 "b:B"
718
719differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
720differenceWith f m1 m2
721  = differenceWithKey (\k x y -> f x y) m1 m2
722
723-- | /O(n+m)/. Difference with a combining function. When two equal keys are
724-- encountered, the combining function is applied to the key and both values.
725-- If it returns 'Nothing', the element is discarded (proper set difference).
726-- If it returns (@'Just' y@), the element is updated with a new value @y@.
727--
728-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
729-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
730-- >     == singleton 3 "3:b|B"
731
732differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
733differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
734  | shorter m1 m2  = difference1
735  | shorter m2 m1  = difference2
736  | p1 == p2       = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)
737  | otherwise      = t1
738  where
739    difference1 | nomatch p2 p1 m1  = t1
740                | zero p2 m1        = bin p1 m1 (differenceWithKey f l1 t2) r1
741                | otherwise         = bin p1 m1 l1 (differenceWithKey f r1 t2)
742
743    difference2 | nomatch p1 p2 m2  = t1
744                | zero p1 m2        = differenceWithKey f t1 l2
745                | otherwise         = differenceWithKey f t1 r2
746
747differenceWithKey f t1@(Tip k x) t2
748  = case lookup k t2 of
749      Just y  -> case f k x y of
750                   Just y' -> Tip k y'
751                   Nothing -> Nil
752      Nothing -> t1
753
754differenceWithKey f Nil t       = Nil
755differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t
756differenceWithKey f t Nil       = t
757
758
759{--------------------------------------------------------------------
760  Intersection
761--------------------------------------------------------------------}
762-- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).
763--
764-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
765
766intersection :: IntMap a -> IntMap b -> IntMap a
767intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
768  | shorter m1 m2  = intersection1
769  | shorter m2 m1  = intersection2
770  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
771  | otherwise      = Nil
772  where
773    intersection1 | nomatch p2 p1 m1  = Nil
774                  | zero p2 m1        = intersection l1 t2
775                  | otherwise         = intersection r1 t2
776
777    intersection2 | nomatch p1 p2 m2  = Nil
778                  | zero p1 m2        = intersection t1 l2
779                  | otherwise         = intersection t1 r2
780
781intersection t1@(Tip k x) t2
782  | member k t2  = t1
783  | otherwise    = Nil
784intersection t (Tip k x) 
785  = case lookup k t of
786      Just y  -> Tip k y
787      Nothing -> Nil
788intersection Nil t = Nil
789intersection t Nil = Nil
790
791-- | /O(n+m)/. The intersection with a combining function.
792--
793-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
794
795intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
796intersectionWith f m1 m2
797  = intersectionWithKey (\k x y -> f x y) m1 m2
798
799-- | /O(n+m)/. The intersection with a combining function.
800--
801-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
802-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
803
804intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
805intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
806  | shorter m1 m2  = intersection1
807  | shorter m2 m1  = intersection2
808  | p1 == p2       = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)
809  | otherwise      = Nil
810  where
811    intersection1 | nomatch p2 p1 m1  = Nil
812                  | zero p2 m1        = intersectionWithKey f l1 t2
813                  | otherwise         = intersectionWithKey f r1 t2
814
815    intersection2 | nomatch p1 p2 m2  = Nil
816                  | zero p1 m2        = intersectionWithKey f t1 l2
817                  | otherwise         = intersectionWithKey f t1 r2
818
819intersectionWithKey f t1@(Tip k x) t2
820  = case lookup k t2 of
821      Just y  -> Tip k (f k x y)
822      Nothing -> Nil
823intersectionWithKey f t1 (Tip k y) 
824  = case lookup k t1 of
825      Just x  -> Tip k (f k x y)
826      Nothing -> Nil
827intersectionWithKey f Nil t = Nil
828intersectionWithKey f t Nil = Nil
829
830
831{--------------------------------------------------------------------
832  Min\/Max
833--------------------------------------------------------------------}
834
835-- | /O(log n)/. Update the value at the minimal key.
836--
837-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
838-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
839
840updateMinWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a
841updateMinWithKey f t
842    = case t of
843        Bin p m l r | m < 0 -> let t' = updateMinWithKeyUnsigned f l in Bin p m t' r
844        Bin p m l r         -> let t' = updateMinWithKeyUnsigned f r in Bin p m l t'
845        Tip k y -> Tip k (f k y)
846        Nil -> error "maxView: empty map has no maximal element"
847
848updateMinWithKeyUnsigned f t
849    = case t of
850        Bin p m l r -> let t' = updateMinWithKeyUnsigned f r in Bin p m l t'
851        Tip k y -> Tip k (f k y)
852
853-- | /O(log n)/. Update the value at the maximal key.
854--
855-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
856-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
857
858updateMaxWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a
859updateMaxWithKey f t
860    = case t of
861        Bin p m l r | m < 0 -> let t' = updateMaxWithKeyUnsigned f r in Bin p m r t'
862        Bin p m l r         -> let t' = updateMaxWithKeyUnsigned f l in Bin p m t' l
863        Tip k y -> Tip k (f k y)
864        Nil -> error "maxView: empty map has no maximal element"
865
866updateMaxWithKeyUnsigned f t
867    = case t of
868        Bin p m l r -> let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'
869        Tip k y -> Tip k (f k y)
870
871
872-- | /O(log n)/. Retrieves the maximal (key,value) couple of the map, and the map stripped from that element.
873-- @fail@s (in the monad) when passed an empty map.
874--
875-- > v <- maxViewWithKey (fromList [(5,"a"), (3,"b")])
876-- > v == ((5,"a"), singleton 3 "b")
877-- > maxViewWithKey empty              Error: empty map
878
879maxViewWithKey :: (Monad m) => IntMap a -> m ((Key, a), IntMap a)
880maxViewWithKey t
881    = case t of
882        Bin p m l r | m < 0 -> let (result, t') = maxViewUnsigned l in return (result, bin p m t' r)
883        Bin p m l r         -> let (result, t') = maxViewUnsigned r in return (result, bin p m l t')
884        Tip k y -> return ((k,y), Nil)
885        Nil -> fail "maxViewWithKey: empty map has no maximal element"
886
887maxViewUnsigned t
888    = case t of
889        Bin p m l r -> let (result,t') = maxViewUnsigned r in (result,bin p m l t')
890        Tip k y -> ((k,y), Nil)
891
892-- | /O(log n)/. Retrieves the minimal (key,value) couple of the map, and the map stripped from that element.
893-- @fail@s (in the monad) when passed an empty map.
894--
895-- > v <- minViewWithKey (fromList [(5,"a"), (3,"b")])
896-- > v ==  ((3,"b"), singleton 5 "a")
897-- > minViewWithKey empty              Error: empty map
898
899minViewWithKey :: (Monad m) => IntMap a -> m ((Key, a), IntMap a)
900minViewWithKey t
901    = case t of
902        Bin p m l r | m < 0 -> let (result, t') = minViewUnsigned r in return (result, bin p m l t')
903        Bin p m l r         -> let (result, t') = minViewUnsigned l in return (result, bin p m t' r)
904        Tip k y -> return ((k,y),Nil)
905        Nil -> fail "minViewWithKey: empty map has no minimal element"
906
907minViewUnsigned t
908    = case t of
909        Bin p m l r -> let (result,t') = minViewUnsigned l in (result,bin p m t' r)
910        Tip k y -> ((k,y),Nil)
911
912
913-- | /O(log n)/. Update the value at the maximal key.
914--
915-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
916-- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
917
918updateMax :: (a -> a) -> IntMap a -> IntMap a
919updateMax f = updateMaxWithKey (const f)
920
921-- | /O(log n)/. Update the value at the minimal key.
922--
923-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
924-- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
925
926updateMin :: (a -> a) -> IntMap a -> IntMap a
927updateMin f = updateMinWithKey (const f)
928
929
930-- Duplicate the Identity monad here because base < mtl.
931newtype Identity a = Identity { runIdentity :: a }
932instance Monad Identity where
933        return a = Identity a
934        m >>= k  = k (runIdentity m)
935-- Similar to the Arrow instance.
936first f (x,y) = (f x,y)
937
938
939-- | /O(log n)/. Retrieves the maximal key of the map, and the map stripped from that element.
940-- @fail@s (in the monad) when passed an empty map.
941maxView t = liftM (first snd) (maxViewWithKey t)
942
943-- | /O(log n)/. Retrieves the minimal key of the map, and the map stripped from that element.
944-- @fail@s (in the monad) when passed an empty map.
945minView t = liftM (first snd) (minViewWithKey t)
946
947-- | /O(log n)/. Delete and find the maximal element.
948deleteFindMax = runIdentity . maxView
949
950-- | /O(log n)/. Delete and find the minimal element.
951deleteFindMin = runIdentity . minView
952
953-- | /O(log n)/. The minimal key of the map.
954findMin = fst . runIdentity . minView
955
956-- | /O(log n)/. The maximal key of the map.
957findMax = fst . runIdentity . maxView
958
959-- | /O(log n)/. Delete the minimal key.
960deleteMin = snd . runIdentity . minView
961
962-- | /O(log n)/. Delete the maximal key.
963deleteMax = snd . runIdentity . maxView
964
965
966{--------------------------------------------------------------------
967  Submap
968--------------------------------------------------------------------}
969-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
970-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
971isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
972isProperSubmapOf m1 m2
973  = isProperSubmapOfBy (==) m1 m2
974
975{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
976 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
977 @m1@ and @m2@ are not equal,
978 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
979 applied to their respective values. For example, the following
980 expressions are all 'True':
981 
982  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
983  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
984
985 But the following are all 'False':
986 
987  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
988  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
989  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])
990-}
991isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
992isProperSubmapOfBy pred t1 t2
993  = case submapCmp pred t1 t2 of 
994      LT -> True
995      ge -> False
996
997submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
998  | shorter m1 m2  = GT
999  | shorter m2 m1  = submapCmpLt
1000  | p1 == p2       = submapCmpEq
1001  | otherwise      = GT  -- disjoint
1002  where
1003    submapCmpLt | nomatch p1 p2 m2  = GT
1004                | zero p1 m2        = submapCmp pred t1 l2
1005                | otherwise         = submapCmp pred t1 r2
1006    submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of
1007                    (GT,_ ) -> GT
1008                    (_ ,GT) -> GT
1009                    (EQ,EQ) -> EQ
1010                    other   -> LT
1011
1012submapCmp pred (Bin p m l r) t  = GT
1013submapCmp pred (Tip kx x) (Tip ky y) 
1014  | (kx == ky) && pred x y = EQ
1015  | otherwise              = GT  -- disjoint
1016submapCmp pred (Tip k x) t     
1017  = case lookup k t of
1018     Just y  | pred x y -> LT
1019     other   -> GT -- disjoint
1020submapCmp pred Nil Nil = EQ
1021submapCmp pred Nil t   = LT
1022
1023-- | /O(n+m)/. Is this a submap?
1024-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
1025isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
1026isSubmapOf m1 m2
1027  = isSubmapOfBy (==) m1 m2
1028
1029{- | /O(n+m)/.
1030 The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if
1031 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
1032 applied to their respective values. For example, the following
1033 expressions are all 'True':
1034 
1035  > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
1036  > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
1037  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
1038
1039 But the following are all 'False':
1040 
1041  > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])
1042  > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
1043  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
1044-}
1045isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
1046isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
1047  | shorter m1 m2  = False
1048  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2
1049                                                      else isSubmapOfBy pred t1 r2)                     
1050  | otherwise      = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2
1051isSubmapOfBy pred (Bin p m l r) t  = False
1052isSubmapOfBy pred (Tip k x) t      = case lookup k t of
1053                                   Just y  -> pred x y
1054                                   Nothing -> False 
1055isSubmapOfBy pred Nil t            = True
1056
1057{--------------------------------------------------------------------
1058  Mapping
1059--------------------------------------------------------------------}
1060-- | /O(n)/. Map a function over all values in the map.
1061--
1062-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
1063
1064map :: (a -> b) -> IntMap a -> IntMap b
1065map f m
1066  = mapWithKey (\k x -> f x) m
1067
1068-- | /O(n)/. Map a function over all values in the map.
1069--
1070-- > let f key x = (show key) ++ ":" ++ x
1071-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
1072
1073mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
1074mapWithKey f t 
1075  = case t of
1076      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
1077      Tip k x     -> Tip k (f k x)
1078      Nil         -> Nil
1079
1080-- | /O(n)/. The function @'mapAccum'@ threads an accumulating
1081-- argument through the map in ascending order of keys.
1082--
1083-- > let f a b = (a ++ b, b ++ "X")
1084-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
1085
1086mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
1087mapAccum f a m
1088  = mapAccumWithKey (\a k x -> f a x) a m
1089
1090-- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating
1091-- argument through the map in ascending order of keys.
1092--
1093-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
1094-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
1095
1096mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
1097mapAccumWithKey f a t
1098  = mapAccumL f a t
1099
1100-- | /O(n)/. The function @'mapAccumL'@ threads an accumulating
1101-- argument through the map in ascending order of keys.
1102mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
1103mapAccumL f a t
1104  = case t of
1105      Bin p m l r -> let (a1,l') = mapAccumL f a l
1106                         (a2,r') = mapAccumL f a1 r
1107                     in (a2,Bin p m l' r')
1108      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')
1109      Nil         -> (a,Nil)
1110
1111
1112-- | /O(n)/. The function @'mapAccumR'@ threads an accumulating
1113-- argument throught the map in descending order of keys.
1114mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
1115mapAccumR f a t
1116  = case t of
1117      Bin p m l r -> let (a1,r') = mapAccumR f a r
1118                         (a2,l') = mapAccumR f a1 l
1119                     in (a2,Bin p m l' r')
1120      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')
1121      Nil         -> (a,Nil)
1122
1123{--------------------------------------------------------------------
1124  Filter
1125--------------------------------------------------------------------}
1126-- | /O(n)/. Filter all values that satisfy some predicate.
1127--
1128-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1129-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty
1130-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty
1131
1132filter :: (a -> Bool) -> IntMap a -> IntMap a
1133filter p m
1134  = filterWithKey (\k x -> p x) m
1135
1136-- | /O(n)/. Filter all keys\/values that satisfy some predicate.
1137--
1138-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1139
1140filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
1141filterWithKey pred t
1142  = case t of
1143      Bin p m l r
1144        -> bin p m (filterWithKey pred l) (filterWithKey pred r)
1145      Tip k x
1146        | pred k x  -> t
1147        | otherwise -> Nil
1148      Nil -> Nil
1149
1150-- | /O(n)/. Partition the map according to some predicate. The first
1151-- map contains all elements that satisfy the predicate, the second all
1152-- elements that fail the predicate. See also 'split'.
1153--
1154-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
1155-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
1156-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
1157
1158partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
1159partition p m
1160  = partitionWithKey (\k x -> p x) m
1161
1162-- | /O(n)/. Partition the map according to some predicate. The first
1163-- map contains all elements that satisfy the predicate, the second all
1164-- elements that fail the predicate. See also 'split'.
1165--
1166-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")
1167-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
1168-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
1169
1170partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
1171partitionWithKey pred t
1172  = case t of
1173      Bin p m l r
1174        -> let (l1,l2) = partitionWithKey pred l
1175               (r1,r2) = partitionWithKey pred r
1176           in (bin p m l1 r1, bin p m l2 r2)
1177      Tip k x
1178        | pred k x  -> (t,Nil)
1179        | otherwise -> (Nil,t)
1180      Nil -> (Nil,Nil)
1181
1182-- | /O(n)/. Map values and collect the 'Just' results.
1183--
1184-- > let f x = if x == "a" then Just "new a" else Nothing
1185-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
1186
1187mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b
1188mapMaybe f m
1189  = mapMaybeWithKey (\k x -> f x) m
1190
1191-- | /O(n)/. Map keys\/values and collect the 'Just' results.
1192--
1193-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
1194-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
1195
1196mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b
1197mapMaybeWithKey f (Bin p m l r)
1198  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)
1199mapMaybeWithKey f (Tip k x) = case f k x of
1200  Just y  -> Tip k y
1201  Nothing -> Nil
1202mapMaybeWithKey f Nil = Nil
1203
1204-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
1205--
1206-- > let f a = if a < "c" then Left a else Right a
1207-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1208-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
1209-- >
1210-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1211-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1212
1213mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)
1214mapEither f m
1215  = mapEitherWithKey (\k x -> f x) m
1216
1217-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
1218--
1219-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
1220-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1221-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
1222-- >
1223-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1224-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
1225
1226mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)
1227mapEitherWithKey f (Bin p m l r)
1228  = (bin p m l1 r1, bin p m l2 r2)
1229  where
1230    (l1,l2) = mapEitherWithKey f l
1231    (r1,r2) = mapEitherWithKey f r
1232mapEitherWithKey f (Tip k x) = case f k x of
1233  Left y  -> (Tip k y, Nil)
1234  Right z -> (Nil, Tip k z)
1235mapEitherWithKey f Nil = (Nil, Nil)
1236
1237-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@
1238-- where all keys in @map1@ are lower than @k@ and all keys in
1239-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
1240--
1241-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])
1242-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")
1243-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
1244-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)
1245-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
1246
1247split :: Key -> IntMap a -> (IntMap a,IntMap a)
1248split k t
1249  = case t of
1250      Bin p m l r
1251          | m < 0 -> (if k >= 0 -- handle negative numbers.
1252                      then let (lt,gt) = split' k l in (union r lt, gt)
1253                      else let (lt,gt) = split' k r in (lt, union gt l))
1254          | otherwise   -> split' k t
1255      Tip ky y
1256        | k>ky      -> (t,Nil)
1257        | k<ky      -> (Nil,t)
1258        | otherwise -> (Nil,Nil)
1259      Nil -> (Nil,Nil)
1260
1261split' :: Key -> IntMap a -> (IntMap a,IntMap a)
1262split' k t
1263  = case t of
1264      Bin p m l r
1265        | nomatch k p m -> if k>p then (t,Nil) else (Nil,t)
1266        | zero k m  -> let (lt,gt) = split k l in (lt,union gt r)
1267        | otherwise -> let (lt,gt) = split k r in (union l lt,gt)
1268      Tip ky y
1269        | k>ky      -> (t,Nil)
1270        | k<ky      -> (Nil,t)
1271        | otherwise -> (Nil,Nil)
1272      Nil -> (Nil,Nil)
1273
1274-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
1275-- key was found in the original map.
1276--
1277-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])
1278-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")
1279-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")
1280-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)
1281-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)
1282
1283splitLookup :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)
1284splitLookup k t
1285  = case t of
1286      Bin p m l r
1287          | m < 0 -> (if k >= 0 -- handle negative numbers.
1288                      then let (lt,found,gt) = splitLookup' k l in (union r lt,found, gt)
1289                      else let (lt,found,gt) = splitLookup' k r in (lt,found, union gt l))
1290          | otherwise   -> splitLookup' k t
1291      Tip ky y
1292        | k>ky      -> (t,Nothing,Nil)
1293        | k<ky      -> (Nil,Nothing,t)
1294        | otherwise -> (Nil,Just y,Nil)
1295      Nil -> (Nil,Nothing,Nil)
1296
1297splitLookup' :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)
1298splitLookup' k t
1299  = case t of
1300      Bin p m l r
1301        | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)
1302        | zero k m  -> let (lt,found,gt) = splitLookup k l in (lt,found,union gt r)
1303        | otherwise -> let (lt,found,gt) = splitLookup k r in (union l lt,found,gt)
1304      Tip ky y
1305        | k>ky      -> (t,Nothing,Nil)
1306        | k<ky      -> (Nil,Nothing,t)
1307        | otherwise -> (Nil,Just y,Nil)
1308      Nil -> (Nil,Nothing,Nil)
1309
1310{--------------------------------------------------------------------
1311  Fold
1312--------------------------------------------------------------------}
1313-- | /O(n)/. Fold the values in the map, such that
1314-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
1315-- For example,
1316--
1317-- > elems map = fold (:) [] map
1318--
1319-- > let f a len = len + (length a)
1320-- > fold f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
1321
1322fold :: (a -> b -> b) -> b -> IntMap a -> b
1323fold f z t
1324  = foldWithKey (\k x y -> f x y) z t
1325
1326-- | /O(n)/. Fold the keys and values in the map, such that
1327-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
1328-- For example,
1329--
1330-- > keys map = foldWithKey (\k x ks -> k:ks) [] map
1331--
1332-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
1333-- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
1334
1335foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
1336foldWithKey f z t
1337  = foldr f z t
1338
1339foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
1340foldr f z t
1341  = case t of
1342      Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r  -- put negative numbers before.
1343      Bin _ _ _ _ -> foldr' f z t
1344      Tip k x     -> f k x z
1345      Nil         -> z
1346
1347foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
1348foldr' f z t
1349  = case t of
1350      Bin p m l r -> foldr' f (foldr' f z r) l
1351      Tip k x     -> f k x z
1352      Nil         -> z
1353
1354
1355
1356{--------------------------------------------------------------------
1357  List variations
1358--------------------------------------------------------------------}
1359-- | /O(n)/.
1360-- Return all elements of the map in the ascending order of their keys.
1361--
1362-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]
1363-- > elems empty == []
1364
1365elems :: IntMap a -> [a]
1366elems m
1367  = foldWithKey (\k x xs -> x:xs) [] m 
1368
1369-- | /O(n)/. Return all keys of the map in ascending order.
1370--
1371-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
1372-- > keys empty == []
1373
1374keys  :: IntMap a -> [Key]
1375keys m
1376  = foldWithKey (\k x ks -> k:ks) [] m
1377
1378-- | /O(n*min(n,W))/. The set of all keys of the map.
1379--
1380-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]
1381-- > keysSet empty == Data.IntSet.empty
1382
1383keysSet :: IntMap a -> IntSet.IntSet
1384keysSet m = IntSet.fromDistinctAscList (keys m)
1385
1386
1387-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
1388--
1389-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
1390-- > assocs empty == []
1391
1392assocs :: IntMap a -> [(Key,a)]
1393assocs m
1394  = toList m
1395
1396
1397{--------------------------------------------------------------------
1398  Lists
1399--------------------------------------------------------------------}
1400-- | /O(n)/. Convert the map to a list of key\/value pairs.
1401--
1402-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
1403-- > toList empty == []
1404
1405toList :: IntMap a -> [(Key,a)]
1406toList t
1407  = foldWithKey (\k x xs -> (k,x):xs) [] t
1408
1409-- | /O(n)/. Convert the map to a list of key\/value pairs where the
1410-- keys are in ascending order.
1411--
1412-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
1413
1414toAscList :: IntMap a -> [(Key,a)]
1415toAscList t   
1416  = -- NOTE: the following algorithm only works for big-endian trees
1417    let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos
1418
1419-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.
1420--
1421-- > fromList [] == empty
1422-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
1423-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
1424
1425fromList :: [(Key,a)] -> IntMap a
1426fromList xs
1427  = foldlStrict ins empty xs
1428  where
1429    ins t (k,x)  = insert k x t
1430
1431-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
1432--
1433-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
1434-- > fromListWith (++) [] == empty
1435
1436fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
1437fromListWith f xs
1438  = fromListWithKey (\k x y -> f x y) xs
1439
1440-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.
1441--
1442-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
1443-- > fromListWith (++) [] == empty
1444
1445fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
1446fromListWithKey f xs
1447  = foldlStrict ins empty xs
1448  where
1449    ins t (k,x) = insertWithKey f k x t
1450
1451-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
1452-- the keys are in ascending order.
1453--
1454-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]
1455-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
1456
1457fromAscList :: [(Key,a)] -> IntMap a
1458fromAscList xs
1459  = fromList xs
1460
1461-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
1462-- the keys are in ascending order, with a combining function on equal keys.
1463--
1464-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
1465
1466fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
1467fromAscListWith f xs
1468  = fromListWith f xs
1469
1470-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
1471-- the keys are in ascending order, with a combining function on equal keys.
1472--
1473-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
1474
1475fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
1476fromAscListWithKey f xs
1477  = fromListWithKey f xs
1478
1479-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
1480-- the keys are in ascending order and all distinct.
1481--
1482-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
1483
1484fromDistinctAscList :: [(Key,a)] -> IntMap a
1485fromDistinctAscList xs
1486  = fromList xs
1487
1488
1489{--------------------------------------------------------------------
1490  Eq
1491--------------------------------------------------------------------}
1492instance Eq a => Eq (IntMap a) where
1493  t1 == t2  = equal t1 t2
1494  t1 /= t2  = nequal t1 t2
1495
1496equal :: Eq a => IntMap a -> IntMap a -> Bool
1497equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
1498  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) 
1499equal (Tip kx x) (Tip ky y)
1500  = (kx == ky) && (x==y)
1501equal Nil Nil = True
1502equal t1 t2   = False
1503
1504nequal :: Eq a => IntMap a -> IntMap a -> Bool
1505nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
1506  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) 
1507nequal (Tip kx x) (Tip ky y)
1508  = (kx /= ky) || (x/=y)
1509nequal Nil Nil = False
1510nequal t1 t2   = True
1511
1512{--------------------------------------------------------------------
1513  Ord
1514--------------------------------------------------------------------}
1515
1516instance Ord a => Ord (IntMap a) where
1517    compare m1 m2 = compare (toList m1) (toList m2)
1518
1519{--------------------------------------------------------------------
1520  Functor
1521--------------------------------------------------------------------}
1522
1523instance Functor IntMap where
1524    fmap = map
1525
1526{--------------------------------------------------------------------
1527  Show
1528--------------------------------------------------------------------}
1529
1530instance Show a => Show (IntMap a) where
1531  showsPrec d m   = showParen (d > 10) $
1532    showString "fromList " . shows (toList m)
1533
1534showMap :: (Show a) => [(Key,a)] -> ShowS
1535showMap []     
1536  = showString "{}" 
1537showMap (x:xs) 
1538  = showChar '{' . showElem x . showTail xs
1539  where
1540    showTail []     = showChar '}'
1541    showTail (x:xs) = showChar ',' . showElem x . showTail xs
1542   
1543    showElem (k,x)  = shows k . showString ":=" . shows x
1544
1545{--------------------------------------------------------------------
1546  Read
1547--------------------------------------------------------------------}
1548instance (Read e) => Read (IntMap e) where
1549#ifdef __GLASGOW_HASKELL__
1550  readPrec = parens $ prec 10 $ do
1551    Ident "fromList" <- lexP
1552    xs <- readPrec
1553    return (fromList xs)
1554
1555  readListPrec = readListPrecDefault
1556#else
1557  readsPrec p = readParen (p > 10) $ \ r -> do
1558    ("fromList",s) <- lex r
1559    (xs,t) <- reads s
1560    return (fromList xs,t)
1561#endif
1562
1563{--------------------------------------------------------------------
1564  Typeable
1565--------------------------------------------------------------------}
1566
1567#include "Typeable.h"
1568INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")
1569
1570{--------------------------------------------------------------------
1571  Debugging
1572--------------------------------------------------------------------}
1573-- | /O(n)/. Show the tree that implements the map. The tree is shown
1574-- in a compressed, hanging format.
1575showTree :: Show a => IntMap a -> String
1576showTree s
1577  = showTreeWith True False s
1578
1579
1580{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
1581 the tree that implements the map. If @hang@ is
1582 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1583 @wide@ is 'True', an extra wide version is shown.
1584-}
1585showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
1586showTreeWith hang wide t
1587  | hang      = (showsTreeHang wide [] t) ""
1588  | otherwise = (showsTree wide [] [] t) ""
1589
1590showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS
1591showsTree wide lbars rbars t
1592  = case t of
1593      Bin p m l r
1594          -> showsTree wide (withBar rbars) (withEmpty rbars) r .
1595             showWide wide rbars .
1596             showsBars lbars . showString (showBin p m) . showString "\n" .
1597             showWide wide lbars .
1598             showsTree wide (withEmpty lbars) (withBar lbars) l
1599      Tip k x
1600          -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n" 
1601      Nil -> showsBars lbars . showString "|\n"
1602
1603showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS
1604showsTreeHang wide bars t
1605  = case t of
1606      Bin p m l r
1607          -> showsBars bars . showString (showBin p m) . showString "\n" . 
1608             showWide wide bars .
1609             showsTreeHang wide (withBar bars) l .
1610             showWide wide bars .
1611             showsTreeHang wide (withEmpty bars) r
1612      Tip k x
1613          -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n" 
1614      Nil -> showsBars bars . showString "|\n" 
1615     
1616showBin p m
1617  = "*" -- ++ show (p,m)
1618
1619showWide wide bars
1620  | wide      = showString (concat (reverse bars)) . showString "|\n" 
1621  | otherwise = id
1622
1623showsBars :: [String] -> ShowS
1624showsBars bars
1625  = case bars of
1626      [] -> id
1627      _  -> showString (concat (reverse (tail bars))) . showString node
1628
1629node           = "+--"
1630withBar bars   = "|  ":bars
1631withEmpty bars = "   ":bars
1632
1633
1634{--------------------------------------------------------------------
1635  Helpers
1636--------------------------------------------------------------------}
1637{--------------------------------------------------------------------
1638  Join
1639--------------------------------------------------------------------}
1640join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
1641join p1 t1 p2 t2
1642  | zero p1 m = Bin p m t1 t2
1643  | otherwise = Bin p m t2 t1
1644  where
1645    m = branchMask p1 p2
1646    p = mask p1 m
1647
1648{--------------------------------------------------------------------
1649  @bin@ assures that we never have empty trees within a tree.
1650--------------------------------------------------------------------}
1651bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
1652bin p m l Nil = l
1653bin p m Nil r = r
1654bin p m l r   = Bin p m l r
1655
1656 
1657{--------------------------------------------------------------------
1658  Endian independent bit twiddling
1659--------------------------------------------------------------------}
1660zero :: Key -> Mask -> Bool
1661zero i m
1662  = (natFromInt i) .&. (natFromInt m) == 0
1663
1664nomatch,match :: Key -> Prefix -> Mask -> Bool
1665nomatch i p m
1666  = (mask i m) /= p
1667
1668match i p m
1669  = (mask i m) == p
1670
1671mask :: Key -> Mask -> Prefix
1672mask i m
1673  = maskW (natFromInt i) (natFromInt m)
1674
1675
1676zeroN :: Nat -> Nat -> Bool
1677zeroN i m = (i .&. m) == 0
1678
1679{--------------------------------------------------------------------
1680  Big endian operations 
1681--------------------------------------------------------------------}
1682maskW :: Nat -> Nat -> Prefix
1683maskW i m
1684  = intFromNat (i .&. (complement (m-1) `xor` m))
1685
1686shorter :: Mask -> Mask -> Bool
1687shorter m1 m2
1688  = (natFromInt m1) > (natFromInt m2)
1689
1690branchMask :: Prefix -> Prefix -> Mask
1691branchMask p1 p2
1692  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
1693 
1694{----------------------------------------------------------------------
1695  Finding the highest bit (mask) in a word [x] can be done efficiently in
1696  three ways:
1697  * convert to a floating point value and the mantissa tells us the
1698    [log2(x)] that corresponds with the highest bit position. The mantissa
1699    is retrieved either via the standard C function [frexp] or by some bit
1700    twiddling on IEEE compatible numbers (float). Note that one needs to
1701    use at least [double] precision for an accurate mantissa of 32 bit
1702    numbers.
1703  * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
1704  * use processor specific assembler instruction (asm).
1705
1706  The most portable way would be [bit], but is it efficient enough?
1707  I have measured the cycle counts of the different methods on an AMD
1708  Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
1709
1710  highestBitMask: method  cycles
1711                  --------------
1712                   frexp   200
1713                   float    33
1714                   bit      11
1715                   asm      12
1716
1717  highestBit:     method  cycles
1718                  --------------
1719                   frexp   195
1720                   float    33
1721                   bit      11
1722                   asm      11
1723
1724  Wow, the bit twiddling is on today's RISC like machines even faster
1725  than a single CISC instruction (BSR)!
1726----------------------------------------------------------------------}
1727
1728{----------------------------------------------------------------------
1729  [highestBitMask] returns a word where only the highest bit is set.
1730  It is found by first setting all bits in lower positions than the
1731  highest bit and than taking an exclusive or with the original value.
1732  Allthough the function may look expensive, GHC compiles this into
1733  excellent C code that subsequently compiled into highly efficient
1734  machine code. The algorithm is derived from Jorg Arndt's FXT library.
1735----------------------------------------------------------------------}
1736highestBitMask :: Nat -> Nat
1737highestBitMask x
1738  = case (x .|. shiftRL x 1) of 
1739     x -> case (x .|. shiftRL x 2) of 
1740      x -> case (x .|. shiftRL x 4) of 
1741       x -> case (x .|. shiftRL x 8) of 
1742        x -> case (x .|. shiftRL x 16) of 
1743         x -> case (x .|. shiftRL x 32) of   -- for 64 bit platforms
1744          x -> (x `xor` (shiftRL x 1))
1745
1746
1747{--------------------------------------------------------------------
1748  Utilities
1749--------------------------------------------------------------------}
1750foldlStrict f z xs
1751  = case xs of
1752      []     -> z
1753      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1754
1755{-
1756{--------------------------------------------------------------------
1757  Testing
1758--------------------------------------------------------------------}
1759testTree :: [Int] -> IntMap Int
1760testTree xs   = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]
1761test1 = testTree [1..20]
1762test2 = testTree [30,29..10]
1763test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1764
1765{--------------------------------------------------------------------
1766  QuickCheck
1767--------------------------------------------------------------------}
1768qcheck prop
1769  = check config prop
1770  where
1771    config = Config
1772      { configMaxTest = 500
1773      , configMaxFail = 5000
1774      , configSize    = \n -> (div n 2 + 3)
1775      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1776      }
1777
1778
1779{--------------------------------------------------------------------
1780  Arbitrary, reasonably balanced trees
1781--------------------------------------------------------------------}
1782instance Arbitrary a => Arbitrary (IntMap a) where
1783  arbitrary = do{ ks <- arbitrary
1784                ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks
1785                ; return (fromList xs)
1786                }
1787
1788
1789{--------------------------------------------------------------------
1790  Single, Insert, Delete
1791--------------------------------------------------------------------}
1792prop_Single :: Key -> Int -> Bool
1793prop_Single k x
1794  = (insert k x empty == singleton k x)
1795
1796prop_InsertDelete :: Key -> Int -> IntMap Int -> Property
1797prop_InsertDelete k x t
1798  = not (member k t) ==> delete k (insert k x t) == t
1799
1800prop_UpdateDelete :: Key -> IntMap Int -> Bool 
1801prop_UpdateDelete k t
1802  = update (const Nothing) k t == delete k t
1803
1804
1805{--------------------------------------------------------------------
1806  Union
1807--------------------------------------------------------------------}
1808prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool
1809prop_UnionInsert k x t
1810  = union (singleton k x) t == insert k x t
1811
1812prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool
1813prop_UnionAssoc t1 t2 t3
1814  = union t1 (union t2 t3) == union (union t1 t2) t3
1815
1816prop_UnionComm :: IntMap Int -> IntMap Int -> Bool
1817prop_UnionComm t1 t2
1818  = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1819
1820
1821prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool
1822prop_Diff xs ys
1823  =  List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1824    == List.sort ((List.\\) (nub (Prelude.map fst xs))  (nub (Prelude.map fst ys)))
1825
1826prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool
1827prop_Int xs ys
1828  =  List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1829    == List.sort (nub ((List.intersect) (Prelude.map fst xs)  (Prelude.map fst ys)))
1830
1831{--------------------------------------------------------------------
1832  Lists
1833--------------------------------------------------------------------}
1834prop_Ordered
1835  = forAll (choose (5,100)) $ \n ->
1836    let xs = [(x,()) | x <- [0..n::Int]]
1837    in fromAscList xs == fromList xs
1838
1839prop_List :: [Key] -> Bool
1840prop_List xs
1841  = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])
1842-}