[project @ 2005-01-20 19:00:26 by ross]
[packages/old-time.git] / Data / IntMap.hs
1 {-# OPTIONS -cpp -fglasgow-exts #-}
2 -----------------------------------------------------------------------------
3 -- Module : Data.IntMap
4 -- Copyright : (c) Daan Leijen 2002
5 -- License : BSD-style
6 -- Maintainer : libraries@haskell.org
7 -- Stability : provisional
8 -- Portability : portable
9 --
10 -- An efficient implementation of maps from integer keys to values.
11 --
12 -- This module is intended to be imported @qualified@, to avoid name
13 -- clashes with "Prelude" functions. eg.
14 --
15 -- > import Data.IntMap as Map
16 --
17 -- The implementation is based on /big-endian patricia trees/. This data
18 -- structure performs especially well on binary operations like 'union'
19 -- and 'intersection'. However, my benchmarks show that it is also
20 -- (much) faster on insertions and deletions when compared to a generic
21 -- size-balanced map implementation (see "Data.Map" and "Data.FiniteMap").
22 --
23 -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
24 -- Workshop on ML, September 1998, pages 77-86,
25 -- <http://www.cse.ogi.edu/~andy/pub/finite.htm>
26 --
27 -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve
28 -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),
29 -- October 1968, pages 514-534.
30 --
31 -- Many operations have a worst-case complexity of /O(min(n,W))/.
32 -- This means that the operation can become linear in the number of
33 -- elements with a maximum of /W/ -- the number of bits in an 'Int'
34 -- (32 or 64).
35 -----------------------------------------------------------------------------
36
37 module Data.IntMap (
38 -- * Map type
39 IntMap, Key -- instance Eq,Show
40
41 -- * Operators
42 , (!), (\\)
43
44 -- * Query
45 , null
46 , size
47 , member
48 , lookup
49 , findWithDefault
50
51 -- * Construction
52 , empty
53 , singleton
54
55 -- ** Insertion
56 , insert
57 , insertWith, insertWithKey, insertLookupWithKey
58
59 -- ** Delete\/Update
60 , delete
61 , adjust
62 , adjustWithKey
63 , update
64 , updateWithKey
65 , updateLookupWithKey
66
67 -- * Combine
68
69 -- ** Union
70 , union
71 , unionWith
72 , unionWithKey
73 , unions
74 , unionsWith
75
76 -- ** Difference
77 , difference
78 , differenceWith
79 , differenceWithKey
80
81 -- ** Intersection
82 , intersection
83 , intersectionWith
84 , intersectionWithKey
85
86 -- * Traversal
87 -- ** Map
88 , map
89 , mapWithKey
90 , mapAccum
91 , mapAccumWithKey
92
93 -- ** Fold
94 , fold
95 , foldWithKey
96
97 -- * Conversion
98 , elems
99 , keys
100 , keysSet
101 , assocs
102
103 -- ** Lists
104 , toList
105 , fromList
106 , fromListWith
107 , fromListWithKey
108
109 -- ** Ordered lists
110 , toAscList
111 , fromAscList
112 , fromAscListWith
113 , fromAscListWithKey
114 , fromDistinctAscList
115
116 -- * Filter
117 , filter
118 , filterWithKey
119 , partition
120 , partitionWithKey
121
122 , split
123 , splitLookup
124
125 -- * Submap
126 , isSubmapOf, isSubmapOfBy
127 , isProperSubmapOf, isProperSubmapOfBy
128
129 -- * Debugging
130 , showTree
131 , showTreeWith
132 ) where
133
134
135 import Prelude hiding (lookup,map,filter,foldr,foldl,null)
136 import Data.Bits
137 import Data.Int
138 import Data.Monoid
139 import qualified Data.IntSet as IntSet
140 import Data.Typeable
141
142 {-
143 -- just for testing
144 import qualified Prelude
145 import Debug.QuickCheck
146 import List (nub,sort)
147 import qualified List
148 -}
149
150 #if __GLASGOW_HASKELL__
151 import Data.Generics.Basics
152 import Data.Generics.Instances
153 #endif
154
155 #if __GLASGOW_HASKELL__ >= 503
156 import GHC.Word
157 import GHC.Exts ( Word(..), Int(..), shiftRL# )
158 #elif __GLASGOW_HASKELL__
159 import Word
160 import GlaExts ( Word(..), Int(..), shiftRL# )
161 #else
162 import Data.Word
163 #endif
164
165 infixl 9 \\{-This comment teaches CPP correct behaviour -}
166
167 -- A "Nat" is a natural machine word (an unsigned Int)
168 type Nat = Word
169
170 natFromInt :: Key -> Nat
171 natFromInt i = fromIntegral i
172
173 intFromNat :: Nat -> Key
174 intFromNat w = fromIntegral w
175
176 shiftRL :: Nat -> Key -> Nat
177 #if __GLASGOW_HASKELL__
178 {--------------------------------------------------------------------
179 GHC: use unboxing to get @shiftRL@ inlined.
180 --------------------------------------------------------------------}
181 shiftRL (W# x) (I# i)
182 = W# (shiftRL# x i)
183 #else
184 shiftRL x i = shiftR x i
185 #endif
186
187 {--------------------------------------------------------------------
188 Operators
189 --------------------------------------------------------------------}
190
191 -- | /O(min(n,W))/. Find the value of a key. Calls 'error' when the element can not be found.
192
193 (!) :: IntMap a -> Key -> a
194 m ! k = find' k m
195
196 -- | /O(n+m)/. See 'difference'.
197 (\\) :: IntMap a -> IntMap b -> IntMap a
198 m1 \\ m2 = difference m1 m2
199
200 {--------------------------------------------------------------------
201 Types
202 --------------------------------------------------------------------}
203 -- | A map of integers to values @a@.
204 data IntMap a = Nil
205 | Tip {-# UNPACK #-} !Key a
206 | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a)
207
208 type Prefix = Int
209 type Mask = Int
210 type Key = Int
211
212 #if __GLASGOW_HASKELL__
213
214 {--------------------------------------------------------------------
215 A Data instance
216 --------------------------------------------------------------------}
217
218 -- This instance preserves data abstraction at the cost of inefficiency.
219 -- We omit reflection services for the sake of data abstraction.
220
221 instance Data a => Data (IntMap a) where
222 gfoldl f z im = z fromList `f` (toList im)
223 toConstr _ = error "toConstr"
224 gunfold _ _ = error "gunfold"
225 dataTypeOf _ = mkNorepType "Data.IntMap.IntMap"
226
227 #endif
228
229 {--------------------------------------------------------------------
230 Query
231 --------------------------------------------------------------------}
232 -- | /O(1)/. Is the map empty?
233 null :: IntMap a -> Bool
234 null Nil = True
235 null other = False
236
237 -- | /O(n)/. Number of elements in the map.
238 size :: IntMap a -> Int
239 size t
240 = case t of
241 Bin p m l r -> size l + size r
242 Tip k x -> 1
243 Nil -> 0
244
245 -- | /O(min(n,W))/. Is the key a member of the map?
246 member :: Key -> IntMap a -> Bool
247 member k m
248 = case lookup k m of
249 Nothing -> False
250 Just x -> True
251
252 -- | /O(min(n,W))/. Lookup the value of a key in the map.
253 lookup :: Key -> IntMap a -> Maybe a
254 lookup k t
255 = let nk = natFromInt k in seq nk (lookupN nk t)
256
257 lookupN :: Nat -> IntMap a -> Maybe a
258 lookupN k t
259 = case t of
260 Bin p m l r
261 | zeroN k (natFromInt m) -> lookupN k l
262 | otherwise -> lookupN k r
263 Tip kx x
264 | (k == natFromInt kx) -> Just x
265 | otherwise -> Nothing
266 Nil -> Nothing
267
268 find' :: Key -> IntMap a -> a
269 find' k m
270 = case lookup k m of
271 Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")
272 Just x -> x
273
274
275 -- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@
276 -- returns the value of key @k@ or returns @def@ when the key is not an
277 -- element of the map.
278 findWithDefault :: a -> Key -> IntMap a -> a
279 findWithDefault def k m
280 = case lookup k m of
281 Nothing -> def
282 Just x -> x
283
284 {--------------------------------------------------------------------
285 Construction
286 --------------------------------------------------------------------}
287 -- | /O(1)/. The empty map.
288 empty :: IntMap a
289 empty
290 = Nil
291
292 -- | /O(1)/. A map of one element.
293 singleton :: Key -> a -> IntMap a
294 singleton k x
295 = Tip k x
296
297 {--------------------------------------------------------------------
298 Insert
299 'insert' is the inlined version of 'insertWith (\k x y -> x)'
300 --------------------------------------------------------------------}
301 -- | /O(min(n,W))/. Insert a new key\/value pair in the map. When the key
302 -- is already an element of the set, its value is replaced by the new value,
303 -- ie. 'insert' is left-biased.
304 insert :: Key -> a -> IntMap a -> IntMap a
305 insert k x t
306 = case t of
307 Bin p m l r
308 | nomatch k p m -> join k (Tip k x) p t
309 | zero k m -> Bin p m (insert k x l) r
310 | otherwise -> Bin p m l (insert k x r)
311 Tip ky y
312 | k==ky -> Tip k x
313 | otherwise -> join k (Tip k x) ky t
314 Nil -> Tip k x
315
316 -- right-biased insertion, used by 'union'
317 -- | /O(min(n,W))/. Insert with a combining function.
318 insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
319 insertWith f k x t
320 = insertWithKey (\k x y -> f x y) k x t
321
322 -- | /O(min(n,W))/. Insert with a combining function.
323 insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
324 insertWithKey f k x t
325 = case t of
326 Bin p m l r
327 | nomatch k p m -> join k (Tip k x) p t
328 | zero k m -> Bin p m (insertWithKey f k x l) r
329 | otherwise -> Bin p m l (insertWithKey f k x r)
330 Tip ky y
331 | k==ky -> Tip k (f k x y)
332 | otherwise -> join k (Tip k x) ky t
333 Nil -> Tip k x
334
335
336 -- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)
337 -- is a pair where the first element is equal to (@'lookup' k map@)
338 -- and the second element equal to (@'insertWithKey' f k x map@).
339 insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
340 insertLookupWithKey f k x t
341 = case t of
342 Bin p m l r
343 | nomatch k p m -> (Nothing,join k (Tip k x) p t)
344 | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
345 | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
346 Tip ky y
347 | k==ky -> (Just y,Tip k (f k x y))
348 | otherwise -> (Nothing,join k (Tip k x) ky t)
349 Nil -> (Nothing,Tip k x)
350
351
352 {--------------------------------------------------------------------
353 Deletion
354 [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
355 --------------------------------------------------------------------}
356 -- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not
357 -- a member of the map, the original map is returned.
358 delete :: Key -> IntMap a -> IntMap a
359 delete k t
360 = case t of
361 Bin p m l r
362 | nomatch k p m -> t
363 | zero k m -> bin p m (delete k l) r
364 | otherwise -> bin p m l (delete k r)
365 Tip ky y
366 | k==ky -> Nil
367 | otherwise -> t
368 Nil -> Nil
369
370 -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
371 -- a member of the map, the original map is returned.
372 adjust :: (a -> a) -> Key -> IntMap a -> IntMap a
373 adjust f k m
374 = adjustWithKey (\k x -> f x) k m
375
376 -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
377 -- a member of the map, the original map is returned.
378 adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a
379 adjustWithKey f k m
380 = updateWithKey (\k x -> Just (f k x)) k m
381
382 -- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
383 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
384 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
385 update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a
386 update f k m
387 = updateWithKey (\k x -> f x) k m
388
389 -- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
390 -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is
391 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
392 updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
393 updateWithKey f k t
394 = case t of
395 Bin p m l r
396 | nomatch k p m -> t
397 | zero k m -> bin p m (updateWithKey f k l) r
398 | otherwise -> bin p m l (updateWithKey f k r)
399 Tip ky y
400 | k==ky -> case (f k y) of
401 Just y' -> Tip ky y'
402 Nothing -> Nil
403 | otherwise -> t
404 Nil -> Nil
405
406 -- | /O(min(n,W))/. Lookup and update.
407 updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
408 updateLookupWithKey f k t
409 = case t of
410 Bin p m l r
411 | nomatch k p m -> (Nothing,t)
412 | zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)
413 | otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')
414 Tip ky y
415 | k==ky -> case (f k y) of
416 Just y' -> (Just y,Tip ky y')
417 Nothing -> (Just y,Nil)
418 | otherwise -> (Nothing,t)
419 Nil -> (Nothing,Nil)
420
421
422 {--------------------------------------------------------------------
423 Union
424 --------------------------------------------------------------------}
425 -- | The union of a list of maps.
426 unions :: [IntMap a] -> IntMap a
427 unions xs
428 = foldlStrict union empty xs
429
430 -- | The union of a list of maps, with a combining operation
431 unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a
432 unionsWith f ts
433 = foldlStrict (unionWith f) empty ts
434
435 -- | /O(n+m)/. The (left-biased) union of two sets.
436 union :: IntMap a -> IntMap a -> IntMap a
437 union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
438 | shorter m1 m2 = union1
439 | shorter m2 m1 = union2
440 | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
441 | otherwise = join p1 t1 p2 t2
442 where
443 union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
444 | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
445 | otherwise = Bin p1 m1 l1 (union r1 t2)
446
447 union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
448 | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
449 | otherwise = Bin p2 m2 l2 (union t1 r2)
450
451 union (Tip k x) t = insert k x t
452 union t (Tip k x) = insertWith (\x y -> y) k x t -- right bias
453 union Nil t = t
454 union t Nil = t
455
456 -- | /O(n+m)/. The union with a combining function.
457 unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
458 unionWith f m1 m2
459 = unionWithKey (\k x y -> f x y) m1 m2
460
461 -- | /O(n+m)/. The union with a combining function.
462 unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
463 unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
464 | shorter m1 m2 = union1
465 | shorter m2 m1 = union2
466 | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)
467 | otherwise = join p1 t1 p2 t2
468 where
469 union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
470 | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1
471 | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2)
472
473 union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
474 | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2
475 | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2)
476
477 unionWithKey f (Tip k x) t = insertWithKey f k x t
478 unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t -- right bias
479 unionWithKey f Nil t = t
480 unionWithKey f t Nil = t
481
482 {--------------------------------------------------------------------
483 Difference
484 --------------------------------------------------------------------}
485 -- | /O(n+m)/. Difference between two maps (based on keys).
486 difference :: IntMap a -> IntMap b -> IntMap a
487 difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
488 | shorter m1 m2 = difference1
489 | shorter m2 m1 = difference2
490 | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
491 | otherwise = t1
492 where
493 difference1 | nomatch p2 p1 m1 = t1
494 | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
495 | otherwise = bin p1 m1 l1 (difference r1 t2)
496
497 difference2 | nomatch p1 p2 m2 = t1
498 | zero p1 m2 = difference t1 l2
499 | otherwise = difference t1 r2
500
501 difference t1@(Tip k x) t2
502 | member k t2 = Nil
503 | otherwise = t1
504
505 difference Nil t = Nil
506 difference t (Tip k x) = delete k t
507 difference t Nil = t
508
509 -- | /O(n+m)/. Difference with a combining function.
510 differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
511 differenceWith f m1 m2
512 = differenceWithKey (\k x y -> f x y) m1 m2
513
514 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
515 -- encountered, the combining function is applied to the key and both values.
516 -- If it returns 'Nothing', the element is discarded (proper set difference).
517 -- If it returns (@'Just' y@), the element is updated with a new value @y@.
518 differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
519 differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
520 | shorter m1 m2 = difference1
521 | shorter m2 m1 = difference2
522 | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)
523 | otherwise = t1
524 where
525 difference1 | nomatch p2 p1 m1 = t1
526 | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1
527 | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2)
528
529 difference2 | nomatch p1 p2 m2 = t1
530 | zero p1 m2 = differenceWithKey f t1 l2
531 | otherwise = differenceWithKey f t1 r2
532
533 differenceWithKey f t1@(Tip k x) t2
534 = case lookup k t2 of
535 Just y -> case f k x y of
536 Just y' -> Tip k y'
537 Nothing -> Nil
538 Nothing -> t1
539
540 differenceWithKey f Nil t = Nil
541 differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t
542 differenceWithKey f t Nil = t
543
544
545 {--------------------------------------------------------------------
546 Intersection
547 --------------------------------------------------------------------}
548 -- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).
549 intersection :: IntMap a -> IntMap b -> IntMap a
550 intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
551 | shorter m1 m2 = intersection1
552 | shorter m2 m1 = intersection2
553 | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
554 | otherwise = Nil
555 where
556 intersection1 | nomatch p2 p1 m1 = Nil
557 | zero p2 m1 = intersection l1 t2
558 | otherwise = intersection r1 t2
559
560 intersection2 | nomatch p1 p2 m2 = Nil
561 | zero p1 m2 = intersection t1 l2
562 | otherwise = intersection t1 r2
563
564 intersection t1@(Tip k x) t2
565 | member k t2 = t1
566 | otherwise = Nil
567 intersection t (Tip k x)
568 = case lookup k t of
569 Just y -> Tip k y
570 Nothing -> Nil
571 intersection Nil t = Nil
572 intersection t Nil = Nil
573
574 -- | /O(n+m)/. The intersection with a combining function.
575 intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
576 intersectionWith f m1 m2
577 = intersectionWithKey (\k x y -> f x y) m1 m2
578
579 -- | /O(n+m)/. The intersection with a combining function.
580 intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
581 intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
582 | shorter m1 m2 = intersection1
583 | shorter m2 m1 = intersection2
584 | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)
585 | otherwise = Nil
586 where
587 intersection1 | nomatch p2 p1 m1 = Nil
588 | zero p2 m1 = intersectionWithKey f l1 t2
589 | otherwise = intersectionWithKey f r1 t2
590
591 intersection2 | nomatch p1 p2 m2 = Nil
592 | zero p1 m2 = intersectionWithKey f t1 l2
593 | otherwise = intersectionWithKey f t1 r2
594
595 intersectionWithKey f t1@(Tip k x) t2
596 = case lookup k t2 of
597 Just y -> Tip k (f k x y)
598 Nothing -> Nil
599 intersectionWithKey f t1 (Tip k y)
600 = case lookup k t1 of
601 Just x -> Tip k (f k x y)
602 Nothing -> Nil
603 intersectionWithKey f Nil t = Nil
604 intersectionWithKey f t Nil = Nil
605
606
607 {--------------------------------------------------------------------
608 Submap
609 --------------------------------------------------------------------}
610 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
611 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
612 isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
613 isProperSubmapOf m1 m2
614 = isProperSubmapOfBy (==) m1 m2
615
616 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
617 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
618 @m1@ and @m2@ are not equal,
619 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
620 applied to their respective values. For example, the following
621 expressions are all 'True':
622
623 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
624 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
625
626 But the following are all 'False':
627
628 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
629 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
630 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
631 -}
632 isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
633 isProperSubmapOfBy pred t1 t2
634 = case submapCmp pred t1 t2 of
635 LT -> True
636 ge -> False
637
638 submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
639 | shorter m1 m2 = GT
640 | shorter m2 m1 = submapCmpLt
641 | p1 == p2 = submapCmpEq
642 | otherwise = GT -- disjoint
643 where
644 submapCmpLt | nomatch p1 p2 m2 = GT
645 | zero p1 m2 = submapCmp pred t1 l2
646 | otherwise = submapCmp pred t1 r2
647 submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of
648 (GT,_ ) -> GT
649 (_ ,GT) -> GT
650 (EQ,EQ) -> EQ
651 other -> LT
652
653 submapCmp pred (Bin p m l r) t = GT
654 submapCmp pred (Tip kx x) (Tip ky y)
655 | (kx == ky) && pred x y = EQ
656 | otherwise = GT -- disjoint
657 submapCmp pred (Tip k x) t
658 = case lookup k t of
659 Just y | pred x y -> LT
660 other -> GT -- disjoint
661 submapCmp pred Nil Nil = EQ
662 submapCmp pred Nil t = LT
663
664 -- | /O(n+m)/. Is this a submap?
665 -- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
666 isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
667 isSubmapOf m1 m2
668 = isSubmapOfBy (==) m1 m2
669
670 {- | /O(n+m)/.
671 The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if
672 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
673 applied to their respective values. For example, the following
674 expressions are all 'True':
675
676 > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
677 > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
678 > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
679
680 But the following are all 'False':
681
682 > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])
683 > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
684 > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
685 -}
686
687 isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
688 isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
689 | shorter m1 m2 = False
690 | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2
691 else isSubmapOfBy pred t1 r2)
692 | otherwise = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2
693 isSubmapOfBy pred (Bin p m l r) t = False
694 isSubmapOfBy pred (Tip k x) t = case lookup k t of
695 Just y -> pred x y
696 Nothing -> False
697 isSubmapOfBy pred Nil t = True
698
699 {--------------------------------------------------------------------
700 Mapping
701 --------------------------------------------------------------------}
702 -- | /O(n)/. Map a function over all values in the map.
703 map :: (a -> b) -> IntMap a -> IntMap b
704 map f m
705 = mapWithKey (\k x -> f x) m
706
707 -- | /O(n)/. Map a function over all values in the map.
708 mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
709 mapWithKey f t
710 = case t of
711 Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
712 Tip k x -> Tip k (f k x)
713 Nil -> Nil
714
715 -- | /O(n)/. The function @'mapAccum'@ threads an accumulating
716 -- argument through the map in an unspecified order.
717 mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
718 mapAccum f a m
719 = mapAccumWithKey (\a k x -> f a x) a m
720
721 -- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating
722 -- argument through the map in an unspecified order.
723 mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
724 mapAccumWithKey f a t
725 = mapAccumL f a t
726
727 -- | /O(n)/. The function @'mapAccumL'@ threads an accumulating
728 -- argument through the map in pre-order.
729 mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
730 mapAccumL f a t
731 = case t of
732 Bin p m l r -> let (a1,l') = mapAccumL f a l
733 (a2,r') = mapAccumL f a1 r
734 in (a2,Bin p m l' r')
735 Tip k x -> let (a',x') = f a k x in (a',Tip k x')
736 Nil -> (a,Nil)
737
738
739 -- | /O(n)/. The function @'mapAccumR'@ threads an accumulating
740 -- argument throught the map in post-order.
741 mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
742 mapAccumR f a t
743 = case t of
744 Bin p m l r -> let (a1,r') = mapAccumR f a r
745 (a2,l') = mapAccumR f a1 l
746 in (a2,Bin p m l' r')
747 Tip k x -> let (a',x') = f a k x in (a',Tip k x')
748 Nil -> (a,Nil)
749
750 {--------------------------------------------------------------------
751 Filter
752 --------------------------------------------------------------------}
753 -- | /O(n)/. Filter all values that satisfy some predicate.
754 filter :: (a -> Bool) -> IntMap a -> IntMap a
755 filter p m
756 = filterWithKey (\k x -> p x) m
757
758 -- | /O(n)/. Filter all keys\/values that satisfy some predicate.
759 filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
760 filterWithKey pred t
761 = case t of
762 Bin p m l r
763 -> bin p m (filterWithKey pred l) (filterWithKey pred r)
764 Tip k x
765 | pred k x -> t
766 | otherwise -> Nil
767 Nil -> Nil
768
769 -- | /O(n)/. partition the map according to some predicate. The first
770 -- map contains all elements that satisfy the predicate, the second all
771 -- elements that fail the predicate. See also 'split'.
772 partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
773 partition p m
774 = partitionWithKey (\k x -> p x) m
775
776 -- | /O(n)/. partition the map according to some predicate. The first
777 -- map contains all elements that satisfy the predicate, the second all
778 -- elements that fail the predicate. See also 'split'.
779 partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
780 partitionWithKey pred t
781 = case t of
782 Bin p m l r
783 -> let (l1,l2) = partitionWithKey pred l
784 (r1,r2) = partitionWithKey pred r
785 in (bin p m l1 r1, bin p m l2 r2)
786 Tip k x
787 | pred k x -> (t,Nil)
788 | otherwise -> (Nil,t)
789 Nil -> (Nil,Nil)
790
791
792 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@
793 -- where all keys in @map1@ are lower than @k@ and all keys in
794 -- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
795 split :: Key -> IntMap a -> (IntMap a,IntMap a)
796 split k t
797 = case t of
798 Bin p m l r
799 | zero k m -> let (lt,gt) = split k l in (lt,union gt r)
800 | otherwise -> let (lt,gt) = split k r in (union l lt,gt)
801 Tip ky y
802 | k>ky -> (t,Nil)
803 | k<ky -> (Nil,t)
804 | otherwise -> (Nil,Nil)
805 Nil -> (Nil,Nil)
806
807 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
808 -- key was found in the original map.
809 splitLookup :: Key -> IntMap a -> (Maybe a,IntMap a,IntMap a)
810 splitLookup k t
811 = case t of
812 Bin p m l r
813 | zero k m -> let (found,lt,gt) = splitLookup k l in (found,lt,union gt r)
814 | otherwise -> let (found,lt,gt) = splitLookup k r in (found,union l lt,gt)
815 Tip ky y
816 | k>ky -> (Nothing,t,Nil)
817 | k<ky -> (Nothing,Nil,t)
818 | otherwise -> (Just y,Nil,Nil)
819 Nil -> (Nothing,Nil,Nil)
820
821 {--------------------------------------------------------------------
822 Fold
823 --------------------------------------------------------------------}
824 -- | /O(n)/. Fold over the elements of a map in an unspecified order.
825 --
826 -- > sum map = fold (+) 0 map
827 -- > elems map = fold (:) [] map
828 fold :: (a -> b -> b) -> b -> IntMap a -> b
829 fold f z t
830 = foldWithKey (\k x y -> f x y) z t
831
832 -- | /O(n)/. Fold over the elements of a map in an unspecified order.
833 --
834 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
835 foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
836 foldWithKey f z t
837 = foldr f z t
838
839 foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
840 foldr f z t
841 = case t of
842 Bin p m l r -> foldr f (foldr f z r) l
843 Tip k x -> f k x z
844 Nil -> z
845
846 {--------------------------------------------------------------------
847 List variations
848 --------------------------------------------------------------------}
849 -- | /O(n)/. Return all elements of the map.
850 elems :: IntMap a -> [a]
851 elems m
852 = foldWithKey (\k x xs -> x:xs) [] m
853
854 -- | /O(n)/. Return all keys of the map.
855 keys :: IntMap a -> [Key]
856 keys m
857 = foldWithKey (\k x ks -> k:ks) [] m
858
859 -- | /O(n*min(n,W))/. The set of all keys of the map.
860 keysSet :: IntMap a -> IntSet.IntSet
861 keysSet m = IntSet.fromDistinctAscList (keys m)
862
863
864 -- | /O(n)/. Return all key\/value pairs in the map.
865 assocs :: IntMap a -> [(Key,a)]
866 assocs m
867 = toList m
868
869
870 {--------------------------------------------------------------------
871 Lists
872 --------------------------------------------------------------------}
873 -- | /O(n)/. Convert the map to a list of key\/value pairs.
874 toList :: IntMap a -> [(Key,a)]
875 toList t
876 = foldWithKey (\k x xs -> (k,x):xs) [] t
877
878 -- | /O(n)/. Convert the map to a list of key\/value pairs where the
879 -- keys are in ascending order.
880 toAscList :: IntMap a -> [(Key,a)]
881 toAscList t
882 = -- NOTE: the following algorithm only works for big-endian trees
883 let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos
884
885 -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.
886 fromList :: [(Key,a)] -> IntMap a
887 fromList xs
888 = foldlStrict ins empty xs
889 where
890 ins t (k,x) = insert k x t
891
892 -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
893 fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
894 fromListWith f xs
895 = fromListWithKey (\k x y -> f x y) xs
896
897 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.
898 fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
899 fromListWithKey f xs
900 = foldlStrict ins empty xs
901 where
902 ins t (k,x) = insertWithKey f k x t
903
904 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
905 -- the keys are in ascending order.
906 fromAscList :: [(Key,a)] -> IntMap a
907 fromAscList xs
908 = fromList xs
909
910 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
911 -- the keys are in ascending order, with a combining function on equal keys.
912 fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
913 fromAscListWith f xs
914 = fromListWith f xs
915
916 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
917 -- the keys are in ascending order, with a combining function on equal keys.
918 fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
919 fromAscListWithKey f xs
920 = fromListWithKey f xs
921
922 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
923 -- the keys are in ascending order and all distinct.
924 fromDistinctAscList :: [(Key,a)] -> IntMap a
925 fromDistinctAscList xs
926 = fromList xs
927
928
929 {--------------------------------------------------------------------
930 Eq
931 --------------------------------------------------------------------}
932 instance Eq a => Eq (IntMap a) where
933 t1 == t2 = equal t1 t2
934 t1 /= t2 = nequal t1 t2
935
936 equal :: Eq a => IntMap a -> IntMap a -> Bool
937 equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
938 = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
939 equal (Tip kx x) (Tip ky y)
940 = (kx == ky) && (x==y)
941 equal Nil Nil = True
942 equal t1 t2 = False
943
944 nequal :: Eq a => IntMap a -> IntMap a -> Bool
945 nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
946 = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
947 nequal (Tip kx x) (Tip ky y)
948 = (kx /= ky) || (x/=y)
949 nequal Nil Nil = False
950 nequal t1 t2 = True
951
952 {--------------------------------------------------------------------
953 Ord
954 --------------------------------------------------------------------}
955
956 instance Ord a => Ord (IntMap a) where
957 compare m1 m2 = compare (toList m1) (toList m2)
958
959 {--------------------------------------------------------------------
960 Functor
961 --------------------------------------------------------------------}
962
963 instance Functor IntMap where
964 fmap = map
965
966 {--------------------------------------------------------------------
967 Monoid
968 --------------------------------------------------------------------}
969
970 instance Ord a => Monoid (IntMap a) where
971 mempty = empty
972 mappend = union
973 mconcat = unions
974
975 {--------------------------------------------------------------------
976 Show
977 --------------------------------------------------------------------}
978
979 instance Show a => Show (IntMap a) where
980 showsPrec d t = showMap (toList t)
981
982
983 showMap :: (Show a) => [(Key,a)] -> ShowS
984 showMap []
985 = showString "{}"
986 showMap (x:xs)
987 = showChar '{' . showElem x . showTail xs
988 where
989 showTail [] = showChar '}'
990 showTail (x:xs) = showChar ',' . showElem x . showTail xs
991
992 showElem (k,x) = shows k . showString ":=" . shows x
993
994 {--------------------------------------------------------------------
995 Typeable
996 --------------------------------------------------------------------}
997
998 #include "Typeable.h"
999 INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")
1000
1001 {--------------------------------------------------------------------
1002 Debugging
1003 --------------------------------------------------------------------}
1004 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1005 -- in a compressed, hanging format.
1006 showTree :: Show a => IntMap a -> String
1007 showTree s
1008 = showTreeWith True False s
1009
1010
1011 {- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
1012 the tree that implements the map. If @hang@ is
1013 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1014 @wide@ is 'True', an extra wide version is shown.
1015 -}
1016 showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
1017 showTreeWith hang wide t
1018 | hang = (showsTreeHang wide [] t) ""
1019 | otherwise = (showsTree wide [] [] t) ""
1020
1021 showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS
1022 showsTree wide lbars rbars t
1023 = case t of
1024 Bin p m l r
1025 -> showsTree wide (withBar rbars) (withEmpty rbars) r .
1026 showWide wide rbars .
1027 showsBars lbars . showString (showBin p m) . showString "\n" .
1028 showWide wide lbars .
1029 showsTree wide (withEmpty lbars) (withBar lbars) l
1030 Tip k x
1031 -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"
1032 Nil -> showsBars lbars . showString "|\n"
1033
1034 showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS
1035 showsTreeHang wide bars t
1036 = case t of
1037 Bin p m l r
1038 -> showsBars bars . showString (showBin p m) . showString "\n" .
1039 showWide wide bars .
1040 showsTreeHang wide (withBar bars) l .
1041 showWide wide bars .
1042 showsTreeHang wide (withEmpty bars) r
1043 Tip k x
1044 -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"
1045 Nil -> showsBars bars . showString "|\n"
1046
1047 showBin p m
1048 = "*" -- ++ show (p,m)
1049
1050 showWide wide bars
1051 | wide = showString (concat (reverse bars)) . showString "|\n"
1052 | otherwise = id
1053
1054 showsBars :: [String] -> ShowS
1055 showsBars bars
1056 = case bars of
1057 [] -> id
1058 _ -> showString (concat (reverse (tail bars))) . showString node
1059
1060 node = "+--"
1061 withBar bars = "| ":bars
1062 withEmpty bars = " ":bars
1063
1064
1065 {--------------------------------------------------------------------
1066 Helpers
1067 --------------------------------------------------------------------}
1068 {--------------------------------------------------------------------
1069 Join
1070 --------------------------------------------------------------------}
1071 join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
1072 join p1 t1 p2 t2
1073 | zero p1 m = Bin p m t1 t2
1074 | otherwise = Bin p m t2 t1
1075 where
1076 m = branchMask p1 p2
1077 p = mask p1 m
1078
1079 {--------------------------------------------------------------------
1080 @bin@ assures that we never have empty trees within a tree.
1081 --------------------------------------------------------------------}
1082 bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
1083 bin p m l Nil = l
1084 bin p m Nil r = r
1085 bin p m l r = Bin p m l r
1086
1087
1088 {--------------------------------------------------------------------
1089 Endian independent bit twiddling
1090 --------------------------------------------------------------------}
1091 zero :: Key -> Mask -> Bool
1092 zero i m
1093 = (natFromInt i) .&. (natFromInt m) == 0
1094
1095 nomatch,match :: Key -> Prefix -> Mask -> Bool
1096 nomatch i p m
1097 = (mask i m) /= p
1098
1099 match i p m
1100 = (mask i m) == p
1101
1102 mask :: Key -> Mask -> Prefix
1103 mask i m
1104 = maskW (natFromInt i) (natFromInt m)
1105
1106
1107 zeroN :: Nat -> Nat -> Bool
1108 zeroN i m = (i .&. m) == 0
1109
1110 {--------------------------------------------------------------------
1111 Big endian operations
1112 --------------------------------------------------------------------}
1113 maskW :: Nat -> Nat -> Prefix
1114 maskW i m
1115 = intFromNat (i .&. (complement (m-1) `xor` m))
1116
1117 shorter :: Mask -> Mask -> Bool
1118 shorter m1 m2
1119 = (natFromInt m1) > (natFromInt m2)
1120
1121 branchMask :: Prefix -> Prefix -> Mask
1122 branchMask p1 p2
1123 = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
1124
1125 {----------------------------------------------------------------------
1126 Finding the highest bit (mask) in a word [x] can be done efficiently in
1127 three ways:
1128 * convert to a floating point value and the mantissa tells us the
1129 [log2(x)] that corresponds with the highest bit position. The mantissa
1130 is retrieved either via the standard C function [frexp] or by some bit
1131 twiddling on IEEE compatible numbers (float). Note that one needs to
1132 use at least [double] precision for an accurate mantissa of 32 bit
1133 numbers.
1134 * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
1135 * use processor specific assembler instruction (asm).
1136
1137 The most portable way would be [bit], but is it efficient enough?
1138 I have measured the cycle counts of the different methods on an AMD
1139 Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
1140
1141 highestBitMask: method cycles
1142 --------------
1143 frexp 200
1144 float 33
1145 bit 11
1146 asm 12
1147
1148 highestBit: method cycles
1149 --------------
1150 frexp 195
1151 float 33
1152 bit 11
1153 asm 11
1154
1155 Wow, the bit twiddling is on today's RISC like machines even faster
1156 than a single CISC instruction (BSR)!
1157 ----------------------------------------------------------------------}
1158
1159 {----------------------------------------------------------------------
1160 [highestBitMask] returns a word where only the highest bit is set.
1161 It is found by first setting all bits in lower positions than the
1162 highest bit and than taking an exclusive or with the original value.
1163 Allthough the function may look expensive, GHC compiles this into
1164 excellent C code that subsequently compiled into highly efficient
1165 machine code. The algorithm is derived from Jorg Arndt's FXT library.
1166 ----------------------------------------------------------------------}
1167 highestBitMask :: Nat -> Nat
1168 highestBitMask x
1169 = case (x .|. shiftRL x 1) of
1170 x -> case (x .|. shiftRL x 2) of
1171 x -> case (x .|. shiftRL x 4) of
1172 x -> case (x .|. shiftRL x 8) of
1173 x -> case (x .|. shiftRL x 16) of
1174 x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms
1175 x -> (x `xor` (shiftRL x 1))
1176
1177
1178 {--------------------------------------------------------------------
1179 Utilities
1180 --------------------------------------------------------------------}
1181 foldlStrict f z xs
1182 = case xs of
1183 [] -> z
1184 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1185
1186 {-
1187 {--------------------------------------------------------------------
1188 Testing
1189 --------------------------------------------------------------------}
1190 testTree :: [Int] -> IntMap Int
1191 testTree xs = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]
1192 test1 = testTree [1..20]
1193 test2 = testTree [30,29..10]
1194 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1195
1196 {--------------------------------------------------------------------
1197 QuickCheck
1198 --------------------------------------------------------------------}
1199 qcheck prop
1200 = check config prop
1201 where
1202 config = Config
1203 { configMaxTest = 500
1204 , configMaxFail = 5000
1205 , configSize = \n -> (div n 2 + 3)
1206 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1207 }
1208
1209
1210 {--------------------------------------------------------------------
1211 Arbitrary, reasonably balanced trees
1212 --------------------------------------------------------------------}
1213 instance Arbitrary a => Arbitrary (IntMap a) where
1214 arbitrary = do{ ks <- arbitrary
1215 ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks
1216 ; return (fromList xs)
1217 }
1218
1219
1220 {--------------------------------------------------------------------
1221 Single, Insert, Delete
1222 --------------------------------------------------------------------}
1223 prop_Single :: Key -> Int -> Bool
1224 prop_Single k x
1225 = (insert k x empty == singleton k x)
1226
1227 prop_InsertDelete :: Key -> Int -> IntMap Int -> Property
1228 prop_InsertDelete k x t
1229 = not (member k t) ==> delete k (insert k x t) == t
1230
1231 prop_UpdateDelete :: Key -> IntMap Int -> Bool
1232 prop_UpdateDelete k t
1233 = update (const Nothing) k t == delete k t
1234
1235
1236 {--------------------------------------------------------------------
1237 Union
1238 --------------------------------------------------------------------}
1239 prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool
1240 prop_UnionInsert k x t
1241 = union (singleton k x) t == insert k x t
1242
1243 prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool
1244 prop_UnionAssoc t1 t2 t3
1245 = union t1 (union t2 t3) == union (union t1 t2) t3
1246
1247 prop_UnionComm :: IntMap Int -> IntMap Int -> Bool
1248 prop_UnionComm t1 t2
1249 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1250
1251
1252 prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool
1253 prop_Diff xs ys
1254 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1255 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1256
1257 prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool
1258 prop_Int xs ys
1259 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1260 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1261
1262 {--------------------------------------------------------------------
1263 Lists
1264 --------------------------------------------------------------------}
1265 prop_Ordered
1266 = forAll (choose (5,100)) $ \n ->
1267 let xs = [(x,()) | x <- [0..n::Int]]
1268 in fromAscList xs == fromList xs
1269
1270 prop_List :: [Key] -> Bool
1271 prop_List xs
1272 = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])
1273 -}