diff --git a/src/UU/DData/IntBag.hs b/src/UU/DData/IntBag.hs deleted file mode 100644 --- a/src/UU/DData/IntBag.hs +++ /dev/null @@ -1,368 +0,0 @@ --------------------------------------------------------------------------------- -{-| Module : IntBag - Copyright : (c) Daan Leijen 2002 - License : BSD-style - - Maintainer : daan@cs.uu.nl - Stability : provisional - Portability : portable - - An efficient implementation of bags of integers on top of the "IntMap" module. - - 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). For more information, see - the references in the "IntMap" module. --} ----------------------------------------------------------------------------------} -module UU.DData.IntBag ( - -- * Bag type - IntBag -- instance Eq,Show - - -- * Operators - , (\\) - - -- *Query - , isEmpty - , size - , distinctSize - , member - , occur - - , subset - , properSubset - - -- * Construction - , empty - , single - , insert - , insertMany - , delete - , deleteAll - - -- * Combine - , union - , difference - , intersection - , unions - - -- * Filter - , filter - , partition - - -- * Fold - , fold - , foldOccur - - -- * Conversion - , elems - - -- ** List - , toList - , fromList - - -- ** Ordered list - , toAscList - , fromAscList - , fromDistinctAscList - - -- ** Occurrence lists - , toOccurList - , toAscOccurList - , fromOccurList - , fromAscOccurList - - -- ** IntMap - , toMap - , fromMap - , fromOccurMap - - -- * Debugging - , showTree - , showTreeWith - ) where - -import Prelude hiding (map,filter) -import qualified Prelude (map,filter) - -import qualified UU.DData.IntMap as M - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} -infixl 9 \\ -- - --- | /O(n+m)/. See 'difference'. -(\\) :: IntBag -> IntBag -> IntBag -b1 \\ b2 = difference b1 b2 - -{-------------------------------------------------------------------- - IntBags are a simple wrapper around Maps, 'Map.Map' ---------------------------------------------------------------------} --- | A bag of integers. -newtype IntBag = IntBag (M.IntMap Int) - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} --- | /O(1)/. Is the bag empty? -isEmpty :: IntBag -> Bool -isEmpty (IntBag m) - = M.isEmpty m - --- | /O(n)/. Returns the number of distinct elements in the bag, ie. (@distinctSize bag == length (nub (toList bag))@). -distinctSize :: IntBag -> Int -distinctSize (IntBag m) - = M.size m - --- | /O(n)/. The number of elements in the bag. -size :: IntBag -> Int -size b - = foldOccur (\x n m -> n+m) 0 b - --- | /O(min(n,W))/. Is the element in the bag? -member :: Int -> IntBag -> Bool -member x m - = (occur x m > 0) - --- | /O(min(n,W))/. The number of occurrences of an element in the bag. -occur :: Int -> IntBag -> Int -occur x (IntBag m) - = case M.lookup x m of - Nothing -> 0 - Just n -> n - --- | /O(n+m)/. Is this a subset of the bag? -subset :: IntBag -> IntBag -> Bool -subset (IntBag m1) (IntBag m2) - = M.subsetBy (<=) m1 m2 - --- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal) -properSubset :: IntBag -> IntBag -> Bool -properSubset b1 b2 - = subset b1 b2 && (b1 /= b2) - -{-------------------------------------------------------------------- - Construction ---------------------------------------------------------------------} --- | /O(1)/. Create an empty bag. -empty :: IntBag -empty - = IntBag (M.empty) - --- | /O(1)/. Create a singleton bag. -single :: Int -> IntBag -single x - = IntBag (M.single x 0) - -{-------------------------------------------------------------------- - Insertion, Deletion ---------------------------------------------------------------------} --- | /O(min(n,W))/. Insert an element in the bag. -insert :: Int -> IntBag -> IntBag -insert x (IntBag m) - = IntBag (M.insertWith (+) x 1 m) - --- | /O(min(n,W))/. The expression (@insertMany x count bag@) --- inserts @count@ instances of @x@ in the bag @bag@. -insertMany :: Int -> Int -> IntBag -> IntBag -insertMany x count (IntBag m) - = IntBag (M.insertWith (+) x count m) - --- | /O(min(n,W))/. Delete a single element. -delete :: Int -> IntBag -> IntBag -delete x (IntBag m) - = IntBag (M.updateWithKey f x m) - where - f x n | n > 0 = Just (n-1) - | otherwise = Nothing - --- | /O(min(n,W))/. Delete all occurrences of an element. -deleteAll :: Int -> IntBag -> IntBag -deleteAll x (IntBag m) - = IntBag (M.delete x m) - -{-------------------------------------------------------------------- - Combine ---------------------------------------------------------------------} --- | /O(n+m)/. Union of two bags. The union adds the elements together. --- --- > IntBag\> union (fromList [1,1,2]) (fromList [1,2,2,3]) --- > {1,1,1,2,2,2,3} -union :: IntBag -> IntBag -> IntBag -union (IntBag t1) (IntBag t2) - = IntBag (M.unionWith (+) t1 t2) - --- | /O(n+m)/. Intersection of two bags. --- --- > IntBag\> intersection (fromList [1,1,2]) (fromList [1,2,2,3]) --- > {1,2} -intersection :: IntBag -> IntBag -> IntBag -intersection (IntBag t1) (IntBag t2) - = IntBag (M.intersectionWith min t1 t2) - --- | /O(n+m)/. Difference between two bags. --- --- > IntBag\> difference (fromList [1,1,2]) (fromList [1,2,2,3]) --- > {1} -difference :: IntBag -> IntBag -> IntBag -difference (IntBag t1) (IntBag t2) - = IntBag (M.differenceWithKey f t1 t2) - where - f x n m | n-m > 0 = Just (n-m) - | otherwise = Nothing - --- | The union of a list of bags. -unions :: [IntBag] -> IntBag -unions bags - = IntBag (M.unions [m | IntBag m <- bags]) - -{-------------------------------------------------------------------- - Filter and partition ---------------------------------------------------------------------} --- | /O(n)/. Filter all elements that satisfy some predicate. -filter :: (Int -> Bool) -> IntBag -> IntBag -filter p (IntBag m) - = IntBag (M.filterWithKey (\x n -> p x) m) - --- | /O(n)/. Partition the bag according to some predicate. -partition :: (Int -> Bool) -> IntBag -> (IntBag,IntBag) -partition p (IntBag m) - = (IntBag l,IntBag r) - where - (l,r) = M.partitionWithKey (\x n -> p x) m - -{-------------------------------------------------------------------- - Fold ---------------------------------------------------------------------} --- | /O(n)/. Fold over each element in the bag. -fold :: (Int -> b -> b) -> b -> IntBag -> b -fold f z (IntBag m) - = M.foldWithKey apply z m - where - apply x n z | n > 0 = apply x (n-1) (f x z) - | otherwise = z - --- | /O(n)/. Fold over all occurrences of an element at once. --- In a call (@foldOccur f z bag@), the function @f@ takes --- the element first and than the occur count. -foldOccur :: (Int -> Int -> b -> b) -> b -> IntBag -> b -foldOccur f z (IntBag m) - = M.foldWithKey f z m - -{-------------------------------------------------------------------- - List variations ---------------------------------------------------------------------} --- | /O(n)/. The list of elements. -elems :: IntBag -> [Int] -elems s - = toList s - -{-------------------------------------------------------------------- - Lists ---------------------------------------------------------------------} --- | /O(n)/. Create a list with all elements. -toList :: IntBag -> [Int] -toList s - = toAscList s - --- | /O(n)/. Create an ascending list of all elements. -toAscList :: IntBag -> [Int] -toAscList (IntBag m) - = [y | (x,n) <- M.toAscList m, y <- replicate n x] - - --- | /O(n*min(n,W))/. Create a bag from a list of elements. -fromList :: [Int] -> IntBag -fromList xs - = IntBag (M.fromListWith (+) [(x,1) | x <- xs]) - --- | /O(n*min(n,W))/. Create a bag from an ascending list. -fromAscList :: [Int] -> IntBag -fromAscList xs - = IntBag (M.fromAscListWith (+) [(x,1) | x <- xs]) - --- | /O(n*min(n,W))/. Create a bag from an ascending list of distinct elements. -fromDistinctAscList :: [Int] -> IntBag -fromDistinctAscList xs - = IntBag (M.fromDistinctAscList [(x,1) | x <- xs]) - --- | /O(n)/. Create a list of element\/occurrence pairs. -toOccurList :: IntBag -> [(Int,Int)] -toOccurList b - = toAscOccurList b - --- | /O(n)/. Create an ascending list of element\/occurrence pairs. -toAscOccurList :: IntBag -> [(Int,Int)] -toAscOccurList (IntBag m) - = M.toAscList m - --- | /O(n*min(n,W))/. Create a bag from a list of element\/occurrence pairs. -fromOccurList :: [(Int,Int)] -> IntBag -fromOccurList xs - = IntBag (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) - --- | /O(n*min(n,W))/. Create a bag from an ascending list of element\/occurrence pairs. -fromAscOccurList :: [(Int,Int)] -> IntBag -fromAscOccurList xs - = IntBag (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) - -{-------------------------------------------------------------------- - Maps ---------------------------------------------------------------------} --- | /O(1)/. Convert to an 'IntMap.IntMap' from elements to number of occurrences. -toMap :: IntBag -> M.IntMap Int -toMap (IntBag m) - = m - --- | /O(n)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag. -fromMap :: M.IntMap Int -> IntBag -fromMap m - = IntBag (M.filter (>0) m) - --- | /O(1)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag. --- Assumes that the 'IntMap.IntMap' contains only elements that occur at least once. -fromOccurMap :: M.IntMap Int -> IntBag -fromOccurMap m - = IntBag m - -{-------------------------------------------------------------------- - Eq, Ord ---------------------------------------------------------------------} -instance Eq (IntBag) where - (IntBag m1) == (IntBag m2) = (m1==m2) - (IntBag m1) /= (IntBag m2) = (m1/=m2) - -{-------------------------------------------------------------------- - Show ---------------------------------------------------------------------} -instance Show (IntBag) where - showsPrec d b = showSet (toAscList b) - -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 - - -{-------------------------------------------------------------------- - Debugging ---------------------------------------------------------------------} --- | /O(n)/. Show the tree structure that implements the 'IntBag'. The tree --- is shown as a compressed and /hanging/. -showTree :: IntBag -> String -showTree bag - = showTreeWith True False bag - --- | /O(n)/. The expression (@showTreeWith hang wide map@) shows --- the tree that implements the bag. The tree is shown /hanging/ when @hang@ is @True@ --- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version --- is shown. -showTreeWith :: Bool -> Bool -> IntBag -> String -showTreeWith hang wide (IntBag m) - = M.showTreeWith hang wide m - diff --git a/src/UU/DData/IntMap.hs b/src/UU/DData/IntMap.hs deleted file mode 100644 --- a/src/UU/DData/IntMap.hs +++ /dev/null @@ -1,1240 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} --------------------------------------------------------------------------------- -{-| Module : IntMap - Copyright : (c) Daan Leijen 2002 - License : BSD-style - - Maintainer : daan@cs.uu.nl - Stability : provisional - Portability : portable - - An efficient implementation of maps from integer keys to values. - - 1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. - If you want to use "IntMap" unqualified, these functions should be hidden. - - > import Prelude hiding (map,lookup,filter) - > import IntMap - - Another solution is to use qualified names. - - > import qualified IntMap - > - > ... IntMap.single "Paris" "France" - - Or, if you prefer a terse coding style: - - > import qualified IntMap as M - > - > ... M.single "Paris" "France" - - 2) 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. - - 3) 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 UU.DData.IntMap ( - -- * Map type - IntMap, Key -- instance Eq,Show - - -- * Operators - , (!), (\\) - - -- * Query - , isEmpty - , size - , member - , lookup - , find - , findWithDefault - - -- * Construction - , empty - , single - - -- ** Insertion - , insert - , insertWith, insertWithKey, insertLookupWithKey - - -- ** Delete\/Update - , delete - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - - -- * Combine - - -- ** Union - , union - , unionWith - , unionWithKey - , unions - - -- ** Difference - , difference - , differenceWith - , differenceWithKey - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithKey - - -- * Traversal - -- ** Map - , map - , mapWithKey - , mapAccum - , mapAccumWithKey - - -- ** Fold - , fold - , foldWithKey - - -- * Conversion - , elems - , keys - , assocs - - -- ** Lists - , toList - , fromList - , fromListWith - , fromListWithKey - - -- ** Ordered lists - , toAscList - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - - -- * Filter - , filter - , filterWithKey - , partition - , partitionWithKey - - , split - , splitLookup - - -- * Subset - , subset, subsetBy - , properSubset, properSubsetBy - - -- * Debugging - , showTree - , showTreeWith - ) where - - -import Prelude hiding (lookup,map,filter) -import Bits -import Int - -{- --- 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 - -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 Word - -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 Word - -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 - -infixl 9 \\ -- - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} - --- | /O(min(n,W))/. See 'find'. -(!) :: IntMap a -> Key -> a -(!) m k = find k m - --- | /O(n+m)/. See 'difference'. -(\\) :: IntMap a -> IntMap a -> IntMap a -m1 \\ m2 = difference m1 m2 - -{-------------------------------------------------------------------- - Types ---------------------------------------------------------------------} --- | A map of integers to values @a@. -data IntMap a = Nil - | Tip !Key a - | Bin !Prefix !Mask !(IntMap a) !(IntMap a) - -type Prefix = Int -type Mask = Int -type Key = Int - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} --- | /O(1)/. Is the map empty? -isEmpty :: IntMap a -> Bool -isEmpty Nil = True -isEmpty 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 - = case t of - Bin p m l r - | nomatch k p m -> Nothing - | zero k m -> lookup k l - | otherwise -> lookup k r - Tip kx x - | (k==kx) -> Just x - | otherwise -> Nothing - Nil -> Nothing - --- | /O(min(n,W))/. Find the value of a key. Calls @error@ when the element can not be found. -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. -single :: Key -> a -> IntMap a -single 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, it's 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 - - --- | /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 a -> 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 -> a -> Maybe a) -> IntMap a -> IntMap a -> 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 -> a -> Maybe a) -> IntMap a -> IntMap a -> 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 a -> 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 -> a -> a) -> IntMap a -> IntMap a -> 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 -> a -> a) -> IntMap a -> IntMap a -> 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 - - -{-------------------------------------------------------------------- - Subset ---------------------------------------------------------------------} --- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). --- Defined as (@properSubset = properSubsetBy (==)@). -properSubset :: Eq a => IntMap a -> IntMap a -> Bool -properSubset m1 m2 - = properSubsetBy (==) m1 m2 - -{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). - The expression (@properSubsetBy 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@. - - > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - - But the following are all @False@: - - > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) - > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) - > properSubsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) --} -properSubsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool -properSubsetBy pred t1 t2 - = case subsetCmp pred t1 t2 of - LT -> True - ge -> False - -subsetCmp pred 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 pred t1 l2 - | otherwise = subsetCmp pred t1 r2 - subsetCmpEq = case (subsetCmp pred l1 l2, subsetCmp pred r1 r2) of - (GT,_ ) -> GT - (_ ,GT) -> GT - (EQ,EQ) -> EQ - other -> LT - -subsetCmp pred (Bin p m l r) t = GT -subsetCmp pred (Tip kx x) (Tip ky y) - | (kx == ky) && pred x y = EQ - | otherwise = GT -- disjoint -subsetCmp pred (Tip k x) t - = case lookup k t of - Just y | pred x y -> LT - other -> GT -- disjoint -subsetCmp pred Nil Nil = EQ -subsetCmp pred Nil t = LT - --- | /O(n+m)/. Is this a subset? Defined as (@subset = subsetBy (==)@). -subset :: Eq a => IntMap a -> IntMap a -> Bool -subset m1 m2 - = subsetBy (==) m1 m2 - -{- | /O(n+m)/. - The expression (@subsetBy 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@. - - > subsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - > subsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) - - But the following are all @False@: - - > subsetBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)]) - > subsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) --} - -subsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool -subsetBy 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 subsetBy pred t1 l2 - else subsetBy pred t1 r2) - | otherwise = (p1==p2) && subsetBy pred l1 l2 && subsetBy pred r1 r2 -subsetBy pred (Bin p m l r) t = False -subsetBy pred (Tip k x) t = case lookup k t of - Just y -> pred x y - Nothing -> False -subsetBy 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@. -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)/. 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 - -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) - - -{-------------------------------------------------------------------- - 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 == single 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 (single 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/src/UU/DData/IntSet.hs b/src/UU/DData/IntSet.hs deleted file mode 100644 --- a/src/UU/DData/IntSet.hs +++ /dev/null @@ -1,852 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} --------------------------------------------------------------------------------- -{-| Module : IntSet - Copyright : (c) Daan Leijen 2002 - License : BSD-style - - Maintainer : daan@cs.uu.nl - Stability : provisional - Portability : portable - - An efficient implementation of integer sets. - - 1) The 'filter' function clashes with the "Prelude". - If you want to use "IntSet" unqualified, this function should be hidden. - - > import Prelude hiding (filter) - > import IntSet - - Another solution is to use qualified names. - - > import qualified IntSet - > - > ... IntSet.fromList [1..5] - - Or, if you prefer a terse coding style: - - > import qualified IntSet as S - > - > ... S.fromList [1..5] - - 2) 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. - - 3) 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 UU.DData.IntSet ( - -- * Set type - IntSet -- instance Eq,Show - - -- * Operators - , (\\) - - -- * Query - , isEmpty - , size - , member - , subset - , properSubset - - -- * Construction - , empty - , single - , insert - , delete - - -- * Combine - , union, unions - , difference - , intersection - - -- * Filter - , filter - , partition - , split - , splitMember - - -- * Fold - , fold - - -- * Conversion - -- ** List - , elems - , toList - , fromList - - -- ** Ordered list - , toAscList - , fromAscList - , fromDistinctAscList - - -- * Debugging - , showTree - , showTreeWith - ) where - - -import Prelude hiding (lookup,filter) -import Bits -import Int - -{- --- 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 - - -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 Word - -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 Word - -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 - -infixl 9 \\ -- - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} --- | /O(n+m)/. See 'difference'. -(\\) :: IntSet -> IntSet -> IntSet -m1 \\ m2 = difference m1 m2 - -{-------------------------------------------------------------------- - Types ---------------------------------------------------------------------} --- | A set of integers. -data IntSet = Nil - | Tip !Int - | Bin !Prefix !Mask !IntSet !IntSet - -type Prefix = Int -type Mask = Int - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} --- | /O(1)/. Is the set empty? -isEmpty :: IntSet -> Bool -isEmpty Nil = True -isEmpty 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 x t - = case t of - Bin p m l r - | nomatch x p m -> Nothing - | zero x m -> lookup x l - | otherwise -> lookup x r - Tip y - | (x==y) -> Just y - | otherwise -> Nothing - Nil -> Nothing - -{-------------------------------------------------------------------- - Construction ---------------------------------------------------------------------} --- | /O(1)/. The empty set. -empty :: IntSet -empty - = Nil - --- | /O(1)/. A set of one element. -single :: Int -> IntSet -single 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). -properSubset :: IntSet -> IntSet -> Bool -properSubset 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? -subset :: IntSet -> IntSet -> Bool -subset 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 subset t1 l2 - else subset t1 r2) - | otherwise = (p1==p2) && subset l1 l2 && subset r1 r2 -subset (Bin p m l r) t = False -subset (Tip x) t = member x t -subset 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 :: 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) - - -{-------------------------------------------------------------------- - 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. -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 - -{-------------------------------------------------------------------- - 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) - - -{-------------------------------------------------------------------- - 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 == single 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 (single 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/src/UU/DData/Map.hs b/src/UU/DData/Map.hs deleted file mode 100644 --- a/src/UU/DData/Map.hs +++ /dev/null @@ -1,1544 +0,0 @@ --------------------------------------------------------------------------------- -{-| Module : Map - Copyright : (c) Daan Leijen 2002 - License : BSD-style - - Maintainer : daan@cs.uu.nl - Stability : provisional - Portability : portable - - An efficient implementation of maps from keys to values (dictionaries). - - 1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. - If you want to use "Map" unqualified, these functions should be hidden. - - > import Prelude hiding (lookup,map,filter) - > import Map - - Another solution is to use qualified names. This is also the only way how - a "Map", "Set", and "MultiSet" can be used within one module. - - > import qualified Map - > - > ... Map.single "Paris" "France" - - Or, if you prefer a terse coding style: - - > import qualified Map as M - > - > ... M.single "Berlin" "Germany" - - 2) 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. - - 3) Another implementation of finite maps based on size balanced trees - exists as "Data.FiniteMap" in the Ghc libraries. The good part about this library - is that it is highly tuned and thorougly tested. However, it is also fairly old, - uses @#ifdef@'s all over the place and only supports the basic finite map operations. - The "Map" module overcomes some of these issues: - - * It tries to export a more complete and consistent set of operations, like - 'partition', 'adjust', 'mapAccum', 'elemAt' etc. - - * It uses the efficient /hedge/ algorithm for both 'union' and 'difference' - (a /hedge/ algorithm is not applicable to 'intersection'). - - * It converts ordered lists in linear time ('fromAscList'). - - * It takes advantage of the module system with names like 'empty' instead of 'Data.FiniteMap.emptyFM'. - - * It sticks to portable Haskell, avoiding @#ifdef@'s and other magic. --} ----------------------------------------------------------------------------------- -module UU.DData.Map ( - -- * Map type - Map -- instance Eq,Show - - -- * Operators - , (!), (\\) - - -- * Query - , isEmpty - , size - , member - , lookup - , find - , findWithDefault - - -- * Construction - , empty - , single - - -- ** Insertion - , insert - , insertWith, insertWithKey, insertLookupWithKey - - -- ** Delete\/Update - , delete - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - - -- * Combine - - -- ** Union - , union - , unionWith - , unionWithKey - , unions - - -- ** Difference - , difference - , differenceWith - , differenceWithKey - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithKey - - -- * Traversal - -- ** Map - , map - , mapWithKey - , mapAccum - , mapAccumWithKey - - -- ** Fold - , fold - , foldWithKey - - -- * Conversion - , elems - , keys - , assocs - - -- ** Lists - , toList - , fromList - , fromListWith - , fromListWithKey - - -- ** Ordered lists - , toAscList - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - - -- * Filter - , filter - , filterWithKey - , partition - , partitionWithKey - - , split - , splitLookup - - -- * Subset - , subset, subsetBy - , properSubset, properSubsetBy - - -- * 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) - - -{- --- for quick check -import qualified Prelude -import qualified List -import Debug.QuickCheck -import List(nub,sort) --} - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} -infixl 9 !,\\ -- - --- | /O(log n)/. See 'find'. -(!) :: Ord k => Map k a -> k -> a -(!) m k = find k m - --- | /O(n+m)/. See 'difference'. -(\\) :: Ord k => Map k a -> Map k a -> Map k a -m1 \\ m2 = difference m1 m2 - -{-------------------------------------------------------------------- - Size balanced trees. ---------------------------------------------------------------------} --- | A Map from keys @k@ and values @a@. -data Map k a = Tip - | Bin !Size !k a !(Map k a) !(Map k a) - -type Size = Int - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} --- | /O(1)/. Is the map empty? -isEmpty :: Map k a -> Bool -isEmpty 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)/. Create an empty map. -empty :: Map k a -empty - = Tip - --- | /O(1)/. Create a map with a single element. -single :: k -> a -> Map k a -single 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 -> single 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 -> single 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, single 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 - --- | /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. -union :: Ord k => Map k a -> Map k a -> Map k a -union Tip t2 = t2 -union t1 Tip = t1 -union t1 t2 -- hedge-union is more efficient on (bigset `union` smallset) - | 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. -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 -- hedge-union is more efficient on (bigset `union` smallset) - | 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 a -> 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 -> a -> Maybe a) -> Map k a -> Map k a -> 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 -> a -> Maybe a) -> Map k a -> Map k a -> 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 a -> 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 -> a -> a) -> Map k a -> Map k a -> Map k a -intersectionWith f m1 m2 - = intersectionWithKey (\k x y -> f x y) m1 m2 - --- | /O(n+m)/. Intersection with a combining function. -intersectionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a -intersectionWithKey f Tip t = Tip -intersectionWithKey f t Tip = Tip -intersectionWithKey f t1 t2 -- intersection is more efficient on (bigset `intersection` smallset) - | 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 - - - -{-------------------------------------------------------------------- - Subset ---------------------------------------------------------------------} --- | /O(n+m)/. --- This function is defined as (@subset = subsetBy (==)@). -subset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool -subset m1 m2 - = subsetBy (==) m1 m2 - -{- | /O(n+m)/. - The expression (@subsetBy 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@. - - > subsetBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) - > subsetBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) - > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)]) - - But the following are all @False@: - - > subsetBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)]) - > subsetBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) - > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)]) --} -subsetBy :: Ord k => (a->a->Bool) -> Map k a -> Map k a -> Bool -subsetBy f t1 t2 - = (size t1 <= size t2) && (subset' f t1 t2) - -subset' f Tip t = True -subset' f t Tip = False -subset' f (Bin _ kx x l r) t - = case found of - Nothing -> False - Just y -> f x y && subset' f l lt && subset' f r gt - where - (found,lt,gt) = splitLookup kx t - --- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). --- Defined as (@properSubset = properSubsetBy (==)@). -properSubset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool -properSubset m1 m2 - = properSubsetBy (==) m1 m2 - -{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). - The expression (@properSubsetBy 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@. - - > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - - But the following are all @False@: - - > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) - > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) - > properSubsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) --} -properSubsetBy :: (Ord k,Eq a) => (a -> a -> Bool) -> Map k a -> Map k a -> Bool -properSubsetBy f t1 t2 - = (size t1 < size t2) && (subset' 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') - -{-------------------------------------------------------------------- - 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)/. 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. -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. -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 -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. -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 (single k1 x1) (single k3 x3)) (single 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@. -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 -> single kx x - Bin sz ky y l r - -> balance ky y l (insertMax kx x r) - -insertMin kx x t - = case t of - Tip -> single 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) - -{-------------------------------------------------------------------- - 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> putStrLn $ showTreeWith (\k x -> show (k,x)) True False $ fromDistinctAscList [(x,()) | x <- [1..5]] -> (4,()) -> +--(2,()) -> | +--(1,()) -> | +--(3,()) -> +--(5,()) -> -> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True $ fromDistinctAscList [(x,()) | x <- [1..5]] -> (4,()) -> | -> +--(2,()) -> | | -> | +--(1,()) -> | | -> | +--(3,()) -> | -> +--(5,()) -> -> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True $ fromDistinctAscList [(x,()) | x <- [1..5]] -> +--(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 == single 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 (single 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/src/UU/DData/MultiSet.hs b/src/UU/DData/MultiSet.hs deleted file mode 100644 --- a/src/UU/DData/MultiSet.hs +++ /dev/null @@ -1,430 +0,0 @@ --------------------------------------------------------------------------------- -{-| Module : MultiSet - Copyright : (c) Daan Leijen 2002 - License : BSD-style - - Maintainer : daan@cs.uu.nl - Stability : provisional - Portability : portable - - An implementation of multi sets on top of the "Map" module. A multi set - differs from a /bag/ in the sense that it is represented as a map from elements - to occurrence counts instead of retaining all elements. This means that equality - on elements should be defined as a /structural/ equality instead of an - equivalence relation. If this is not the case, operations that observe the - elements, like 'filter' and 'fold', should be used with care. --} ----------------------------------------------------------------------------------} -module UU.DData.MultiSet ( - -- * MultiSet type - MultiSet -- instance Eq,Show - - -- * Operators - , (\\) - - -- *Query - , isEmpty - , size - , distinctSize - , member - , occur - - , subset - , properSubset - - -- * Construction - , empty - , single - , insert - , insertMany - , delete - , deleteAll - - -- * Combine - , union - , difference - , intersection - , unions - - -- * Filter - , filter - , partition - - -- * Fold - , fold - , foldOccur - - -- * Min\/Max - , findMin - , findMax - , deleteMin - , deleteMax - , deleteMinAll - , deleteMaxAll - - -- * Conversion - , elems - - -- ** List - , toList - , fromList - - -- ** Ordered list - , toAscList - , fromAscList - , fromDistinctAscList - - -- ** Occurrence lists - , toOccurList - , toAscOccurList - , fromOccurList - , fromAscOccurList - - -- ** Map - , toMap - , fromMap - , fromOccurMap - - -- * Debugging - , showTree - , showTreeWith - , valid - ) where - -import Prelude hiding (map,filter) -import qualified Prelude (map,filter) - -import qualified UU.DData.Map as M - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} -infixl 9 \\ -- - --- | /O(n+m)/. See 'difference'. -(\\) :: Ord a => MultiSet a -> MultiSet a -> MultiSet a -b1 \\ b2 = difference b1 b2 - -{-------------------------------------------------------------------- - MultiSets are a simple wrapper around Maps, 'Map.Map' ---------------------------------------------------------------------} --- | A multi set of values @a@. -newtype MultiSet a = MultiSet (M.Map a Int) - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} --- | /O(1)/. Is the multi set empty? -isEmpty :: MultiSet a -> Bool -isEmpty (MultiSet m) - = M.isEmpty m - --- | /O(1)/. Returns the number of distinct elements in the multi set, ie. (@distinctSize mset == Set.size ('toSet' mset)@). -distinctSize :: MultiSet a -> Int -distinctSize (MultiSet m) - = M.size m - --- | /O(n)/. The number of elements in the multi set. -size :: MultiSet a -> Int -size b - = foldOccur (\x n m -> n+m) 0 b - --- | /O(log n)/. Is the element in the multi set? -member :: Ord a => a -> MultiSet a -> Bool -member x m - = (occur x m > 0) - --- | /O(log n)/. The number of occurrences of an element in the multi set. -occur :: Ord a => a -> MultiSet a -> Int -occur x (MultiSet m) - = case M.lookup x m of - Nothing -> 0 - Just n -> n - --- | /O(n+m)/. Is this a subset of the multi set? -subset :: Ord a => MultiSet a -> MultiSet a -> Bool -subset (MultiSet m1) (MultiSet m2) - = M.subsetBy (<=) m1 m2 - --- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal) -properSubset :: Ord a => MultiSet a -> MultiSet a -> Bool -properSubset b1 b2 - | distinctSize b1 == distinctSize b2 = (subset b1 b2) && (b1 /= b2) - | distinctSize b1 < distinctSize b2 = (subset b1 b2) - | otherwise = False - -{-------------------------------------------------------------------- - Construction ---------------------------------------------------------------------} --- | /O(1)/. Create an empty multi set. -empty :: MultiSet a -empty - = MultiSet (M.empty) - --- | /O(1)/. Create a singleton multi set. -single :: a -> MultiSet a -single x - = MultiSet (M.single x 1) - -{-------------------------------------------------------------------- - Insertion, Deletion ---------------------------------------------------------------------} --- | /O(log n)/. Insert an element in the multi set. -insert :: Ord a => a -> MultiSet a -> MultiSet a -insert x (MultiSet m) - = MultiSet (M.insertWith (+) x 1 m) - --- | /O(min(n,W))/. The expression (@insertMany x count mset@) --- inserts @count@ instances of @x@ in the multi set @mset@. -insertMany :: Ord a => a -> Int -> MultiSet a -> MultiSet a --- We still expect not to get count < 0 -insertMany x 0 multiset = multiset -insertMany x count (MultiSet m) - = MultiSet (M.insertWith (+) x count m) - --- | /O(log n)/. Delete a single element. -delete :: Ord a => a -> MultiSet a -> MultiSet a -delete x (MultiSet m) - = MultiSet (M.updateWithKey f x m) - where - f x n | n > 1 = Just (n-1) - | otherwise = Nothing - --- | /O(log n)/. Delete all occurrences of an element. -deleteAll :: Ord a => a -> MultiSet a -> MultiSet a -deleteAll x (MultiSet m) - = MultiSet (M.delete x m) - -{-------------------------------------------------------------------- - Combine ---------------------------------------------------------------------} --- | /O(n+m)/. Union of two multisets. The union adds the elements together. --- --- > MultiSet\> union (fromList [1,1,2]) (fromList [1,2,2,3]) --- > {1,1,1,2,2,2,3} -union :: Ord a => MultiSet a -> MultiSet a -> MultiSet a -union (MultiSet t1) (MultiSet t2) - = MultiSet (M.unionWith (+) t1 t2) - --- | /O(n+m)/. Intersection of two multisets. --- --- > MultiSet\> intersection (fromList [1,1,2]) (fromList [1,2,2,3]) --- > {1,2} -intersection :: Ord a => MultiSet a -> MultiSet a -> MultiSet a -intersection (MultiSet t1) (MultiSet t2) - = MultiSet (M.intersectionWith min t1 t2) - --- | /O(n+m)/. Difference between two multisets. --- --- > MultiSet\> difference (fromList [1,1,2]) (fromList [1,2,2,3]) --- > {1} -difference :: Ord a => MultiSet a -> MultiSet a -> MultiSet a -difference (MultiSet t1) (MultiSet t2) - = MultiSet (M.differenceWithKey f t1 t2) - where - f x n m | n-m > 0 = Just (n-m) - | otherwise = Nothing - --- | The union of a list of multisets. -unions :: Ord a => [MultiSet a] -> MultiSet a -unions multisets - -- Original, wrong - -- = MultiSet (M.unions [m | MultiSet m <- multisets]) - -- Map has no unionsWith - -- = MultiSet (M.unionsWith (+) [m | MultiSet m <- multisets]) - -- Correct, but requires Data.List.foldl' - -- = MultiSet (foldl' (M.unionWith (+)) M.empty [m | MultiSet m <- multisets]) - -- Correct, but not strict like the original (M.unions uses foldStrict) - = foldr union empty multisets - -{-------------------------------------------------------------------- - Filter and partition ---------------------------------------------------------------------} --- | /O(n)/. Filter all elements that satisfy some predicate. -filter :: Ord a => (a -> Bool) -> MultiSet a -> MultiSet a -filter p (MultiSet m) - = MultiSet (M.filterWithKey (\x n -> p x) m) - --- | /O(n)/. Partition the multi set according to some predicate. -partition :: Ord a => (a -> Bool) -> MultiSet a -> (MultiSet a,MultiSet a) -partition p (MultiSet m) - = (MultiSet l,MultiSet r) - where - (l,r) = M.partitionWithKey (\x n -> p x) m - -{-------------------------------------------------------------------- - Fold ---------------------------------------------------------------------} --- | /O(n)/. Fold over each element in the multi set. -fold :: (a -> b -> b) -> b -> MultiSet a -> b -fold f z (MultiSet m) - = M.foldWithKey apply z m - where - apply x n z | n > 0 = apply x (n-1) (f x z) - | otherwise = z - --- | /O(n)/. Fold over all occurrences of an element at once. -foldOccur :: (a -> Int -> b -> b) -> b -> MultiSet a -> b -foldOccur f z (MultiSet m) - = M.foldWithKey f z m - -{-------------------------------------------------------------------- - Minimal, Maximal ---------------------------------------------------------------------} --- | /O(log n)/. The minimal element of a multi set. -findMin :: MultiSet a -> a -findMin (MultiSet m) - = fst (M.findMin m) - --- | /O(log n)/. The maximal element of a multi set. -findMax :: MultiSet a -> a -findMax (MultiSet m) - = fst (M.findMax m) - --- | /O(log n)/. Delete the minimal element. -deleteMin :: MultiSet a -> MultiSet a -deleteMin (MultiSet m) - = MultiSet (M.updateMin f m) - where - f n | n > 0 = Just (n-1) - | otherwise = Nothing - --- | /O(log n)/. Delete the maximal element. -deleteMax :: MultiSet a -> MultiSet a -deleteMax (MultiSet m) - = MultiSet (M.updateMax f m) - where - f n | n > 0 = Just (n-1) - | otherwise = Nothing - --- | /O(log n)/. Delete all occurrences of the minimal element. -deleteMinAll :: MultiSet a -> MultiSet a -deleteMinAll (MultiSet m) - = MultiSet (M.deleteMin m) - --- | /O(log n)/. Delete all occurrences of the maximal element. -deleteMaxAll :: MultiSet a -> MultiSet a -deleteMaxAll (MultiSet m) - = MultiSet (M.deleteMax m) - - -{-------------------------------------------------------------------- - List variations ---------------------------------------------------------------------} --- | /O(n)/. The list of elements. -elems :: MultiSet a -> [a] -elems s - = toList s - -{-------------------------------------------------------------------- - Lists ---------------------------------------------------------------------} --- | /O(n)/. Create a list with all elements. -toList :: MultiSet a -> [a] -toList s - = toAscList s - --- | /O(n)/. Create an ascending list of all elements. -toAscList :: MultiSet a -> [a] -toAscList (MultiSet m) - = [y | (x,n) <- M.toAscList m, y <- replicate n x] - - --- | /O(n*log n)/. Create a multi set from a list of elements. -fromList :: Ord a => [a] -> MultiSet a -fromList xs - = MultiSet (M.fromListWith (+) [(x,1) | x <- xs]) - --- | /O(n)/. Create a multi set from an ascending list in linear time. -fromAscList :: Eq a => [a] -> MultiSet a -fromAscList xs - = MultiSet (M.fromAscListWith (+) [(x,1) | x <- xs]) - --- | /O(n)/. Create a multi set from an ascending list of distinct elements in linear time. -fromDistinctAscList :: [a] -> MultiSet a -fromDistinctAscList xs - = MultiSet (M.fromDistinctAscList [(x,1) | x <- xs]) - --- | /O(n)/. Create a list of element\/occurrence pairs. -toOccurList :: MultiSet a -> [(a,Int)] -toOccurList b - = toAscOccurList b - --- | /O(n)/. Create an ascending list of element\/occurrence pairs. -toAscOccurList :: MultiSet a -> [(a,Int)] -toAscOccurList (MultiSet m) - = M.toAscList m - --- | /O(n*log n)/. Create a multi set from a list of element\/occurrence pairs. -fromOccurList :: Ord a => [(a,Int)] -> MultiSet a -fromOccurList xs - = MultiSet (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) - --- | /O(n)/. Create a multi set from an ascending list of element\/occurrence pairs. -fromAscOccurList :: Ord a => [(a,Int)] -> MultiSet a -fromAscOccurList xs - = MultiSet (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs)) - -{-------------------------------------------------------------------- - Maps ---------------------------------------------------------------------} --- | /O(1)/. Convert to a 'Map.Map' from elements to number of occurrences. -toMap :: MultiSet a -> M.Map a Int -toMap (MultiSet m) - = m - --- | /O(n)/. Convert a 'Map.Map' from elements to occurrences into a multi set. -fromMap :: Ord a => M.Map a Int -> MultiSet a -fromMap m - = MultiSet (M.filter (>0) m) - --- | /O(1)/. Convert a 'Map.Map' from elements to occurrences into a multi set. --- Assumes that the 'Map.Map' contains only elements that occur at least once. -fromOccurMap :: M.Map a Int -> MultiSet a -fromOccurMap m - = MultiSet m - -{-------------------------------------------------------------------- - Eq, Ord ---------------------------------------------------------------------} -instance Eq a => Eq (MultiSet a) where - (MultiSet m1) == (MultiSet m2) = (m1==m2) - -{-------------------------------------------------------------------- - Show ---------------------------------------------------------------------} -instance Show a => Show (MultiSet a) where - showsPrec d b = showSet (toAscList b) - -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 - - -{-------------------------------------------------------------------- - Debugging ---------------------------------------------------------------------} --- | /O(n)/. Show the tree structure that implements the 'MultiSet'. The tree --- is shown as a compressed and /hanging/. -showTree :: (Show a) => MultiSet a -> String -showTree mset - = showTreeWith True False mset - --- | /O(n)/. The expression (@showTreeWith hang wide map@) shows --- the tree that implements the multi set. The tree is shown /hanging/ when @hang@ is @True@ --- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version --- is shown. -showTreeWith :: Show a => Bool -> Bool -> MultiSet a -> String -showTreeWith hang wide (MultiSet m) - = M.showTreeWith (\x n -> show x ++ " (" ++ show n ++ ")") hang wide m - - --- | /O(n)/. Is this a valid multi set? -valid :: Ord a => MultiSet a -> Bool -valid (MultiSet m) - = M.valid m && (M.isEmpty (M.filter (<=0) m)) diff --git a/src/UU/DData/Queue.hs b/src/UU/DData/Queue.hs deleted file mode 100644 --- a/src/UU/DData/Queue.hs +++ /dev/null @@ -1,281 +0,0 @@ --------------------------------------------------------------------------------- -{-| Module : Queue - Copyright : (c) Daan Leijen 2002 - License : BSD-style - - Maintainer : daan@cs.uu.nl - Stability : provisional - Portability : portable - - An efficient implementation of queues (FIFO buffers). Based on: - - * Chris Okasaki, \"/Simple and Efficient Purely Functional Queues and Deques/\", - Journal of Functional Programming 5(4):583-592, October 1995. --} ----------------------------------------------------------------------------------} -module UU.DData.Queue ( - -- * Queue type - Queue -- instance Eq,Show - - -- * Operators - , (<>) - - -- * Query - , isEmpty - , length - , head - , tail - , front - - -- * Construction - , empty - , single - , insert - , append - - -- * Filter - , filter - , partition - - -- * Fold - , foldL - , foldR - - -- * Conversion - , elems - - -- ** List - , toList - , fromList - ) where - -import qualified Prelude as P (length,filter) -import Prelude hiding (length,head,tail,filter) -import qualified List - --- just for testing --- import QuickCheck - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} -infixr 5 <> - --- | /O(n)/. Append two queues, see 'append'. -(<>) :: Queue a -> Queue a -> Queue a -s <> t - = append s t - -{-------------------------------------------------------------------- - Queue. - Invariants for @(Queue xs ys zs)@: - * @length ys <= length xs@ - * @length zs == length xs - length ys@ ---------------------------------------------------------------------} --- A queue of elements @a@. -data Queue a = Queue [a] [a] [a] - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} - --- | /O(1)/. Is the queue empty? -isEmpty :: Queue a -> Bool -isEmpty (Queue xs ys zs) - = null xs - --- | /O(n)/. The number of elements in the queue. -length :: Queue a -> Int -length (Queue xs ys zs) - = P.length xs + P.length ys - --- | /O(1)/. The element in front of the queue. Raises an error --- when the queue is empty. -head :: Queue a -> a -head (Queue xs ys zs) - = case xs of - (x:xx) -> x - [] -> error "Queue.head: empty queue" - --- | /O(1)/. The tail of the queue. --- Raises an error when the queue is empty. -tail :: Queue a -> Queue a -tail (Queue xs ys zs) - = case xs of - (x:xx) -> queue xx ys zs - [] -> error "Queue.tail: empty queue" - --- | /O(1)/. The head and tail of the queue. -front :: Queue a -> Maybe (a,Queue a) -front (Queue xs ys zs) - = case xs of - (x:xx) -> Just (x,queue xx ys zs) - [] -> Nothing - - -{-------------------------------------------------------------------- - Construction ---------------------------------------------------------------------} --- | /O(1)/. The empty queue. -empty :: Queue a -empty - = Queue [] [] [] - --- | /O(1)/. A queue of one element. -single :: a -> Queue a -single x - = Queue [x] [] [x] - --- | /O(1)/. Insert an element at the back of a queue. -insert :: a -> Queue a -> Queue a -insert x (Queue xs ys zs) - = queue xs (x:ys) zs - - --- | /O(n)/. Append two queues. -append :: Queue a -> Queue a -> Queue a -append (Queue xs1 ys1 zs1) (Queue xs2 ys2 zs2) - = Queue (xs1++xs2) (ys1++ys2) (zs1++zs2) - -{-------------------------------------------------------------------- - Filter ---------------------------------------------------------------------} --- | /O(n)/. Filter elements according to some predicate. -filter :: (a -> Bool) -> Queue a -> Queue a -filter pred (Queue xs ys zs) - = balance xs' ys' - where - xs' = P.filter pred xs - ys' = P.filter pred ys - --- | /O(n)/. Partition the elements according to some predicate. -partition :: (a -> Bool) -> Queue a -> (Queue a,Queue a) -partition pred (Queue xs ys zs) - = (balance xs1 ys1, balance xs2 ys2) - where - (xs1,xs2) = List.partition pred xs - (ys1,ys2) = List.partition pred ys - - -{-------------------------------------------------------------------- - Fold ---------------------------------------------------------------------} --- | /O(n)/. Fold over the elements from left to right (ie. head to tail). -foldL :: (b -> a -> b) -> b -> Queue a -> b -foldL f z (Queue xs ys zs) - = foldr (flip f) (foldl f z xs) ys - --- | /O(n)/. Fold over the elements from right to left (ie. tail to head). -foldR :: (a -> b -> b) -> b -> Queue a -> b -foldR f z (Queue xs ys zs) - = foldr f (foldl (flip f) z ys) xs - - -{-------------------------------------------------------------------- - Conversion ---------------------------------------------------------------------} --- | /O(n)/. The elements of a queue. -elems :: Queue a -> [a] -elems q - = toList q - --- | /O(n)/. Convert to a list. -toList :: Queue a -> [a] -toList (Queue xs ys zs) - = xs ++ reverse ys - --- | /O(n)/. Convert from a list. -fromList :: [a] -> Queue a -fromList xs - = Queue xs [] xs - - -{-------------------------------------------------------------------- - instance Eq, Show ---------------------------------------------------------------------} -instance Eq a => Eq (Queue a) where - q1 == q2 = toList q1 == toList q2 - -instance Show a => Show (Queue a) where - showsPrec d q = showsPrec d (toList q) - - -{-------------------------------------------------------------------- - Smart constructor: - Note that @(queue xs ys zs)@ is always called with - @(length zs == length xs - length ys + 1)@. and thus - @rotate@ is always called when @(length xs == length ys+1)@. ---------------------------------------------------------------------} -balance :: [a] -> [a] -> Queue a -balance xs ys - = Queue qs [] qs - where - qs = xs ++ reverse ys - -queue :: [a] -> [a] -> [a] -> Queue a -queue xs ys (z:zs) = Queue xs ys zs -queue xs ys [] = Queue qs [] qs - where - qs = rotate xs ys [] - --- @(rotate xs ys []) == xs ++ reverse ys)@ -rotate :: [a] -> [a] -> [a] -> [a] -rotate [] [y] zs = y:zs -rotate (x:xs) (y:ys) zs = x:rotate xs ys (y:zs) -rotate xs ys zs = error "Queue.rotate: unbalanced queue" - - -valid :: Queue a -> Bool -valid (Queue xs ys zs) - = (P.length zs == P.length xs - P.length ys) && (P.length ys <= P.length xs) - -{- -{-------------------------------------------------------------------- - QuickCheck ---------------------------------------------------------------------} -qcheck prop - = check config prop - where - config = Config - { configMaxTest = 500 - , configMaxFail = 10000 - , configSize = \n -> (div n 2 + 3) - , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] - } - - -{-------------------------------------------------------------------- - Arbitrary, reasonably balanced queues ---------------------------------------------------------------------} -instance Arbitrary a => Arbitrary (Queue a) where - arbitrary = do{ qs <- arbitrary - ; let (ys,xs) = splitAt (P.length qs `div` 2) qs - ; return (Queue xs ys (xs ++ reverse ys)) - } - - -prop_Valid :: Queue Int -> Bool -prop_Valid q - = valid q - -prop_InsertLast :: [Int] -> Property -prop_InsertLast xs - = not (null xs) ==> head (foldr insert empty xs) == last xs - -prop_InsertValid :: [Int] -> Bool -prop_InsertValid xs - = valid (foldr insert empty xs) - -prop_Queue :: [Int] -> Bool -prop_Queue xs - = toList (foldl (flip insert) empty xs) == foldr (:) [] xs - -prop_List :: [Int] -> Bool -prop_List xs - = toList (fromList xs) == xs - -prop_TailValid :: [Int] -> Bool -prop_TailValid xs - = valid (tail (foldr insert empty (1:xs))) --} - diff --git a/src/UU/DData/Scc.hs b/src/UU/DData/Scc.hs deleted file mode 100644 --- a/src/UU/DData/Scc.hs +++ /dev/null @@ -1,309 +0,0 @@ --------------------------------------------------------------------------------- -{-| Module : Scc - Copyright : (c) Daan Leijen 2002 - License : BSD-style - - Maintainer : daan@cs.uu.nl - Stability : provisional - Portability : portable - - Compute the /strongly connected components/ of a directed graph. - The implementation is based on the following article: - - * David King and John Launchbury, /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/, - ACM Principles of Programming Languages, San Francisco, 1995. - - In contrast to their description, this module doesn't use lazy state - threads but is instead purely functional -- using the "Map" and "Set" module. - This means that the complexity of 'scc' is /O(n*log n)/ instead of /O(n)/ but - due to the hidden constant factor, this implementation performs very well in practice. --} ----------------------------------------------------------------------------------} -module UU.DData.Scc ( scc ) where - -import qualified UU.DData.Map as Map -import qualified UU.DData.Set as Set - -{- --- just for testing -import Debug.QuickCheck -import List(nub,sort) --} - -{-------------------------------------------------------------------- - Graph ---------------------------------------------------------------------} --- | A @Graph v@ is a directed graph with nodes @v@. -newtype Graph v = Graph (Map.Map v [v]) - --- | An @Edge v@ is a pair @(x,y)@ that represents an arrow from --- node @x@ to node @y@. -type Edge v = (v,v) -type Node v = (v,[v]) - -{-------------------------------------------------------------------- - Conversion ---------------------------------------------------------------------} -nodes :: Graph v -> [Node v] -nodes (Graph g) - = Map.toList g - -graph :: Ord v => [Node v] -> Graph v -graph es - = Graph (Map.fromListWith (++) es) - -{-------------------------------------------------------------------- - Graph functions ---------------------------------------------------------------------} -edges :: Graph v -> [Edge v] -edges g - = [(v,w) | (v,vs) <- nodes g, w <- vs] - -vertices :: Graph v -> [v] -vertices g - = [v | (v,vs) <- nodes g] - -successors :: Ord v => v -> Graph v -> [v] -successors v (Graph g) - = Map.findWithDefault [] v g - -transpose :: Ord v => Graph v -> Graph v -transpose g@(Graph m) - = Graph (foldr add empty (edges g)) - where - empty = Map.map (const []) m - add (v,w) m = Map.adjust (v:) w m - - -{-------------------------------------------------------------------- - Depth first search and forests ---------------------------------------------------------------------} -data Tree v = Node v (Forest v) -type Forest v = [Tree v] - -dff :: Ord v => Graph v -> Forest v -dff g - = dfs g (vertices g) - -dfs :: Ord v => Graph v -> [v] -> Forest v -dfs g vs - = prune (map (tree g) vs) - -tree :: Ord v => Graph v -> v -> Tree v -tree g v - = Node v (map (tree g) (successors v g)) - -prune :: Ord v => Forest v -> Forest v -prune fs - = snd (chop Set.empty fs) - where - chop ms [] = (ms,[]) - chop ms (Node v vs:fs) - | visited = chop ms fs - | otherwise = let ms0 = Set.insert v ms - (ms1,vs') = chop ms0 vs - (ms2,fs') = chop ms1 fs - in (ms2,Node v vs':fs') - where - visited = Set.member v ms - -{-------------------------------------------------------------------- - Orderings ---------------------------------------------------------------------} -preorder :: Ord v => Graph v -> [v] -preorder g - = preorderF (dff g) - -preorderF fs - = concatMap preorderT fs - -preorderT (Node v fs) - = v:preorderF fs - -postorder :: Ord v => Graph v -> [v] -postorder g - = postorderF (dff g) - -postorderT t - = postorderF [t] - -postorderF ts - = postorderF' ts [] - where - -- efficient concatenation by passing the tail around. - postorderF' [] tl = tl - postorderF' (t:ts) tl = postorderT' t (postorderF' ts tl) - postorderT' (Node v fs) tl = postorderF' fs (v:tl) - - -{-------------------------------------------------------------------- - Strongly connected components ---------------------------------------------------------------------} - -{- | - Compute the strongly connected components of a graph. The algorithm - is tailored toward the needs of compiler writers that need to compute - recursive binding groups (for example, the original order is preserved - as much as possible). - - The expression (@scc xs@) computes the strongly connectected components - of graph @xs@. A graph is a list of nodes @(v,ws)@ where @v@ is the node - label and @ws@ a list of nodes where @v@ points to, ie. there is an - arrow\/dependency from @v@ to each node in @ws@. Here is an example - of @scc@: - -> Scc\> scc [(0,[1]),(1,[1,2,3]),(2,[1]),(3,[]),(4,[])] -> [[3],[1,2],[0],[4]] - - In an expression @(scc xs)@, the graph @xs@ should contain an entry for - every node in the graph, ie: - -> all (`elem` nodes) targets -> where nodes = map fst xs -> targets = concat (map snd xs) - - Furthermore, the returned components consist exactly of the original nodes: - -> sort (concat (scc xs)) == sort (map fst xs) - - The connected components are sorted by dependency, ie. there are - no arrows\/dependencies from left-to-right. Furthermore, the original order - is preserved as much as possible. --} -scc :: Ord v => [(v,[v])] -> [[v]] -scc nodes - = sccG (graph nodes) - -sccG :: Ord v => Graph v -> [[v]] -sccG g - = map preorderT (sccF g) - -sccF :: Ord v => Graph v -> Forest v -sccF g - = reverse (dfs (transpose g) (topsort g)) - -topsort g - = reverse (postorder g) - -{-------------------------------------------------------------------- - Reachable and path ---------------------------------------------------------------------} -reachable v g - = preorderF (dfs g [v]) - -path v w g - = elem w (reachable v g) - - -{-------------------------------------------------------------------- - Show ---------------------------------------------------------------------} -instance Show v => Show (Graph v) where - showsPrec d (Graph m) = shows m - -instance Show v => Show (Tree v) where - showsPrec d (Node v []) = shows v - showsPrec d (Node v fs) = shows v . showList fs - - -{-------------------------------------------------------------------- - Quick Test ---------------------------------------------------------------------} -tgraph0 :: Graph Int -tgraph0 = graph - [(0,[1]) - ,(1,[2,1,3]) - ,(2,[1]) - ,(3,[]) - ] - -tgraph1 = graph - [ ('a',"jg") - , ('b',"ia") - , ('c',"he") - , ('d',"") - , ('e',"jhd") - , ('f',"i") - , ('g',"fb") - , ('h',"") - ] - -{- -{-------------------------------------------------------------------- - 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 Graph's ---------------------------------------------------------------------} -instance (Ord v,Arbitrary v) => Arbitrary (Graph v) where - arbitrary = sized arbgraph - - -arbgraph :: (Ord v,Arbitrary v) => Int -> Gen (Graph v) -arbgraph n - = do nodes <- arbitrary - g <- mapM (targets nodes) nodes - return (graph g) - where - targets nodes v - = do sz <- choose (0,length nodes-1) - ts <- mapM (target nodes) [1..sz] - return (v,ts) - - target nodes _ - = do idx <- choose (0,length nodes-1) - return (nodes!!idx) - -{-------------------------------------------------------------------- - Properties ---------------------------------------------------------------------} -prop_ValidGraph :: Graph Int -> Bool -prop_ValidGraph g - = all (`elem` srcs) targets - where - srcs = map fst (nodes g) - targets = concatMap snd (nodes g) - --- all scc nodes are in the original graph and the other way around -prop_SccComplete :: Graph Int -> Bool -prop_SccComplete g - = sort (concat (sccG g)) == sort (vertices g) - --- all scc nodes have only backward dependencies -prop_SccForward :: Graph Int -> Bool -prop_SccForward g - = all noforwards (zip prevs ss) - where - ss = sccG g - prevs = scanl1 (++) ss - - noforwards (prev,xs) - = all (noforward prev) xs - - noforward prev x - = all (`elem` prev) (successors x g) - --- all strongly connected components refer to each other -prop_SccConnected :: Graph Int -> Bool -prop_SccConnected g - = all connected (sccG g) - where - connected xs - = all (paths xs) xs - - paths xs x - = all (\y -> path x y g) xs - --} - diff --git a/src/UU/DData/Seq.hs b/src/UU/DData/Seq.hs deleted file mode 100644 --- a/src/UU/DData/Seq.hs +++ /dev/null @@ -1,91 +0,0 @@ --------------------------------------------------------------------------------- -{-| Module : Seq - Copyright : (c) Daan Leijen 2002 - License : BSD-style - - Maintainer : daan@cs.uu.nl - Stability : provisional - Portability : portable - - An implementation of John Hughes's efficient catenable sequence type. A lazy sequence - @Seq a@ can be concatenated in /O(1)/ time. After - construction, the sequence in converted in /O(n)/ time into a list. --} ----------------------------------------------------------------------------------} -module UU.DData.Seq( -- * Type - Seq - -- * Operators - , (<>) - - -- * Construction - , empty - , single - , cons - , append - - -- * Conversion - , toList - , fromList - ) where - - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} -infixr 5 <> - --- | /O(1)/. Append two sequences, see 'append'. -(<>) :: Seq a -> Seq a -> Seq a -s <> t - = append s t - -{-------------------------------------------------------------------- - Type ---------------------------------------------------------------------} --- | Sequences of values @a@. -newtype Seq a = Seq ([a] -> [a]) - -{-------------------------------------------------------------------- - Construction ---------------------------------------------------------------------} --- | /O(1)/. Create an empty sequence. -empty :: Seq a -empty - = Seq (\ts -> ts) - --- | /O(1)/. Create a sequence of one element. -single :: a -> Seq a -single x - = Seq (\ts -> x:ts) - --- | /O(1)/. Put a value in front of a sequence. -cons :: a -> Seq a -> Seq a -cons x (Seq f) - = Seq (\ts -> x:f ts) - --- | /O(1)/. Append two sequences. -append :: Seq a -> Seq a -> Seq a -append (Seq f) (Seq g) - = Seq (\ts -> f (g ts)) - - -{-------------------------------------------------------------------- - Conversion ---------------------------------------------------------------------} --- | /O(n)/. Convert a sequence to a list. -toList :: Seq a -> [a] -toList (Seq f) - = f [] - --- | /O(n)/. Create a sequence from a list. -fromList :: [a] -> Seq a -fromList xs - = Seq (\ts -> xs++ts) - - - - - - - - diff --git a/src/UU/DData/Set.hs b/src/UU/DData/Set.hs deleted file mode 100644 --- a/src/UU/DData/Set.hs +++ /dev/null @@ -1,1032 +0,0 @@ --------------------------------------------------------------------------------- -{-| Module : Set - Copyright : (c) Daan Leijen 2002 - License : BSD-style - - Maintainer : daan@cs.uu.nl - Stability : provisional - Portability : portable - - An efficient implementation of sets. - - 1) The 'filter' function clashes with the "Prelude". - If you want to use "Set" unqualified, this function should be hidden. - - > import Prelude hiding (filter) - > import Set - - Another solution is to use qualified names. This is also the only way how - a "Map", "Set", and "MultiSet" can be used within one module. - - > import qualified Set - > - > ... Set.single "Paris" - - Or, if you prefer a terse coding style: - - > import qualified Set as S - > - > ... S.single "Berlin" - - 2) 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. - - 3) Note that the implementation /left-biased/ -- the elements of a first argument - are always perferred to the second, for example in 'union' or 'insert'. - Off course, left-biasing can only be observed when equality an equivalence relation - instead of structural equality. - - 4) Another implementation of sets based on size balanced trees - exists as "Data.Set" in the Ghc libraries. The good part about this library - is that it is highly tuned and thorougly tested. However, it is also fairly old, - it is implemented indirectly on top of "Data.FiniteMap" and only supports - the basic set operations. - The "Set" module overcomes some of these issues: - - * It tries to export a more complete and consistent set of operations, like - 'partition', 'subset' etc. - - * It uses the efficient /hedge/ algorithm for both 'union' and 'difference' - (a /hedge/ algorithm is not applicable to 'intersection'). - - * It converts ordered lists in linear time ('fromAscList'). - - * It takes advantage of the module system with names like 'empty' instead of 'Data.Set.emptySet'. - - * It is implemented directly, instead of using a seperate finite map implementation. --} ---------------------------------------------------------------------------------- -module UU.DData.Set ( - -- * Set type - Set -- instance Eq,Show - - -- * Operators - , (\\) - - -- * Query - , isEmpty - , size - , member - , subset - , properSubset - - -- * Construction - , empty - , single - , insert - , delete - - -- * Combine - , union, unions - , difference - , intersection - - -- * Filter - , filter - , partition - , split - , splitMember - - -- * Fold - , fold - - -- * Min\/Max - , findMin - , findMax - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax - - -- * Conversion - - -- ** List - , elems - , toList - , fromList - - -- ** Ordered list - , toAscList - , fromAscList - , fromDistinctAscList - - -- * Debugging - , showTree - , showTreeWith - , valid - ) where - -import Prelude hiding (filter) - -{- --- just for testing -import QuickCheck -import List (nub,sort) -import qualified List --} - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} -infixl 9 \\ -- - --- | /O(n+m)/. See 'difference'. -(\\) :: Ord a => Set a -> Set a -> Set a -m1 \\ m2 = difference m1 m2 - -{-------------------------------------------------------------------- - Sets are size balanced trees ---------------------------------------------------------------------} --- | A set of values @a@. -data Set a = Tip - | Bin !Size a !(Set a) !(Set a) - -type Size = Int - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} --- | /O(1)/. Is this the empty set? -isEmpty :: Set a -> Bool -isEmpty 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. -single :: a -> Set a -single 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 -> single 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). -properSubset :: Ord a => Set a -> Set a -> Bool -properSubset s1 s2 - = (size s1 < size s2) && (subset s1 s2) - - --- | /O(n+m)/. Is this a subset? -subset :: Ord a => Set a -> Set a -> Bool -subset t1 t2 - = (size t1 <= size t2) && (subsetX t1 t2) - -subsetX Tip t = True -subsetX t Tip = False -subsetX (Bin _ x l r) t - = found && subsetX l lt && subsetX 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. -union :: Ord a => Set a -> Set a -> Set a -union Tip t2 = t2 -union t1 Tip = t1 -union t1 t2 -- hedge-union is more efficient on (bigset `union` smallset) - | size t1 >= size t2 = hedgeUnion (const LT) (const GT) t1 t2 - | otherwise = hedgeUnion (const LT) (const GT) t2 t1 - -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 - -{-------------------------------------------------------------------- - 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 - -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 - -{-------------------------------------------------------------------- - Intersection ---------------------------------------------------------------------} --- | /O(n+m)/. The intersection of two sets. -intersection :: Ord a => Set a -> Set a -> Set a -intersection Tip t = Tip -intersection t Tip = Tip -intersection t1 t2 -- intersection is more efficient on (bigset `intersection` smallset) - | size t1 >= size t2 = intersect t1 t2 - | otherwise = intersect t2 t1 - -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 - -{-------------------------------------------------------------------- - Fold ---------------------------------------------------------------------} --- | /O(n)/. Fold the elements of a set. -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 a 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 map from an ascending list in linear time. -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. -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 (single x1) (single x3)) (single 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) - -{-------------------------------------------------------------------- - 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@. -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 -> single x - Bin sz y l r - -> balance y l (insertMax x r) - -insertMin x t - = case t of - Tip -> single 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 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 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 == single 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 (single 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)) --} diff --git a/src/UU/Parsing/Offside.hs b/src/UU/Parsing/Offside.hs --- a/src/UU/Parsing/Offside.hs +++ b/src/UU/Parsing/Offside.hs @@ -5,7 +5,9 @@ , pOpen , pClose , pSeparator - , scanOffside + , scanOffside + , scanOffsideWithTriggers + , OffsideTrigger(..) , OffsideSymbol(..) , OffsideInput , Stream @@ -13,100 +15,118 @@ ) where import GHC.Prim +import Data.Maybe import UU.Parsing.Interface import UU.Parsing.Machine import UU.Parsing.Derived(opt, pFoldr1Sep,pList,pList1, pList1Sep) import UU.Scanner.Position -data OffsideSymbol s = - Symbol s - | SemiColon - | CloseBrace - | OpenBrace - deriving (Ord,Eq,Show) +data OffsideTrigger + = Trigger_IndentGT + | Trigger_IndentGE + deriving Eq +data OffsideSymbol s + = Symbol s + | SemiColon + | CloseBrace + | OpenBrace + deriving (Ord,Eq,Show) +data Stream inp s p + = Cons (OffsideSymbol s) (OffsideInput inp s p) + | End inp + +data IndentContext + = Cxt Bool -- properties: allows nesting on equal indentation (triggered by Trigger_IndentGE) + Int -- indentation + +data OffsideInput inp s p + = Off p -- position + (Stream inp s p) -- input stream + (Maybe (OffsideInput inp s p)) -- next in stack of nested OffsideInput's + scanOffside :: (InputState i s p, Position p, Eq s) => s -> s -> s -> [s] -> i -> OffsideInput i s p -scanOffside mod open close triggers ts = start ts [] +scanOffside mod open close triggers ts + = scanOffsideWithTriggers mod open close (zip (repeat Trigger_IndentGT) triggers) ts + +scanOffsideWithTriggers :: (InputState i s p, Position p, Eq s) + => s -> s -> s -> [(OffsideTrigger,s)] -> i -> OffsideInput i s p +scanOffsideWithTriggers mod open close triggers ts = start ts [] where - isModule t = t == mod - isOpen t = t == open - isClose t = t == close - isTrigger t = t `elem` triggers + isModule t = t == mod + isOpen t = t == open + isClose t = t == close + isTrigger tr = \t -> t `elem` triggers' + where triggers' = [ s | (tr',s) <- triggers, tr == tr' ] + isTriggerGT = isTrigger Trigger_IndentGT + isTriggerGE = isTrigger Trigger_IndentGE end ts = Off (getPosition ts) (End ts) cons :: p -> OffsideSymbol s -> OffsideInput i s p -> OffsideInput i s p cons p s r = Off p (Cons s r) Nothing start = case splitStateE ts of - Left' t _ | not (isModule t || isOpen t) -> implicitL 0 (column (getPosition ts) ) + Left' t _ | not (isModule t || isOpen t) -> implicitL 0 (Cxt False (column (getPosition ts))) _ -> layoutL 0 - -- L (:ts) (m:ms) = ; : (L ts (m:ms)) if m = n - -- = } : (L (:ts) ms) if n < m - -- L (:ts) ms = L ts ms - startlnL l n ts (m:ms) | m == n = cons (getPosition ts) SemiColon (layoutL (line (getPosition ts)) ts (m:ms)) - | n < m = cons (getPosition ts) CloseBrace (startlnL l n ts ms) - startlnL l n ts ms = layoutL (line (getPosition ts)) ts ms - -- L ({n}:ts) (m:ms) = { : (L ts (n:m:ms)) if n > m (Note 1) - -- L ({n}:ts) [] = { : (L ts [n]) if n > 0 (Note 1) + -- L (:ts) (m:ms) = ; : (L ts (m:ms)) if m = n + -- = } : (L (:ts) ms) if n < m + -- L (:ts) ms = L ts ms + startlnL l n ts (m:ms) | m == n = cons (getPosition ts) SemiColon (layoutL (line (getPosition ts)) ts (m:ms)) + | n < m = cons (getPosition ts) CloseBrace (startlnL l n ts ms) + startlnL l n ts ms = layoutL (line (getPosition ts)) ts ms + + -- L ({n}:ts) (m:ms) = { : (L ts (n:m:ms)) if n > m (Note 1) + -- L ({n}:ts) (m:ms) = { : (L ts (n:m:ms)) if n >= m (as per Haskell2010, inside a do only) + -- L ({n}:ts) [] = { : (L ts [n]) if n > 0 (Note 1) -- L ({n}:ts) ms = { : } : (L (:ts) ms) (Note 2) - implicitL l n ts (m:ms) | n > m = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts (n:m:ms)) - implicitL l n ts [] | n > 0 = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts [n]) - implicitL l n ts ms = cons (getPosition ts) OpenBrace (cons (getPosition ts) CloseBrace (startlnL l n ts ms)) - layoutL ln ts ms | ln /= sln = startln (column pos) ts ms - | otherwise = sameln ts ms + implicitL l (Cxt ge n) ts (m:ms) | n > m + || (n >= m && ge) + = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts (n:m:ms)) + implicitL l (Cxt _ n) ts [] | n > 0 = cons (getPosition ts) OpenBrace (layoutL (line (getPosition ts)) ts [n]) + implicitL l (Cxt _ n) ts ms = cons (getPosition ts) OpenBrace (cons (getPosition ts) CloseBrace (startlnL l n ts ms)) + + layoutL ln ts ms | ln /= sln = startln (column pos) ts ms + | otherwise = sameln ts ms - where sln = line pos - pos = getPosition ts + where sln = line pos + pos = getPosition ts layout = layoutL ln implicit = implicitL ln - startln = startlnL ln + startln = startlnL ln -- If a let ,where ,do , or of keyword is not followed by the lexeme {, -- the token {n} is inserted after the keyword, where nis the indentation of -- the next lexeme if there is one, or 0 if the end of file has been reached. - aftertrigger ts ms = case splitStateE ts of - Left' t _ | isOpen t -> layout ts ms - | otherwise -> implicit (column(getPosition ts)) ts ms - Right' _ -> implicit 0 ts ms + aftertrigger isTriggerGE ts ms + = case splitStateE ts of + Left' t _ | isOpen t -> layout ts ms + | otherwise -> implicit (Cxt isTriggerGE (column(getPosition ts))) ts ms + Right' _ -> implicit (Cxt False 0 ) ts ms -- L ( }:ts) (0:ms) = } : (L ts ms) (Note 3) - -- L ( }:ts) ms = parse-error (Note 3), matching of implicit/explicit braces is handled by parser + -- L ( }:ts) ms = parse-error (Note 3), matching of implicit/explicit braces is handled by parser -- L ( {:ts) ms = {: (L ts (0:ms)) (Note 4) -- L (t:ts) (m:ms) = }: (L (t:ts) ms) if m /= 0 and parse-error(t) (Note 5) -- L (t:ts) ms = t : (L ts ms) - sameln tts ms = case splitStateE tts of + sameln tts ms + = case splitStateE tts of Left' t ts -> let tail - | isTrigger t = aftertrigger ts ms - | isClose t = case ms of - 0:rs -> layout ts rs - _ -> layout ts ms + | isTriggerGE t = aftertrigger True ts ms + | isTriggerGT t = aftertrigger False ts ms + | isClose t = case ms of + 0:rs -> layout ts rs + _ -> layout ts ms - | isOpen t = layout ts (0:ms) - | otherwise = layout ts ms + | isOpen t = layout ts (0:ms) + | otherwise = layout ts ms parseError = case ms of m:ms | m /= 0 -> Just (layout tts ms) _ -> Nothing in Off pos (Cons (Symbol t) tail) parseError Right' rest -> endofinput pos rest ms where pos = getPosition tts -{- - sameln tts ms = case splitStateE tts of - Left' t ts | isTrigger t -> cons pos (Symbol t) (aftertrigger ts ms) - | isClose t -> cons pos (Symbol t) - (case ms of - 0:ms -> layout ts ms - _ -> layout ts ms - ) - | isOpen t -> cons pos (Symbol t) (layout ts (0:ms)) - | otherwise -> let parseError = case ms of - m:ms | m /= 0 -> Just (layout tts ms) - _ -> Nothing - in Off pos (Cons (Symbol t) (layout ts ms)) parseError - Right' rest -> endofinput pos rest ms - where pos = getPosition tts --} -- L [] [] = [] -- L [] (m:ms) = } : L [] ms if m /=0 (Note 6) @@ -116,18 +136,17 @@ | otherwise = endofinput pos rest ms -data Stream inp s p = Cons (OffsideSymbol s) (OffsideInput inp s p) - | End inp - -data OffsideInput inp s p = Off p (Stream inp s p) (Maybe (OffsideInput inp s p)) - instance InputState inp s p => InputState (OffsideInput inp s p) (OffsideSymbol s) p where - splitStateE inp@(Off p stream _) = case stream of - Cons s rest -> Left' s rest - _ -> Right' inp - splitState (Off _ stream _) = - case stream of - Cons s rest -> (# s ,rest #) + splitStateE inp@(Off p stream _) + = case stream of + Cons s rest -> Left' s rest + where take 0 _ = [] + take _ (Off _ (End _) _) = [] + take n (Off _ (Cons h t) _) = h : take (n-1) t + _ -> Right' inp + splitState (Off _ stream _) + = case stream of + Cons s rest -> (# s, rest #) getPosition (Off pos _ _ ) = pos @@ -140,7 +159,7 @@ symBefore s = case s of Symbol s -> Symbol (symBefore s) SemiColon -> error "Symbol.symBefore SemiColon" - OpenBrace -> error "Symbol.symBeforeOpenBrace" + OpenBrace -> error "Symbol.symBefore OpenBrace" CloseBrace -> error "Symbol.symBefore CloseBrace" symAfter s = case s of Symbol s -> Symbol (symAfter s) @@ -198,9 +217,12 @@ pClose = OP (pWrap f g ( () <$ pSym CloseBrace) ) where g state steps1 k = (state,ar,k) where ar = case state of - Off _ _ (Just state') -> let steps2 = k state' - in if not (hasSuccess steps1) && hasSuccess steps2 then steps2 else steps1 - _ -> steps1 + Off _ _ (Just state') + -> let steps2 = k state' + in if not (hasSuccess steps1) && hasSuccess steps2 + then Cost 1# steps2 + else steps1 + _ -> steps1 f acc state steps k = let (stl,ar,str2rr) = g state (val snd steps) k in (stl ,val (acc ()) ar , str2rr ) @@ -224,11 +246,18 @@ -> OffsideParser i o s p a -> OffsideParser i o s p [a] pBlock open sep close p = pOffside open close explicit implicit + where elem = (Just <$> p) `opt` Nothing + sep' = () <$ sep + elems s = (\h t -> catMaybes (h:t)) <$> elem <*> pList (s *> elem) + explicit = elems sep' + implicit = elems (sep' <|> pSeparator) +{- where elem = (:) <$> p `opt` id sep' = () <$ sep elems s = ($[]) <$> pFoldr1Sep ((.),id) s elem explicit = elems sep' implicit = elems (sep' <|> pSeparator) +-} pBlock1 :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) => OffsideParser i o s p x @@ -237,11 +266,34 @@ -> OffsideParser i o s p a -> OffsideParser i o s p [a] pBlock1 open sep close p = pOffside open close explicit implicit + where elem = (Just <$> p) `opt` Nothing + sep' = () <$ sep + elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList (s *> elem) + explicit = elems sep' + implicit = elems (sep' <|> pSeparator) +{- + where elem = (Just <$> p) `opt` Nothing + sep' = () <$ sep + elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList ( s *> elem) + explicit = elems sep' + implicit = elems (sep' <|> pSeparator) +-} +{- +pBlock1 open sep close p = pOffside open close explicit implicit + where elem = (Just <$> p) <|> pSucceed Nothing + sep' = () <$ sep + elems s = (\h t -> catMaybes (h:t)) <$ pList s <*> (Just <$> p) <*> pList ( s *> elem) + explicit = elems sep' + implicit = elems (sep' <|> pSeparator) +-} +{- +pBlock1 open sep close p = pOffside open close explicit implicit where elem = (:) <$> p `opt` id sep' = () <$ sep elems s = (:) <$ pList s <*> p <*> (($[]) <$> pFoldr1Sep ((.),id) s elem) explicit = elems sep' implicit = elems (sep' <|> pSeparator) +-} {- pBlock1 open sep close p = pOffside open close explicit implicit where sep' = () <$ sep diff --git a/uulib.cabal b/uulib.cabal --- a/uulib.cabal +++ b/uulib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.1 build-type: Simple name: uulib -version: 0.9.10 +version: 0.9.11 license: LGPL license-file: COPYRIGHT maintainer: Arie Middelkoop @@ -21,24 +21,21 @@ description: ghc-prim as separate module library if flag(have_ghc_prim) - build-depends: base>=4, ghc-prim + build-depends: base>=4 && <10, ghc-prim else build-depends: base<4 build-depends: haskell98 exposed-modules: UU.Parsing.CharParser UU.Parsing.Derived UU.Parsing.Interface UU.Parsing.MachineInterface UU.Parsing.Merge UU.Parsing.Offside UU.Parsing.Perms - UU.Parsing.StateParser UU.Parsing UU.DData.IntBag - UU.DData.Map UU.DData.MultiSet UU.DData.Queue - UU.DData.Scc UU.DData.Seq UU.DData.Set UU.PPrint + UU.Parsing.StateParser UU.Parsing + UU.PPrint UU.Pretty.Ext UU.Pretty UU.Scanner.GenToken UU.Scanner.GenTokenOrd UU.Scanner.GenTokenParser UU.Scanner.GenTokenSymbol UU.Scanner.Position UU.Scanner.Scanner UU.Scanner.Token UU.Scanner.TokenParser UU.Scanner.TokenShow UU.Scanner UU.Util.BinaryTrees UU.Util.PermTree UU.Util.Utils UU.Pretty.Basic UU.Parsing.Machine - UU.DData.IntMap - UU.DData.IntSet extensions: RankNTypes FunctionalDependencies TypeSynonymInstances UndecidableInstances FlexibleInstances MultiParamTypeClasses FlexibleContexts CPP ExistentialQuantification ghc-options: -fglasgow-exts hs-source-dirs: src