[project @ 2005-10-21 10:26:57 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 qualified Data.IntSet as IntSet
139 import Data.Typeable
140
141 {-
142 -- just for testing
143 import qualified Prelude
144 import Debug.QuickCheck
145 import List (nub,sort)
146 import qualified List
147 -}
148
149 #if __GLASGOW_HASKELL__
150 import Data.Generics.Basics
151 import Data.Generics.Instances
152 #endif
153
154 #if __GLASGOW_HASKELL__ >= 503
155 import GHC.Word
156 import GHC.Exts ( Word(..), Int(..), shiftRL# )
157 #elif __GLASGOW_HASKELL__
158 import Word
159 import GlaExts ( Word(..), Int(..), shiftRL# )
160 #else
161 import Data.Word
162 #endif
163
164 infixl 9 \\{-This comment teaches CPP correct behaviour -}
165
166 -- A "Nat" is a natural machine word (an unsigned Int)
167 type Nat = Word
168
169 natFromInt :: Key -> Nat
170 natFromInt i = fromIntegral i
171
172 intFromNat :: Nat -> Key
173 intFromNat w = fromIntegral w
174
175 shiftRL :: Nat -> Key -> Nat
176 #if __GLASGOW_HASKELL__
177 {--------------------------------------------------------------------
178 GHC: use unboxing to get @shiftRL@ inlined.
179 --------------------------------------------------------------------}
180 shiftRL (W# x) (I# i)
181 = W# (shiftRL# x i)
182 #else
183 shiftRL x i = shiftR x i
184 #endif
185
186 {--------------------------------------------------------------------
187 Operators
188 --------------------------------------------------------------------}
189
190 -- | /O(min(n,W))/. Find the value at a key.
191 -- 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 at 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 at 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 --------------------------------------------------------------------}
300 -- | /O(min(n,W))/. Insert a new key\/value pair in the map.
301 -- If the key is already present in the map, the associated value is
302 -- replaced with the supplied value, i.e. 'insert' is equivalent to
303 -- @'insertWith' 'const'@.
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 maps.
436 -- It prefers the first map when duplicate keys are encountered,
437 -- i.e. (@'union' == 'unionWith' 'const'@).
438 union :: IntMap a -> IntMap a -> IntMap a
439 union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
440 | shorter m1 m2 = union1
441 | shorter m2 m1 = union2
442 | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
443 | otherwise = join p1 t1 p2 t2
444 where
445 union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
446 | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
447 | otherwise = Bin p1 m1 l1 (union r1 t2)
448
449 union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
450 | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
451 | otherwise = Bin p2 m2 l2 (union t1 r2)
452
453 union (Tip k x) t = insert k x t
454 union t (Tip k x) = insertWith (\x y -> y) k x t -- right bias
455 union Nil t = t
456 union t Nil = t
457
458 -- | /O(n+m)/. The union with a combining function.
459 unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
460 unionWith f m1 m2
461 = unionWithKey (\k x y -> f x y) m1 m2
462
463 -- | /O(n+m)/. The union with a combining function.
464 unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
465 unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
466 | shorter m1 m2 = union1
467 | shorter m2 m1 = union2
468 | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)
469 | otherwise = join p1 t1 p2 t2
470 where
471 union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
472 | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1
473 | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2)
474
475 union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
476 | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2
477 | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2)
478
479 unionWithKey f (Tip k x) t = insertWithKey f k x t
480 unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t -- right bias
481 unionWithKey f Nil t = t
482 unionWithKey f t Nil = t
483
484 {--------------------------------------------------------------------
485 Difference
486 --------------------------------------------------------------------}
487 -- | /O(n+m)/. Difference between two maps (based on keys).
488 difference :: IntMap a -> IntMap b -> IntMap a
489 difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
490 | shorter m1 m2 = difference1
491 | shorter m2 m1 = difference2
492 | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
493 | otherwise = t1
494 where
495 difference1 | nomatch p2 p1 m1 = t1
496 | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
497 | otherwise = bin p1 m1 l1 (difference r1 t2)
498
499 difference2 | nomatch p1 p2 m2 = t1
500 | zero p1 m2 = difference t1 l2
501 | otherwise = difference t1 r2
502
503 difference t1@(Tip k x) t2
504 | member k t2 = Nil
505 | otherwise = t1
506
507 difference Nil t = Nil
508 difference t (Tip k x) = delete k t
509 difference t Nil = t
510
511 -- | /O(n+m)/. Difference with a combining function.
512 differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
513 differenceWith f m1 m2
514 = differenceWithKey (\k x y -> f x y) m1 m2
515
516 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
517 -- encountered, the combining function is applied to the key and both values.
518 -- If it returns 'Nothing', the element is discarded (proper set difference).
519 -- If it returns (@'Just' y@), the element is updated with a new value @y@.
520 differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
521 differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
522 | shorter m1 m2 = difference1
523 | shorter m2 m1 = difference2
524 | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)
525 | otherwise = t1
526 where
527 difference1 | nomatch p2 p1 m1 = t1
528 | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1
529 | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2)
530
531 difference2 | nomatch p1 p2 m2 = t1
532 | zero p1 m2 = differenceWithKey f t1 l2
533 | otherwise = differenceWithKey f t1 r2
534
535 differenceWithKey f t1@(Tip k x) t2
536 = case lookup k t2 of
537 Just y -> case f k x y of
538 Just y' -> Tip k y'
539 Nothing -> Nil
540 Nothing -> t1
541
542 differenceWithKey f Nil t = Nil
543 differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t
544 differenceWithKey f t Nil = t
545
546
547 {--------------------------------------------------------------------
548 Intersection
549 --------------------------------------------------------------------}
550 -- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).
551 intersection :: IntMap a -> IntMap b -> IntMap a
552 intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
553 | shorter m1 m2 = intersection1
554 | shorter m2 m1 = intersection2
555 | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
556 | otherwise = Nil
557 where
558 intersection1 | nomatch p2 p1 m1 = Nil
559 | zero p2 m1 = intersection l1 t2
560 | otherwise = intersection r1 t2
561
562 intersection2 | nomatch p1 p2 m2 = Nil
563 | zero p1 m2 = intersection t1 l2
564 | otherwise = intersection t1 r2
565
566 intersection t1@(Tip k x) t2
567 | member k t2 = t1
568 | otherwise = Nil
569 intersection t (Tip k x)
570 = case lookup k t of
571 Just y -> Tip k y
572 Nothing -> Nil
573 intersection Nil t = Nil
574 intersection t Nil = Nil
575
576 -- | /O(n+m)/. The intersection with a combining function.
577 intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
578 intersectionWith f m1 m2
579 = intersectionWithKey (\k x y -> f x y) m1 m2
580
581 -- | /O(n+m)/. The intersection with a combining function.
582 intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
583 intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
584 | shorter m1 m2 = intersection1
585 | shorter m2 m1 = intersection2
586 | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)
587 | otherwise = Nil
588 where
589 intersection1 | nomatch p2 p1 m1 = Nil
590 | zero p2 m1 = intersectionWithKey f l1 t2
591 | otherwise = intersectionWithKey f r1 t2
592
593 intersection2 | nomatch p1 p2 m2 = Nil
594 | zero p1 m2 = intersectionWithKey f t1 l2
595 | otherwise = intersectionWithKey f t1 r2
596
597 intersectionWithKey f t1@(Tip k x) t2
598 = case lookup k t2 of
599 Just y -> Tip k (f k x y)
600 Nothing -> Nil
601 intersectionWithKey f t1 (Tip k y)
602 = case lookup k t1 of
603 Just x -> Tip k (f k x y)
604 Nothing -> Nil
605 intersectionWithKey f Nil t = Nil
606 intersectionWithKey f t Nil = Nil
607
608
609 {--------------------------------------------------------------------
610 Submap
611 --------------------------------------------------------------------}
612 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
613 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
614 isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
615 isProperSubmapOf m1 m2
616 = isProperSubmapOfBy (==) m1 m2
617
618 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
619 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
620 @m1@ and @m2@ are not equal,
621 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
622 applied to their respective values. For example, the following
623 expressions are all 'True':
624
625 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
626 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
627
628 But the following are all 'False':
629
630 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
631 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
632 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
633 -}
634 isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
635 isProperSubmapOfBy pred t1 t2
636 = case submapCmp pred t1 t2 of
637 LT -> True
638 ge -> False
639
640 submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
641 | shorter m1 m2 = GT
642 | shorter m2 m1 = submapCmpLt
643 | p1 == p2 = submapCmpEq
644 | otherwise = GT -- disjoint
645 where
646 submapCmpLt | nomatch p1 p2 m2 = GT
647 | zero p1 m2 = submapCmp pred t1 l2
648 | otherwise = submapCmp pred t1 r2
649 submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of
650 (GT,_ ) -> GT
651 (_ ,GT) -> GT
652 (EQ,EQ) -> EQ
653 other -> LT
654
655 submapCmp pred (Bin p m l r) t = GT
656 submapCmp pred (Tip kx x) (Tip ky y)
657 | (kx == ky) && pred x y = EQ
658 | otherwise = GT -- disjoint
659 submapCmp pred (Tip k x) t
660 = case lookup k t of
661 Just y | pred x y -> LT
662 other -> GT -- disjoint
663 submapCmp pred Nil Nil = EQ
664 submapCmp pred Nil t = LT
665
666 -- | /O(n+m)/. Is this a submap?
667 -- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
668 isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
669 isSubmapOf m1 m2
670 = isSubmapOfBy (==) m1 m2
671
672 {- | /O(n+m)/.
673 The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if
674 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
675 applied to their respective values. For example, the following
676 expressions are all 'True':
677
678 > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
679 > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
680 > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
681
682 But the following are all 'False':
683
684 > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])
685 > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
686 > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
687 -}
688
689 isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
690 isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
691 | shorter m1 m2 = False
692 | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2
693 else isSubmapOfBy pred t1 r2)
694 | otherwise = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2
695 isSubmapOfBy pred (Bin p m l r) t = False
696 isSubmapOfBy pred (Tip k x) t = case lookup k t of
697 Just y -> pred x y
698 Nothing -> False
699 isSubmapOfBy pred Nil t = True
700
701 {--------------------------------------------------------------------
702 Mapping
703 --------------------------------------------------------------------}
704 -- | /O(n)/. Map a function over all values in the map.
705 map :: (a -> b) -> IntMap a -> IntMap b
706 map f m
707 = mapWithKey (\k x -> f x) m
708
709 -- | /O(n)/. Map a function over all values in the map.
710 mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
711 mapWithKey f t
712 = case t of
713 Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
714 Tip k x -> Tip k (f k x)
715 Nil -> Nil
716
717 -- | /O(n)/. The function @'mapAccum'@ threads an accumulating
718 -- argument through the map in ascending order of keys.
719 mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
720 mapAccum f a m
721 = mapAccumWithKey (\a k x -> f a x) a m
722
723 -- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating
724 -- argument through the map in ascending order of keys.
725 mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
726 mapAccumWithKey f a t
727 = mapAccumL f a t
728
729 -- | /O(n)/. The function @'mapAccumL'@ threads an accumulating
730 -- argument through the map in ascending order of keys.
731 mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
732 mapAccumL f a t
733 = case t of
734 Bin p m l r -> let (a1,l') = mapAccumL f a l
735 (a2,r') = mapAccumL f a1 r
736 in (a2,Bin p m l' r')
737 Tip k x -> let (a',x') = f a k x in (a',Tip k x')
738 Nil -> (a,Nil)
739
740
741 -- | /O(n)/. The function @'mapAccumR'@ threads an accumulating
742 -- argument throught the map in descending order of keys.
743 mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
744 mapAccumR f a t
745 = case t of
746 Bin p m l r -> let (a1,r') = mapAccumR f a r
747 (a2,l') = mapAccumR f a1 l
748 in (a2,Bin p m l' r')
749 Tip k x -> let (a',x') = f a k x in (a',Tip k x')
750 Nil -> (a,Nil)
751
752 {--------------------------------------------------------------------
753 Filter
754 --------------------------------------------------------------------}
755 -- | /O(n)/. Filter all values that satisfy some predicate.
756 filter :: (a -> Bool) -> IntMap a -> IntMap a
757 filter p m
758 = filterWithKey (\k x -> p x) m
759
760 -- | /O(n)/. Filter all keys\/values that satisfy some predicate.
761 filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
762 filterWithKey pred t
763 = case t of
764 Bin p m l r
765 -> bin p m (filterWithKey pred l) (filterWithKey pred r)
766 Tip k x
767 | pred k x -> t
768 | otherwise -> Nil
769 Nil -> Nil
770
771 -- | /O(n)/. partition the map according to some predicate. The first
772 -- map contains all elements that satisfy the predicate, the second all
773 -- elements that fail the predicate. See also 'split'.
774 partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
775 partition p m
776 = partitionWithKey (\k x -> p x) m
777
778 -- | /O(n)/. partition the map according to some predicate. The first
779 -- map contains all elements that satisfy the predicate, the second all
780 -- elements that fail the predicate. See also 'split'.
781 partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
782 partitionWithKey pred t
783 = case t of
784 Bin p m l r
785 -> let (l1,l2) = partitionWithKey pred l
786 (r1,r2) = partitionWithKey pred r
787 in (bin p m l1 r1, bin p m l2 r2)
788 Tip k x
789 | pred k x -> (t,Nil)
790 | otherwise -> (Nil,t)
791 Nil -> (Nil,Nil)
792
793
794 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@
795 -- where all keys in @map1@ are lower than @k@ and all keys in
796 -- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
797 split :: Key -> IntMap a -> (IntMap a,IntMap a)
798 split k t
799 = case t of
800 Bin p m l r
801 | nomatch k p m -> if k>p then (t,Nil) else (Nil,t)
802 | zero k m -> let (lt,gt) = split k l in (lt,union gt r)
803 | otherwise -> let (lt,gt) = split k r in (union l lt,gt)
804 Tip ky y
805 | k>ky -> (t,Nil)
806 | k<ky -> (Nil,t)
807 | otherwise -> (Nil,Nil)
808 Nil -> (Nil,Nil)
809
810 -- | /O(log n)/. Performs a 'split' but also returns whether the pivot
811 -- key was found in the original map.
812 splitLookup :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)
813 splitLookup k t
814 = case t of
815 Bin p m l r
816 | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)
817 | zero k m -> let (lt,found,gt) = splitLookup k l in (lt,found,union gt r)
818 | otherwise -> let (lt,found,gt) = splitLookup k r in (union l lt,found,gt)
819 Tip ky y
820 | k>ky -> (t,Nothing,Nil)
821 | k<ky -> (Nil,Nothing,t)
822 | otherwise -> (Nil,Just y,Nil)
823 Nil -> (Nil,Nothing,Nil)
824
825 {--------------------------------------------------------------------
826 Fold
827 --------------------------------------------------------------------}
828 -- | /O(n)/. Fold the values in the map, such that
829 -- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
830 -- For example,
831 --
832 -- > elems map = fold (:) [] map
833 --
834 fold :: (a -> b -> b) -> b -> IntMap a -> b
835 fold f z t
836 = foldWithKey (\k x y -> f x y) z t
837
838 -- | /O(n)/. Fold the keys and values in the map, such that
839 -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
840 -- For example,
841 --
842 -- > keys map = foldWithKey (\k x ks -> k:ks) [] map
843 --
844 foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
845 foldWithKey f z t
846 = foldr f z t
847
848 foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
849 foldr f z t
850 = case t of
851 Bin p m l r -> foldr f (foldr f z r) l
852 Tip k x -> f k x z
853 Nil -> z
854
855 {--------------------------------------------------------------------
856 List variations
857 --------------------------------------------------------------------}
858 -- | /O(n)/.
859 -- Return all elements of the map in the ascending order of their keys.
860 elems :: IntMap a -> [a]
861 elems m
862 = foldWithKey (\k x xs -> x:xs) [] m
863
864 -- | /O(n)/. Return all keys of the map in ascending order.
865 keys :: IntMap a -> [Key]
866 keys m
867 = foldWithKey (\k x ks -> k:ks) [] m
868
869 -- | /O(n*min(n,W))/. The set of all keys of the map.
870 keysSet :: IntMap a -> IntSet.IntSet
871 keysSet m = IntSet.fromDistinctAscList (keys m)
872
873
874 -- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
875 assocs :: IntMap a -> [(Key,a)]
876 assocs m
877 = toList m
878
879
880 {--------------------------------------------------------------------
881 Lists
882 --------------------------------------------------------------------}
883 -- | /O(n)/. Convert the map to a list of key\/value pairs.
884 toList :: IntMap a -> [(Key,a)]
885 toList t
886 = foldWithKey (\k x xs -> (k,x):xs) [] t
887
888 -- | /O(n)/. Convert the map to a list of key\/value pairs where the
889 -- keys are in ascending order.
890 toAscList :: IntMap a -> [(Key,a)]
891 toAscList t
892 = -- NOTE: the following algorithm only works for big-endian trees
893 let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos
894
895 -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.
896 fromList :: [(Key,a)] -> IntMap a
897 fromList xs
898 = foldlStrict ins empty xs
899 where
900 ins t (k,x) = insert k x t
901
902 -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
903 fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
904 fromListWith f xs
905 = fromListWithKey (\k x y -> f x y) xs
906
907 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.
908 fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
909 fromListWithKey f xs
910 = foldlStrict ins empty xs
911 where
912 ins t (k,x) = insertWithKey f k x t
913
914 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
915 -- the keys are in ascending order.
916 fromAscList :: [(Key,a)] -> IntMap a
917 fromAscList xs
918 = fromList xs
919
920 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
921 -- the keys are in ascending order, with a combining function on equal keys.
922 fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
923 fromAscListWith f xs
924 = fromListWith f xs
925
926 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
927 -- the keys are in ascending order, with a combining function on equal keys.
928 fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
929 fromAscListWithKey f xs
930 = fromListWithKey f xs
931
932 -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
933 -- the keys are in ascending order and all distinct.
934 fromDistinctAscList :: [(Key,a)] -> IntMap a
935 fromDistinctAscList xs
936 = fromList xs
937
938
939 {--------------------------------------------------------------------
940 Eq
941 --------------------------------------------------------------------}
942 instance Eq a => Eq (IntMap a) where
943 t1 == t2 = equal t1 t2
944 t1 /= t2 = nequal t1 t2
945
946 equal :: Eq a => IntMap a -> IntMap a -> Bool
947 equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
948 = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
949 equal (Tip kx x) (Tip ky y)
950 = (kx == ky) && (x==y)
951 equal Nil Nil = True
952 equal t1 t2 = False
953
954 nequal :: Eq a => IntMap a -> IntMap a -> Bool
955 nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
956 = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
957 nequal (Tip kx x) (Tip ky y)
958 = (kx /= ky) || (x/=y)
959 nequal Nil Nil = False
960 nequal t1 t2 = True
961
962 {--------------------------------------------------------------------
963 Ord
964 --------------------------------------------------------------------}
965
966 instance Ord a => Ord (IntMap a) where
967 compare m1 m2 = compare (toList m1) (toList m2)
968
969 {--------------------------------------------------------------------
970 Functor
971 --------------------------------------------------------------------}
972
973 instance Functor IntMap where
974 fmap = map
975
976 {--------------------------------------------------------------------
977 Show
978 --------------------------------------------------------------------}
979
980 instance Show a => Show (IntMap a) where
981 showsPrec d t = showMap (toList t)
982
983
984 showMap :: (Show a) => [(Key,a)] -> ShowS
985 showMap []
986 = showString "{}"
987 showMap (x:xs)
988 = showChar '{' . showElem x . showTail xs
989 where
990 showTail [] = showChar '}'
991 showTail (x:xs) = showChar ',' . showElem x . showTail xs
992
993 showElem (k,x) = shows k . showString ":=" . shows x
994
995 {--------------------------------------------------------------------
996 Typeable
997 --------------------------------------------------------------------}
998
999 #include "Typeable.h"
1000 INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")
1001
1002 {--------------------------------------------------------------------
1003 Debugging
1004 --------------------------------------------------------------------}
1005 -- | /O(n)/. Show the tree that implements the map. The tree is shown
1006 -- in a compressed, hanging format.
1007 showTree :: Show a => IntMap a -> String
1008 showTree s
1009 = showTreeWith True False s
1010
1011
1012 {- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
1013 the tree that implements the map. If @hang@ is
1014 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
1015 @wide@ is 'True', an extra wide version is shown.
1016 -}
1017 showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
1018 showTreeWith hang wide t
1019 | hang = (showsTreeHang wide [] t) ""
1020 | otherwise = (showsTree wide [] [] t) ""
1021
1022 showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS
1023 showsTree wide lbars rbars t
1024 = case t of
1025 Bin p m l r
1026 -> showsTree wide (withBar rbars) (withEmpty rbars) r .
1027 showWide wide rbars .
1028 showsBars lbars . showString (showBin p m) . showString "\n" .
1029 showWide wide lbars .
1030 showsTree wide (withEmpty lbars) (withBar lbars) l
1031 Tip k x
1032 -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"
1033 Nil -> showsBars lbars . showString "|\n"
1034
1035 showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS
1036 showsTreeHang wide bars t
1037 = case t of
1038 Bin p m l r
1039 -> showsBars bars . showString (showBin p m) . showString "\n" .
1040 showWide wide bars .
1041 showsTreeHang wide (withBar bars) l .
1042 showWide wide bars .
1043 showsTreeHang wide (withEmpty bars) r
1044 Tip k x
1045 -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"
1046 Nil -> showsBars bars . showString "|\n"
1047
1048 showBin p m
1049 = "*" -- ++ show (p,m)
1050
1051 showWide wide bars
1052 | wide = showString (concat (reverse bars)) . showString "|\n"
1053 | otherwise = id
1054
1055 showsBars :: [String] -> ShowS
1056 showsBars bars
1057 = case bars of
1058 [] -> id
1059 _ -> showString (concat (reverse (tail bars))) . showString node
1060
1061 node = "+--"
1062 withBar bars = "| ":bars
1063 withEmpty bars = " ":bars
1064
1065
1066 {--------------------------------------------------------------------
1067 Helpers
1068 --------------------------------------------------------------------}
1069 {--------------------------------------------------------------------
1070 Join
1071 --------------------------------------------------------------------}
1072 join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
1073 join p1 t1 p2 t2
1074 | zero p1 m = Bin p m t1 t2
1075 | otherwise = Bin p m t2 t1
1076 where
1077 m = branchMask p1 p2
1078 p = mask p1 m
1079
1080 {--------------------------------------------------------------------
1081 @bin@ assures that we never have empty trees within a tree.
1082 --------------------------------------------------------------------}
1083 bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
1084 bin p m l Nil = l
1085 bin p m Nil r = r
1086 bin p m l r = Bin p m l r
1087
1088
1089 {--------------------------------------------------------------------
1090 Endian independent bit twiddling
1091 --------------------------------------------------------------------}
1092 zero :: Key -> Mask -> Bool
1093 zero i m
1094 = (natFromInt i) .&. (natFromInt m) == 0
1095
1096 nomatch,match :: Key -> Prefix -> Mask -> Bool
1097 nomatch i p m
1098 = (mask i m) /= p
1099
1100 match i p m
1101 = (mask i m) == p
1102
1103 mask :: Key -> Mask -> Prefix
1104 mask i m
1105 = maskW (natFromInt i) (natFromInt m)
1106
1107
1108 zeroN :: Nat -> Nat -> Bool
1109 zeroN i m = (i .&. m) == 0
1110
1111 {--------------------------------------------------------------------
1112 Big endian operations
1113 --------------------------------------------------------------------}
1114 maskW :: Nat -> Nat -> Prefix
1115 maskW i m
1116 = intFromNat (i .&. (complement (m-1) `xor` m))
1117
1118 shorter :: Mask -> Mask -> Bool
1119 shorter m1 m2
1120 = (natFromInt m1) > (natFromInt m2)
1121
1122 branchMask :: Prefix -> Prefix -> Mask
1123 branchMask p1 p2
1124 = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
1125
1126 {----------------------------------------------------------------------
1127 Finding the highest bit (mask) in a word [x] can be done efficiently in
1128 three ways:
1129 * convert to a floating point value and the mantissa tells us the
1130 [log2(x)] that corresponds with the highest bit position. The mantissa
1131 is retrieved either via the standard C function [frexp] or by some bit
1132 twiddling on IEEE compatible numbers (float). Note that one needs to
1133 use at least [double] precision for an accurate mantissa of 32 bit
1134 numbers.
1135 * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
1136 * use processor specific assembler instruction (asm).
1137
1138 The most portable way would be [bit], but is it efficient enough?
1139 I have measured the cycle counts of the different methods on an AMD
1140 Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
1141
1142 highestBitMask: method cycles
1143 --------------
1144 frexp 200
1145 float 33
1146 bit 11
1147 asm 12
1148
1149 highestBit: method cycles
1150 --------------
1151 frexp 195
1152 float 33
1153 bit 11
1154 asm 11
1155
1156 Wow, the bit twiddling is on today's RISC like machines even faster
1157 than a single CISC instruction (BSR)!
1158 ----------------------------------------------------------------------}
1159
1160 {----------------------------------------------------------------------
1161 [highestBitMask] returns a word where only the highest bit is set.
1162 It is found by first setting all bits in lower positions than the
1163 highest bit and than taking an exclusive or with the original value.
1164 Allthough the function may look expensive, GHC compiles this into
1165 excellent C code that subsequently compiled into highly efficient
1166 machine code. The algorithm is derived from Jorg Arndt's FXT library.
1167 ----------------------------------------------------------------------}
1168 highestBitMask :: Nat -> Nat
1169 highestBitMask x
1170 = case (x .|. shiftRL x 1) of
1171 x -> case (x .|. shiftRL x 2) of
1172 x -> case (x .|. shiftRL x 4) of
1173 x -> case (x .|. shiftRL x 8) of
1174 x -> case (x .|. shiftRL x 16) of
1175 x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms
1176 x -> (x `xor` (shiftRL x 1))
1177
1178
1179 {--------------------------------------------------------------------
1180 Utilities
1181 --------------------------------------------------------------------}
1182 foldlStrict f z xs
1183 = case xs of
1184 [] -> z
1185 (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
1186
1187 {-
1188 {--------------------------------------------------------------------
1189 Testing
1190 --------------------------------------------------------------------}
1191 testTree :: [Int] -> IntMap Int
1192 testTree xs = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]
1193 test1 = testTree [1..20]
1194 test2 = testTree [30,29..10]
1195 test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
1196
1197 {--------------------------------------------------------------------
1198 QuickCheck
1199 --------------------------------------------------------------------}
1200 qcheck prop
1201 = check config prop
1202 where
1203 config = Config
1204 { configMaxTest = 500
1205 , configMaxFail = 5000
1206 , configSize = \n -> (div n 2 + 3)
1207 , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
1208 }
1209
1210
1211 {--------------------------------------------------------------------
1212 Arbitrary, reasonably balanced trees
1213 --------------------------------------------------------------------}
1214 instance Arbitrary a => Arbitrary (IntMap a) where
1215 arbitrary = do{ ks <- arbitrary
1216 ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks
1217 ; return (fromList xs)
1218 }
1219
1220
1221 {--------------------------------------------------------------------
1222 Single, Insert, Delete
1223 --------------------------------------------------------------------}
1224 prop_Single :: Key -> Int -> Bool
1225 prop_Single k x
1226 = (insert k x empty == singleton k x)
1227
1228 prop_InsertDelete :: Key -> Int -> IntMap Int -> Property
1229 prop_InsertDelete k x t
1230 = not (member k t) ==> delete k (insert k x t) == t
1231
1232 prop_UpdateDelete :: Key -> IntMap Int -> Bool
1233 prop_UpdateDelete k t
1234 = update (const Nothing) k t == delete k t
1235
1236
1237 {--------------------------------------------------------------------
1238 Union
1239 --------------------------------------------------------------------}
1240 prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool
1241 prop_UnionInsert k x t
1242 = union (singleton k x) t == insert k x t
1243
1244 prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool
1245 prop_UnionAssoc t1 t2 t3
1246 = union t1 (union t2 t3) == union (union t1 t2) t3
1247
1248 prop_UnionComm :: IntMap Int -> IntMap Int -> Bool
1249 prop_UnionComm t1 t2
1250 = (union t1 t2 == unionWith (\x y -> y) t2 t1)
1251
1252
1253 prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool
1254 prop_Diff xs ys
1255 = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
1256 == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
1257
1258 prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool
1259 prop_Int xs ys
1260 = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
1261 == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
1262
1263 {--------------------------------------------------------------------
1264 Lists
1265 --------------------------------------------------------------------}
1266 prop_Ordered
1267 = forAll (choose (5,100)) $ \n ->
1268 let xs = [(x,()) | x <- [0..n::Int]]
1269 in fromAscList xs == fromList xs
1270
1271 prop_List :: [Key] -> Bool
1272 prop_List xs
1273 = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])
1274 -}