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