From bbbba97cbcf12039810533e3a2daf2eefdefe7f0 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 13 Jan 2005 10:37:38 +0000 Subject: [PATCH] [project @ 2005-01-13 10:37:35 by simonmar] Add Data.Map, Data.Set, Data.IntMap and Data.IntSet from Daan Leijen's DData library, with some modifications by JP Bernardy and others on the libraries@haskell.org list. Minor changes by me to remove the last references to DData, and add a DEPRECATED copy of the old Data.Set interface to the new Data.Set. Data.FiniteMap is now DEPRECATED. --- Data/FiniteMap.hs | 6 +- Data/IntMap.hs | 1275 ++++++++++++++++++++++++++++++++++++++++++ Data/IntSet.hs | 882 +++++++++++++++++++++++++++++ Data/Map.hs | 1589 +++++++++++++++++++++++++++++++++++++++++++++++++++++ Data/Set.hs | 1157 +++++++++++++++++++++++++++++++++++--- package.conf.in | 3 + 6 files changed, 4846 insertions(+), 66 deletions(-) create mode 100644 Data/IntMap.hs create mode 100644 Data/IntSet.hs create mode 100644 Data/Map.hs diff --git a/Data/FiniteMap.hs b/Data/FiniteMap.hs index 3f3fd04..f8d0826 100644 --- a/Data/FiniteMap.hs +++ b/Data/FiniteMap.hs @@ -8,6 +8,8 @@ -- 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 @@ -38,7 +40,9 @@ #define OUTPUTABLE_key {--} #endif -module Data.FiniteMap ( +module Data.FiniteMap + {-# DEPRECATED "Please use Data.Map instead." #-} + ( -- * The @FiniteMap@ type FiniteMap, -- abstract type diff --git a/Data/IntMap.hs b/Data/IntMap.hs new file mode 100644 index 0000000..2562c2e --- /dev/null +++ b/Data/IntMap.hs @@ -0,0 +1,1275 @@ +{-# 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, + + * 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 (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 (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])]) +-} diff --git a/Data/IntSet.hs b/Data/IntSet.hs new file mode 100644 index 0000000..7c66dbb --- /dev/null +++ b/Data/IntSet.hs @@ -0,0 +1,882 @@ +{-# 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, + + * 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 (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 (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)) +-} diff --git a/Data/Map.hs b/Data/Map.hs new file mode 100644 index 0000000..e2dd0b6 --- /dev/null +++ b/Data/Map.hs @@ -0,0 +1,1589 @@ +-------------------------------------------------------------------------------- +{-| 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, . + + * 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) 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])]) +-} diff --git a/Data/Set.hs b/Data/Set.hs index 3c81002..e515667 100644 --- a/Data/Set.hs +++ b/Data/Set.hs @@ -1,102 +1,1129 @@ ------------------------------------------------------------------------------ --- | --- 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, . + + * 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) 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 diff --git a/package.conf.in b/package.conf.in index a05185a..2ddecaf 100644 --- a/package.conf.in +++ b/package.conf.in @@ -50,9 +50,12 @@ exposed-modules: Data.HashTable, Data.IORef, Data.Int, + Data.IntMap, + Data.IntSet, Data.Ix, Data.List, Data.Maybe, + Data.Map, Data.Monoid, Data.PackedString, Data.Queue, -- 1.7.10.4