X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FSet.hs;h=5f45ce9079a9359a9279e7e09e13aa3429d52500;hb=a70f356e023abdd0abb130cc149b0e3de7469044;hp=b357f96d852b9c8930e91123e21c3d433f4eebdb;hpb=0d6c1599c246100deb2fa54315811ed94d1a300c;p=haskell-directory.git

diff --git a/Data/Set.hs b/Data/Set.hs
index b357f96..5f45ce9 100644
--- a/Data/Set.hs
+++ b/Data/Set.hs
@@ -9,10 +9,11 @@
 --
 -- An efficient implementation of sets.
 --
--- This module is intended to be imported @qualified@, to avoid name
--- clashes with "Prelude" functions.  eg.
+-- Since many function names (but not the type name) clash with
+-- "Prelude" names, this module is usually imported @qualified@, e.g.
 --
--- >  import Data.Set as Set
+-- >  import Data.Set (Set)
+-- >  import qualified Data.Set as Set
 --
 -- The implementation of 'Set' is based on /size balanced/ binary trees (or
 -- trees of /bounded balance/) as described by:
@@ -26,7 +27,7 @@
 --	SIAM journal of computing 2(1), March 1973.
 --
 -- Note that the implementation is /left-biased/ -- the elements of a
--- first argument are always perferred to the second, for example in
+-- first argument are always preferred to the second, for example in
 -- 'union' or 'insert'.  Of course, left-biasing can only be observed
 -- when equality is an equivalence relation instead of structural
 -- equality.
