disjoint-containers 0.2.1 → 0.2.2

raw patch · 4 files changed

+184/−28 lines, 4 filesdep +aesondep +quickcheck-classesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, quickcheck-classes

API changes (from Hackage documentation)

Files

• disjoint-containers.cabal +4/−1
• src/Data/DisjointMap.hs +41/−6
• src/Data/DisjointSet.hs +94/−21
• test/Spec.hs +45/−0

@@ -1,5 +1,5 @@ name: disjoint-containers-version: 0.2.1+version: 0.2.2 synopsis: Disjoint containers description: Disjoint containers homepage: https://github.com/andrewthad/disjoint-containers#readme@@ -22,6 +22,7 @@       base >= 4.7 && < 5     , transformers >= 0.5 && < 0.6     , containers >= 0.5 && < 0.6+    , aeson >= 0.11 && < 1.3   default-language: Haskell2010  test-suite test@@ -33,6 +34,8 @@     , disjoint-containers     , containers     , QuickCheck+    , quickcheck-classes+    , aeson   default-language: Haskell2010  test-suite doctest

@@ -8,13 +8,10 @@  {-| Maps with disjoint sets as the key. The type in this module can be-understood as:+roughly understood as: -> DisjointMap k v ≡ Map (DisjointSet k) v+> DisjointMap k v ≈ Map (Set 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@@ -57,6 +54,8 @@ import Data.Bifunctor (first) import Data.Foldable (Foldable) import Data.Maybe (fromMaybe)+import Data.Aeson (ToJSON(..),FromJSON(..))+import Data.Foldable (foldlM) import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified GHC.OldList as L@@ -88,6 +87,41 @@ instance (Show k, Ord k, Show v) => Show (DisjointMap k v) where   show = showDisjointSet +instance (ToJSON k, ToJSON v) => ToJSON (DisjointMap k v) where+  toJSON = toJSON . toSets++instance (FromJSON k, FromJSON v, Ord k) => FromJSON (DisjointMap k v) where+  parseJSON x = do+    theSets <- parseJSON x+    case fromSets theSets of+      Nothing -> fail "the sets comprising the DisjointSet were not distinct"+      Just s -> return s++fromSets :: Ord k => [(Set k,v)] -> Maybe (DisjointMap k v)+fromSets xs = case unionDistinctAll (map fst xs) of+  Nothing -> Nothing+  Just _ -> Just (unsafeFromSets xs empty)++unsafeFromSets :: Ord k => [(Set k,v)] -> DisjointMap k v -> DisjointMap k v+unsafeFromSets ys !ds@(DisjointMap p r) = case ys of+  [] -> ds+  (x,v) : xs -> case setLookupMin x of+    Nothing -> unsafeFromSets xs ds+    Just m -> unsafeFromSets xs $ DisjointMap+      (M.union (M.fromSet (\_ -> m) x) p)+      (M.insert m (Ranked 0 x v) r)+  ++unionDistinctAll :: Ord a => [Set a] -> Maybe (Set a)+unionDistinctAll = foldlM unionDistinct S.empty++unionDistinct :: Ord a => Set a -> Set a -> Maybe (Set a)+unionDistinct a b = +  let s = S.union a b+   in if S.size a + S.size b == S.size s+        then Just s+        else Nothing+ showDisjointSet :: (Show k, Ord k, Show v) => DisjointMap k v -> String showDisjointSet = show . toLists @@ -199,7 +233,8 @@   Nothing -> empty   Just x ->     let p = M.fromSet (\_ -> x) s-        r = M.singleton x (Ranked 1 s v)+        rank = if S.size s == 1 then 0 else 1+        r = M.singleton x (Ranked rank s v)     in DisjointMap p r  setLookupMin :: Set a -> Maybe a

@@ -7,6 +7,10 @@ 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.+The type in this module can be roughly understood as:++> DisjointSet a ≈ Set (Set a)+ This library provides the fundamental operations classically known as @union@, @find@, and @makeSet@. It also offers novelties like a 'Monoid' instance for disjoint sets@@ -28,11 +32,16 @@   , equivalent   , sets   , values+  , equivalences   , representative   , representative'     -- * Conversion   , toLists+  , fromLists+  , toSets+  , fromSets   , pretty+  , showInternal     -- * Tutorial     -- $tutorial   ) where@@ -47,6 +56,8 @@ import Data.Set (Set) import Data.Semigroup (Semigroup) import Data.Maybe (fromMaybe)+import Data.Aeson (ToJSON(..),FromJSON(..))+import Data.Foldable (foldlM) import qualified Data.Semigroup import qualified Data.Map.Strict as M import qualified Data.Set as S@@ -54,8 +65,54 @@  data DisjointSet a = DisjointSet   !(Map a a) -- parents-  !(Map a Int) -- ranks+  !(Map a (RankChildren a)) -- ranks +data RankChildren a = RankChildren {-# UNPACK #-} !Int !(Set a)+  deriving Show++data RevealDisjointSet a = RevealDisjointSet+  !(Map a a)+  !(Map a (RankChildren a))+  deriving Show++showInternal :: Show a => DisjointSet a -> String+showInternal (DisjointSet p r) = show (RevealDisjointSet p r)++instance ToJSON a => ToJSON (DisjointSet a) where+  toJSON = toJSON . toSets++instance (Ord a, FromJSON a) => FromJSON (DisjointSet a) where+  parseJSON x = do+    theSets <- parseJSON x+    case fromSets theSets of+      Nothing -> fail "the sets comprising the DisjointSet were not distinct"+      Just s -> return s++fromSets :: Ord a => [Set a] -> Maybe (DisjointSet a)+fromSets xs = case unionDistinctAll xs of+  Nothing -> Nothing+  Just _ -> Just (unsafeFromSets xs empty)++unsafeFromSets :: Ord a => [Set a] -> DisjointSet a -> DisjointSet a+unsafeFromSets ys !ds@(DisjointSet p r) = case ys of+  [] -> ds+  x : xs -> case setLookupMin x of+    Nothing -> unsafeFromSets xs ds+    Just m -> unsafeFromSets xs $ DisjointSet+      (M.union (M.fromSet (\_ -> m) x) p)+      (M.insert m (RankChildren 0 x) r)+  ++unionDistinctAll :: Ord a => [Set a] -> Maybe (Set a)+unionDistinctAll = foldlM unionDistinct S.empty++unionDistinct :: Ord a => Set a -> Set a -> Maybe (Set a)+unionDistinct a b = +  let s = S.union a b+   in if S.size a + S.size b == S.size s+        then Just s+        else Nothing+ instance Ord a => Monoid (DisjointSet a) where   mappend = append   mempty = empty@@ -73,7 +130,7 @@   show = showDisjointSet  showDisjointSet :: (Show a, Ord a) => DisjointSet a -> String-showDisjointSet = show . toLists+showDisjointSet = showString "fromLists " . show . toLists  pretty :: (Ord a, Show a) => DisjointSet a -> String pretty xs = id@@ -86,20 +143,17 @@ applyList [] = id applyList (f : fs) = f . applyList fs -toLists :: Ord a => DisjointSet a -> [[a]]+toLists :: DisjointSet a -> [[a]] toLists = map S.toList . toSets -toSets :: Ord a => DisjointSet a -> [Set a]-toSets = M.elems . flatten+-- this definition is pretty awful. Come up with something that+-- behaves a little more reasonably in the presence of failure.+fromLists :: Ord a => [[a]] -> DisjointSet a+fromLists xs = fromMaybe empty (fromSets (map S.fromList xs)) --- in the result of this, the key in the--- map keeps everything separate.-flatten :: Ord a => DisjointSet a -> Map a (Set a)-flatten ds@(DisjointSet p _) = S.foldl'-  ( \m a -> case find a ds of-    Nothing -> error "DisjointSet flatten: invariant violated. missing key."-    Just b -> M.insertWith S.union b (S.singleton a) m-  ) M.empty (M.keysSet p)+toSets :: DisjointSet a -> [Set a]+toSets (DisjointSet _ r) = M.foldr+  (\(RankChildren _ s) xs -> s : xs) [] r  {-| Create an equivalence relation between x and y. If either x or y@@ -112,17 +166,18 @@   repy <- lift $ state $ lookupCompressAdd y   guard $ repx /= repy   DisjointSet p r <- lift get-  let rankx = r M.! repx-  let ranky = r M.! repy+  let RankChildren rankx keysx = r M.! repx+  let RankChildren ranky keysy = r M.! repy+      keys = mappend keysx keysy   lift $ put $! case compare rankx ranky of     LT -> let p' = M.insert repx repy p-              r' = M.delete repx r+              r' = M.delete repx $! M.insert repy (RankChildren ranky keys) r           in  DisjointSet p' r'     GT -> let p' = M.insert repy repx p-              r' = M.delete repy r+              r' = M.delete repy $! M.insert repx (RankChildren rankx keys) r           in  DisjointSet p' r'     EQ -> let p' = M.insert repx repy p-              r' = M.delete repx $! M.insert repy (ranky + 1) r+              r' = M.delete repx $! M.insert repy (RankChildren (ranky + 1) keys) r           in  DisjointSet p' r'  {-|@@ -138,6 +193,23 @@   y <- representative b ds   Just (x == y) +{-| All elements the are considered equal to the value. In the event+    that the element does not exist, a singleton set will be returned.+-}+equivalences :: Ord a => a -> DisjointSet a -> Set a+equivalences a (DisjointSet p r) = case M.lookup a p of+  Nothing -> S.singleton a+  Just b -> case M.lookup (lookupUntilRoot b p) r of+    Nothing -> error "Data.DisjointSet equivalences: invariant violated"+    Just (RankChildren _ s) -> s++lookupUntilRoot :: Ord a => a -> Map a a -> a+lookupUntilRoot a m = case M.lookup a m of+  Nothing -> a+  Just a' -> if a == a'+    then a+    else lookupUntilRoot a' m+ {-| Count the number of disjoint sets -} sets :: DisjointSet a -> Int sets (DisjointSet _ r) = M.size r@@ -156,14 +228,14 @@     in  case l of           Just _  -> set           Nothing ->-              let r' = M.insert x 0 r+              let r' = M.insert x (RankChildren 0 (S.singleton x)) r               in  DisjointSet p' r'  {-| Create a disjoint set with one member. O(1). -} singleton :: a -> DisjointSet a singleton !x =   let p = M.singleton x x-      r = M.singleton x 0+      r = M.singleton x (RankChildren 0 (S.singleton x))    in DisjointSet p r  {-| Create a disjoint set with a single set containing two members -}@@ -191,7 +263,8 @@   Nothing -> empty   Just x ->     let p = M.fromSet (\_ -> x) s-        r = M.singleton x 1+        rank = if S.size s == 1 then 0 else 1+        r = M.singleton x (RankChildren rank s)     in DisjointSet p r  setLookupMin :: Set a -> Maybe a

@@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  import Test.QuickCheck import Data.Word@@ -7,7 +9,11 @@ import Data.DisjointMap (DisjointMap) import Data.Set (Set) import Data.Foldable (toList)+import Test.QuickCheck.Classes (jsonProps)+import Data.Proxy (Proxy(..))+import Data.Aeson (ToJSON,FromJSON) import qualified Data.Foldable as F+import qualified Data.Set as S import qualified Data.DisjointSet as DS import qualified Data.DisjointMap as DM import qualified GHC.OldList as L@@ -18,7 +24,16 @@   quickCheck propUnionAll   quickCheck propUnionAppend   quickCheck propSingletons+  quickCheck propEquivalances   quickCheck propMapUnionAppend+  putStrLn "* Disjoint Set JSON"+  F.forM_ (jsonProps (Proxy :: Proxy (DisjointSet Word8))) $ \(name,p) -> do+    putStrLn name+    quickCheck p+  putStrLn "* Disjoint Map JSON"+  F.forM_ (jsonProps (Proxy :: Proxy (DisjointMap Word8 WrapWord8))) $ \(name,p) -> do+    putStrLn name+    quickCheck p  propUnionAll :: [Word] -> Bool propUnionAll xs =@@ -48,6 +63,12 @@ propSingletons :: [Set Word] -> Bool propSingletons xs = foldMap unionFoldable xs == foldMap DS.singletons xs +propEquivalances :: [(Word,Word)] -> Bool+propEquivalances xs =+  let s = foldMap (\(a,b) -> DS.singletons (S.fromList [a,b])) xs+      All r = foldMap (\(a,b) -> All $ DS.equivalences a s == DS.equivalences b s) xs+   in r+ splitList :: [a] -> ([a],[a]) splitList xs =   let halfLen = div (L.length xs) 2@@ -79,3 +100,27 @@ unionMapPairsGo :: (Ord k, Monoid v) => [(k,k)] -> DisjointMap k v -> DisjointMap k v unionMapPairsGo [] !ds = ds unionMapPairsGo ((a,b):xs) !ds = unionMapPairsGo xs (DM.union a b ds)++instance (Arbitrary a, Ord a) => Arbitrary (DisjointSet a) where+  arbitrary = do+    xs <- arbitrary+    ys <- arbitrary+    let s1 = foldMap (\(a,b) -> DS.doubleton a b) (xs :: [(a,a)])+        s2 = foldMap DS.singleton (ys :: [a])+    return (s1 <> s2)++instance (Arbitrary k, Ord k, Monoid v, Arbitrary v) => Arbitrary (DisjointMap k v) where+  arbitrary = do+    xs <- arbitrary+    ys <- arbitrary+    let s1 = foldMap (\(k,v) -> DM.singleton k v) (xs :: [(k,v)])+        s2 = foldMap (\(k1,k2) -> DM.union k1 k2 DM.empty) (ys :: [(k,k)])+    return (s1 <> s2)++newtype WrapWord8 = WrapWord8 Word8+  deriving (FromJSON,ToJSON,Show,Eq,Arbitrary,Ord)++instance Monoid WrapWord8 where+  mempty = WrapWord8 0+  mappend (WrapWord8 a) (WrapWord8 b) = WrapWord8 (a + b)+