disjoint-containers 0.1.0 → 0.2.0

raw patch · 4 files changed

+299/−39 lines, 4 filesdep +doctestdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: doctest

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• disjoint-containers.cabal +13/−1
• src/Data/DisjointMap.hs +152/−38
• src/Data/DisjointSet.hs +127/−0
• test/Doctest.hs +7/−0

@@ -1,5 +1,5 @@ name: disjoint-containers-version: 0.1.0+version: 0.2.0 synopsis: Disjoint containers description: Disjoint containers homepage: https://github.com/andrewthad/disjoint-containers#readme@@ -34,6 +34,18 @@     , containers     , QuickCheck   default-language: Haskell2010++test-suite doctest+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Doctest.hs+  build-depends:+      base+    , disjoint-containers+    , doctest >= 0.10+    , QuickCheck+  default-language:    Haskell2010+  source-repository head   type: git

@@ -1,18 +1,48 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}  {-# OPTIONS_GHC -Wall #-} +{-|+Maps with disjoint sets as the key. The type in this module can be+understood as:++> DisjointMap k v ≡ Map (DisjointSet k) v++However, actually using a 'Map' with @DisjointSet@ as the key+would offer terrible performance. This is because the 'Ord'+instance for @DisjointSet@ cannot be made to perform well.+Internally, @DisjointMap@ is implemented like a disjoint set+but the data structure that maps representatives to their rank also holds the value+associated with that representative element. Additionally, it holds the set+of all keys that in the same equivalence class as the representative.+This makes it possible to implementat functions like @foldlWithKeys\'@+efficiently.++-}+ module Data.DisjointMap   ( DisjointMap+    -- * Construction   , empty   , singleton   , singletons   , insert   , union+    -- * Query   , lookup+  , lookup'   , representative   , representative'+    -- * Conversion   , toLists+  , pretty+  , prettyList+  , foldlWithKeys'+    -- * Tutorial+    -- $tutorial   ) where  import Prelude hiding (lookup)@@ -24,15 +54,23 @@ import Data.Map (Map) import Data.Set (Set) import Data.Bifunctor (first)+import Data.Foldable (Foldable)+import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as M-import qualified Data.Map.Merge.Strict as MM import qualified Data.Set as S+import qualified GHC.OldList as L +-- | A map having disjoints sets of @k@ as keys and+--   @v@ as values. data DisjointMap k v = DisjointMap   !(Map k k) -- parents and values-  !(Map k (Ranked v)) -- ranks+  !(Map k (Ranked k v)) -- ranks+  deriving (Functor,Foldable,Traversable) -data Ranked b = Ranked {-# UNPACK #-} !Int !b+-- the name ranked is no longer totally appropriate since+-- a set of keys has been added in here as well.+data Ranked k v = Ranked {-# UNPACK #-} !Int !(Set k) !v+  deriving (Functor,Foldable,Traversable)  instance (Ord k, Monoid v) => Monoid (DisjointMap k v) where   mappend = append@@ -52,25 +90,30 @@ showDisjointSet :: (Show k, Ord k, Show v) => DisjointMap k v -> String showDisjointSet = show . toLists -toLists :: Ord k => DisjointMap k v -> [([k],v)]+toLists :: DisjointMap k v -> [([k],v)] toLists = (fmap.first) S.toList . toSets -toSets :: Ord k => DisjointMap k v -> [(Set k,v)]-toSets dm@(DisjointMap _ r) = M.elems $ MM.merge MM.dropMissing MM.dropMissing (MM.zipWithMatched $ \_ ks (Ranked _ v) -> (ks,v)) (flatten dm) r+toSets :: DisjointMap k v -> [(Set k,v)]+toSets (DisjointMap _ r) = M.foldr+  (\(Ranked _ s v) xs -> (s,v) : xs) [] r --- in the result of this, the key in the--- map keeps everything separate.-flatten :: Ord k => DisjointMap k v -> Map k (Set k)-flatten ds@(DisjointMap p _) = S.foldl'-  ( \m a -> case find a ds of-    Nothing -> error "DisjointMap flatten: invariant violated. missing key."-    Just b -> M.insertWith S.union b (S.singleton a) m-  ) M.empty (M.keysSet p)+pretty :: (Show k, Show v) => DisjointMap k v -> String+pretty dm = "{" ++ L.intercalate ", " (prettyList dm) ++ "}" +prettyList :: (Show k, Show v) => DisjointMap k v -> [String]+prettyList dm = L.map (\(ks,v) -> "{" ++ commafied ks ++ "} -> " ++ show v) (toSets dm)++commafied :: Show k => Set k -> String+commafied = join . L.intersperse "," . map show . S.toList++foldlWithKeys' :: (a -> Set k -> v -> a) -> a -> DisjointMap k v -> a+foldlWithKeys' f a0 (DisjointMap _ r) =+  M.foldl' (\a (Ranked _ ks v) -> f a ks v) a0 r+ {-| Create an equivalence relation between x and y. If either x or y are not already is the disjoint set, they are first created-as singletons.+as singletons with a value that is 'mempty'. -} union :: (Ord k, Monoid v) => k -> k -> DisjointMap k v -> DisjointMap k v union !x !y set = flip execState set $ runMaybeT $ do@@ -78,50 +121,59 @@   repy <- lift $ state $ lookupCompressAdd y   guard $ repx /= repy   DisjointMap p r <- lift get-  let Ranked rankx valx = r M.! repx-  let Ranked ranky valy = r M.! repy+  let Ranked rankx keysx valx = r M.! repx+  let Ranked ranky keysy valy = r M.! repy   let val = mappend valx valy+      keys = mappend keysx keysy   lift $ put $! case compare rankx ranky of     LT -> let p' = M.insert repx repy p-              r' = M.delete repx $! M.insert repy (Ranked ranky val) r+              r' = M.delete repx $! M.insert repy (Ranked ranky keys val) r           in  DisjointMap p' r'     GT -> let p' = M.insert repy repx p-              r' = M.delete repy $! M.insert repx (Ranked rankx val) r+              r' = M.delete repy $! M.insert repx (Ranked rankx keys val) r           in  DisjointMap p' r'     EQ -> let p' = M.insert repx repy p-              r' = M.delete repx $! M.insert repy (Ranked (ranky + 1) val) r+              r' = M.delete repx $! M.insert repy (Ranked (ranky + 1) keys val) r           in  DisjointMap p' r'  {-|-Find the set representative for this input.+Find the set representative for this input. This function+ignores the values in the map. -} representative :: Ord k => k -> DisjointMap k v -> Maybe k representative = find -{-| Insert x into the disjoint set.  If it is already a member,-    then do nothing, otherwise x has no equivalence relations.-    O(logn).+{-| Insert a key-value pair into the disjoint map. If the key+    is is already present in another set, combine the value+    monoidally with the value belonging to it.+    Otherwise, this creates a singleton set as a new key and+    associates it with the value. -} insert :: (Ord k, Monoid v) => k -> v -> DisjointMap k v -> DisjointMap k v-insert !x !v set@(DisjointMap p r) =+insert !x = insertInternal x (S.singleton x)++insertInternal :: (Ord k, Monoid v) => k -> Set k -> v -> DisjointMap k v -> DisjointMap k v+insertInternal !x !ks !v set@(DisjointMap p r) =   let (l, p') = M.insertLookupWithKey (\_ _ old -> old) x x p    in case l of         Just _ ->-          let (m,DisjointMap p' r') = representative' x set+          let (m,DisjointMap p2 r') = representative' x set            in case m of                 Nothing -> error "DisjointMap insert: invariant violated"-                Just root -> DisjointMap p' (M.adjust (\(Ranked rank vOld) -> Ranked rank (mappend v vOld)) root r')+                Just root -> DisjointMap p2 (M.adjust (\(Ranked rank oldKs vOld) -> Ranked rank (mappend oldKs ks) (mappend v vOld)) root r')         Nothing ->-          let r' = M.insert x (Ranked 0 v) r+          let r' = M.insert x (Ranked 0 ks v) r           in  DisjointMap p' r' -{-| Create a disjoint set with one member. O(1). -}++{-| Create a disjoint map with one key: a singleton set. O(1). -} singleton :: k -> v -> DisjointMap k v singleton !x !v =   let p = M.singleton x x-      r = M.singleton x (Ranked 0 v)+      r = M.singleton x (Ranked 0 (S.singleton x) v)    in DisjointMap p r +{-| The empty map -} empty :: DisjointMap k v empty = DisjointMap M.empty M.empty @@ -130,20 +182,23 @@   then appendParents r2 s1 m2   else appendParents r1 s2 m1 -appendParents :: (Ord k, Monoid v) => Map k (Ranked v) -> DisjointMap k v -> Map k k -> DisjointMap k v+appendParents :: (Ord k, Monoid v) => Map k (Ranked k v) -> DisjointMap k v -> Map k k -> DisjointMap k v appendParents !ranks = M.foldlWithKey' $ \ds x y -> if x == y   then case M.lookup x ranks of     Nothing -> error "DisjointMap appendParents: invariant violated"-    Just (Ranked _ v) -> insert x v ds+    Just (Ranked _ ks v) -> insertInternal x ks v ds   else union x y ds -{-| Create a disjoint set where all members are equal. -}+{-| Create a disjoint map with one key. Everything in the+    'Set' argument is consider part of the same equivalence+    class.+-} singletons :: Eq k => Set k -> v -> DisjointMap k v singletons s v = case S.lookupMin s of   Nothing -> empty   Just x ->     let p = M.fromSet (\_ -> x) s-        r = M.singleton x (Ranked 1 v)+        r = M.singleton x (Ranked 1 s v)     in DisjointMap p r  {-|@@ -171,19 +226,28 @@   where find' y = let y' = p M.! y                   in  if y == y' then y' else find' y' -lookup :: Ord k => k -> DisjointMap k v -> Maybe v-lookup !x (DisjointMap p r) =+{-| Find the value associated with the set containing+    the provided key. If the key is not found, use 'mempty'.+-}+lookup :: (Ord k, Monoid v) => k -> DisjointMap k v -> v+lookup k = fromMaybe mempty . lookup' k++{-| Find the value associated with the set containing+    the provided key.+-}+lookup' :: Ord k => k -> DisjointMap k v -> Maybe v+lookup' !x (DisjointMap p r) =   do x' <- M.lookup x p      if x == x'        then case M.lookup x r of          Nothing -> Nothing-         Just (Ranked _ v) -> Just v+         Just (Ranked _ _ v) -> Just v        else find' x'   where find' y = let y' = p M.! y                    in if y == y'                         then case M.lookup y r of                           Nothing -> Nothing-                          Just (Ranked _ v) -> Just v+                          Just (Ranked _ _ v) -> Just v                         else find' y'  -- TODO: make this smarter about recreating the parents Map.@@ -198,4 +262,54 @@           set'  = let p' = M.insert x rep p                   in  p' `seq` DisjointMap p' r +{- $tutorial++The disjoint map data structure can be used to model scenarios where+the key of a map is a disjoint set. Let us consider trying to find+the lowest rating of our by town. Due to differing subcultures,+inhabitants do not necessarily agree on a canonical name for each town.+Consequently, the survey allows participants to write in their town+name as they would call it. We begin with a rating data type:++>>> import Data.Function ((&))+>>> data Rating = Lowest | Low | Medium | High | Highest deriving (Eq,Ord,Show)+>>> instance Monoid Rating where mempty = Highest; mappend = min++Notice that the 'Monoid' instance combines ratings by choosing+the lower one. Now, we consider the data from the survey:++>>> let resA = [("Big Lake",High),("Newport Lake",Medium),("Dustboro",Low)]+>>> let resB = [("Sand Town",Medium),("Sand Town",High),("Mount Lucy",High)]+>>> let resC = [("Lucy Hill",Highest),("Dustboro",High),("Dustville",High)]+>>> let m1 = foldMap (uncurry singleton) (resA ++ resB ++ resC)+>>> :t m1+m1 :: DisjointMap [Char] Rating+>>> mapM_ putStrLn (prettyList m1)+{"Big Lake"} -> High+{"Dustboro"} -> Low+{"Dustville"} -> High+{"Lucy Hill"} -> Highest+{"Mount Lucy"} -> High+{"Newport Lake"} -> Medium+{"Sand Town"} -> Medium++Since we haven't defined any equivalence classes for the town names yet,+what we have so far is no different from an ordinary 'Map'. Now we+will introduce some equivalences:++>>> let m2 = m1 & union "Big Lake" "Newport Lake" & union "Sand Town" "Dustboro"+>>> let m3 = m2 & union "Dustboro" "Dustville" & union "Lucy Hill" "Mount Lucy"+>>> mapM_ putStrLn (prettyList m3)+{"Dustboro","Dustville","Sand Town"} -> Low+{"Lucy Hill","Mount Lucy"} -> High+{"Big Lake","Newport Lake"} -> Medium++We can now query the map to find the lowest rating in a given town:++>>> lookup "Dustville" m3+Low+>>> lookup "Lucy Hill" m3+High++-} 

@@ -2,16 +2,38 @@  {-# OPTIONS_GHC -Wall #-} +{-|+Persistent disjoint-sets. Disjoint-sets are a set of elements +with equivalence relations defined between elements, i.e. +two elements may be members of the same equivalence set.+This library provides the fundamental operations classically+known as @union@, @find@, and @makeSet@. It also offers+novelties like a 'Monoid' instance for disjoint sets+and conversion functions for interoperating with lists.+See the tutorial at the bottom of this page for an example+of how to use this library.+-}+ module Data.DisjointSet   ( DisjointSet+    -- * Construction   , empty   , singleton   , singletons+  , doubleton   , insert   , union+    -- * Query+  , equivalent+  , sets+  , values   , representative   , representative'+    -- * Conversion   , toLists+  , pretty+    -- * Tutorial+    -- $tutorial   ) where  import Prelude hiding (lookup)@@ -23,9 +45,11 @@ import Data.Map (Map) import Data.Set (Set) import Data.Semigroup (Semigroup)+import Data.Maybe (fromMaybe) import qualified Data.Semigroup import qualified Data.Map.Strict as M import qualified Data.Set as S+import qualified Data.List as L  data DisjointSet a = DisjointSet   !(Map a a) -- parents@@ -50,6 +74,17 @@ showDisjointSet :: (Show a, Ord a) => DisjointSet a -> String showDisjointSet = show . toLists +pretty :: (Ord a, Show a) => DisjointSet a -> String+pretty xs = id+  . showChar '{'+  . applyList (L.intersperse (showChar ',') (map (\x -> showChar '{' . applyList (L.intersperse (showChar ',') (map shows x)) . showChar '}') (toLists xs)))+  . showChar '}'+  $ []++applyList :: [(a -> a)] -> a -> a+applyList [] = id+applyList (f : fs) = f . applyList fs+ toLists :: Ord a => DisjointSet a -> [[a]] toLists = map S.toList . toSets @@ -95,6 +130,21 @@ representative :: Ord a => a -> DisjointSet a -> Maybe a representative = find +{-| Decides whether the two values belong to the same set -}+equivalent :: Ord a => a -> a -> DisjointSet a -> Bool+equivalent a b ds = fromMaybe False $ do+  x <- representative a ds+  y <- representative b ds+  Just (x == y)++{-| Count the number of disjoint sets -}+sets :: DisjointSet a -> Int+sets (DisjointSet _ r) = M.size r++{-| Count the total number of values contained by the disjoint sets -}+values :: DisjointSet a -> Int+values (DisjointSet p _) = M.size p+ {-| Insert x into the disjoint set.  If it is already a member,     then do nothing, otherwise x has no equivalence relations.     O(logn).@@ -115,6 +165,12 @@       r = M.singleton x 0    in DisjointSet p r +{-| Create a disjoint set with a single set containing two members -}+doubleton :: Ord a => a -> a -> DisjointSet a+doubleton a b = union a b empty+-- doubleton could be more efficient++{-| The empty set of disjoint sets. -} empty :: DisjointSet a empty = DisjointSet M.empty M.empty @@ -162,6 +218,8 @@   where find' y = let y' = p M.! y                   in  if y == y' then y' else find' y' ++ -- TODO: make this smarter about recreating the parents Map. -- Currently, it will recreate it more often than needed. compress :: Ord a => a -> a -> DisjointSet a -> DisjointSet a@@ -172,4 +230,73 @@               where x'    = p M.! x                     set'  = let p' = M.insert x rep p                             in  p' `seq` DisjointSet p' r++{- $tutorial++The disjoint set data structure represents sets that are+disjoint. Each set in the data structure can be interpreted+as an equivalance class. For example, let us consider a scenario+in which we are investigating spies who each use one or more aliases. There are three+actions we may repeated take:++    1. we learn an alias is in use by someone (make set)+    2. we learn two aliases refer to the same individual (union)+    3. we check our notes to figure out if two aliases refer to the same individual (find)++We initially learn of the existence of several aliases:++>>> import Data.Function ((&))+>>> import Data.Monoid ((<>))+>>> import Data.Foldable (fold,foldMap)+>>> let s0 = empty+>>> let s1 = s0 & insert "Scar" & insert "Carene" & insert "Barth" & insert "Coral"+>>> let s2 = s1 & insert "Boris" & insert "Esma" & insert "Mayra"+>>> putStr (pretty s2)+{{"Barth"},{"Boris"},{"Carene"},{"Coral"},{"Esma"},{"Mayra"},{"Scar"}}++Note that the 'Monoid' instance gives us a way to construct this more succintly:++>>> s2 == foldMap singleton ["Barth","Boris","Carene","Coral","Esma","Mayra","Scar"]+True++After some preliminary research, we learn that Barth and Esma are the same person. We+also learn that Carene and Mayra are the same:++>>> let s3 = s2 & union "Barth" "Esma" & union "Carene" "Mayra"+>>> putStr (pretty s3)+{{"Boris"},{"Coral"},{"Barth","Esma"},{"Carene","Mayra"},{"Scar"}}++Another informant comes forward who tells us they have worked for someone+that went by the names Mayra and Esma. Going through old letters, we learn+that Boris is a pen name used by Scar:++>>> let s4 = s3 & union "Mayra" "Esma" & union "Boris" "Scar"+>>> putStr (pretty s4)+{{"Coral"},{"Barth","Carene","Esma","Mayra"},{"Boris","Scar"}}++At this point, Detective Laura from another department drops by with+questions about a case she is working on. She asks if Boris the same+person as Barth and if Carene is the same person as Esma. We answer:++>>> equivalent "Boris" "Barth" s4+False+>>> equivalent "Carene" "Esma" s4+True++The correct way to interpret this is that @False@ means something more+along the lines of unknown, but we definitely know that Carene is Esma.+Finally, before the detective leaves, she gives us some of her case+notes to synthesize with our information. Notice that there are+some aliases she encountered that we did not and vice versa:++>>> let laura = union "Scar" "Coral" $ union "Esma" "Henri" $ foldMap singleton ["Carene","Boris","Barth"]+>>> putStr (pretty laura)+{{"Barth"},{"Boris"},{"Carene"},{"Coral","Scar"},{"Esma","Henri"}}+>>> putStr (pretty (laura <> s4))+{{"Barth","Carene","Esma","Henri","Mayra"},{"Boris","Coral","Scar"}}++With Laura's shared findings, we now see that there are really only (at most)+two spies that we are dealing with.++-} 

@@ -0,0 +1,7 @@+import Test.DocTest++main :: IO ()+main = doctest+  [ "src/Data/DisjointSet.hs"+  , "src/Data/DisjointMap.hs"+  ]