@@ -34,7 +35,7 @@
 
 module Data.Set  ( 
             -- * Set type
-              Set          -- instance Eq,Show
+              Set          -- instance Eq,Ord,Show,Read,Data,Typeable
 
             -- * Operators
             , (\\)
@@ -43,6 +44,7 @@ module Data.Set  (
             , null
             , size
             , member
+            , notMember
             , isSubsetOf
             , isProperSubsetOf
             
@@ -77,6 +79,8 @@ module Data.Set  (
             , deleteMax
             , deleteFindMin
             , deleteFindMax
+            , maxView
+            , minView
 
             -- * Conversion
 
@@ -94,27 +98,13 @@ module Data.Set  (
             , showTree
             , showTreeWith
             , valid
-
-	-- * Old interface, DEPRECATED
-	,emptySet,       -- :: Set a
-	mkSet,          -- :: Ord a => [a]  -> Set a
-	setToList,      -- :: Set a -> [a] 
-	unitSet,        -- :: a -> Set a
-	elementOf,      -- :: Ord a => a -> Set a -> Bool
-	isEmptySet,     -- :: Set a -> Bool
-	cardinality,    -- :: Set a -> Int
-	unionManySets,  -- :: Ord a => [Set a] -> Set a
-	minusSet,       -- :: Ord a => Set a -> Set a -> Set a
-	mapSet,         -- :: Ord a => (b -> a) -> Set b -> Set a
-	intersect,      -- :: Ord a => Set a -> Set a -> Set a
-	addToSet,      	-- :: Ord a => Set a -> a -> Set a
-	delFromSet,    	-- :: Ord a => Set a -> a -> Set a
             ) where
 
-import Prelude hiding (filter,foldr,foldl,null,map)
-import Data.Monoid
+import Prelude hiding (filter,foldr,null,map)
 import qualified Data.List as List
+import Data.Monoid (Monoid(..))
 import Data.Typeable
+import Data.Foldable (Foldable(foldMap))
 
 {-
 -- just for testing
@@ -124,6 +114,7 @@ import qualified List
 -}
 
 #if __GLASGOW_HASKELL__
+import Text.Read
 import Data.Generics.Basics
 import Data.Generics.Instances
 #endif
@@ -146,12 +137,21 @@ data Set a    = Tip
 
 type Size     = Int
 
+instance Ord a => Monoid (Set a) where
+    mempty  = empty
+    mappend = union
+    mconcat = unions
+
+instance Foldable Set where
+    foldMap f Tip = mempty
+    foldMap f (Bin _s k l r) = foldMap f l `mappend` f k `mappend` foldMap f r
+
+#if __GLASGOW_HASKELL__
+
 {--------------------------------------------------------------------
   A Data instance  
 --------------------------------------------------------------------}
 
-#if __GLASGOW_HASKELL__
-
 -- This instance preserves data abstraction at the cost of inefficiency.
 -- We omit reflection services for the sake of data abstraction.
 
@@ -160,6 +160,7 @@ instance (Data a, Ord a) => Data (Set a) where
   toConstr _     = error "toConstr"
   gunfold _ _    = error "gunfold"
   dataTypeOf _   = mkNorepType "Data.Set.Set"
+  dataCast1 f    = gcast1 f
 
 #endif
 
@@ -191,6 +192,10 @@ member x t
                GT -> member x r
                EQ -> True       
 
+-- | /O(log n)/. Is the element not in the set?
+notMember :: Ord a => a -> Set a -> Bool
+notMember x t = not $ member x t
+
 {--------------------------------------------------------------------
   Construction
 --------------------------------------------------------------------}
@@ -208,6 +213,8 @@ singleton x
   Insertion, Deletion
 --------------------------------------------------------------------}
 -- | /O(log n)/. Insert an element in a set.
+-- If the set already contains an element equal to the given value,
+-- it is replaced with the new value.
 insert :: Ord a => a -> Set a -> Set a
 insert x t
   = case t of
@@ -240,7 +247,7 @@ isProperSubsetOf s1 s2
 
 
 -- | /O(n+m)/. Is this a subset?
--- @(s1 `isSubsetOf` s2)@ tells whether s1 is a subset of s2.
+-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.
 isSubsetOf :: Ord a => Set a -> Set a -> Bool
 isSubsetOf t1 t2
   = (size t1 <= size t2) && (isSubsetOfX t1 t2)
@@ -250,7 +257,7 @@ isSubsetOfX t Tip = False
 isSubsetOfX (Bin _ x l r) t
   = found && isSubsetOfX l lt && isSubsetOfX r gt
   where
-    (found,lt,gt) = splitMember x t
+    (lt,found,gt) = splitMember x t
 
 
 {--------------------------------------------------------------------
@@ -284,20 +291,20 @@ deleteMax Tip             = Tip
 {--------------------------------------------------------------------
   Union. 
 --------------------------------------------------------------------}
--- | The union of a list of sets: (@unions == foldl union empty@).
+-- | 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.
+-- | /O(n+m)/. The union of two sets, preferring the first set when
+-- equal elements are encountered.
+-- The implementation uses the efficient /hedge-union/ algorithm.
 -- Hedge-union is more efficient on (bigset `union` smallset).
 union :: Ord a => Set a -> Set a -> Set a
 union Tip t2  = t2
 union t1 Tip  = t1
-union t1 t2
-  | size t1 >= size t2  = hedgeUnion (const LT) (const GT) t1 t2
-  | otherwise           = hedgeUnion (const LT) (const GT) t2 t1
+union t1 t2 = hedgeUnion (const LT) (const GT) t1 t2
 
 hedgeUnion cmplo cmphi t1 Tip 
   = t1
@@ -333,24 +340,23 @@ hedgeDiff cmplo cmphi t (Bin _ x l r)
   Intersection
 --------------------------------------------------------------------}
 -- | /O(n+m)/. The intersection of two sets.
--- Intersection is more efficient on (bigset `intersection` smallset).
+-- Elements of the result come from the first set.
 intersection :: Ord a => Set a -> Set a -> Set a
 intersection Tip t = Tip
 intersection t Tip = Tip
-intersection t1 t2
-  | size t1 >= size t2  = intersect' t1 t2
-  | otherwise           = intersect' t2 t1
-
-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
-
+intersection t1@(Bin s1 x1 l1 r1) t2@(Bin s2 x2 l2 r2) =
+   if s1 >= s2 then
+      let (lt,found,gt) = splitLookup x2 t1
+          tl            = intersection lt l2
+          tr            = intersection gt r2
+      in case found of
+      Just x -> join x tl tr
+      Nothing -> merge tl tr
+   else let (lt,found,gt) = splitMember x1 t2
+            tl            = intersection l1 lt
+            tr            = intersection r1 gt
+        in if found then join x1 tl tr
+           else merge tl tr
 
 {--------------------------------------------------------------------
   Filter and partition
@@ -379,7 +385,7 @@ partition p (Bin _ x l r)
 ----------------------------------------------------------------------}
 
 -- | /O(n*log n)/. 
--- @map f s@ is the set obtained by applying @f@ to each element of @s@.
+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.
 -- 
 -- It's worth noting that the size of the result may be smaller if,
 -- for some @(x,y)@, @x \/= y && f x == f y@
@@ -389,7 +395,7 @@ map f = fromList . List.map f . toList
 
 -- | /O(n)/. The 
 --
--- @mapMonotonic f s == 'map' f s@, but works only when @f@ is monotonic.
+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic.
 -- /The precondition is not checked./
 -- Semi-formally, we have:
 -- 
@@ -427,7 +433,7 @@ elems s
 {--------------------------------------------------------------------
   Lists 
 --------------------------------------------------------------------}
--- | /O(n)/. Convert the set to an ascending list of elements.
+-- | /O(n)/. Convert the set to a list of elements.
 toList :: Set a -> [a]
 toList s
   = toAscList s
@@ -506,19 +512,11 @@ instance Ord a => Ord (Set a) where
     compare s1 s2 = compare (toAscList s1) (toAscList s2) 
 
 {--------------------------------------------------------------------
-  Monoid 
---------------------------------------------------------------------}
-
-instance Ord a => Monoid (Set a) where
-    mempty = empty
-    mappend = union
-    mconcat = unions
-
-{--------------------------------------------------------------------
   Show
 --------------------------------------------------------------------}
 instance Show a => Show (Set a) where
-  showsPrec d s  = showSet (toAscList s)
+  showsPrec p xs = showParen (p > 10) $
+    showString "fromList " . shows (toList xs)
 
 showSet :: (Show a) => [a] -> ShowS
 showSet []     
@@ -528,7 +526,24 @@ showSet (x:xs)
   where
     showTail []     = showChar '}'
     showTail (x:xs) = showChar ',' . shows x . showTail xs
-    
+
+{--------------------------------------------------------------------
+  Read
+--------------------------------------------------------------------}
+instance (Read a, Ord a) => Read (Set a) where
+#ifdef __GLASGOW_HASKELL__
+  readPrec = parens $ prec 10 $ do
+    Ident "fromList" <- lexP
+    xs <- readPrec
+    return (fromList xs)
+
+  readListPrec = readListPrecDefault
+#else
+  readsPrec p = readParen (p > 10) $ \ r -> do
+    ("fromList",s) <- lex r
+    (xs,t) <- reads s
+    return (fromList xs,t)
+#endif
 
 {--------------------------------------------------------------------
   Typeable/Data
@@ -603,7 +618,7 @@ filterLt cmp (Bin sx x l r)
 {--------------------------------------------------------------------
   Split
 --------------------------------------------------------------------}
--- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@
+-- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@
 -- where all elements in @set1@ are lower than @x@ and all elements in
 -- @set2@ larger than @x@. @x@ is not found in neither @set1@ nor @set2@.
 split :: Ord a => a -> Set a -> (Set a,Set a)
@@ -616,13 +631,19 @@ split x (Bin sy y 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)
+splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)
+splitMember x t = let (l,m,r) = splitLookup x t in
+     (l,maybe False (const True) m,r)
+
+-- | /O(log n)/. Performs a 'split' but also returns the pivot
+-- element that was found in the original set.
+splitLookup :: Ord a => a -> Set a -> (Set a,Maybe a,Set a)
+splitLookup x Tip = (Tip,Nothing,Tip)
+splitLookup x (Bin sy y l r)
+   = case compare x y of
+       LT -> let (lt,found,gt) = splitLookup x l in (lt,found,join y gt r)
+       GT -> let (lt,found,gt) = splitLookup x r in (join y l lt,found,gt)
+       EQ -> (l,Just y,r)
 
 {--------------------------------------------------------------------
   Utility functions that maintain the balance properties of the tree.
@@ -723,6 +744,21 @@ deleteFindMax t
       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)
 
+-- | /O(log n)/. Retrieves the minimal key of the set, and the set stripped from that element
+-- @fail@s (in the monad) when passed an empty set.
+minView :: Monad m => Set a -> m (Set a, a)
+minView Tip = fail "Set.minView: empty set"
+minView x = return (swap $ deleteFindMin x)
+
+-- | /O(log n)/. Retrieves the maximal key of the set, and the set stripped from that element
+-- @fail@s (in the monad) when passed an empty set.
+maxView :: Monad m => Set a -> m (Set a, a)
+maxView Tip = fail "Set.maxView: empty set"
+maxView x = return (swap $ deleteFindMax x)
+
+swap (a,b) = (b,a)
+
+
 
 {--------------------------------------------------------------------
   [balance x l r] balances two trees with value x.
@@ -831,7 +867,7 @@ showTree 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.
+ @wide@ is 'True', an extra wide version is shown.
 
 > Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]
 > 4
@@ -1105,72 +1141,3 @@ prop_List :: [Int] -> Bool
 prop_List xs
   = (sort (nub xs) == toList (fromList xs))
 -}
-
-{--------------------------------------------------------------------
-  Old Data.Set compatibility interface
---------------------------------------------------------------------}
-
-{-# DEPRECATED emptySet "Use empty instead" #-}
--- | Obsolete equivalent of 'empty'.
-emptySet :: Set a
-emptySet = empty
-
-{-# DEPRECATED mkSet "Use fromList instead" #-}
--- | Obsolete equivalent of 'fromList'.
-mkSet :: Ord a => [a]  -> Set a
-mkSet = fromList
-
-{-# DEPRECATED setToList "Use elems instead." #-}
--- | Obsolete equivalent of 'elems'.
-setToList :: Set a -> [a] 
-setToList = elems
-
-{-# DEPRECATED unitSet "Use singleton instead." #-}
--- | Obsolete equivalent of 'singleton'.
-unitSet :: a -> Set a
-unitSet = singleton
-
-{-# DEPRECATED elementOf "Use member instead." #-}
--- | Obsolete equivalent of 'member'.
-elementOf :: Ord a => a -> Set a -> Bool
-elementOf = member
-
-{-# DEPRECATED isEmptySet "Use null instead." #-}
--- | Obsolete equivalent of 'null'.
-isEmptySet :: Set a -> Bool
-isEmptySet = null
-
-{-# DEPRECATED cardinality "Use size instead." #-}
--- | Obsolete equivalent of 'size'.
-cardinality :: Set a -> Int
-cardinality = size
-
-{-# DEPRECATED unionManySets "Use unions instead." #-}
--- | Obsolete equivalent of 'unions'.
-unionManySets :: Ord a => [Set a] -> Set a
-unionManySets = unions
-
-{-# DEPRECATED minusSet "Use difference instead." #-}
--- | Obsolete equivalent of 'difference'.
-minusSet :: Ord a => Set a -> Set a -> Set a
-minusSet = difference
-
-{-# DEPRECATED mapSet "Use map instead." #-}
--- | Obsolete equivalent of 'map'.
-mapSet :: (Ord a, Ord b) => (b -> a) -> Set b -> Set a
-mapSet = map
-
-{-# DEPRECATED intersect "Use intersection instead." #-}
--- | Obsolete equivalent of 'intersection'.
-intersect :: Ord a => Set a -> Set a -> Set a
-intersect = intersection
-
-{-# DEPRECATED addToSet "Use 'flip insert' instead." #-}
--- | Obsolete equivalent of @'flip' 'insert'@.
-addToSet :: Ord a => Set a -> a -> Set a
-addToSet = flip insert
-
-{-# DEPRECATED delFromSet "Use `flip delete' instead." #-}
--- | Obsolete equivalent of @'flip' 'delete'@.
-delFromSet :: Ord a => Set a -> a -> Set a
-delFromSet = flip delete