-- Stability : provisional
-- Portability : portable
--
+-- NOTE: Data.FiniteMap is DEPRECATED, please use "Data.Map" instead.
+--
-- A finite map implementation, derived from the paper:
-- /Efficient sets: a balancing act/, S. Adams,
-- Journal of functional programming 3(4) Oct 1993, pp553-562
#define OUTPUTABLE_key {--}
#endif
-module Data.FiniteMap (
+module Data.FiniteMap
+ {-# DEPRECATED "Please use Data.Map instead." #-}
+ (
-- * The @FiniteMap@ type
FiniteMap, -- abstract type
--- /dev/null
+{-# OPTIONS -cpp -fglasgow-exts #-}
+--------------------------------------------------------------------------------
+{-| Module : Data.IntMap
+ Copyright : (c) Daan Leijen 2002
+ License : BSD-style
+ Maintainer : libraries@haskell.org
+ Stability : provisional
+ Portability : portable
+
+ An efficient implementation of maps from integer keys to values.
+
+ This module is intended to be imported @qualified@, to avoid name
+ clashes with Prelude functions. eg.
+
+ > import Data.IntMap as Map
+
+ The implementation is based on /big-endian patricia trees/. This data structure
+ performs especially well on binary operations like 'union' and 'intersection'. However,
+ my benchmarks show that it is also (much) faster on insertions and deletions when
+ compared to a generic size-balanced map implementation (see "Map" and "Data.FiniteMap").
+
+ * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
+ Workshop on ML, September 1998, pages 77--86, <http://www.cse.ogi.edu/~andy/pub/finite.htm>
+
+ * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information
+ Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534.
+
+ Many operations have a worst-case complexity of /O(min(n,W))/. This means that the
+ operation can become linear in the number of elements
+ with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64).
+-}
+---------------------------------------------------------------------------------
+module Data.IntMap (
+ -- * Map type
+ IntMap, Key -- instance Eq,Show
+
+ -- * Operators
+ , (!), (\\)
+
+ -- * Query
+ , null
+ , size
+ , member
+ , lookup
+ , findWithDefault
+
+ -- * Construction
+ , empty
+ , singleton
+
+ -- ** Insertion
+ , insert
+ , insertWith, insertWithKey, insertLookupWithKey
+
+ -- ** Delete\/Update
+ , delete
+ , adjust
+ , adjustWithKey
+ , update
+ , updateWithKey
+ , updateLookupWithKey
+
+ -- * Combine
+
+ -- ** Union
+ , union
+ , unionWith
+ , unionWithKey
+ , unions
+ , unionsWith
+
+ -- ** Difference
+ , difference
+ , differenceWith
+ , differenceWithKey
+
+ -- ** Intersection
+ , intersection
+ , intersectionWith
+ , intersectionWithKey
+
+ -- * Traversal
+ -- ** Map
+ , map
+ , mapWithKey
+ , mapAccum
+ , mapAccumWithKey
+
+ -- ** Fold
+ , fold
+ , foldWithKey
+
+ -- * Conversion
+ , elems
+ , keys
+ , keysSet
+ , assocs
+
+ -- ** Lists
+ , toList
+ , fromList
+ , fromListWith
+ , fromListWithKey
+
+ -- ** Ordered lists
+ , toAscList
+ , fromAscList
+ , fromAscListWith
+ , fromAscListWithKey
+ , fromDistinctAscList
+
+ -- * Filter
+ , filter
+ , filterWithKey
+ , partition
+ , partitionWithKey
+
+ , split
+ , splitLookup
+
+ -- * Submap
+ , isSubmapOf, isSubmapOfBy
+ , isProperSubmapOf, isProperSubmapOfBy
+
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ ) where
+
+
+import Prelude hiding (lookup,map,filter,foldr,foldl,null)
+import Data.Bits
+import Data.Int
+import Data.Monoid
+import qualified Data.IntSet as IntSet
+
+{-
+-- just for testing
+import qualified Prelude
+import Debug.QuickCheck
+import List (nub,sort)
+import qualified List
+-}
+
+#ifdef __GLASGOW_HASKELL__
+{--------------------------------------------------------------------
+ GHC: use unboxing to get @shiftRL@ inlined.
+--------------------------------------------------------------------}
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Word
+import GHC.Exts ( Word(..), Int(..), shiftRL# )
+#else
+import Word
+import GlaExts ( Word(..), Int(..), shiftRL# )
+#endif
+
+infixl 9 \\{-This comment teaches CPP correct behaviour -}
+
+type Nat = Word
+
+natFromInt :: Key -> Nat
+natFromInt i = fromIntegral i
+
+intFromNat :: Nat -> Key
+intFromNat w = fromIntegral w
+
+shiftRL :: Nat -> Key -> Nat
+shiftRL (W# x) (I# i)
+ = W# (shiftRL# x i)
+
+#elif __HUGS__
+{--------------------------------------------------------------------
+ Hugs:
+ * raises errors on boundary values when using 'fromIntegral'
+ but not with the deprecated 'fromInt/toInt'.
+ * Older Hugs doesn't define 'Word'.
+ * Newer Hugs defines 'Word' in the Prelude but no operations.
+--------------------------------------------------------------------}
+import Data.Word
+infixl 9 \\
+
+type Nat = Word32 -- illegal on 64-bit platforms!
+
+natFromInt :: Key -> Nat
+natFromInt i = fromInt i
+
+intFromNat :: Nat -> Key
+intFromNat w = toInt w
+
+shiftRL :: Nat -> Key -> Nat
+shiftRL x i = shiftR x i
+
+#else
+{--------------------------------------------------------------------
+ 'Standard' Haskell
+ * A "Nat" is a natural machine word (an unsigned Int)
+--------------------------------------------------------------------}
+import Data.Word
+infixl 9 \\
+
+type Nat = Word
+
+natFromInt :: Key -> Nat
+natFromInt i = fromIntegral i
+
+intFromNat :: Nat -> Key
+intFromNat w = fromIntegral w
+
+shiftRL :: Nat -> Key -> Nat
+shiftRL w i = shiftR w i
+
+#endif
+
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+
+-- | /O(min(n,W))/. Find the value of a key. Calls @error@ when the element can not be found.
+
+(!) :: IntMap a -> Key -> a
+m ! k = find' k m
+
+-- | /O(n+m)/. See 'difference'.
+(\\) :: IntMap a -> IntMap b -> IntMap a
+m1 \\ m2 = difference m1 m2
+
+{--------------------------------------------------------------------
+ Types
+--------------------------------------------------------------------}
+-- | A map of integers to values @a@.
+data IntMap a = Nil
+ | Tip {-# UNPACK #-} !Key a
+ | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a)
+
+type Prefix = Int
+type Mask = Int
+type Key = Int
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is the map empty?
+null :: IntMap a -> Bool
+null Nil = True
+null other = False
+
+-- | /O(n)/. Number of elements in the map.
+size :: IntMap a -> Int
+size t
+ = case t of
+ Bin p m l r -> size l + size r
+ Tip k x -> 1
+ Nil -> 0
+
+-- | /O(min(n,W))/. Is the key a member of the map?
+member :: Key -> IntMap a -> Bool
+member k m
+ = case lookup k m of
+ Nothing -> False
+ Just x -> True
+
+-- | /O(min(n,W))/. Lookup the value of a key in the map.
+lookup :: Key -> IntMap a -> Maybe a
+lookup k t
+ = let nk = natFromInt k in seq nk (lookupN nk t)
+
+lookupN :: Nat -> IntMap a -> Maybe a
+lookupN k t
+ = case t of
+ Bin p m l r
+ | zeroN k (natFromInt m) -> lookupN k l
+ | otherwise -> lookupN k r
+ Tip kx x
+ | (k == natFromInt kx) -> Just x
+ | otherwise -> Nothing
+ Nil -> Nothing
+
+find' :: Key -> IntMap a -> a
+find' k m
+ = case lookup k m of
+ Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")
+ Just x -> x
+
+
+-- | /O(min(n,W))/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when
+-- the key is not an element of the map.
+findWithDefault :: a -> Key -> IntMap a -> a
+findWithDefault def k m
+ = case lookup k m of
+ Nothing -> def
+ Just x -> x
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty map.
+empty :: IntMap a
+empty
+ = Nil
+
+-- | /O(1)/. A map of one element.
+singleton :: Key -> a -> IntMap a
+singleton k x
+ = Tip k x
+
+{--------------------------------------------------------------------
+ Insert
+ 'insert' is the inlined version of 'insertWith (\k x y -> x)'
+--------------------------------------------------------------------}
+-- | /O(min(n,W))/. Insert a new key\/value pair in the map. When the key
+-- is already an element of the set, its value is replaced by the new value,
+-- ie. 'insert' is left-biased.
+insert :: Key -> a -> IntMap a -> IntMap a
+insert k x t
+ = case t of
+ Bin p m l r
+ | nomatch k p m -> join k (Tip k x) p t
+ | zero k m -> Bin p m (insert k x l) r
+ | otherwise -> Bin p m l (insert k x r)
+ Tip ky y
+ | k==ky -> Tip k x
+ | otherwise -> join k (Tip k x) ky t
+ Nil -> Tip k x
+
+-- right-biased insertion, used by 'union'
+-- | /O(min(n,W))/. Insert with a combining function.
+insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
+insertWith f k x t
+ = insertWithKey (\k x y -> f x y) k x t
+
+-- | /O(min(n,W))/. Insert with a combining function.
+insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
+insertWithKey f k x t
+ = case t of
+ Bin p m l r
+ | nomatch k p m -> join k (Tip k x) p t
+ | zero k m -> Bin p m (insertWithKey f k x l) r
+ | otherwise -> Bin p m l (insertWithKey f k x r)
+ Tip ky y
+ | k==ky -> Tip k (f k x y)
+ | otherwise -> join k (Tip k x) ky t
+ Nil -> Tip k x
+
+
+-- | /O(min(n,W))/. The expression (@insertLookupWithKey f k x map@) is a pair where
+-- the first element is equal to (@lookup k map@) and the second element
+-- equal to (@insertWithKey f k x map@).
+insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
+insertLookupWithKey f k x t
+ = case t of
+ Bin p m l r
+ | nomatch k p m -> (Nothing,join k (Tip k x) p t)
+ | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
+ | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
+ Tip ky y
+ | k==ky -> (Just y,Tip k (f k x y))
+ | otherwise -> (Nothing,join k (Tip k x) ky t)
+ Nil -> (Nothing,Tip k x)
+
+
+{--------------------------------------------------------------------
+ Deletion
+ [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
+--------------------------------------------------------------------}
+-- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not
+-- a member of the map, the original map is returned.
+delete :: Key -> IntMap a -> IntMap a
+delete k t
+ = case t of
+ Bin p m l r
+ | nomatch k p m -> t
+ | zero k m -> bin p m (delete k l) r
+ | otherwise -> bin p m l (delete k r)
+ Tip ky y
+ | k==ky -> Nil
+ | otherwise -> t
+ Nil -> Nil
+
+-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+adjust :: (a -> a) -> Key -> IntMap a -> IntMap a
+adjust f k m
+ = adjustWithKey (\k x -> f x) k m
+
+-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a
+adjustWithKey f k m
+ = updateWithKey (\k x -> Just (f k x)) k m
+
+-- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is
+-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
+update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a
+update f k m
+ = updateWithKey (\k x -> f x) k m
+
+-- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is
+-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
+updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
+updateWithKey f k t
+ = case t of
+ Bin p m l r
+ | nomatch k p m -> t
+ | zero k m -> bin p m (updateWithKey f k l) r
+ | otherwise -> bin p m l (updateWithKey f k r)
+ Tip ky y
+ | k==ky -> case (f k y) of
+ Just y' -> Tip ky y'
+ Nothing -> Nil
+ | otherwise -> t
+ Nil -> Nil
+
+-- | /O(min(n,W))/. Lookup and update.
+updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
+updateLookupWithKey f k t
+ = case t of
+ Bin p m l r
+ | nomatch k p m -> (Nothing,t)
+ | zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)
+ | otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')
+ Tip ky y
+ | k==ky -> case (f k y) of
+ Just y' -> (Just y,Tip ky y')
+ Nothing -> (Just y,Nil)
+ | otherwise -> (Nothing,t)
+ Nil -> (Nothing,Nil)
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+-- | The union of a list of maps.
+unions :: [IntMap a] -> IntMap a
+unions xs
+ = foldlStrict union empty xs
+
+-- | The union of a list of maps, with a combining operation
+unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a
+unionsWith f ts
+ = foldlStrict (unionWith f) empty ts
+
+-- | /O(n+m)/. The (left-biased) union of two sets.
+union :: IntMap a -> IntMap a -> IntMap a
+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = union1
+ | shorter m2 m1 = union2
+ | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
+ | otherwise = join p1 t1 p2 t2
+ where
+ union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
+ | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
+ | otherwise = Bin p1 m1 l1 (union r1 t2)
+
+ union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
+ | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
+ | otherwise = Bin p2 m2 l2 (union t1 r2)
+
+union (Tip k x) t = insert k x t
+union t (Tip k x) = insertWith (\x y -> y) k x t -- right bias
+union Nil t = t
+union t Nil = t
+
+-- | /O(n+m)/. The union with a combining function.
+unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
+unionWith f m1 m2
+ = unionWithKey (\k x y -> f x y) m1 m2
+
+-- | /O(n+m)/. The union with a combining function.
+unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
+unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = union1
+ | shorter m2 m1 = union2
+ | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)
+ | otherwise = join p1 t1 p2 t2
+ where
+ union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
+ | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1
+ | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2)
+
+ union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
+ | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2
+ | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2)
+
+unionWithKey f (Tip k x) t = insertWithKey f k x t
+unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t -- right bias
+unionWithKey f Nil t = t
+unionWithKey f t Nil = t
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Difference between two maps (based on keys).
+difference :: IntMap a -> IntMap b -> IntMap a
+difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = difference1
+ | shorter m2 m1 = difference2
+ | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
+ | otherwise = t1
+ where
+ difference1 | nomatch p2 p1 m1 = t1
+ | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
+ | otherwise = bin p1 m1 l1 (difference r1 t2)
+
+ difference2 | nomatch p1 p2 m2 = t1
+ | zero p1 m2 = difference t1 l2
+ | otherwise = difference t1 r2
+
+difference t1@(Tip k x) t2
+ | member k t2 = Nil
+ | otherwise = t1
+
+difference Nil t = Nil
+difference t (Tip k x) = delete k t
+difference t Nil = t
+
+-- | /O(n+m)/. Difference with a combining function.
+differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
+differenceWith f m1 m2
+ = differenceWithKey (\k x y -> f x y) m1 m2
+
+-- | /O(n+m)/. Difference with a combining function. When two equal keys are
+-- encountered, the combining function is applied to the key and both values.
+-- If it returns @Nothing@, the element is discarded (proper set difference). If
+-- it returns (@Just y@), the element is updated with a new value @y@.
+differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
+differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = difference1
+ | shorter m2 m1 = difference2
+ | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)
+ | otherwise = t1
+ where
+ difference1 | nomatch p2 p1 m1 = t1
+ | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1
+ | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2)
+
+ difference2 | nomatch p1 p2 m2 = t1
+ | zero p1 m2 = differenceWithKey f t1 l2
+ | otherwise = differenceWithKey f t1 r2
+
+differenceWithKey f t1@(Tip k x) t2
+ = case lookup k t2 of
+ Just y -> case f k x y of
+ Just y' -> Tip k y'
+ Nothing -> Nil
+ Nothing -> t1
+
+differenceWithKey f Nil t = Nil
+differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t
+differenceWithKey f t Nil = t
+
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).
+intersection :: IntMap a -> IntMap b -> IntMap a
+intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = intersection1
+ | shorter m2 m1 = intersection2
+ | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
+ | otherwise = Nil
+ where
+ intersection1 | nomatch p2 p1 m1 = Nil
+ | zero p2 m1 = intersection l1 t2
+ | otherwise = intersection r1 t2
+
+ intersection2 | nomatch p1 p2 m2 = Nil
+ | zero p1 m2 = intersection t1 l2
+ | otherwise = intersection t1 r2
+
+intersection t1@(Tip k x) t2
+ | member k t2 = t1
+ | otherwise = Nil
+intersection t (Tip k x)
+ = case lookup k t of
+ Just y -> Tip k y
+ Nothing -> Nil
+intersection Nil t = Nil
+intersection t Nil = Nil
+
+-- | /O(n+m)/. The intersection with a combining function.
+intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
+intersectionWith f m1 m2
+ = intersectionWithKey (\k x y -> f x y) m1 m2
+
+-- | /O(n+m)/. The intersection with a combining function.
+intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a
+intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = intersection1
+ | shorter m2 m1 = intersection2
+ | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)
+ | otherwise = Nil
+ where
+ intersection1 | nomatch p2 p1 m1 = Nil
+ | zero p2 m1 = intersectionWithKey f l1 t2
+ | otherwise = intersectionWithKey f r1 t2
+
+ intersection2 | nomatch p1 p2 m2 = Nil
+ | zero p1 m2 = intersectionWithKey f t1 l2
+ | otherwise = intersectionWithKey f t1 r2
+
+intersectionWithKey f t1@(Tip k x) t2
+ = case lookup k t2 of
+ Just y -> Tip k (f k x y)
+ Nothing -> Nil
+intersectionWithKey f t1 (Tip k y)
+ = case lookup k t1 of
+ Just x -> Tip k (f k x y)
+ Nothing -> Nil
+intersectionWithKey f Nil t = Nil
+intersectionWithKey f t Nil = Nil
+
+
+{--------------------------------------------------------------------
+ Submap
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
+-- Defined as (@isProperSubmapOf = isProperSubmapOfBy (==)@).
+isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
+isProperSubmapOf m1 m2
+ = isProperSubmapOfBy (==) m1 m2
+
+{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
+ The expression (@isProperSubmapOfBy f m1 m2@) returns @True@ when
+ @m1@ and @m2@ are not equal,
+ all keys in @m1@ are in @m2@, and when @f@ returns @True@ when
+ applied to their respective values. For example, the following
+ expressions are all @True@.
+
+ > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+
+ But the following are all @False@:
+
+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+-}
+isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
+isProperSubmapOfBy pred t1 t2
+ = case submapCmp pred t1 t2 of
+ LT -> True
+ ge -> False
+
+submapCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = GT
+ | shorter m2 m1 = submapCmpLt
+ | p1 == p2 = submapCmpEq
+ | otherwise = GT -- disjoint
+ where
+ submapCmpLt | nomatch p1 p2 m2 = GT
+ | zero p1 m2 = submapCmp pred t1 l2
+ | otherwise = submapCmp pred t1 r2
+ submapCmpEq = case (submapCmp pred l1 l2, submapCmp pred r1 r2) of
+ (GT,_ ) -> GT
+ (_ ,GT) -> GT
+ (EQ,EQ) -> EQ
+ other -> LT
+
+submapCmp pred (Bin p m l r) t = GT
+submapCmp pred (Tip kx x) (Tip ky y)
+ | (kx == ky) && pred x y = EQ
+ | otherwise = GT -- disjoint
+submapCmp pred (Tip k x) t
+ = case lookup k t of
+ Just y | pred x y -> LT
+ other -> GT -- disjoint
+submapCmp pred Nil Nil = EQ
+submapCmp pred Nil t = LT
+
+-- | /O(n+m)/. Is this a submap? Defined as (@isSubmapOf = isSubmapOfBy (==)@).
+isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
+isSubmapOf m1 m2
+ = isSubmapOfBy (==) m1 m2
+
+{- | /O(n+m)/.
+ The expression (@isSubmapOfBy f m1 m2@) returns @True@ if
+ all keys in @m1@ are in @m2@, and when @f@ returns @True@ when
+ applied to their respective values. For example, the following
+ expressions are all @True@.
+
+ > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+ > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+ > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
+
+ But the following are all @False@:
+
+ > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])
+ > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+ > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
+-}
+
+isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
+isSubmapOfBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = False
+ | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy pred t1 l2
+ else isSubmapOfBy pred t1 r2)
+ | otherwise = (p1==p2) && isSubmapOfBy pred l1 l2 && isSubmapOfBy pred r1 r2
+isSubmapOfBy pred (Bin p m l r) t = False
+isSubmapOfBy pred (Tip k x) t = case lookup k t of
+ Just y -> pred x y
+ Nothing -> False
+isSubmapOfBy pred Nil t = True
+
+{--------------------------------------------------------------------
+ Mapping
+--------------------------------------------------------------------}
+-- | /O(n)/. Map a function over all values in the map.
+map :: (a -> b) -> IntMap a -> IntMap b
+map f m
+ = mapWithKey (\k x -> f x) m
+
+-- | /O(n)/. Map a function over all values in the map.
+mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b
+mapWithKey f t
+ = case t of
+ Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
+ Tip k x -> Tip k (f k x)
+ Nil -> Nil
+
+-- | /O(n)/. The function @mapAccum@ threads an accumulating
+-- argument through the map in an unspecified order.
+mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
+mapAccum f a m
+ = mapAccumWithKey (\a k x -> f a x) a m
+
+-- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating
+-- argument through the map in an unspecified order.
+mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
+mapAccumWithKey f a t
+ = mapAccumL f a t
+
+-- | /O(n)/. The function @mapAccumL@ threads an accumulating
+-- argument through the map in pre-order.
+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
+mapAccumL f a t
+ = case t of
+ Bin p m l r -> let (a1,l') = mapAccumL f a l
+ (a2,r') = mapAccumL f a1 r
+ in (a2,Bin p m l' r')
+ Tip k x -> let (a',x') = f a k x in (a',Tip k x')
+ Nil -> (a,Nil)
+
+
+-- | /O(n)/. The function @mapAccumR@ threads an accumulating
+-- argument throught the map in post-order.
+mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
+mapAccumR f a t
+ = case t of
+ Bin p m l r -> let (a1,r') = mapAccumR f a r
+ (a2,l') = mapAccumR f a1 l
+ in (a2,Bin p m l' r')
+ Tip k x -> let (a',x') = f a k x in (a',Tip k x')
+ Nil -> (a,Nil)
+
+{--------------------------------------------------------------------
+ Filter
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all values that satisfy some predicate.
+filter :: (a -> Bool) -> IntMap a -> IntMap a
+filter p m
+ = filterWithKey (\k x -> p x) m
+
+-- | /O(n)/. Filter all keys\/values that satisfy some predicate.
+filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a
+filterWithKey pred t
+ = case t of
+ Bin p m l r
+ -> bin p m (filterWithKey pred l) (filterWithKey pred r)
+ Tip k x
+ | pred k x -> t
+ | otherwise -> Nil
+ Nil -> Nil
+
+-- | /O(n)/. partition the map according to some predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
+partition p m
+ = partitionWithKey (\k x -> p x) m
+
+-- | /O(n)/. partition the map according to some predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
+partitionWithKey pred t
+ = case t of
+ Bin p m l r
+ -> let (l1,l2) = partitionWithKey pred l
+ (r1,r2) = partitionWithKey pred r
+ in (bin p m l1 r1, bin p m l2 r2)
+ Tip k x
+ | pred k x -> (t,Nil)
+ | otherwise -> (Nil,t)
+ Nil -> (Nil,Nil)
+
+
+-- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@
+-- where all keys in @map1@ are lower than @k@ and all keys in
+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
+split :: Key -> IntMap a -> (IntMap a,IntMap a)
+split k t
+ = case t of
+ Bin p m l r
+ | zero k m -> let (lt,gt) = split k l in (lt,union gt r)
+ | otherwise -> let (lt,gt) = split k r in (union l lt,gt)
+ Tip ky y
+ | k>ky -> (t,Nil)
+ | k<ky -> (Nil,t)
+ | otherwise -> (Nil,Nil)
+ Nil -> (Nil,Nil)
+
+-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
+-- key was found in the original map.
+splitLookup :: Key -> IntMap a -> (Maybe a,IntMap a,IntMap a)
+splitLookup k t
+ = case t of
+ Bin p m l r
+ | zero k m -> let (found,lt,gt) = splitLookup k l in (found,lt,union gt r)
+ | otherwise -> let (found,lt,gt) = splitLookup k r in (found,union l lt,gt)
+ Tip ky y
+ | k>ky -> (Nothing,t,Nil)
+ | k<ky -> (Nothing,Nil,t)
+ | otherwise -> (Just y,Nil,Nil)
+ Nil -> (Nothing,Nil,Nil)
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+-- | /O(n)/. Fold over the elements of a map in an unspecified order.
+--
+-- > sum map = fold (+) 0 map
+-- > elems map = fold (:) [] map
+fold :: (a -> b -> b) -> b -> IntMap a -> b
+fold f z t
+ = foldWithKey (\k x y -> f x y) z t
+
+-- | /O(n)/. Fold over the elements of a map in an unspecified order.
+--
+-- > keys map = foldWithKey (\k x ks -> k:ks) [] map
+foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
+foldWithKey f z t
+ = foldr f z t
+
+foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
+foldr f z t
+ = case t of
+ Bin p m l r -> foldr f (foldr f z r) l
+ Tip k x -> f k x z
+ Nil -> z
+
+{--------------------------------------------------------------------
+ List variations
+--------------------------------------------------------------------}
+-- | /O(n)/. Return all elements of the map.
+elems :: IntMap a -> [a]
+elems m
+ = foldWithKey (\k x xs -> x:xs) [] m
+
+-- | /O(n)/. Return all keys of the map.
+keys :: IntMap a -> [Key]
+keys m
+ = foldWithKey (\k x ks -> k:ks) [] m
+
+-- | /O(n*min(n,W))/. The set of all keys of the map.
+keysSet :: IntMap a -> IntSet.IntSet
+keysSet m = IntSet.fromDistinctAscList (keys m)
+
+
+-- | /O(n)/. Return all key\/value pairs in the map.
+assocs :: IntMap a -> [(Key,a)]
+assocs m
+ = toList m
+
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+-- | /O(n)/. Convert the map to a list of key\/value pairs.
+toList :: IntMap a -> [(Key,a)]
+toList t
+ = foldWithKey (\k x xs -> (k,x):xs) [] t
+
+-- | /O(n)/. Convert the map to a list of key\/value pairs where the
+-- keys are in ascending order.
+toAscList :: IntMap a -> [(Key,a)]
+toAscList t
+ = -- NOTE: the following algorithm only works for big-endian trees
+ let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos
+
+-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.
+fromList :: [(Key,a)] -> IntMap a
+fromList xs
+ = foldlStrict ins empty xs
+ where
+ ins t (k,x) = insert k x t
+
+-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
+fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
+fromListWith f xs
+ = fromListWithKey (\k x y -> f x y) xs
+
+-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.
+fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
+fromListWithKey f xs
+ = foldlStrict ins empty xs
+ where
+ ins t (k,x) = insertWithKey f k x t
+
+-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
+-- the keys are in ascending order.
+fromAscList :: [(Key,a)] -> IntMap a
+fromAscList xs
+ = fromList xs
+
+-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
+-- the keys are in ascending order, with a combining function on equal keys.
+fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a
+fromAscListWith f xs
+ = fromListWith f xs
+
+-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
+-- the keys are in ascending order, with a combining function on equal keys.
+fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a
+fromAscListWithKey f xs
+ = fromListWithKey f xs
+
+-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where
+-- the keys are in ascending order and all distinct.
+fromDistinctAscList :: [(Key,a)] -> IntMap a
+fromDistinctAscList xs
+ = fromList xs
+
+
+{--------------------------------------------------------------------
+ Eq
+--------------------------------------------------------------------}
+instance Eq a => Eq (IntMap a) where
+ t1 == t2 = equal t1 t2
+ t1 /= t2 = nequal t1 t2
+
+equal :: Eq a => IntMap a -> IntMap a -> Bool
+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
+equal (Tip kx x) (Tip ky y)
+ = (kx == ky) && (x==y)
+equal Nil Nil = True
+equal t1 t2 = False
+
+nequal :: Eq a => IntMap a -> IntMap a -> Bool
+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
+nequal (Tip kx x) (Tip ky y)
+ = (kx /= ky) || (x/=y)
+nequal Nil Nil = False
+nequal t1 t2 = True
+
+{--------------------------------------------------------------------
+ Ord
+--------------------------------------------------------------------}
+
+instance Ord a => Ord (IntMap a) where
+ compare m1 m2 = compare (toList m1) (toList m2)
+
+{--------------------------------------------------------------------
+ Functor
+--------------------------------------------------------------------}
+
+instance Functor IntMap where
+ fmap = map
+
+{--------------------------------------------------------------------
+ Monoid
+--------------------------------------------------------------------}
+
+instance Ord a => Monoid (IntMap a) where
+ mempty = empty
+ mappend = union
+ mconcat = unions
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+
+instance Show a => Show (IntMap a) where
+ showsPrec d t = showMap (toList t)
+
+
+showMap :: (Show a) => [(Key,a)] -> ShowS
+showMap []
+ = showString "{}"
+showMap (x:xs)
+ = showChar '{' . showElem x . showTail xs
+ where
+ showTail [] = showChar '}'
+ showTail (x:xs) = showChar ',' . showElem x . showTail xs
+
+ showElem (k,x) = shows k . showString ":=" . shows x
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+-- | /O(n)/. Show the tree that implements the map. The tree is shown
+-- in a compressed, hanging format.
+showTree :: Show a => IntMap a -> String
+showTree s
+ = showTreeWith True False s
+
+
+{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
+ the tree that implements the map. If @hang@ is
+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
+ @wide@ is true, an extra wide version is shown.
+-}
+showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
+showTreeWith hang wide t
+ | hang = (showsTreeHang wide [] t) ""
+ | otherwise = (showsTree wide [] [] t) ""
+
+showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS
+showsTree wide lbars rbars t
+ = case t of
+ Bin p m l r
+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . showString (showBin p m) . showString "\n" .
+ showWide wide lbars .
+ showsTree wide (withEmpty lbars) (withBar lbars) l
+ Tip k x
+ -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"
+ Nil -> showsBars lbars . showString "|\n"
+
+showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS
+showsTreeHang wide bars t
+ = case t of
+ Bin p m l r
+ -> showsBars bars . showString (showBin p m) . showString "\n" .
+ showWide wide bars .
+ showsTreeHang wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang wide (withEmpty bars) r
+ Tip k x
+ -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"
+ Nil -> showsBars bars . showString "|\n"
+
+showBin p m
+ = "*" -- ++ show (p,m)
+
+showWide wide bars
+ | wide = showString (concat (reverse bars)) . showString "|\n"
+ | otherwise = id
+
+showsBars :: [String] -> ShowS
+showsBars bars
+ = case bars of
+ [] -> id
+ _ -> showString (concat (reverse (tail bars))) . showString node
+
+node = "+--"
+withBar bars = "| ":bars
+withEmpty bars = " ":bars
+
+
+{--------------------------------------------------------------------
+ Helpers
+--------------------------------------------------------------------}
+{--------------------------------------------------------------------
+ Join
+--------------------------------------------------------------------}
+join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
+join p1 t1 p2 t2
+ | zero p1 m = Bin p m t1 t2
+ | otherwise = Bin p m t2 t1
+ where
+ m = branchMask p1 p2
+ p = mask p1 m
+
+{--------------------------------------------------------------------
+ @bin@ assures that we never have empty trees within a tree.
+--------------------------------------------------------------------}
+bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
+bin p m l Nil = l
+bin p m Nil r = r
+bin p m l r = Bin p m l r
+
+
+{--------------------------------------------------------------------
+ Endian independent bit twiddling
+--------------------------------------------------------------------}
+zero :: Key -> Mask -> Bool
+zero i m
+ = (natFromInt i) .&. (natFromInt m) == 0
+
+nomatch,match :: Key -> Prefix -> Mask -> Bool
+nomatch i p m
+ = (mask i m) /= p
+
+match i p m
+ = (mask i m) == p
+
+mask :: Key -> Mask -> Prefix
+mask i m
+ = maskW (natFromInt i) (natFromInt m)
+
+
+zeroN :: Nat -> Nat -> Bool
+zeroN i m = (i .&. m) == 0
+
+{--------------------------------------------------------------------
+ Big endian operations
+--------------------------------------------------------------------}
+maskW :: Nat -> Nat -> Prefix
+maskW i m
+ = intFromNat (i .&. (complement (m-1) `xor` m))
+
+shorter :: Mask -> Mask -> Bool
+shorter m1 m2
+ = (natFromInt m1) > (natFromInt m2)
+
+branchMask :: Prefix -> Prefix -> Mask
+branchMask p1 p2
+ = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
+
+{----------------------------------------------------------------------
+ Finding the highest bit (mask) in a word [x] can be done efficiently in
+ three ways:
+ * convert to a floating point value and the mantissa tells us the
+ [log2(x)] that corresponds with the highest bit position. The mantissa
+ is retrieved either via the standard C function [frexp] or by some bit
+ twiddling on IEEE compatible numbers (float). Note that one needs to
+ use at least [double] precision for an accurate mantissa of 32 bit
+ numbers.
+ * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
+ * use processor specific assembler instruction (asm).
+
+ The most portable way would be [bit], but is it efficient enough?
+ I have measured the cycle counts of the different methods on an AMD
+ Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
+
+ highestBitMask: method cycles
+ --------------
+ frexp 200
+ float 33
+ bit 11
+ asm 12
+
+ highestBit: method cycles
+ --------------
+ frexp 195
+ float 33
+ bit 11
+ asm 11
+
+ Wow, the bit twiddling is on today's RISC like machines even faster
+ than a single CISC instruction (BSR)!
+----------------------------------------------------------------------}
+
+{----------------------------------------------------------------------
+ [highestBitMask] returns a word where only the highest bit is set.
+ It is found by first setting all bits in lower positions than the
+ highest bit and than taking an exclusive or with the original value.
+ Allthough the function may look expensive, GHC compiles this into
+ excellent C code that subsequently compiled into highly efficient
+ machine code. The algorithm is derived from Jorg Arndt's FXT library.
+----------------------------------------------------------------------}
+highestBitMask :: Nat -> Nat
+highestBitMask x
+ = case (x .|. shiftRL x 1) of
+ x -> case (x .|. shiftRL x 2) of
+ x -> case (x .|. shiftRL x 4) of
+ x -> case (x .|. shiftRL x 8) of
+ x -> case (x .|. shiftRL x 16) of
+ x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms
+ x -> (x `xor` (shiftRL x 1))
+
+
+{--------------------------------------------------------------------
+ Utilities
+--------------------------------------------------------------------}
+foldlStrict f z xs
+ = case xs of
+ [] -> z
+ (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
+
+{-
+{--------------------------------------------------------------------
+ Testing
+--------------------------------------------------------------------}
+testTree :: [Int] -> IntMap Int
+testTree xs = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]
+test1 = testTree [1..20]
+test2 = testTree [30,29..10]
+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
+
+{--------------------------------------------------------------------
+ QuickCheck
+--------------------------------------------------------------------}
+qcheck prop
+ = check config prop
+ where
+ config = Config
+ { configMaxTest = 500
+ , configMaxFail = 5000
+ , configSize = \n -> (div n 2 + 3)
+ , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
+ }
+
+
+{--------------------------------------------------------------------
+ Arbitrary, reasonably balanced trees
+--------------------------------------------------------------------}
+instance Arbitrary a => Arbitrary (IntMap a) where
+ arbitrary = do{ ks <- arbitrary
+ ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks
+ ; return (fromList xs)
+ }
+
+
+{--------------------------------------------------------------------
+ Single, Insert, Delete
+--------------------------------------------------------------------}
+prop_Single :: Key -> Int -> Bool
+prop_Single k x
+ = (insert k x empty == singleton k x)
+
+prop_InsertDelete :: Key -> Int -> IntMap Int -> Property
+prop_InsertDelete k x t
+ = not (member k t) ==> delete k (insert k x t) == t
+
+prop_UpdateDelete :: Key -> IntMap Int -> Bool
+prop_UpdateDelete k t
+ = update (const Nothing) k t == delete k t
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool
+prop_UnionInsert k x t
+ = union (singleton k x) t == insert k x t
+
+prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool
+prop_UnionAssoc t1 t2 t3
+ = union t1 (union t2 t3) == union (union t1 t2) t3
+
+prop_UnionComm :: IntMap Int -> IntMap Int -> Bool
+prop_UnionComm t1 t2
+ = (union t1 t2 == unionWith (\x y -> y) t2 t1)
+
+
+prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool
+prop_Diff xs ys
+ = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
+ == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
+
+prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool
+prop_Int xs ys
+ = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
+ == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+prop_Ordered
+ = forAll (choose (5,100)) $ \n ->
+ let xs = [(x,()) | x <- [0..n::Int]]
+ in fromAscList xs == fromList xs
+
+prop_List :: [Key] -> Bool
+prop_List xs
+ = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])
+-}
--- /dev/null
+{-# OPTIONS -cpp -fglasgow-exts #-}
+--------------------------------------------------------------------------------
+{-| Module : Data.IntSet
+ Copyright : (c) Daan Leijen 2002
+ License : BSD-style
+ Maintainer : libraries@haskell.org
+ Stability : provisional
+ Portability : portable
+
+ An efficient implementation of integer sets.
+
+ This module is intended to be imported @qualified@, to avoid name
+ clashes with Prelude functions. eg.
+
+ > import Data.IntSet as Set
+
+ The implementation is based on /big-endian patricia trees/. This data structure
+ performs especially well on binary operations like 'union' and 'intersection'. However,
+ my benchmarks show that it is also (much) faster on insertions and deletions when
+ compared to a generic size-balanced set implementation (see "Set").
+
+ * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",
+ Workshop on ML, September 1998, pages 77--86, <http://www.cse.ogi.edu/~andy/pub/finite.htm>
+
+ * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information
+ Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534.
+
+ Many operations have a worst-case complexity of /O(min(n,W))/. This means that the
+ operation can become linear in the number of elements
+ with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64).
+-}
+---------------------------------------------------------------------------------}
+module Data.IntSet (
+ -- * Set type
+ IntSet -- instance Eq,Show
+
+ -- * Operators
+ , (\\)
+
+ -- * Query
+ , null
+ , size
+ , member
+ , isSubsetOf
+ , isProperSubsetOf
+
+ -- * Construction
+ , empty
+ , singleton
+ , insert
+ , delete
+
+ -- * Combine
+ , union, unions
+ , difference
+ , intersection
+
+ -- * Filter
+ , filter
+ , partition
+ , split
+ , splitMember
+
+ -- * Map
+ , map
+
+ -- * Fold
+ , fold
+
+ -- * Conversion
+ -- ** List
+ , elems
+ , toList
+ , fromList
+
+ -- ** Ordered list
+ , toAscList
+ , fromAscList
+ , fromDistinctAscList
+
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ ) where
+
+
+import Prelude hiding (lookup,filter,foldr,foldl,null,map)
+import Data.Bits
+import Data.Int
+
+import qualified Data.List as List
+import Data.Monoid
+
+{-
+-- just for testing
+import QuickCheck
+import List (nub,sort)
+import qualified List
+-}
+
+
+#ifdef __GLASGOW_HASKELL__
+{--------------------------------------------------------------------
+ GHC: use unboxing to get @shiftRL@ inlined.
+--------------------------------------------------------------------}
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Word
+import GHC.Exts ( Word(..), Int(..), shiftRL# )
+#else
+import Word
+import GlaExts ( Word(..), Int(..), shiftRL# )
+#endif
+
+infixl 9 \\{-This comment teaches CPP correct behaviour -}
+
+type Nat = Word
+
+natFromInt :: Int -> Nat
+natFromInt i = fromIntegral i
+
+intFromNat :: Nat -> Int
+intFromNat w = fromIntegral w
+
+shiftRL :: Nat -> Int -> Nat
+shiftRL (W# x) (I# i)
+ = W# (shiftRL# x i)
+
+#elif __HUGS__
+{--------------------------------------------------------------------
+ Hugs:
+ * raises errors on boundary values when using 'fromIntegral'
+ but not with the deprecated 'fromInt/toInt'.
+ * Older Hugs doesn't define 'Word'.
+ * Newer Hugs defines 'Word' in the Prelude but no operations.
+--------------------------------------------------------------------}
+import Data.Word
+infixl 9 \\
+
+type Nat = Word32 -- illegal on 64-bit platforms!
+
+natFromInt :: Int -> Nat
+natFromInt i = fromInt i
+
+intFromNat :: Nat -> Int
+intFromNat w = toInt w
+
+shiftRL :: Nat -> Int -> Nat
+shiftRL x i = shiftR x i
+
+#else
+{--------------------------------------------------------------------
+ 'Standard' Haskell
+ * A "Nat" is a natural machine word (an unsigned Int)
+--------------------------------------------------------------------}
+import Data.Word
+infixl 9 \\
+
+type Nat = Word
+
+natFromInt :: Int -> Nat
+natFromInt i = fromIntegral i
+
+intFromNat :: Nat -> Int
+intFromNat w = fromIntegral w
+
+shiftRL :: Nat -> Int -> Nat
+shiftRL w i = shiftR w i
+
+#endif
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+-- | /O(n+m)/. See 'difference'.
+(\\) :: IntSet -> IntSet -> IntSet
+m1 \\ m2 = difference m1 m2
+
+{--------------------------------------------------------------------
+ Types
+--------------------------------------------------------------------}
+-- | A set of integers.
+data IntSet = Nil
+ | Tip {-# UNPACK #-} !Int
+ | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntSet !IntSet
+
+type Prefix = Int
+type Mask = Int
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is the set empty?
+null :: IntSet -> Bool
+null Nil = True
+null other = False
+
+-- | /O(n)/. Cardinality of the set.
+size :: IntSet -> Int
+size t
+ = case t of
+ Bin p m l r -> size l + size r
+ Tip y -> 1
+ Nil -> 0
+
+-- | /O(min(n,W))/. Is the value a member of the set?
+member :: Int -> IntSet -> Bool
+member x t
+ = case t of
+ Bin p m l r
+ | nomatch x p m -> False
+ | zero x m -> member x l
+ | otherwise -> member x r
+ Tip y -> (x==y)
+ Nil -> False
+
+-- 'lookup' is used by 'intersection' for left-biasing
+lookup :: Int -> IntSet -> Maybe Int
+lookup k t
+ = let nk = natFromInt k in seq nk (lookupN nk t)
+
+lookupN :: Nat -> IntSet -> Maybe Int
+lookupN k t
+ = case t of
+ Bin p m l r
+ | zeroN k (natFromInt m) -> lookupN k l
+ | otherwise -> lookupN k r
+ Tip kx
+ | (k == natFromInt kx) -> Just kx
+ | otherwise -> Nothing
+ Nil -> Nothing
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty set.
+empty :: IntSet
+empty
+ = Nil
+
+-- | /O(1)/. A set of one element.
+singleton :: Int -> IntSet
+singleton x
+ = Tip x
+
+{--------------------------------------------------------------------
+ Insert
+--------------------------------------------------------------------}
+-- | /O(min(n,W))/. Add a value to the set. When the value is already
+-- an element of the set, it is replaced by the new one, ie. 'insert'
+-- is left-biased.
+insert :: Int -> IntSet -> IntSet
+insert x t
+ = case t of
+ Bin p m l r
+ | nomatch x p m -> join x (Tip x) p t
+ | zero x m -> Bin p m (insert x l) r
+ | otherwise -> Bin p m l (insert x r)
+ Tip y
+ | x==y -> Tip x
+ | otherwise -> join x (Tip x) y t
+ Nil -> Tip x
+
+-- right-biased insertion, used by 'union'
+insertR :: Int -> IntSet -> IntSet
+insertR x t
+ = case t of
+ Bin p m l r
+ | nomatch x p m -> join x (Tip x) p t
+ | zero x m -> Bin p m (insert x l) r
+ | otherwise -> Bin p m l (insert x r)
+ Tip y
+ | x==y -> t
+ | otherwise -> join x (Tip x) y t
+ Nil -> Tip x
+
+-- | /O(min(n,W))/. Delete a value in the set. Returns the
+-- original set when the value was not present.
+delete :: Int -> IntSet -> IntSet
+delete x t
+ = case t of
+ Bin p m l r
+ | nomatch x p m -> t
+ | zero x m -> bin p m (delete x l) r
+ | otherwise -> bin p m l (delete x r)
+ Tip y
+ | x==y -> Nil
+ | otherwise -> t
+ Nil -> Nil
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+-- | The union of a list of sets.
+unions :: [IntSet] -> IntSet
+unions xs
+ = foldlStrict union empty xs
+
+
+-- | /O(n+m)/. The union of two sets.
+union :: IntSet -> IntSet -> IntSet
+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = union1
+ | shorter m2 m1 = union2
+ | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)
+ | otherwise = join p1 t1 p2 t2
+ where
+ union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
+ | zero p2 m1 = Bin p1 m1 (union l1 t2) r1
+ | otherwise = Bin p1 m1 l1 (union r1 t2)
+
+ union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
+ | zero p1 m2 = Bin p2 m2 (union t1 l2) r2
+ | otherwise = Bin p2 m2 l2 (union t1 r2)
+
+union (Tip x) t = insert x t
+union t (Tip x) = insertR x t -- right bias
+union Nil t = t
+union t Nil = t
+
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Difference between two sets.
+difference :: IntSet -> IntSet -> IntSet
+difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = difference1
+ | shorter m2 m1 = difference2
+ | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)
+ | otherwise = t1
+ where
+ difference1 | nomatch p2 p1 m1 = t1
+ | zero p2 m1 = bin p1 m1 (difference l1 t2) r1
+ | otherwise = bin p1 m1 l1 (difference r1 t2)
+
+ difference2 | nomatch p1 p2 m2 = t1
+ | zero p1 m2 = difference t1 l2
+ | otherwise = difference t1 r2
+
+difference t1@(Tip x) t2
+ | member x t2 = Nil
+ | otherwise = t1
+
+difference Nil t = Nil
+difference t (Tip x) = delete x t
+difference t Nil = t
+
+
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | /O(n+m)/. The intersection of two sets.
+intersection :: IntSet -> IntSet -> IntSet
+intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = intersection1
+ | shorter m2 m1 = intersection2
+ | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
+ | otherwise = Nil
+ where
+ intersection1 | nomatch p2 p1 m1 = Nil
+ | zero p2 m1 = intersection l1 t2
+ | otherwise = intersection r1 t2
+
+ intersection2 | nomatch p1 p2 m2 = Nil
+ | zero p1 m2 = intersection t1 l2
+ | otherwise = intersection t1 r2
+
+intersection t1@(Tip x) t2
+ | member x t2 = t1
+ | otherwise = Nil
+intersection t (Tip x)
+ = case lookup x t of
+ Just y -> Tip y
+ Nothing -> Nil
+intersection Nil t = Nil
+intersection t Nil = Nil
+
+
+
+{--------------------------------------------------------------------
+ Subset
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
+isProperSubsetOf :: IntSet -> IntSet -> Bool
+isProperSubsetOf t1 t2
+ = case subsetCmp t1 t2 of
+ LT -> True
+ ge -> False
+
+subsetCmp t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = GT
+ | shorter m2 m1 = subsetCmpLt
+ | p1 == p2 = subsetCmpEq
+ | otherwise = GT -- disjoint
+ where
+ subsetCmpLt | nomatch p1 p2 m2 = GT
+ | zero p1 m2 = subsetCmp t1 l2
+ | otherwise = subsetCmp t1 r2
+ subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of
+ (GT,_ ) -> GT
+ (_ ,GT) -> GT
+ (EQ,EQ) -> EQ
+ other -> LT
+
+subsetCmp (Bin p m l r) t = GT
+subsetCmp (Tip x) (Tip y)
+ | x==y = EQ
+ | otherwise = GT -- disjoint
+subsetCmp (Tip x) t
+ | member x t = LT
+ | otherwise = GT -- disjoint
+subsetCmp Nil Nil = EQ
+subsetCmp Nil t = LT
+
+-- | /O(n+m)/. Is this a subset?
+-- @(s1 `isSubsetOf` s2)@ tells whether s1 is a subset of s2.
+
+isSubsetOf :: IntSet -> IntSet -> Bool
+isSubsetOf t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+ | shorter m1 m2 = False
+ | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2
+ else isSubsetOf t1 r2)
+ | otherwise = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2
+isSubsetOf (Bin p m l r) t = False
+isSubsetOf (Tip x) t = member x t
+isSubsetOf Nil t = True
+
+
+{--------------------------------------------------------------------
+ Filter
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all elements that satisfy some predicate.
+filter :: (Int -> Bool) -> IntSet -> IntSet
+filter pred t
+ = case t of
+ Bin p m l r
+ -> bin p m (filter pred l) (filter pred r)
+ Tip x
+ | pred x -> t
+ | otherwise -> Nil
+ Nil -> Nil
+
+-- | /O(n)/. partition the set according to some predicate.
+partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet)
+partition pred t
+ = case t of
+ Bin p m l r
+ -> let (l1,l2) = partition pred l
+ (r1,r2) = partition pred r
+ in (bin p m l1 r1, bin p m l2 r2)
+ Tip x
+ | pred x -> (t,Nil)
+ | otherwise -> (Nil,t)
+ Nil -> (Nil,Nil)
+
+
+-- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@
+-- where all elements in @set1@ are lower than @x@ and all elements in
+-- @set2@ larger than @x@.
+--
+-- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [3,4])
+split :: Int -> IntSet -> (IntSet,IntSet)
+split x t
+ = case t of
+ Bin p m l r
+ | zero x m -> let (lt,gt) = split x l in (lt,union gt r)
+ | otherwise -> let (lt,gt) = split x r in (union l lt,gt)
+ Tip y
+ | x>y -> (t,Nil)
+ | x<y -> (Nil,t)
+ | otherwise -> (Nil,Nil)
+ Nil -> (Nil,Nil)
+
+-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
+-- element was found in the original set.
+splitMember :: Int -> IntSet -> (Bool,IntSet,IntSet)
+splitMember x t
+ = case t of
+ Bin p m l r
+ | zero x m -> let (found,lt,gt) = splitMember x l in (found,lt,union gt r)
+ | otherwise -> let (found,lt,gt) = splitMember x r in (found,union l lt,gt)
+ Tip y
+ | x>y -> (False,t,Nil)
+ | x<y -> (False,Nil,t)
+ | otherwise -> (True,Nil,Nil)
+ Nil -> (False,Nil,Nil)
+
+{----------------------------------------------------------------------
+ Map
+----------------------------------------------------------------------}
+
+-- | /O(n*min(n,W))/.
+-- @map f s@ is the set obtained by applying @f@ to each element of @s@.
+--
+-- It's worth noting that the size of the result may be smaller if,
+-- for some @(x,y)@, @x \/= y && f x == f y@
+
+map :: (Int->Int) -> IntSet -> IntSet
+map f = fromList . List.map f . toList
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+-- | /O(n)/. Fold over the elements of a set in an unspecified order.
+--
+-- > sum set == fold (+) 0 set
+-- > elems set == fold (:) [] set
+fold :: (Int -> b -> b) -> b -> IntSet -> b
+fold f z t
+ = foldr f z t
+
+foldr :: (Int -> b -> b) -> b -> IntSet -> b
+foldr f z t
+ = case t of
+ Bin p m l r -> foldr f (foldr f z r) l
+ Tip x -> f x z
+ Nil -> z
+
+{--------------------------------------------------------------------
+ List variations
+--------------------------------------------------------------------}
+-- | /O(n)/. The elements of a set. (For sets, this is equivalent to toList)
+elems :: IntSet -> [Int]
+elems s
+ = toList s
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+-- | /O(n)/. Convert the set to a list of elements.
+toList :: IntSet -> [Int]
+toList t
+ = fold (:) [] t
+
+-- | /O(n)/. Convert the set to an ascending list of elements.
+toAscList :: IntSet -> [Int]
+toAscList t
+ = -- NOTE: the following algorithm only works for big-endian trees
+ let (pos,neg) = span (>=0) (foldr (:) [] t) in neg ++ pos
+
+-- | /O(n*min(n,W))/. Create a set from a list of integers.
+fromList :: [Int] -> IntSet
+fromList xs
+ = foldlStrict ins empty xs
+ where
+ ins t x = insert x t
+
+-- | /O(n*min(n,W))/. Build a set from an ascending list of elements.
+fromAscList :: [Int] -> IntSet
+fromAscList xs
+ = fromList xs
+
+-- | /O(n*min(n,W))/. Build a set from an ascending list of distinct elements.
+fromDistinctAscList :: [Int] -> IntSet
+fromDistinctAscList xs
+ = fromList xs
+
+
+{--------------------------------------------------------------------
+ Eq
+--------------------------------------------------------------------}
+instance Eq IntSet where
+ t1 == t2 = equal t1 t2
+ t1 /= t2 = nequal t1 t2
+
+equal :: IntSet -> IntSet -> Bool
+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)
+equal (Tip x) (Tip y)
+ = (x==y)
+equal Nil Nil = True
+equal t1 t2 = False
+
+nequal :: IntSet -> IntSet -> Bool
+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)
+nequal (Tip x) (Tip y)
+ = (x/=y)
+nequal Nil Nil = False
+nequal t1 t2 = True
+
+{--------------------------------------------------------------------
+ Ord
+--------------------------------------------------------------------}
+
+instance Ord IntSet where
+ compare s1 s2 = compare (toAscList s1) (toAscList s2)
+ -- tentative implementation. See if more efficient exists.
+
+{--------------------------------------------------------------------
+ Monoid
+--------------------------------------------------------------------}
+
+instance Monoid IntSet where
+ mempty = empty
+ mappend = union
+ mconcat = unions
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance Show IntSet where
+ showsPrec d s = showSet (toList s)
+
+showSet :: [Int] -> ShowS
+showSet []
+ = showString "{}"
+showSet (x:xs)
+ = showChar '{' . shows x . showTail xs
+ where
+ showTail [] = showChar '}'
+ showTail (x:xs) = showChar ',' . shows x . showTail xs
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+-- | /O(n)/. Show the tree that implements the set. The tree is shown
+-- in a compressed, hanging format.
+showTree :: IntSet -> String
+showTree s
+ = showTreeWith True False s
+
+
+{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
+ the tree that implements the set. If @hang@ is
+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
+ @wide@ is true, an extra wide version is shown.
+-}
+showTreeWith :: Bool -> Bool -> IntSet -> String
+showTreeWith hang wide t
+ | hang = (showsTreeHang wide [] t) ""
+ | otherwise = (showsTree wide [] [] t) ""
+
+showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS
+showsTree wide lbars rbars t
+ = case t of
+ Bin p m l r
+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . showString (showBin p m) . showString "\n" .
+ showWide wide lbars .
+ showsTree wide (withEmpty lbars) (withBar lbars) l
+ Tip x
+ -> showsBars lbars . showString " " . shows x . showString "\n"
+ Nil -> showsBars lbars . showString "|\n"
+
+showsTreeHang :: Bool -> [String] -> IntSet -> ShowS
+showsTreeHang wide bars t
+ = case t of
+ Bin p m l r
+ -> showsBars bars . showString (showBin p m) . showString "\n" .
+ showWide wide bars .
+ showsTreeHang wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang wide (withEmpty bars) r
+ Tip x
+ -> showsBars bars . showString " " . shows x . showString "\n"
+ Nil -> showsBars bars . showString "|\n"
+
+showBin p m
+ = "*" -- ++ show (p,m)
+
+showWide wide bars
+ | wide = showString (concat (reverse bars)) . showString "|\n"
+ | otherwise = id
+
+showsBars :: [String] -> ShowS
+showsBars bars
+ = case bars of
+ [] -> id
+ _ -> showString (concat (reverse (tail bars))) . showString node
+
+node = "+--"
+withBar bars = "| ":bars
+withEmpty bars = " ":bars
+
+
+{--------------------------------------------------------------------
+ Helpers
+--------------------------------------------------------------------}
+{--------------------------------------------------------------------
+ Join
+--------------------------------------------------------------------}
+join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet
+join p1 t1 p2 t2
+ | zero p1 m = Bin p m t1 t2
+ | otherwise = Bin p m t2 t1
+ where
+ m = branchMask p1 p2
+ p = mask p1 m
+
+{--------------------------------------------------------------------
+ @bin@ assures that we never have empty trees within a tree.
+--------------------------------------------------------------------}
+bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet
+bin p m l Nil = l
+bin p m Nil r = r
+bin p m l r = Bin p m l r
+
+
+{--------------------------------------------------------------------
+ Endian independent bit twiddling
+--------------------------------------------------------------------}
+zero :: Int -> Mask -> Bool
+zero i m
+ = (natFromInt i) .&. (natFromInt m) == 0
+
+nomatch,match :: Int -> Prefix -> Mask -> Bool
+nomatch i p m
+ = (mask i m) /= p
+
+match i p m
+ = (mask i m) == p
+
+mask :: Int -> Mask -> Prefix
+mask i m
+ = maskW (natFromInt i) (natFromInt m)
+
+zeroN :: Nat -> Nat -> Bool
+zeroN i m = (i .&. m) == 0
+
+{--------------------------------------------------------------------
+ Big endian operations
+--------------------------------------------------------------------}
+maskW :: Nat -> Nat -> Prefix
+maskW i m
+ = intFromNat (i .&. (complement (m-1) `xor` m))
+
+shorter :: Mask -> Mask -> Bool
+shorter m1 m2
+ = (natFromInt m1) > (natFromInt m2)
+
+branchMask :: Prefix -> Prefix -> Mask
+branchMask p1 p2
+ = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
+
+{----------------------------------------------------------------------
+ Finding the highest bit (mask) in a word [x] can be done efficiently in
+ three ways:
+ * convert to a floating point value and the mantissa tells us the
+ [log2(x)] that corresponds with the highest bit position. The mantissa
+ is retrieved either via the standard C function [frexp] or by some bit
+ twiddling on IEEE compatible numbers (float). Note that one needs to
+ use at least [double] precision for an accurate mantissa of 32 bit
+ numbers.
+ * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
+ * use processor specific assembler instruction (asm).
+
+ The most portable way would be [bit], but is it efficient enough?
+ I have measured the cycle counts of the different methods on an AMD
+ Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
+
+ highestBitMask: method cycles
+ --------------
+ frexp 200
+ float 33
+ bit 11
+ asm 12
+
+ highestBit: method cycles
+ --------------
+ frexp 195
+ float 33
+ bit 11
+ asm 11
+
+ Wow, the bit twiddling is on today's RISC like machines even faster
+ than a single CISC instruction (BSR)!
+----------------------------------------------------------------------}
+
+{----------------------------------------------------------------------
+ [highestBitMask] returns a word where only the highest bit is set.
+ It is found by first setting all bits in lower positions than the
+ highest bit and than taking an exclusive or with the original value.
+ Allthough the function may look expensive, GHC compiles this into
+ excellent C code that subsequently compiled into highly efficient
+ machine code. The algorithm is derived from Jorg Arndt's FXT library.
+----------------------------------------------------------------------}
+highestBitMask :: Nat -> Nat
+highestBitMask x
+ = case (x .|. shiftRL x 1) of
+ x -> case (x .|. shiftRL x 2) of
+ x -> case (x .|. shiftRL x 4) of
+ x -> case (x .|. shiftRL x 8) of
+ x -> case (x .|. shiftRL x 16) of
+ x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms
+ x -> (x `xor` (shiftRL x 1))
+
+
+{--------------------------------------------------------------------
+ Utilities
+--------------------------------------------------------------------}
+foldlStrict f z xs
+ = case xs of
+ [] -> z
+ (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
+
+
+{-
+{--------------------------------------------------------------------
+ Testing
+--------------------------------------------------------------------}
+testTree :: [Int] -> IntSet
+testTree xs = fromList xs
+test1 = testTree [1..20]
+test2 = testTree [30,29..10]
+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
+
+{--------------------------------------------------------------------
+ QuickCheck
+--------------------------------------------------------------------}
+qcheck prop
+ = check config prop
+ where
+ config = Config
+ { configMaxTest = 500
+ , configMaxFail = 5000
+ , configSize = \n -> (div n 2 + 3)
+ , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
+ }
+
+
+{--------------------------------------------------------------------
+ Arbitrary, reasonably balanced trees
+--------------------------------------------------------------------}
+instance Arbitrary IntSet where
+ arbitrary = do{ xs <- arbitrary
+ ; return (fromList xs)
+ }
+
+
+{--------------------------------------------------------------------
+ Single, Insert, Delete
+--------------------------------------------------------------------}
+prop_Single :: Int -> Bool
+prop_Single x
+ = (insert x empty == singleton x)
+
+prop_InsertDelete :: Int -> IntSet -> Property
+prop_InsertDelete k t
+ = not (member k t) ==> delete k (insert k t) == t
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+prop_UnionInsert :: Int -> IntSet -> Bool
+prop_UnionInsert x t
+ = union t (singleton x) == insert x t
+
+prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool
+prop_UnionAssoc t1 t2 t3
+ = union t1 (union t2 t3) == union (union t1 t2) t3
+
+prop_UnionComm :: IntSet -> IntSet -> Bool
+prop_UnionComm t1 t2
+ = (union t1 t2 == union t2 t1)
+
+prop_Diff :: [Int] -> [Int] -> Bool
+prop_Diff xs ys
+ = toAscList (difference (fromList xs) (fromList ys))
+ == List.sort ((List.\\) (nub xs) (nub ys))
+
+prop_Int :: [Int] -> [Int] -> Bool
+prop_Int xs ys
+ = toAscList (intersection (fromList xs) (fromList ys))
+ == List.sort (nub ((List.intersect) (xs) (ys)))
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+prop_Ordered
+ = forAll (choose (5,100)) $ \n ->
+ let xs = [0..n::Int]
+ in fromAscList xs == fromList xs
+
+prop_List :: [Int] -> Bool
+prop_List xs
+ = (sort (nub xs) == toAscList (fromList xs))
+-}
--- /dev/null
+--------------------------------------------------------------------------------
+{-| Module : Data.Map
+ Copyright : (c) Daan Leijen 2002
+ License : BSD-style
+ Maintainer : libraries@haskell.org
+ Stability : provisional
+ Portability : portable
+
+ An efficient implementation of maps from keys to values (dictionaries).
+
+ This module is intended to be imported @qualified@, to avoid name
+ clashes with Prelude functions. eg.
+
+ > import Data.Map as Map
+
+ The implementation of "Map" is based on /size balanced/ binary trees (or
+ trees of /bounded balance/) as described by:
+
+ * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional
+ Programming 3(4):553-562, October 1993, <http://www.swiss.ai.mit.edu/~adams/BB>.
+
+ * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\",
+ SIAM journal of computing 2(1), March 1973.
+-}
+----------------------------------------------------------------------------------
+module Data.Map (
+ -- * Map type
+ Map -- instance Eq,Show
+
+ -- * Operators
+ , (!), (\\)
+
+
+ -- * Query
+ , null
+ , size
+ , member
+ , lookup
+ , findWithDefault
+
+ -- * Construction
+ , empty
+ , singleton
+
+ -- ** Insertion
+ , insert
+ , insertWith, insertWithKey, insertLookupWithKey
+
+ -- ** Delete\/Update
+ , delete
+ , adjust
+ , adjustWithKey
+ , update
+ , updateWithKey
+ , updateLookupWithKey
+
+ -- * Combine
+
+ -- ** Union
+ , union
+ , unionWith
+ , unionWithKey
+ , unions
+ , unionsWith
+
+ -- ** Difference
+ , difference
+ , differenceWith
+ , differenceWithKey
+
+ -- ** Intersection
+ , intersection
+ , intersectionWith
+ , intersectionWithKey
+
+ -- * Traversal
+ -- ** Map
+ , map
+ , mapWithKey
+ , mapAccum
+ , mapAccumWithKey
+ , mapKeys
+ , mapKeysWith
+ , mapKeysMonotonic
+
+ -- ** Fold
+ , fold
+ , foldWithKey
+
+ -- * Conversion
+ , elems
+ , keys
+ , keysSet
+ , assocs
+
+ -- ** Lists
+ , toList
+ , fromList
+ , fromListWith
+ , fromListWithKey
+
+ -- ** Ordered lists
+ , toAscList
+ , fromAscList
+ , fromAscListWith
+ , fromAscListWithKey
+ , fromDistinctAscList
+
+ -- * Filter
+ , filter
+ , filterWithKey
+ , partition
+ , partitionWithKey
+
+ , split
+ , splitLookup
+
+ -- * Submap
+ , isSubmapOf, isSubmapOfBy
+ , isProperSubmapOf, isProperSubmapOfBy
+
+ -- * Indexed
+ , lookupIndex
+ , findIndex
+ , elemAt
+ , updateAt
+ , deleteAt
+
+ -- * Min\/Max
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , updateMin
+ , updateMax
+ , updateMinWithKey
+ , updateMaxWithKey
+
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ , valid
+ ) where
+
+import Prelude hiding (lookup,map,filter,foldr,foldl,null)
+import Data.Monoid
+import qualified Data.Set as Set
+import qualified Data.List as List
+
+{-
+-- for quick check
+import qualified Prelude
+import qualified List
+import Debug.QuickCheck
+import List(nub,sort)
+-}
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+infixl 9 !,\\ --
+
+-- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found.
+(!) :: Ord k => Map k a -> k -> a
+m ! k = find k m
+
+-- | /O(n+m)/. See 'difference'.
+(\\) :: Ord k => Map k a -> Map k b -> Map k a
+m1 \\ m2 = difference m1 m2
+
+{--------------------------------------------------------------------
+ Size balanced trees.
+--------------------------------------------------------------------}
+-- | A Map from keys @k@ to values @a@.
+data Map k a = Tip
+ | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
+
+type Size = Int
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is the map empty?
+null :: Map k a -> Bool
+null t
+ = case t of
+ Tip -> True
+ Bin sz k x l r -> False
+
+-- | /O(1)/. The number of elements in the map.
+size :: Map k a -> Int
+size t
+ = case t of
+ Tip -> 0
+ Bin sz k x l r -> sz
+
+
+-- | /O(log n)/. Lookup the value of key in the map.
+lookup :: Ord k => k -> Map k a -> Maybe a
+lookup k t
+ = case t of
+ Tip -> Nothing
+ Bin sz kx x l r
+ -> case compare k kx of
+ LT -> lookup k l
+ GT -> lookup k r
+ EQ -> Just x
+
+-- | /O(log n)/. Is the key a member of the map?
+member :: Ord k => k -> Map k a -> Bool
+member k m
+ = case lookup k m of
+ Nothing -> False
+ Just x -> True
+
+-- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found.
+find :: Ord k => k -> Map k a -> a
+find k m
+ = case lookup k m of
+ Nothing -> error "Map.find: element not in the map"
+ Just x -> x
+
+-- | /O(log n)/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when
+-- the key is not in the map.
+findWithDefault :: Ord k => a -> k -> Map k a -> a
+findWithDefault def k m
+ = case lookup k m of
+ Nothing -> def
+ Just x -> x
+
+
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty map.
+empty :: Map k a
+empty
+ = Tip
+
+-- | /O(1)/. Create a map with a single element.
+singleton :: k -> a -> Map k a
+singleton k x
+ = Bin 1 k x Tip Tip
+
+{--------------------------------------------------------------------
+ Insertion
+ [insert] is the inlined version of [insertWith (\k x y -> x)]
+--------------------------------------------------------------------}
+-- | /O(log n)/. Insert a new key and value in the map.
+insert :: Ord k => k -> a -> Map k a -> Map k a
+insert kx x t
+ = case t of
+ Tip -> singleton kx x
+ Bin sz ky y l r
+ -> case compare kx ky of
+ LT -> balance ky y (insert kx x l) r
+ GT -> balance ky y l (insert kx x r)
+ EQ -> Bin sz kx x l r
+
+-- | /O(log n)/. Insert with a combining function.
+insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
+insertWith f k x m
+ = insertWithKey (\k x y -> f x y) k x m
+
+-- | /O(log n)/. Insert with a combining function.
+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
+insertWithKey f kx x t
+ = case t of
+ Tip -> singleton kx x
+ Bin sy ky y l r
+ -> case compare kx ky of
+ LT -> balance ky y (insertWithKey f kx x l) r
+ GT -> balance ky y l (insertWithKey f kx x r)
+ EQ -> Bin sy ky (f ky x y) l r
+
+-- | /O(log n)/. The expression (@insertLookupWithKey f k x map@) is a pair where
+-- the first element is equal to (@lookup k map@) and the second element
+-- equal to (@insertWithKey f k x map@).
+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
+insertLookupWithKey f kx x t
+ = case t of
+ Tip -> (Nothing, singleton kx x)
+ Bin sy ky y l r
+ -> case compare kx ky of
+ LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
+ GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
+ EQ -> (Just y, Bin sy ky (f ky x y) l r)
+
+{--------------------------------------------------------------------
+ Deletion
+ [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
+--------------------------------------------------------------------}
+-- | /O(log n)/. Delete a key and its value from the map. When the key is not
+-- a member of the map, the original map is returned.
+delete :: Ord k => k -> Map k a -> Map k a
+delete k t
+ = case t of
+ Tip -> Tip
+ Bin sx kx x l r
+ -> case compare k kx of
+ LT -> balance kx x (delete k l) r
+ GT -> balance kx x l (delete k r)
+ EQ -> glue l r
+
+-- | /O(log n)/. Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
+adjust f k m
+ = adjustWithKey (\k x -> f x) k m
+
+-- | /O(log n)/. Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
+adjustWithKey f k m
+ = updateWithKey (\k x -> Just (f k x)) k m
+
+-- | /O(log n)/. The expression (@update f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is
+-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
+update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
+update f k m
+ = updateWithKey (\k x -> f x) k m
+
+-- | /O(log n)/. The expression (@update f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is
+-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
+updateWithKey f k t
+ = case t of
+ Tip -> Tip
+ Bin sx kx x l r
+ -> case compare k kx of
+ LT -> balance kx x (updateWithKey f k l) r
+ GT -> balance kx x l (updateWithKey f k r)
+ EQ -> case f kx x of
+ Just x' -> Bin sx kx x' l r
+ Nothing -> glue l r
+
+-- | /O(log n)/. Lookup and update.
+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
+updateLookupWithKey f k t
+ = case t of
+ Tip -> (Nothing,Tip)
+ Bin sx kx x l r
+ -> case compare k kx of
+ LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
+ GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r')
+ EQ -> case f kx x of
+ Just x' -> (Just x',Bin sx kx x' l r)
+ Nothing -> (Just x,glue l r)
+
+{--------------------------------------------------------------------
+ Indexing
+--------------------------------------------------------------------}
+-- | /O(log n)/. Return the /index/ of a key. The index is a number from
+-- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
+-- the key is not a 'member' of the map.
+findIndex :: Ord k => k -> Map k a -> Int
+findIndex k t
+ = case lookupIndex k t of
+ Nothing -> error "Map.findIndex: element is not in the map"
+ Just idx -> idx
+
+-- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
+-- /0/ up to, but not including, the 'size' of the map.
+lookupIndex :: Ord k => k -> Map k a -> Maybe Int
+lookupIndex k t
+ = lookup 0 t
+ where
+ lookup idx Tip = Nothing
+ lookup idx (Bin _ kx x l r)
+ = case compare k kx of
+ LT -> lookup idx l
+ GT -> lookup (idx + size l + 1) r
+ EQ -> Just (idx + size l)
+
+-- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
+-- invalid index is used.
+elemAt :: Int -> Map k a -> (k,a)
+elemAt i Tip = error "Map.elemAt: index out of range"
+elemAt i (Bin _ kx x l r)
+ = case compare i sizeL of
+ LT -> elemAt i l
+ GT -> elemAt (i-sizeL-1) r
+ EQ -> (kx,x)
+ where
+ sizeL = size l
+
+-- | /O(log n)/. Update the element at /index/. Calls 'error' when an
+-- invalid index is used.
+updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
+updateAt f i Tip = error "Map.updateAt: index out of range"
+updateAt f i (Bin sx kx x l r)
+ = case compare i sizeL of
+ LT -> updateAt f i l
+ GT -> updateAt f (i-sizeL-1) r
+ EQ -> case f kx x of
+ Just x' -> Bin sx kx x' l r
+ Nothing -> glue l r
+ where
+ sizeL = size l
+
+-- | /O(log n)/. Delete the element at /index/. Defined as (@deleteAt i map = updateAt (\k x -> Nothing) i map@).
+deleteAt :: Int -> Map k a -> Map k a
+deleteAt i map
+ = updateAt (\k x -> Nothing) i map
+
+
+{--------------------------------------------------------------------
+ Minimal, Maximal
+--------------------------------------------------------------------}
+-- | /O(log n)/. The minimal key of the map.
+findMin :: Map k a -> (k,a)
+findMin (Bin _ kx x Tip r) = (kx,x)
+findMin (Bin _ kx x l r) = findMin l
+findMin Tip = error "Map.findMin: empty tree has no minimal element"
+
+-- | /O(log n)/. The maximal key of the map.
+findMax :: Map k a -> (k,a)
+findMax (Bin _ kx x l Tip) = (kx,x)
+findMax (Bin _ kx x l r) = findMax r
+findMax Tip = error "Map.findMax: empty tree has no maximal element"
+
+-- | /O(log n)/. Delete the minimal key.
+deleteMin :: Map k a -> Map k a
+deleteMin (Bin _ kx x Tip r) = r
+deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
+deleteMin Tip = Tip
+
+-- | /O(log n)/. Delete the maximal key.
+deleteMax :: Map k a -> Map k a
+deleteMax (Bin _ kx x l Tip) = l
+deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
+deleteMax Tip = Tip
+
+-- | /O(log n)/. Update the minimal key.
+updateMin :: (a -> Maybe a) -> Map k a -> Map k a
+updateMin f m
+ = updateMinWithKey (\k x -> f x) m
+
+-- | /O(log n)/. Update the maximal key.
+updateMax :: (a -> Maybe a) -> Map k a -> Map k a
+updateMax f m
+ = updateMaxWithKey (\k x -> f x) m
+
+
+-- | /O(log n)/. Update the minimal key.
+updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
+updateMinWithKey f t
+ = case t of
+ Bin sx kx x Tip r -> case f kx x of
+ Nothing -> r
+ Just x' -> Bin sx kx x' Tip r
+ Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
+ Tip -> Tip
+
+-- | /O(log n)/. Update the maximal key.
+updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
+updateMaxWithKey f t
+ = case t of
+ Bin sx kx x l Tip -> case f kx x of
+ Nothing -> l
+ Just x' -> Bin sx kx x' l Tip
+ Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
+ Tip -> Tip
+
+
+{--------------------------------------------------------------------
+ Union.
+--------------------------------------------------------------------}
+-- | The union of a list of maps: (@unions == foldl union empty@).
+unions :: Ord k => [Map k a] -> Map k a
+unions ts
+ = foldlStrict union empty ts
+
+-- | The union of a list of maps, with a combining operation:
+-- (@unionsWith f == foldl (unionWith f) empty@).
+unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
+unionsWith f ts
+ = foldlStrict (unionWith f) empty ts
+
+-- | /O(n+m)/.
+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
+-- It prefers @t1@ when duplicate keys are encountered, ie. (@union == unionWith const@).
+-- The implementation uses the efficient /hedge-union/ algorithm.
+-- Hedge-union is more efficient on (bigset `union` smallset)?
+union :: Ord k => Map k a -> Map k a -> Map k a
+union Tip t2 = t2
+union t1 Tip = t1
+union t1 t2
+ | size t1 >= size t2 = hedgeUnionL (const LT) (const GT) t1 t2
+ | otherwise = hedgeUnionR (const LT) (const GT) t2 t1
+
+-- left-biased hedge union
+hedgeUnionL cmplo cmphi t1 Tip
+ = t1
+hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
+ = join kx x (filterGt cmplo l) (filterLt cmphi r)
+hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
+ = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2))
+ (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
+ where
+ cmpkx k = compare kx k
+
+-- right-biased hedge union
+hedgeUnionR cmplo cmphi t1 Tip
+ = t1
+hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
+ = join kx x (filterGt cmplo l) (filterLt cmphi r)
+hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
+ = join kx newx (hedgeUnionR cmplo cmpkx l lt)
+ (hedgeUnionR cmpkx cmphi r gt)
+ where
+ cmpkx k = compare kx k
+ lt = trim cmplo cmpkx t2
+ (found,gt) = trimLookupLo kx cmphi t2
+ newx = case found of
+ Nothing -> x
+ Just y -> y
+
+{--------------------------------------------------------------------
+ Union with a combining function
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
+unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
+unionWith f m1 m2
+ = unionWithKey (\k x y -> f x y) m1 m2
+
+-- | /O(n+m)/.
+-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
+-- Hedge-union is more efficient on (bigset `union` smallset).
+unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
+unionWithKey f Tip t2 = t2
+unionWithKey f t1 Tip = t1
+unionWithKey f t1 t2
+ | size t1 >= size t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
+ | otherwise = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1
+ where
+ flipf k x y = f k y x
+
+hedgeUnionWithKey f cmplo cmphi t1 Tip
+ = t1
+hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
+ = join kx x (filterGt cmplo l) (filterLt cmphi r)
+hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
+ = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt)
+ (hedgeUnionWithKey f cmpkx cmphi r gt)
+ where
+ cmpkx k = compare kx k
+ lt = trim cmplo cmpkx t2
+ (found,gt) = trimLookupLo kx cmphi t2
+ newx = case found of
+ Nothing -> x
+ Just y -> f kx x y
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Difference of two maps.
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+difference :: Ord k => Map k a -> Map k b -> Map k a
+difference Tip t2 = Tip
+difference t1 Tip = t1
+difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
+
+hedgeDiff cmplo cmphi Tip t
+ = Tip
+hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip
+ = join kx x (filterGt cmplo l) (filterLt cmphi r)
+hedgeDiff cmplo cmphi t (Bin _ kx x l r)
+ = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l)
+ (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
+ where
+ cmpkx k = compare kx k
+
+-- | /O(n+m)/. Difference with a combining function.
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
+differenceWith f m1 m2
+ = differenceWithKey (\k x y -> f x y) m1 m2
+
+-- | /O(n+m)/. Difference with a combining function. When two equal keys are
+-- encountered, the combining function is applied to the key and both values.
+-- If it returns @Nothing@, the element is discarded (proper set difference). If
+-- it returns (@Just y@), the element is updated with a new value @y@.
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
+differenceWithKey f Tip t2 = Tip
+differenceWithKey f t1 Tip = t1
+differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
+
+hedgeDiffWithKey f cmplo cmphi Tip t
+ = Tip
+hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip
+ = join kx x (filterGt cmplo l) (filterLt cmphi r)
+hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r)
+ = case found of
+ Nothing -> merge tl tr
+ Just y -> case f kx y x of
+ Nothing -> merge tl tr
+ Just z -> join kx z tl tr
+ where
+ cmpkx k = compare kx k
+ lt = trim cmplo cmpkx t
+ (found,gt) = trimLookupLo kx cmphi t
+ tl = hedgeDiffWithKey f cmplo cmpkx lt l
+ tr = hedgeDiffWithKey f cmpkx cmphi gt r
+
+
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Intersection of two maps. The values in the first
+-- map are returned, i.e. (@intersection m1 m2 == intersectionWith const m1 m2@).
+intersection :: Ord k => Map k a -> Map k b -> Map k a
+intersection m1 m2
+ = intersectionWithKey (\k x y -> x) m1 m2
+
+-- | /O(n+m)/. Intersection with a combining function.
+intersectionWith :: Ord k => (a -> b -> a) -> Map k a -> Map k b -> Map k a
+intersectionWith f m1 m2
+ = intersectionWithKey (\k x y -> f x y) m1 m2
+
+-- | /O(n+m)/. Intersection with a combining function.
+-- Intersection is more efficient on (bigset `intersection` smallset)
+intersectionWithKey :: Ord k => (k -> a -> b -> a) -> Map k a -> Map k b -> Map k a
+intersectionWithKey f Tip t = Tip
+intersectionWithKey f t Tip = Tip
+intersectionWithKey f t1 t2
+ | size t1 >= size t2 = intersectWithKey f t1 t2
+ | otherwise = intersectWithKey flipf t2 t1
+ where
+ flipf k x y = f k y x
+
+intersectWithKey f Tip t = Tip
+intersectWithKey f t Tip = Tip
+intersectWithKey f t (Bin _ kx x l r)
+ = case found of
+ Nothing -> merge tl tr
+ Just y -> join kx (f kx y x) tl tr
+ where
+ (found,lt,gt) = splitLookup kx t
+ tl = intersectWithKey f lt l
+ tr = intersectWithKey f gt r
+
+
+
+{--------------------------------------------------------------------
+ Submap
+--------------------------------------------------------------------}
+-- | /O(n+m)/.
+-- This function is defined as (@submap = submapBy (==)@).
+isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
+isSubmapOf m1 m2
+ = isSubmapOfBy (==) m1 m2
+
+{- | /O(n+m)/.
+ The expression (@isSubmapOfBy f t1 t2@) returns @True@ if
+ all keys in @t1@ are in tree @t2@, and when @f@ returns @True@ when
+ applied to their respective values. For example, the following
+ expressions are all @True@.
+
+ > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
+ > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
+
+ But the following are all @False@:
+
+ > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
+ > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
+-}
+isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
+isSubmapOfBy f t1 t2
+ = (size t1 <= size t2) && (submap' f t1 t2)
+
+submap' f Tip t = True
+submap' f t Tip = False
+submap' f (Bin _ kx x l r) t
+ = case found of
+ Nothing -> False
+ Just y -> f x y && submap' f l lt && submap' f r gt
+ where
+ (found,lt,gt) = splitLookup kx t
+
+-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
+-- Defined as (@isProperSubmapOf = isProperSubmapOfBy (==)@).
+isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
+isProperSubmapOf m1 m2
+ = isProperSubmapOfBy (==) m1 m2
+
+{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
+ The expression (@isProperSubmapOfBy f m1 m2@) returns @True@ when
+ @m1@ and @m2@ are not equal,
+ all keys in @m1@ are in @m2@, and when @f@ returns @True@ when
+ applied to their respective values. For example, the following
+ expressions are all @True@.
+
+ > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+
+ But the following are all @False@:
+
+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
+-}
+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
+isProperSubmapOfBy f t1 t2
+ = (size t1 < size t2) && (submap' f t1 t2)
+
+{--------------------------------------------------------------------
+ Filter and partition
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all values that satisfy the predicate.
+filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
+filter p m
+ = filterWithKey (\k x -> p x) m
+
+-- | /O(n)/. Filter all keys\/values that satisfy the predicate.
+filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
+filterWithKey p Tip = Tip
+filterWithKey p (Bin _ kx x l r)
+ | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
+ | otherwise = merge (filterWithKey p l) (filterWithKey p r)
+
+
+-- | /O(n)/. partition the map according to a predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
+partition p m
+ = partitionWithKey (\k x -> p x) m
+
+-- | /O(n)/. partition the map according to a predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
+partitionWithKey p Tip = (Tip,Tip)
+partitionWithKey p (Bin _ kx x l r)
+ | p kx x = (join kx x l1 r1,merge l2 r2)
+ | otherwise = (merge l1 r1,join kx x l2 r2)
+ where
+ (l1,l2) = partitionWithKey p l
+ (r1,r2) = partitionWithKey p r
+
+
+{--------------------------------------------------------------------
+ Mapping
+--------------------------------------------------------------------}
+-- | /O(n)/. Map a function over all values in the map.
+map :: (a -> b) -> Map k a -> Map k b
+map f m
+ = mapWithKey (\k x -> f x) m
+
+-- | /O(n)/. Map a function over all values in the map.
+mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
+mapWithKey f Tip = Tip
+mapWithKey f (Bin sx kx x l r)
+ = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
+
+-- | /O(n)/. The function @mapAccum@ threads an accumulating
+-- argument through the map in an unspecified order.
+mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccum f a m
+ = mapAccumWithKey (\a k x -> f a x) a m
+
+-- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating
+-- argument through the map in unspecified order. (= ascending pre-order)
+mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccumWithKey f a t
+ = mapAccumL f a t
+
+-- | /O(n)/. The function @mapAccumL@ threads an accumulating
+-- argument throught the map in (ascending) pre-order.
+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccumL f a t
+ = case t of
+ Tip -> (a,Tip)
+ Bin sx kx x l r
+ -> let (a1,l') = mapAccumL f a l
+ (a2,x') = f a1 kx x
+ (a3,r') = mapAccumL f a2 r
+ in (a3,Bin sx kx x' l' r')
+
+-- | /O(n)/. The function @mapAccumR@ threads an accumulating
+-- argument throught the map in (descending) post-order.
+mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccumR f a t
+ = case t of
+ Tip -> (a,Tip)
+ Bin sx kx x l r
+ -> let (a1,r') = mapAccumR f a r
+ (a2,x') = f a1 kx x
+ (a3,l') = mapAccumR f a2 l
+ in (a3,Bin sx kx x' l' r')
+
+-- | /O(n*log n)/.
+-- @mapKeys f s@ is the map obtained by applying @f@ to each key of @s@.
+--
+-- It's worth noting that the size of the result may be smaller if,
+-- for some @(x,y)@, @x \/= y && f x == f y@
+
+mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
+mapKeys = mapKeysWith (\x y->x)
+
+-- | /O(n*log n)/.
+-- @mapKeysWith c f s@ is the map obtained by applying @f@ to each key of @s@.
+--
+-- It's worth noting that the size of the result may be smaller if,
+-- for some @(x,y)@, @x \/= y && f x == f y@
+-- In such a case, the values will be combined using @c@
+
+mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
+mapKeysWith c f = fromListWith c . List.map fFirst . toList
+ where fFirst (x,y) = (f x, y)
+
+
+-- | /O(n)/. The
+--
+-- @mapMonotonic f s == 'map' f s@, but works only when @f@ is monotonic.
+-- /The precondition is not checked./
+-- Semi-formally, we have:
+--
+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]
+-- > ==> mapMonotonic f s == map f s
+-- > where ls = keys s
+
+mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
+mapKeysMonotonic f Tip = Tip
+mapKeysMonotonic f (Bin sz k x l r) =
+ Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
+
+{--------------------------------------------------------------------
+ Folds
+--------------------------------------------------------------------}
+-- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).
+fold :: (a -> b -> b) -> b -> Map k a -> b
+fold f z m
+ = foldWithKey (\k x z -> f x z) z m
+
+-- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).
+foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
+foldWithKey f z t
+ = foldr f z t
+
+-- | /O(n)/. In-order fold.
+foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b
+foldi f z Tip = z
+foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)
+
+-- | /O(n)/. Post-order fold.
+foldr :: (k -> a -> b -> b) -> b -> Map k a -> b
+foldr f z Tip = z
+foldr f z (Bin _ kx x l r) = foldr f (f kx x (foldr f z r)) l
+
+-- | /O(n)/. Pre-order fold.
+foldl :: (b -> k -> a -> b) -> b -> Map k a -> b
+foldl f z Tip = z
+foldl f z (Bin _ kx x l r) = foldl f (f (foldl f z l) kx x) r
+
+{--------------------------------------------------------------------
+ List variations
+--------------------------------------------------------------------}
+-- | /O(n)/. Return all elements of the map.
+elems :: Map k a -> [a]
+elems m
+ = [x | (k,x) <- assocs m]
+
+-- | /O(n)/. Return all keys of the map.
+keys :: Map k a -> [k]
+keys m
+ = [k | (k,x) <- assocs m]
+
+-- | /O(n)/. The set of all keys of the map.
+keysSet :: Map k a -> Set.Set k
+keysSet m = Set.fromDistinctAscList (keys m)
+
+-- | /O(n)/. Return all key\/value pairs in the map.
+assocs :: Map k a -> [(k,a)]
+assocs m
+ = toList m
+
+{--------------------------------------------------------------------
+ Lists
+ use [foldlStrict] to reduce demand on the control-stack
+--------------------------------------------------------------------}
+-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
+fromList :: Ord k => [(k,a)] -> Map k a
+fromList xs
+ = foldlStrict ins empty xs
+ where
+ ins t (k,x) = insert k x t
+
+-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
+fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
+fromListWith f xs
+ = fromListWithKey (\k x y -> f x y) xs
+
+-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
+fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
+fromListWithKey f xs
+ = foldlStrict ins empty xs
+ where
+ ins t (k,x) = insertWithKey f k x t
+
+-- | /O(n)/. Convert to a list of key\/value pairs.
+toList :: Map k a -> [(k,a)]
+toList t = toAscList t
+
+-- | /O(n)/. Convert to an ascending list.
+toAscList :: Map k a -> [(k,a)]
+toAscList t = foldr (\k x xs -> (k,x):xs) [] t
+
+-- | /O(n)/.
+toDescList :: Map k a -> [(k,a)]
+toDescList t = foldl (\xs k x -> (k,x):xs) [] t
+
+
+{--------------------------------------------------------------------
+ Building trees from ascending/descending lists can be done in linear time.
+
+ Note that if [xs] is ascending that:
+ fromAscList xs == fromList xs
+ fromAscListWith f xs == fromListWith f xs
+--------------------------------------------------------------------}
+-- | /O(n)/. Build a map from an ascending list in linear time.
+-- /The precondition (input list is ascending) is not checked./
+fromAscList :: Eq k => [(k,a)] -> Map k a
+fromAscList xs
+ = fromAscListWithKey (\k x y -> x) xs
+
+-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
+-- /The precondition (input list is ascending) is not checked./
+fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
+fromAscListWith f xs
+ = fromAscListWithKey (\k x y -> f x y) xs
+
+-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys
+-- /The precondition (input list is ascending) is not checked./
+fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
+fromAscListWithKey f xs
+ = fromDistinctAscList (combineEq f xs)
+ where
+ -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
+ combineEq f xs
+ = case xs of
+ [] -> []
+ [x] -> [x]
+ (x:xx) -> combineEq' x xx
+
+ combineEq' z [] = [z]
+ combineEq' z@(kz,zz) (x@(kx,xx):xs)
+ | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
+ | otherwise = z:combineEq' x xs
+
+
+-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
+--
+-- /The precondition is not checked./
+fromDistinctAscList :: [(k,a)] -> Map k a
+fromDistinctAscList xs
+ = build const (length xs) xs
+ where
+ -- 1) use continutations so that we use heap space instead of stack space.
+ -- 2) special case for n==5 to build bushier trees.
+ build c 0 xs = c Tip xs
+ build c 5 xs = case xs of
+ ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
+ -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx
+ build c n xs = seq nr $ build (buildR nr c) nl xs
+ where
+ nl = n `div` 2
+ nr = n - nl - 1
+
+ buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
+ buildB l k x c r zs = c (bin k x l r) zs
+
+
+
+{--------------------------------------------------------------------
+ Utility functions that return sub-ranges of the original
+ tree. Some functions take a comparison function as argument to
+ allow comparisons against infinite values. A function [cmplo k]
+ should be read as [compare lo k].
+
+ [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
+ and [cmphi k == GT] for the key [k] of the root.
+ [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
+ [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
+
+ [split k t] Returns two trees [l] and [r] where all keys
+ in [l] are <[k] and all keys in [r] are >[k].
+ [splitLookup k t] Just like [split] but also returns whether [k]
+ was found in the tree.
+--------------------------------------------------------------------}
+
+{--------------------------------------------------------------------
+ [trim lo hi t] trims away all subtrees that surely contain no
+ values between the range [lo] to [hi]. The returned tree is either
+ empty or the key of the root is between @lo@ and @hi@.
+--------------------------------------------------------------------}
+trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
+trim cmplo cmphi Tip = Tip
+trim cmplo cmphi t@(Bin sx kx x l r)
+ = case cmplo kx of
+ LT -> case cmphi kx of
+ GT -> t
+ le -> trim cmplo cmphi l
+ ge -> trim cmplo cmphi r
+
+trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a)
+trimLookupLo lo cmphi Tip = (Nothing,Tip)
+trimLookupLo lo cmphi t@(Bin sx kx x l r)
+ = case compare lo kx of
+ LT -> case cmphi kx of
+ GT -> (lookup lo t, t)
+ le -> trimLookupLo lo cmphi l
+ GT -> trimLookupLo lo cmphi r
+ EQ -> (Just x,trim (compare lo) cmphi r)
+
+
+{--------------------------------------------------------------------
+ [filterGt k t] filter all keys >[k] from tree [t]
+ [filterLt k t] filter all keys <[k] from tree [t]
+--------------------------------------------------------------------}
+filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
+filterGt cmp Tip = Tip
+filterGt cmp (Bin sx kx x l r)
+ = case cmp kx of
+ LT -> join kx x (filterGt cmp l) r
+ GT -> filterGt cmp r
+ EQ -> r
+
+filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
+filterLt cmp Tip = Tip
+filterLt cmp (Bin sx kx x l r)
+ = case cmp kx of
+ LT -> filterLt cmp l
+ GT -> join kx x l (filterLt cmp r)
+ EQ -> l
+
+{--------------------------------------------------------------------
+ Split
+--------------------------------------------------------------------}
+-- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@ where
+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
+split :: Ord k => k -> Map k a -> (Map k a,Map k a)
+split k Tip = (Tip,Tip)
+split k (Bin sx kx x l r)
+ = case compare k kx of
+ LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
+ GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
+ EQ -> (l,r)
+
+-- | /O(log n)/. The expression (@splitLookup k map@) splits a map just
+-- like 'split' but also returns @lookup k map@.
+splitLookup :: Ord k => k -> Map k a -> (Maybe a,Map k a,Map k a)
+splitLookup k Tip = (Nothing,Tip,Tip)
+splitLookup k (Bin sx kx x l r)
+ = case compare k kx of
+ LT -> let (z,lt,gt) = splitLookup k l in (z,lt,join kx x gt r)
+ GT -> let (z,lt,gt) = splitLookup k r in (z,join kx x l lt,gt)
+ EQ -> (Just x,l,r)
+
+{--------------------------------------------------------------------
+ Utility functions that maintain the balance properties of the tree.
+ All constructors assume that all values in [l] < [k] and all values
+ in [r] > [k], and that [l] and [r] are valid trees.
+
+ In order of sophistication:
+ [Bin sz k x l r] The type constructor.
+ [bin k x l r] Maintains the correct size, assumes that both [l]
+ and [r] are balanced with respect to each other.
+ [balance k x l r] Restores the balance and size.
+ Assumes that the original tree was balanced and
+ that [l] or [r] has changed by at most one element.
+ [join k x l r] Restores balance and size.
+
+ Furthermore, we can construct a new tree from two trees. Both operations
+ assume that all values in [l] < all values in [r] and that [l] and [r]
+ are valid:
+ [glue l r] Glues [l] and [r] together. Assumes that [l] and
+ [r] are already balanced with respect to each other.
+ [merge l r] Merges two trees and restores balance.
+
+ Note: in contrast to Adam's paper, we use (<=) comparisons instead
+ of (<) comparisons in [join], [merge] and [balance].
+ Quickcheck (on [difference]) showed that this was necessary in order
+ to maintain the invariants. It is quite unsatisfactory that I haven't
+ been able to find out why this is actually the case! Fortunately, it
+ doesn't hurt to be a bit more conservative.
+--------------------------------------------------------------------}
+
+{--------------------------------------------------------------------
+ Join
+--------------------------------------------------------------------}
+join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
+join kx x Tip r = insertMin kx x r
+join kx x l Tip = insertMax kx x l
+join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
+ | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
+ | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
+ | otherwise = bin kx x l r
+
+
+-- insertMin and insertMax don't perform potentially expensive comparisons.
+insertMax,insertMin :: k -> a -> Map k a -> Map k a
+insertMax kx x t
+ = case t of
+ Tip -> singleton kx x
+ Bin sz ky y l r
+ -> balance ky y l (insertMax kx x r)
+
+insertMin kx x t
+ = case t of
+ Tip -> singleton kx x
+ Bin sz ky y l r
+ -> balance ky y (insertMin kx x l) r
+
+{--------------------------------------------------------------------
+ [merge l r]: merges two trees.
+--------------------------------------------------------------------}
+merge :: Map k a -> Map k a -> Map k a
+merge Tip r = r
+merge l Tip = l
+merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
+ | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
+ | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
+ | otherwise = glue l r
+
+{--------------------------------------------------------------------
+ [glue l r]: glues two trees together.
+ Assumes that [l] and [r] are already balanced with respect to each other.
+--------------------------------------------------------------------}
+glue :: Map k a -> Map k a -> Map k a
+glue Tip r = r
+glue l Tip = l
+glue l r
+ | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
+ | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
+
+
+-- | /O(log n)/. Delete and find the minimal element.
+deleteFindMin :: Map k a -> ((k,a),Map k a)
+deleteFindMin t
+ = case t of
+ Bin _ k x Tip r -> ((k,x),r)
+ Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
+ Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
+
+-- | /O(log n)/. Delete and find the maximal element.
+deleteFindMax :: Map k a -> ((k,a),Map k a)
+deleteFindMax t
+ = case t of
+ Bin _ k x l Tip -> ((k,x),l)
+ Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
+ Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
+
+
+{--------------------------------------------------------------------
+ [balance l x r] balances two trees with value x.
+ The sizes of the trees should balance after decreasing the
+ size of one of them. (a rotation).
+
+ [delta] is the maximal relative difference between the sizes of
+ two trees, it corresponds with the [w] in Adams' paper.
+ [ratio] is the ratio between an outer and inner sibling of the
+ heavier subtree in an unbalanced setting. It determines
+ whether a double or single rotation should be performed
+ to restore balance. It is correspondes with the inverse
+ of $\alpha$ in Adam's article.
+
+ Note that:
+ - [delta] should be larger than 4.646 with a [ratio] of 2.
+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.
+
+ - A lower [delta] leads to a more 'perfectly' balanced tree.
+ - A higher [delta] performs less rebalancing.
+
+ - Balancing is automaic for random data and a balancing
+ scheme is only necessary to avoid pathological worst cases.
+ Almost any choice will do, and in practice, a rather large
+ [delta] may perform better than smaller one.
+
+ Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
+ to decide whether a single or double rotation is needed. Allthough
+ he actually proves that this ratio is needed to maintain the
+ invariants, his implementation uses an invalid ratio of [1].
+--------------------------------------------------------------------}
+delta,ratio :: Int
+delta = 5
+ratio = 2
+
+balance :: k -> a -> Map k a -> Map k a -> Map k a
+balance k x l r
+ | sizeL + sizeR <= 1 = Bin sizeX k x l r
+ | sizeR >= delta*sizeL = rotateL k x l r
+ | sizeL >= delta*sizeR = rotateR k x l r
+ | otherwise = Bin sizeX k x l r
+ where
+ sizeL = size l
+ sizeR = size r
+ sizeX = sizeL + sizeR + 1
+
+-- rotate
+rotateL k x l r@(Bin _ _ _ ly ry)
+ | size ly < ratio*size ry = singleL k x l r
+ | otherwise = doubleL k x l r
+
+rotateR k x l@(Bin _ _ _ ly ry) r
+ | size ry < ratio*size ly = singleR k x l r
+ | otherwise = doubleR k x l r
+
+-- basic rotations
+singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
+singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
+
+doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)
+doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)
+
+
+{--------------------------------------------------------------------
+ The bin constructor maintains the size of the tree
+--------------------------------------------------------------------}
+bin :: k -> a -> Map k a -> Map k a -> Map k a
+bin k x l r
+ = Bin (size l + size r + 1) k x l r
+
+
+{--------------------------------------------------------------------
+ Eq converts the tree to a list. In a lazy setting, this
+ actually seems one of the faster methods to compare two trees
+ and it is certainly the simplest :-)
+--------------------------------------------------------------------}
+instance (Eq k,Eq a) => Eq (Map k a) where
+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
+
+{--------------------------------------------------------------------
+ Ord
+--------------------------------------------------------------------}
+
+instance (Ord k, Ord v) => Ord (Map k v) where
+ compare m1 m2 = compare (toList m1) (toList m2)
+
+{--------------------------------------------------------------------
+ Monoid
+--------------------------------------------------------------------}
+
+instance (Ord k) => Monoid (Map k v) where
+ mempty = empty
+ mappend = union
+ mconcat = unions
+
+{--------------------------------------------------------------------
+ Functor
+--------------------------------------------------------------------}
+instance Functor (Map k) where
+ fmap f m = map f m
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance (Show k, Show a) => Show (Map k a) where
+ showsPrec d m = showMap (toAscList m)
+
+showMap :: (Show k,Show a) => [(k,a)] -> ShowS
+showMap []
+ = showString "{}"
+showMap (x:xs)
+ = showChar '{' . showElem x . showTail xs
+ where
+ showTail [] = showChar '}'
+ showTail (x:xs) = showChar ',' . showElem x . showTail xs
+
+ showElem (k,x) = shows k . showString ":=" . shows x
+
+
+-- | /O(n)/. Show the tree that implements the map. The tree is shown
+-- in a compressed, hanging format.
+showTree :: (Show k,Show a) => Map k a -> String
+showTree m
+ = showTreeWith showElem True False m
+ where
+ showElem k x = show k ++ ":=" ++ show x
+
+
+{- | /O(n)/. The expression (@showTreeWith showelem hang wide map@) shows
+ the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
+ @wide@ is true, an extra wide version is shown.
+
+> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
+> (4,())
+> +--(2,())
+> | +--(1,())
+> | +--(3,())
+> +--(5,())
+>
+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
+> (4,())
+> |
+> +--(2,())
+> | |
+> | +--(1,())
+> | |
+> | +--(3,())
+> |
+> +--(5,())
+>
+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
+> +--(5,())
+> |
+> (4,())
+> |
+> | +--(3,())
+> | |
+> +--(2,())
+> |
+> +--(1,())
+
+-}
+showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
+showTreeWith showelem hang wide t
+ | hang = (showsTreeHang showelem wide [] t) ""
+ | otherwise = (showsTree showelem wide [] [] t) ""
+
+showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
+showsTree showelem wide lbars rbars t
+ = case t of
+ Tip -> showsBars lbars . showString "|\n"
+ Bin sz kx x Tip Tip
+ -> showsBars lbars . showString (showelem kx x) . showString "\n"
+ Bin sz kx x l r
+ -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . showString (showelem kx x) . showString "\n" .
+ showWide wide lbars .
+ showsTree showelem wide (withEmpty lbars) (withBar lbars) l
+
+showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
+showsTreeHang showelem wide bars t
+ = case t of
+ Tip -> showsBars bars . showString "|\n"
+ Bin sz kx x Tip Tip
+ -> showsBars bars . showString (showelem kx x) . showString "\n"
+ Bin sz kx x l r
+ -> showsBars bars . showString (showelem kx x) . showString "\n" .
+ showWide wide bars .
+ showsTreeHang showelem wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang showelem wide (withEmpty bars) r
+
+
+showWide wide bars
+ | wide = showString (concat (reverse bars)) . showString "|\n"
+ | otherwise = id
+
+showsBars :: [String] -> ShowS
+showsBars bars
+ = case bars of
+ [] -> id
+ _ -> showString (concat (reverse (tail bars))) . showString node
+
+node = "+--"
+withBar bars = "| ":bars
+withEmpty bars = " ":bars
+
+
+{--------------------------------------------------------------------
+ Assertions
+--------------------------------------------------------------------}
+-- | /O(n)/. Test if the internal map structure is valid.
+valid :: Ord k => Map k a -> Bool
+valid t
+ = balanced t && ordered t && validsize t
+
+ordered t
+ = bounded (const True) (const True) t
+ where
+ bounded lo hi t
+ = case t of
+ Tip -> True
+ Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
+
+-- | Exported only for "Debug.QuickCheck"
+balanced :: Map k a -> Bool
+balanced t
+ = case t of
+ Tip -> True
+ Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
+ balanced l && balanced r
+
+
+validsize t
+ = (realsize t == Just (size t))
+ where
+ realsize t
+ = case t of
+ Tip -> Just 0
+ Bin sz kx x l r -> case (realsize l,realsize r) of
+ (Just n,Just m) | n+m+1 == sz -> Just sz
+ other -> Nothing
+
+{--------------------------------------------------------------------
+ Utilities
+--------------------------------------------------------------------}
+foldlStrict f z xs
+ = case xs of
+ [] -> z
+ (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
+
+
+{-
+{--------------------------------------------------------------------
+ Testing
+--------------------------------------------------------------------}
+testTree xs = fromList [(x,"*") | x <- xs]
+test1 = testTree [1..20]
+test2 = testTree [30,29..10]
+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
+
+{--------------------------------------------------------------------
+ QuickCheck
+--------------------------------------------------------------------}
+qcheck prop
+ = check config prop
+ where
+ config = Config
+ { configMaxTest = 500
+ , configMaxFail = 5000
+ , configSize = \n -> (div n 2 + 3)
+ , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
+ }
+
+
+{--------------------------------------------------------------------
+ Arbitrary, reasonably balanced trees
+--------------------------------------------------------------------}
+instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where
+ arbitrary = sized (arbtree 0 maxkey)
+ where maxkey = 10000
+
+arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
+arbtree lo hi n
+ | n <= 0 = return Tip
+ | lo >= hi = return Tip
+ | otherwise = do{ x <- arbitrary
+ ; i <- choose (lo,hi)
+ ; m <- choose (1,30)
+ ; let (ml,mr) | m==(1::Int)= (1,2)
+ | m==2 = (2,1)
+ | m==3 = (1,1)
+ | otherwise = (2,2)
+ ; l <- arbtree lo (i-1) (n `div` ml)
+ ; r <- arbtree (i+1) hi (n `div` mr)
+ ; return (bin (toEnum i) x l r)
+ }
+
+
+{--------------------------------------------------------------------
+ Valid tree's
+--------------------------------------------------------------------}
+forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
+forValid f
+ = forAll arbitrary $ \t ->
+-- classify (balanced t) "balanced" $
+ classify (size t == 0) "empty" $
+ classify (size t > 0 && size t <= 10) "small" $
+ classify (size t > 10 && size t <= 64) "medium" $
+ classify (size t > 64) "large" $
+ balanced t ==> f t
+
+forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
+forValidIntTree f
+ = forValid f
+
+forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
+forValidUnitTree f
+ = forValid f
+
+
+prop_Valid
+ = forValidUnitTree $ \t -> valid t
+
+{--------------------------------------------------------------------
+ Single, Insert, Delete
+--------------------------------------------------------------------}
+prop_Single :: Int -> Int -> Bool
+prop_Single k x
+ = (insert k x empty == singleton k x)
+
+prop_InsertValid :: Int -> Property
+prop_InsertValid k
+ = forValidUnitTree $ \t -> valid (insert k () t)
+
+prop_InsertDelete :: Int -> Map Int () -> Property
+prop_InsertDelete k t
+ = (lookup k t == Nothing) ==> delete k (insert k () t) == t
+
+prop_DeleteValid :: Int -> Property
+prop_DeleteValid k
+ = forValidUnitTree $ \t ->
+ valid (delete k (insert k () t))
+
+{--------------------------------------------------------------------
+ Balance
+--------------------------------------------------------------------}
+prop_Join :: Int -> Property
+prop_Join k
+ = forValidUnitTree $ \t ->
+ let (l,r) = split k t
+ in valid (join k () l r)
+
+prop_Merge :: Int -> Property
+prop_Merge k
+ = forValidUnitTree $ \t ->
+ let (l,r) = split k t
+ in valid (merge l r)
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+prop_UnionValid :: Property
+prop_UnionValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (union t1 t2)
+
+prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
+prop_UnionInsert k x t
+ = union (singleton k x) t == insert k x t
+
+prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
+prop_UnionAssoc t1 t2 t3
+ = union t1 (union t2 t3) == union (union t1 t2) t3
+
+prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
+prop_UnionComm t1 t2
+ = (union t1 t2 == unionWith (\x y -> y) t2 t1)
+
+prop_UnionWithValid
+ = forValidIntTree $ \t1 ->
+ forValidIntTree $ \t2 ->
+ valid (unionWithKey (\k x y -> x+y) t1 t2)
+
+prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
+prop_UnionWith xs ys
+ = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))
+ == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
+
+prop_DiffValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (difference t1 t2)
+
+prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool
+prop_Diff xs ys
+ = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))
+ == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))
+
+prop_IntValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (intersection t1 t2)
+
+prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool
+prop_Int xs ys
+ = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))
+ == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+prop_Ordered
+ = forAll (choose (5,100)) $ \n ->
+ let xs = [(x,()) | x <- [0..n::Int]]
+ in fromAscList xs == fromList xs
+
+prop_List :: [Int] -> Bool
+prop_List xs
+ = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])
+-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Set
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- An implementation of sets, based on the "Data.FiniteMap".
---
------------------------------------------------------------------------------
+{-| Module : Data.Set
+ Copyright : (c) Daan Leijen 2002
+ License : BSD-style
+ Maintainer : libraries@haskell.org
+ Stability : provisional
+ Portability : portable
+
+ An efficient implementation of sets.
+
+ This module is intended to be imported @qualified@, to avoid name
+ clashes with Prelude functions. eg.
+
+ > import Data.Set as Set
+
+ The implementation of "Set" is based on /size balanced/ binary trees (or
+ trees of /bounded balance/) as described by:
+
+ * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional
+ Programming 3(4):553-562, October 1993, <http://www.swiss.ai.mit.edu/~adams/BB>.
+
+ * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\",
+ SIAM journal of computing 2(1), March 1973.
+
+ Note that the implementation is /left-biased/ -- the elements of a
+ first argument are always perferred to the second, for example in
+ 'union' or 'insert'. Of course, left-biasing can only be observed
+ when equality an equivalence relation instead of structural
+ equality.
+-}
+---------------------------------------------------------------------------------
+module Data.Set (
+ -- * Set type
+ Set -- instance Eq,Show
+
+ -- * Operators
+ , (\\)
-module Data.Set (
- -- * The @Set@ type
- Set, -- abstract, instance of: Eq
+ -- * Query
+ , null
+ , size
+ , member
+ , isSubsetOf
+ , isProperSubsetOf
+
+ -- * Construction
+ , empty
+ , singleton
+ , insert
+ , delete
+
+ -- * Combine
+ , union, unions
+ , difference
+ , intersection
+
+ -- * Filter
+ , filter
+ , partition
+ , split
+ , splitMember
- -- * Construction
- emptySet, -- :: Set a
+ -- * Map
+ , map
+ , mapMonotonic
+
+ -- * Fold
+ , fold
+
+ -- * Min\/Max
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+
+ -- * Conversion
+
+ -- ** List
+ , elems
+ , toList
+ , fromList
+
+ -- ** Ordered list
+ , toAscList
+ , fromAscList
+ , fromDistinctAscList
+
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ , valid
+
+ -- * Old interface, DEPRECATED
+ ,emptySet, -- :: Set a
mkSet, -- :: Ord a => [a] -> Set a
setToList, -- :: Set a -> [a]
unitSet, -- :: a -> Set a
-
- -- * Inspection
elementOf, -- :: Ord a => a -> Set a -> Bool
isEmptySet, -- :: Set a -> Bool
cardinality, -- :: Set a -> Int
-
- -- * Operations
- union, -- :: Ord a => Set a -> Set a -> Set a
unionManySets, -- :: Ord a => [Set a] -> Set a
minusSet, -- :: Ord a => Set a -> Set a -> Set a
mapSet, -- :: Ord a => (b -> a) -> Set b -> Set a
intersect, -- :: Ord a => Set a -> Set a -> Set a
addToSet, -- :: Ord a => Set a -> a -> Set a
delFromSet, -- :: Ord a => Set a -> a -> Set a
- ) where
+ ) where
-import Prelude
+import Prelude hiding (filter,foldr,foldl,null,map)
+import Data.Monoid
+import qualified Data.List as List
-import Data.FiniteMap
-import Data.Maybe
+{-
+-- just for testing
+import QuickCheck
+import List (nub,sort)
+import qualified List
+-}
--- This can't be a type synonym if you want to use constructor classes.
-newtype Set a = MkSet (FiniteMap a ())
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+infixl 9 \\ --
-emptySet :: Set a
-emptySet = MkSet emptyFM
+-- | /O(n+m)/. See 'difference'.
+(\\) :: Ord a => Set a -> Set a -> Set a
+m1 \\ m2 = difference m1 m2
-unitSet :: a -> Set a
-unitSet x = MkSet (unitFM x ())
+{--------------------------------------------------------------------
+ Sets are size balanced trees
+--------------------------------------------------------------------}
+-- | A set of values @a@.
+data Set a = Tip
+ | Bin {-# UNPACK #-} !Size a !(Set a) !(Set a)
-setToList :: Set a -> [a]
-setToList (MkSet set) = keysFM set
+type Size = Int
-mkSet :: Ord a => [a] -> Set a
-mkSet xs = MkSet (listToFM [ (x, ()) | x <- xs])
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is this the empty set?
+null :: Set a -> Bool
+null t
+ = case t of
+ Tip -> True
+ Bin sz x l r -> False
+-- | /O(1)/. The number of elements in the set.
+size :: Set a -> Int
+size t
+ = case t of
+ Tip -> 0
+ Bin sz x l r -> sz
+
+-- | /O(log n)/. Is the element in the set?
+member :: Ord a => a -> Set a -> Bool
+member x t
+ = case t of
+ Tip -> False
+ Bin sz y l r
+ -> case compare x y of
+ LT -> member x l
+ GT -> member x r
+ EQ -> True
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty set.
+empty :: Set a
+empty
+ = Tip
+
+-- | /O(1)/. Create a singleton set.
+singleton :: a -> Set a
+singleton x
+ = Bin 1 x Tip Tip
+
+{--------------------------------------------------------------------
+ Insertion, Deletion
+--------------------------------------------------------------------}
+-- | /O(log n)/. Insert an element in a set.
+insert :: Ord a => a -> Set a -> Set a
+insert x t
+ = case t of
+ Tip -> singleton x
+ Bin sz y l r
+ -> case compare x y of
+ LT -> balance y (insert x l) r
+ GT -> balance y l (insert x r)
+ EQ -> Bin sz x l r
+
+
+-- | /O(log n)/. Delete an element from a set.
+delete :: Ord a => a -> Set a -> Set a
+delete x t
+ = case t of
+ Tip -> Tip
+ Bin sz y l r
+ -> case compare x y of
+ LT -> balance y (delete x l) r
+ GT -> balance y l (delete x r)
+ EQ -> glue l r
+
+{--------------------------------------------------------------------
+ Subset
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
+isProperSubsetOf :: Ord a => Set a -> Set a -> Bool
+isProperSubsetOf s1 s2
+ = (size s1 < size s2) && (isSubsetOf s1 s2)
+
+
+-- | /O(n+m)/. Is this a subset?
+-- @(s1 `isSubsetOf` s2)@ tells whether s1 is a subset of s2.
+isSubsetOf :: Ord a => Set a -> Set a -> Bool
+isSubsetOf t1 t2
+ = (size t1 <= size t2) && (isSubsetOfX t1 t2)
+
+isSubsetOfX Tip t = True
+isSubsetOfX t Tip = False
+isSubsetOfX (Bin _ x l r) t
+ = found && isSubsetOfX l lt && isSubsetOfX r gt
+ where
+ (found,lt,gt) = splitMember x t
+
+
+{--------------------------------------------------------------------
+ Minimal, Maximal
+--------------------------------------------------------------------}
+-- | /O(log n)/. The minimal element of a set.
+findMin :: Set a -> a
+findMin (Bin _ x Tip r) = x
+findMin (Bin _ x l r) = findMin l
+findMin Tip = error "Set.findMin: empty set has no minimal element"
+
+-- | /O(log n)/. The maximal element of a set.
+findMax :: Set a -> a
+findMax (Bin _ x l Tip) = x
+findMax (Bin _ x l r) = findMax r
+findMax Tip = error "Set.findMax: empty set has no maximal element"
+
+-- | /O(log n)/. Delete the minimal element.
+deleteMin :: Set a -> Set a
+deleteMin (Bin _ x Tip r) = r
+deleteMin (Bin _ x l r) = balance x (deleteMin l) r
+deleteMin Tip = Tip
+
+-- | /O(log n)/. Delete the maximal element.
+deleteMax :: Set a -> Set a
+deleteMax (Bin _ x l Tip) = l
+deleteMax (Bin _ x l r) = balance x l (deleteMax r)
+deleteMax Tip = Tip
+
+
+{--------------------------------------------------------------------
+ Union.
+--------------------------------------------------------------------}
+-- | The union of a list of sets: (@unions == foldl union empty@).
+unions :: Ord a => [Set a] -> Set a
+unions ts
+ = foldlStrict union empty ts
+
+
+-- | /O(n+m)/. The union of two sets. Uses the efficient /hedge-union/ algorithm.
+-- Hedge-union is more efficient on (bigset `union` smallset).
union :: Ord a => Set a -> Set a -> Set a
-union (MkSet set1) (MkSet set2) = MkSet (plusFM set1 set2)
+union Tip t2 = t2
+union t1 Tip = t1
+union t1 t2
+ | size t1 >= size t2 = hedgeUnion (const LT) (const GT) t1 t2
+ | otherwise = hedgeUnion (const LT) (const GT) t2 t1
-unionManySets :: Ord a => [Set a] -> Set a
-unionManySets ss = foldr union emptySet ss
+hedgeUnion cmplo cmphi t1 Tip
+ = t1
+hedgeUnion cmplo cmphi Tip (Bin _ x l r)
+ = join x (filterGt cmplo l) (filterLt cmphi r)
+hedgeUnion cmplo cmphi (Bin _ x l r) t2
+ = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2))
+ (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2))
+ where
+ cmpx y = compare x y
-minusSet :: Ord a => Set a -> Set a -> Set a
-minusSet (MkSet set1) (MkSet set2) = MkSet (minusFM set1 set2)
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Difference of two sets.
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+difference :: Ord a => Set a -> Set a -> Set a
+difference Tip t2 = Tip
+difference t1 Tip = t1
+difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
-intersect :: Ord a => Set a -> Set a -> Set a
-intersect (MkSet set1) (MkSet set2) = MkSet (intersectFM set1 set2)
+hedgeDiff cmplo cmphi Tip t
+ = Tip
+hedgeDiff cmplo cmphi (Bin _ x l r) Tip
+ = join x (filterGt cmplo l) (filterLt cmphi r)
+hedgeDiff cmplo cmphi t (Bin _ x l r)
+ = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l)
+ (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r)
+ where
+ cmpx y = compare x y
-addToSet :: Ord a => Set a -> a -> Set a
-addToSet (MkSet set) a = MkSet (addToFM set a ())
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | /O(n+m)/. The intersection of two sets.
+-- Intersection is more efficient on (bigset `intersection` smallset).
+intersection :: Ord a => Set a -> Set a -> Set a
+intersection Tip t = Tip
+intersection t Tip = Tip
+intersection t1 t2
+ | size t1 >= size t2 = intersect' t1 t2
+ | otherwise = intersect' t2 t1
-delFromSet :: Ord a => Set a -> a -> Set a
-delFromSet (MkSet set) a = MkSet (delFromFM set a)
+intersect' Tip t = Tip
+intersect' t Tip = Tip
+intersect' t (Bin _ x l r)
+ | found = join x tl tr
+ | otherwise = merge tl tr
+ where
+ (found,lt,gt) = splitMember x t
+ tl = intersect' lt l
+ tr = intersect' gt r
+
+
+{--------------------------------------------------------------------
+ Filter and partition
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all elements that satisfy the predicate.
+filter :: Ord a => (a -> Bool) -> Set a -> Set a
+filter p Tip = Tip
+filter p (Bin _ x l r)
+ | p x = join x (filter p l) (filter p r)
+ | otherwise = merge (filter p l) (filter p r)
+
+-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
+-- the predicate and one with all elements that don't satisfy the predicate.
+-- See also 'split'.
+partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a)
+partition p Tip = (Tip,Tip)
+partition p (Bin _ x l r)
+ | p x = (join x l1 r1,merge l2 r2)
+ | otherwise = (merge l1 r1,join x l2 r2)
+ where
+ (l1,l2) = partition p l
+ (r1,r2) = partition p r
+
+{----------------------------------------------------------------------
+ Map
+----------------------------------------------------------------------}
+
+-- | /O(n*log n)/.
+-- @map f s@ is the set obtained by applying @f@ to each element of @s@.
+--
+-- It's worth noting that the size of the result may be smaller if,
+-- for some @(x,y)@, @x \/= y && f x == f y@
+
+map :: (Ord a, Ord b) => (a->b) -> Set a -> Set b
+map f = fromList . List.map f . toList
+
+-- | /O(n)/. The
+--
+-- @mapMonotonic f s == 'map' f s@, but works only when @f@ is monotonic.
+-- /The precondition is not checked./
+-- Semi-formally, we have:
+--
+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]
+-- > ==> mapMonotonic f s == map f s
+-- > where ls = toList s
+
+mapMonotonic :: (a->b) -> Set a -> Set b
+mapMonotonic f Tip = Tip
+mapMonotonic f (Bin sz x l r) =
+ Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)
+
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+-- | /O(n)/. Fold over the elements of a set in an unspecified order.
+fold :: (a -> b -> b) -> b -> Set a -> b
+fold f z s
+ = foldr f z s
+
+-- | /O(n)/. Post-order fold.
+foldr :: (a -> b -> b) -> b -> Set a -> b
+foldr f z Tip = z
+foldr f z (Bin _ x l r) = foldr f (f x (foldr f z r)) l
+
+{--------------------------------------------------------------------
+ List variations
+--------------------------------------------------------------------}
+-- | /O(n)/. The elements of a set.
+elems :: Set a -> [a]
+elems s
+ = toList s
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+-- | /O(n)/. Convert the set to an ascending list of elements.
+toList :: Set a -> [a]
+toList s
+ = toAscList s
+
+-- | /O(n)/. Convert the set to an ascending list of elements.
+toAscList :: Set a -> [a]
+toAscList t
+ = foldr (:) [] t
+
+
+-- | /O(n*log n)/. Create a set from a list of elements.
+fromList :: Ord a => [a] -> Set a
+fromList xs
+ = foldlStrict ins empty xs
+ where
+ ins t x = insert x t
+
+{--------------------------------------------------------------------
+ Building trees from ascending/descending lists can be done in linear time.
+
+ Note that if [xs] is ascending that:
+ fromAscList xs == fromList xs
+--------------------------------------------------------------------}
+-- | /O(n)/. Build a set from an ascending list in linear time.
+-- /The precondition (input list is ascending) is not checked./
+fromAscList :: Eq a => [a] -> Set a
+fromAscList xs
+ = fromDistinctAscList (combineEq xs)
+ where
+ -- [combineEq xs] combines equal elements with [const] in an ordered list [xs]
+ combineEq xs
+ = case xs of
+ [] -> []
+ [x] -> [x]
+ (x:xx) -> combineEq' x xx
+
+ combineEq' z [] = [z]
+ combineEq' z (x:xs)
+ | z==x = combineEq' z xs
+ | otherwise = z:combineEq' x xs
+
+
+-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.
+-- /The precondition (input list is strictly ascending) is not checked./
+fromDistinctAscList :: [a] -> Set a
+fromDistinctAscList xs
+ = build const (length xs) xs
+ where
+ -- 1) use continutations so that we use heap space instead of stack space.
+ -- 2) special case for n==5 to build bushier trees.
+ build c 0 xs = c Tip xs
+ build c 5 xs = case xs of
+ (x1:x2:x3:x4:x5:xx)
+ -> c (bin x4 (bin x2 (singleton x1) (singleton x3)) (singleton x5)) xx
+ build c n xs = seq nr $ build (buildR nr c) nl xs
+ where
+ nl = n `div` 2
+ nr = n - nl - 1
+
+ buildR n c l (x:ys) = build (buildB l x c) n ys
+ buildB l x c r zs = c (bin x l r) zs
+
+{--------------------------------------------------------------------
+ Eq converts the set to a list. In a lazy setting, this
+ actually seems one of the faster methods to compare two trees
+ and it is certainly the simplest :-)
+--------------------------------------------------------------------}
+instance Eq a => Eq (Set a) where
+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
+
+{--------------------------------------------------------------------
+ Ord
+--------------------------------------------------------------------}
+
+instance Ord a => Ord (Set a) where
+ compare s1 s2 = compare (toAscList s1) (toAscList s2)
+
+{--------------------------------------------------------------------
+ Monoid
+--------------------------------------------------------------------}
+
+instance Ord a => Monoid (Set a) where
+ mempty = empty
+ mappend = union
+ mconcat = unions
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance Show a => Show (Set a) where
+ showsPrec d s = showSet (toAscList s)
+
+showSet :: (Show a) => [a] -> ShowS
+showSet []
+ = showString "{}"
+showSet (x:xs)
+ = showChar '{' . shows x . showTail xs
+ where
+ showTail [] = showChar '}'
+ showTail (x:xs) = showChar ',' . shows x . showTail xs
+
+
+{--------------------------------------------------------------------
+ Utility functions that return sub-ranges of the original
+ tree. Some functions take a comparison function as argument to
+ allow comparisons against infinite values. A function [cmplo x]
+ should be read as [compare lo x].
+
+ [trim cmplo cmphi t] A tree that is either empty or where [cmplo x == LT]
+ and [cmphi x == GT] for the value [x] of the root.
+ [filterGt cmp t] A tree where for all values [k]. [cmp k == LT]
+ [filterLt cmp t] A tree where for all values [k]. [cmp k == GT]
+
+ [split k t] Returns two trees [l] and [r] where all values
+ in [l] are <[k] and all keys in [r] are >[k].
+ [splitMember k t] Just like [split] but also returns whether [k]
+ was found in the tree.
+--------------------------------------------------------------------}
+
+{--------------------------------------------------------------------
+ [trim lo hi t] trims away all subtrees that surely contain no
+ values between the range [lo] to [hi]. The returned tree is either
+ empty or the key of the root is between @lo@ and @hi@.
+--------------------------------------------------------------------}
+trim :: (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a
+trim cmplo cmphi Tip = Tip
+trim cmplo cmphi t@(Bin sx x l r)
+ = case cmplo x of
+ LT -> case cmphi x of
+ GT -> t
+ le -> trim cmplo cmphi l
+ ge -> trim cmplo cmphi r
+
+trimMemberLo :: Ord a => a -> (a -> Ordering) -> Set a -> (Bool, Set a)
+trimMemberLo lo cmphi Tip = (False,Tip)
+trimMemberLo lo cmphi t@(Bin sx x l r)
+ = case compare lo x of
+ LT -> case cmphi x of
+ GT -> (member lo t, t)
+ le -> trimMemberLo lo cmphi l
+ GT -> trimMemberLo lo cmphi r
+ EQ -> (True,trim (compare lo) cmphi r)
+
+
+{--------------------------------------------------------------------
+ [filterGt x t] filter all values >[x] from tree [t]
+ [filterLt x t] filter all values <[x] from tree [t]
+--------------------------------------------------------------------}
+filterGt :: (a -> Ordering) -> Set a -> Set a
+filterGt cmp Tip = Tip
+filterGt cmp (Bin sx x l r)
+ = case cmp x of
+ LT -> join x (filterGt cmp l) r
+ GT -> filterGt cmp r
+ EQ -> r
+
+filterLt :: (a -> Ordering) -> Set a -> Set a
+filterLt cmp Tip = Tip
+filterLt cmp (Bin sx x l r)
+ = case cmp x of
+ LT -> filterLt cmp l
+ GT -> join x l (filterLt cmp r)
+ EQ -> l
+
+
+{--------------------------------------------------------------------
+ Split
+--------------------------------------------------------------------}
+-- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@
+-- where all elements in @set1@ are lower than @x@ and all elements in
+-- @set2@ larger than @x@. @x@ is not found in neither @set1@ nor @set2@.
+split :: Ord a => a -> Set a -> (Set a,Set a)
+split x Tip = (Tip,Tip)
+split x (Bin sy y l r)
+ = case compare x y of
+ LT -> let (lt,gt) = split x l in (lt,join y gt r)
+ GT -> let (lt,gt) = split x r in (join y l lt,gt)
+ EQ -> (l,r)
+
+-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
+-- element was found in the original set.
+splitMember :: Ord a => a -> Set a -> (Bool,Set a,Set a)
+splitMember x Tip = (False,Tip,Tip)
+splitMember x (Bin sy y l r)
+ = case compare x y of
+ LT -> let (found,lt,gt) = splitMember x l in (found,lt,join y gt r)
+ GT -> let (found,lt,gt) = splitMember x r in (found,join y l lt,gt)
+ EQ -> (True,l,r)
+
+{--------------------------------------------------------------------
+ Utility functions that maintain the balance properties of the tree.
+ All constructors assume that all values in [l] < [x] and all values
+ in [r] > [x], and that [l] and [r] are valid trees.
+
+ In order of sophistication:
+ [Bin sz x l r] The type constructor.
+ [bin x l r] Maintains the correct size, assumes that both [l]
+ and [r] are balanced with respect to each other.
+ [balance x l r] Restores the balance and size.
+ Assumes that the original tree was balanced and
+ that [l] or [r] has changed by at most one element.
+ [join x l r] Restores balance and size.
+
+ Furthermore, we can construct a new tree from two trees. Both operations
+ assume that all values in [l] < all values in [r] and that [l] and [r]
+ are valid:
+ [glue l r] Glues [l] and [r] together. Assumes that [l] and
+ [r] are already balanced with respect to each other.
+ [merge l r] Merges two trees and restores balance.
+
+ Note: in contrast to Adam's paper, we use (<=) comparisons instead
+ of (<) comparisons in [join], [merge] and [balance].
+ Quickcheck (on [difference]) showed that this was necessary in order
+ to maintain the invariants. It is quite unsatisfactory that I haven't
+ been able to find out why this is actually the case! Fortunately, it
+ doesn't hurt to be a bit more conservative.
+--------------------------------------------------------------------}
+
+{--------------------------------------------------------------------
+ Join
+--------------------------------------------------------------------}
+join :: a -> Set a -> Set a -> Set a
+join x Tip r = insertMin x r
+join x l Tip = insertMax x l
+join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)
+ | delta*sizeL <= sizeR = balance z (join x l lz) rz
+ | delta*sizeR <= sizeL = balance y ly (join x ry r)
+ | otherwise = bin x l r
+
+-- insertMin and insertMax don't perform potentially expensive comparisons.
+insertMax,insertMin :: a -> Set a -> Set a
+insertMax x t
+ = case t of
+ Tip -> singleton x
+ Bin sz y l r
+ -> balance y l (insertMax x r)
+
+insertMin x t
+ = case t of
+ Tip -> singleton x
+ Bin sz y l r
+ -> balance y (insertMin x l) r
+
+{--------------------------------------------------------------------
+ [merge l r]: merges two trees.
+--------------------------------------------------------------------}
+merge :: Set a -> Set a -> Set a
+merge Tip r = r
+merge l Tip = l
+merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
+ | delta*sizeL <= sizeR = balance y (merge l ly) ry
+ | delta*sizeR <= sizeL = balance x lx (merge rx r)
+ | otherwise = glue l r
+
+{--------------------------------------------------------------------
+ [glue l r]: glues two trees together.
+ Assumes that [l] and [r] are already balanced with respect to each other.
+--------------------------------------------------------------------}
+glue :: Set a -> Set a -> Set a
+glue Tip r = r
+glue l Tip = l
+glue l r
+ | size l > size r = let (m,l') = deleteFindMax l in balance m l' r
+ | otherwise = let (m,r') = deleteFindMin r in balance m l r'
+
+
+-- | /O(log n)/. Delete and find the minimal element.
+--
+-- > deleteFindMin set = (findMin set, deleteMin set)
+
+deleteFindMin :: Set a -> (a,Set a)
+deleteFindMin t
+ = case t of
+ Bin _ x Tip r -> (x,r)
+ Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balance x l' r)
+ Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)
+
+-- | /O(log n)/. Delete and find the maximal element.
+--
+-- > deleteFindMax set = (findMax set, deleteMax set)
+deleteFindMax :: Set a -> (a,Set a)
+deleteFindMax t
+ = case t of
+ Bin _ x l Tip -> (x,l)
+ Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balance x l r')
+ Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)
+
+
+{--------------------------------------------------------------------
+ [balance x l r] balances two trees with value x.
+ The sizes of the trees should balance after decreasing the
+ size of one of them. (a rotation).
+
+ [delta] is the maximal relative difference between the sizes of
+ two trees, it corresponds with the [w] in Adams' paper,
+ or equivalently, [1/delta] corresponds with the $\alpha$
+ in Nievergelt's paper. Adams shows that [delta] should
+ be larger than 3.745 in order to garantee that the
+ rotations can always restore balance.
+
+ [ratio] is the ratio between an outer and inner sibling of the
+ heavier subtree in an unbalanced setting. It determines
+ whether a double or single rotation should be performed
+ to restore balance. It is correspondes with the inverse
+ of $\alpha$ in Adam's article.
+
+ Note that:
+ - [delta] should be larger than 4.646 with a [ratio] of 2.
+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.
+
+ - A lower [delta] leads to a more 'perfectly' balanced tree.
+ - A higher [delta] performs less rebalancing.
+
+ - Balancing is automatic for random data and a balancing
+ scheme is only necessary to avoid pathological worst cases.
+ Almost any choice will do in practice
+
+ - Allthough it seems that a rather large [delta] may perform better
+ than smaller one, measurements have shown that the smallest [delta]
+ of 4 is actually the fastest on a wide range of operations. It
+ especially improves performance on worst-case scenarios like
+ a sequence of ordered insertions.
+
+ Note: in contrast to Adams' paper, we use a ratio of (at least) 2
+ to decide whether a single or double rotation is needed. Allthough
+ he actually proves that this ratio is needed to maintain the
+ invariants, his implementation uses a (invalid) ratio of 1.
+ He is aware of the problem though since he has put a comment in his
+ original source code that he doesn't care about generating a
+ slightly inbalanced tree since it doesn't seem to matter in practice.
+ However (since we use quickcheck :-) we will stick to strictly balanced
+ trees.
+--------------------------------------------------------------------}
+delta,ratio :: Int
+delta = 4
+ratio = 2
+
+balance :: a -> Set a -> Set a -> Set a
+balance x l r
+ | sizeL + sizeR <= 1 = Bin sizeX x l r
+ | sizeR >= delta*sizeL = rotateL x l r
+ | sizeL >= delta*sizeR = rotateR x l r
+ | otherwise = Bin sizeX x l r
+ where
+ sizeL = size l
+ sizeR = size r
+ sizeX = sizeL + sizeR + 1
+
+-- rotate
+rotateL x l r@(Bin _ _ ly ry)
+ | size ly < ratio*size ry = singleL x l r
+ | otherwise = doubleL x l r
+
+rotateR x l@(Bin _ _ ly ry) r
+ | size ry < ratio*size ly = singleR x l r
+ | otherwise = doubleR x l r
+
+-- basic rotations
+singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3
+singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)
+
+doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
+doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
+
+
+{--------------------------------------------------------------------
+ The bin constructor maintains the size of the tree
+--------------------------------------------------------------------}
+bin :: a -> Set a -> Set a -> Set a
+bin x l r
+ = Bin (size l + size r + 1) x l r
+
+
+{--------------------------------------------------------------------
+ Utilities
+--------------------------------------------------------------------}
+foldlStrict f z xs
+ = case xs of
+ [] -> z
+ (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
+
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+-- | /O(n)/. Show the tree that implements the set. The tree is shown
+-- in a compressed, hanging format.
+showTree :: Show a => Set a -> String
+showTree s
+ = showTreeWith True False s
+
+
+{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
+ the tree that implements the set. If @hang@ is
+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
+ @wide@ is true, an extra wide version is shown.
+
+> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]
+> 4
+> +--2
+> | +--1
+> | +--3
+> +--5
+>
+> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]
+> 4
+> |
+> +--2
+> | |
+> | +--1
+> | |
+> | +--3
+> |
+> +--5
+>
+> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]
+> +--5
+> |
+> 4
+> |
+> | +--3
+> | |
+> +--2
+> |
+> +--1
+
+-}
+showTreeWith :: Show a => Bool -> Bool -> Set a -> String
+showTreeWith hang wide t
+ | hang = (showsTreeHang wide [] t) ""
+ | otherwise = (showsTree wide [] [] t) ""
+
+showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS
+showsTree wide lbars rbars t
+ = case t of
+ Tip -> showsBars lbars . showString "|\n"
+ Bin sz x Tip Tip
+ -> showsBars lbars . shows x . showString "\n"
+ Bin sz x l r
+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . shows x . showString "\n" .
+ showWide wide lbars .
+ showsTree wide (withEmpty lbars) (withBar lbars) l
+
+showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS
+showsTreeHang wide bars t
+ = case t of
+ Tip -> showsBars bars . showString "|\n"
+ Bin sz x Tip Tip
+ -> showsBars bars . shows x . showString "\n"
+ Bin sz x l r
+ -> showsBars bars . shows x . showString "\n" .
+ showWide wide bars .
+ showsTreeHang wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang wide (withEmpty bars) r
+
+
+showWide wide bars
+ | wide = showString (concat (reverse bars)) . showString "|\n"
+ | otherwise = id
+
+showsBars :: [String] -> ShowS
+showsBars bars
+ = case bars of
+ [] -> id
+ _ -> showString (concat (reverse (tail bars))) . showString node
+
+node = "+--"
+withBar bars = "| ":bars
+withEmpty bars = " ":bars
+
+{--------------------------------------------------------------------
+ Assertions
+--------------------------------------------------------------------}
+-- | /O(n)/. Test if the internal set structure is valid.
+valid :: Ord a => Set a -> Bool
+valid t
+ = balanced t && ordered t && validsize t
+
+ordered t
+ = bounded (const True) (const True) t
+ where
+ bounded lo hi t
+ = case t of
+ Tip -> True
+ Bin sz x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r
+
+balanced :: Set a -> Bool
+balanced t
+ = case t of
+ Tip -> True
+ Bin sz x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
+ balanced l && balanced r
+
+
+validsize t
+ = (realsize t == Just (size t))
+ where
+ realsize t
+ = case t of
+ Tip -> Just 0
+ Bin sz x l r -> case (realsize l,realsize r) of
+ (Just n,Just m) | n+m+1 == sz -> Just sz
+ other -> Nothing
+
+{-
+{--------------------------------------------------------------------
+ Testing
+--------------------------------------------------------------------}
+testTree :: [Int] -> Set Int
+testTree xs = fromList xs
+test1 = testTree [1..20]
+test2 = testTree [30,29..10]
+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]
+
+{--------------------------------------------------------------------
+ QuickCheck
+--------------------------------------------------------------------}
+qcheck prop
+ = check config prop
+ where
+ config = Config
+ { configMaxTest = 500
+ , configMaxFail = 5000
+ , configSize = \n -> (div n 2 + 3)
+ , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
+ }
+
+
+{--------------------------------------------------------------------
+ Arbitrary, reasonably balanced trees
+--------------------------------------------------------------------}
+instance (Enum a) => Arbitrary (Set a) where
+ arbitrary = sized (arbtree 0 maxkey)
+ where maxkey = 10000
+
+arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)
+arbtree lo hi n
+ | n <= 0 = return Tip
+ | lo >= hi = return Tip
+ | otherwise = do{ i <- choose (lo,hi)
+ ; m <- choose (1,30)
+ ; let (ml,mr) | m==(1::Int)= (1,2)
+ | m==2 = (2,1)
+ | m==3 = (1,1)
+ | otherwise = (2,2)
+ ; l <- arbtree lo (i-1) (n `div` ml)
+ ; r <- arbtree (i+1) hi (n `div` mr)
+ ; return (bin (toEnum i) l r)
+ }
+
+
+{--------------------------------------------------------------------
+ Valid tree's
+--------------------------------------------------------------------}
+forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property
+forValid f
+ = forAll arbitrary $ \t ->
+-- classify (balanced t) "balanced" $
+ classify (size t == 0) "empty" $
+ classify (size t > 0 && size t <= 10) "small" $
+ classify (size t > 10 && size t <= 64) "medium" $
+ classify (size t > 64) "large" $
+ balanced t ==> f t
+
+forValidIntTree :: Testable a => (Set Int -> a) -> Property
+forValidIntTree f
+ = forValid f
+
+forValidUnitTree :: Testable a => (Set Int -> a) -> Property
+forValidUnitTree f
+ = forValid f
+
+
+prop_Valid
+ = forValidUnitTree $ \t -> valid t
+
+{--------------------------------------------------------------------
+ Single, Insert, Delete
+--------------------------------------------------------------------}
+prop_Single :: Int -> Bool
+prop_Single x
+ = (insert x empty == singleton x)
+
+prop_InsertValid :: Int -> Property
+prop_InsertValid k
+ = forValidUnitTree $ \t -> valid (insert k t)
+
+prop_InsertDelete :: Int -> Set Int -> Property
+prop_InsertDelete k t
+ = not (member k t) ==> delete k (insert k t) == t
+
+prop_DeleteValid :: Int -> Property
+prop_DeleteValid k
+ = forValidUnitTree $ \t ->
+ valid (delete k (insert k t))
+
+{--------------------------------------------------------------------
+ Balance
+--------------------------------------------------------------------}
+prop_Join :: Int -> Property
+prop_Join x
+ = forValidUnitTree $ \t ->
+ let (l,r) = split x t
+ in valid (join x l r)
+
+prop_Merge :: Int -> Property
+prop_Merge x
+ = forValidUnitTree $ \t ->
+ let (l,r) = split x t
+ in valid (merge l r)
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+prop_UnionValid :: Property
+prop_UnionValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (union t1 t2)
+
+prop_UnionInsert :: Int -> Set Int -> Bool
+prop_UnionInsert x t
+ = union t (singleton x) == insert x t
+
+prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
+prop_UnionAssoc t1 t2 t3
+ = union t1 (union t2 t3) == union (union t1 t2) t3
+
+prop_UnionComm :: Set Int -> Set Int -> Bool
+prop_UnionComm t1 t2
+ = (union t1 t2 == union t2 t1)
+
+
+prop_DiffValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (difference t1 t2)
+
+prop_Diff :: [Int] -> [Int] -> Bool
+prop_Diff xs ys
+ = toAscList (difference (fromList xs) (fromList ys))
+ == List.sort ((List.\\) (nub xs) (nub ys))
+
+prop_IntValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (intersection t1 t2)
+
+prop_Int :: [Int] -> [Int] -> Bool
+prop_Int xs ys
+ = toAscList (intersection (fromList xs) (fromList ys))
+ == List.sort (nub ((List.intersect) (xs) (ys)))
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+prop_Ordered
+ = forAll (choose (5,100)) $ \n ->
+ let xs = [0..n::Int]
+ in fromAscList xs == fromList xs
+
+prop_List :: [Int] -> Bool
+prop_List xs
+ = (sort (nub xs) == toList (fromList xs))
+-}
+
+{--------------------------------------------------------------------
+ Old Data.Set compatibility interface
+--------------------------------------------------------------------}
+
+{-# DEPRECATED emptySet "Use empty instead" #-}
+emptySet :: Set a
+emptySet = empty
+
+{-# DEPRECATED mkSet "Equivalent to 'foldl insert empty'." #-}
+mkSet :: Ord a => [a] -> Set a
+mkSet = List.foldl' (flip insert) empty
+
+{-# DEPRECATED setToList "Use instead." #-}
+setToList :: Set a -> [a]
+setToList = elems
+
+{-# DEPRECATED unitSet "Use singleton instead." #-}
+unitSet :: a -> Set a
+unitSet = singleton
+
+{-# DEPRECATED elementOf "Use member instead." #-}
elementOf :: Ord a => a -> Set a -> Bool
-elementOf x (MkSet set) = isJust (lookupFM set x)
+elementOf = member
+{-# DEPRECATED isEmptySet "Use null instead." #-}
isEmptySet :: Set a -> Bool
-isEmptySet (MkSet set) = sizeFM set == 0
-
-mapSet :: Ord a => (b -> a) -> Set b -> Set a
-mapSet f (MkSet set) = MkSet (listToFM [ (f key, ()) | key <- keysFM set ])
+isEmptySet = null
+{-# DEPRECATED cardinality "Use size instead." #-}
cardinality :: Set a -> Int
-cardinality (MkSet set) = sizeFM set
+cardinality = size
--- fair enough...
-instance (Eq a) => Eq (Set a) where
- (MkSet set_1) == (MkSet set_2) = set_1 == set_2
- (MkSet set_1) /= (MkSet set_2) = set_1 /= set_2
+{-# DEPRECATED unionManySets "Use unions instead." #-}
+unionManySets :: Ord a => [Set a] -> Set a
+unionManySets = unions
-instance Show e => Show (Set e) where
- showsPrec p s = showsPrec p (setToList s)
+{-# DEPRECATED minusSet "Use difference instead." #-}
+minusSet :: Ord a => Set a -> Set a -> Set a
+minusSet = difference
--- but not so clear what the right thing to do is:
-{- NO:
-instance (Ord a) => Ord (Set a) where
- (MkSet set_1) <= (MkSet set_2) = set_1 <= set_2
--}
+{-# DEPRECATED mapSet "Use map instead." #-}
+mapSet :: (Ord a, Ord b) => (b -> a) -> Set b -> Set a
+mapSet = map
+
+{-# DEPRECATED intersect "Use intersection instead." #-}
+intersect :: Ord a => Set a -> Set a -> Set a
+intersect = intersection
+
+{-# DEPRECATED addToSet "Use insert instead." #-}
+addToSet :: Ord a => Set a -> a -> Set a
+addToSet = flip insert
+
+{-# DEPRECATED delFromSet "Use delete instead." #-}
+delFromSet :: Ord a => Set a -> a -> Set a
+delFromSet = flip delete
Data.HashTable,
Data.IORef,
Data.Int,
+ Data.IntMap,
+ Data.IntSet,
Data.Ix,
Data.List,
Data.Maybe,
+ Data.Map,
Data.Monoid,
Data.PackedString,
Data.Queue,
projects / ghc-base.git / commitdiff