disjoint-containers 0.3.0 → 0.3.0.1
raw patch · 7 files changed
+403/−363 lines, 7 filesdep −semigroupsdep ~QuickChecksetup-changednew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies removed: semigroups
Dependency ranges changed: QuickCheck
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- Setup.hs +0/−2
- disjoint-containers.cabal +44/−40
- src/Data/DisjointMap.hs +143/−125
- src/Data/DisjointSet.hs +135/−118
- test/Doctest.hs +5/−4
- test/Spec.hs +71/−74
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for disjoint-containers++## 0.3.0.1 -- 2024-02-05++* Update package metadata.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
disjoint-containers.cabal view
@@ -1,58 +1,62 @@-name: disjoint-containers-version: 0.3.0-synopsis: Disjoint containers-description: Disjoint containers-homepage: https://github.com/andrewthad/disjoint-containers#readme-license: BSD3-license-file: LICENSE-author: Andrew Martin-maintainer: andrew.thaddeus@gmail.com-copyright: 2017 Andrew Martin-category: Web-build-type: Simple-extra-source-files: README.md-cabal-version: >=1.10+cabal-version: 2.4+name: disjoint-containers+version: 0.3.0.1+synopsis: Disjoint containers+description: Disjoint containers.+homepage: https://github.com/byteverse/disjoint-containers+bug-reports: https://github.com/byteverse/disjoint-containers/issues+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: amartin@layer3com.com+copyright: 2017 Andrew Martin+category: Web+build-type: Simple+extra-doc-files:+ CHANGELOG.md+ README.md +common build-settings+ default-language: Haskell2010+ ghc-options: -Wall -Wunused-packages+ library- hs-source-dirs: src+ import: build-settings+ hs-source-dirs: src exposed-modules:- Data.DisjointSet Data.DisjointMap+ Data.DisjointSet+ build-depends:- base >= 4.11.1 && < 5- , transformers >= 0.5 && < 0.7- , containers >= 0.5 && < 0.7- default-language: Haskell2010+ , base >=4.11.1 && <5+ , containers >=0.5 && <0.7+ , transformers >=0.5 && <0.7 test-suite test- type: exitcode-stdio-1.0+ import: build-settings+ type: exitcode-stdio-1.0 hs-source-dirs: test- main-is: Spec.hs+ main-is: Spec.hs build-depends:- base- , disjoint-containers+ , base , containers- , QuickCheck >= 2.11- , quickcheck-classes >= 0.5- , tasty- , tasty-quickcheck+ , disjoint-containers , enum-types+ , QuickCheck >=2.11+ , quickcheck-classes >=0.5 , quickcheck-enum-instances- , semigroups- default-language: Haskell2010+ , tasty+ , tasty-quickcheck test-suite doctest- type: exitcode-stdio-1.0+ import: build-settings+ type: exitcode-stdio-1.0 hs-source-dirs: test- main-is: Doctest.hs+ main-is: Doctest.hs build-depends:- base- , disjoint-containers- , doctest >= 0.10- , QuickCheck- default-language: Haskell2010-+ , base+ , doctest >=0.10 source-repository head- type: git- location: https://github.com/andrewthad/disjoint-containers+ type: git+ location: git://github.com/byteverse/disjoint-containers.git
src/Data/DisjointMap.hs view
@@ -1,12 +1,9 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE CPP #-}-+{-# LANGUAGE DeriveTraversable #-} {-# OPTIONS_GHC -Wall #-} -{-|+{- | Maps with disjoint sets as the key. The type in this module can be roughly understood as: @@ -18,11 +15,10 @@ 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@@ -30,11 +26,13 @@ , insert , union , unionWeakly+ -- * Query , lookup , lookup' , representative , representative'+ -- * Conversion , toLists , toSets@@ -42,45 +40,48 @@ , pretty , prettyList , foldlWithKeys'+ -- * Tutorial -- $tutorial ) where -import Prelude hiding (lookup)-import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Class import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State.Strict+import Prelude hiding (lookup) -import Data.Map (Map)-import Data.Set (Set) import Data.Bifunctor (first)-import Data.Foldable (Foldable)-import Data.Maybe (fromMaybe) import Data.Foldable (foldlM)-import qualified Data.Semigroup as SG+import qualified Data.Foldable as F+import Data.Map (Map) import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import qualified Data.Semigroup as SG+import Data.Set (Set) import qualified Data.Set as S import qualified GHC.OldList as L-import qualified Data.Foldable as F --- | 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 k v)) -- ranks- deriving (Functor,Foldable,Traversable)+{- | 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 k v)) -- ranks+ deriving (Functor, Foldable, Traversable) -- 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)+ deriving (Functor, Foldable, Traversable) instance (Ord k, Monoid v) => Monoid (DisjointMap k v) where mempty = empty --- | This only satisfies the associativity law when the 'Monoid'--- instance for @v@ is commutative.+{- | This only satisfies the associativity law when the 'Monoid'+ instance for @v@ is commutative.+-} instance (Ord k, Semigroup v) => SG.Semigroup (DisjointMap k v) where (<>) = append @@ -95,26 +96,27 @@ instance (Show k, Ord k, Show v) => Show (DisjointMap k v) where show = showDisjointSet -fromSets :: Ord k => [(Set k,v)] -> Maybe (DisjointMap k v)+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 :: (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+ (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)- + 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 :: (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 = +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@@ -123,27 +125,30 @@ showDisjointSet :: (Show k, Ord k, Show v) => DisjointMap k v -> String showDisjointSet = show . toLists -toLists :: DisjointMap k v -> [([k],v)]-toLists = (fmap.first) S.toList . toSets+toLists :: DisjointMap k v -> [([k], v)]+toLists = (fmap . first) S.toList . toSets -toSets :: DisjointMap k v -> [(Set k,v)]-toSets (DisjointMap _ r) = M.foldr- (\(Ranked _ s v) xs -> (s,v) : xs) [] r+toSets :: DisjointMap k v -> [(Set k, v)]+toSets (DisjointMap _ r) =+ M.foldr+ (\(Ranked _ s v) xs -> (s, v) : xs)+ []+ r 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)+prettyList dm = L.map (\(ks, v) -> "{" ++ commafied ks ++ "} -> " ++ show v) (toSets dm) -commafied :: Show k => Set k -> String+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 in the disjoint set, they are first created as singletons with a value that is 'mempty'.@@ -159,16 +164,20 @@ 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 keys val) r- in DisjointMap p' r'- GT -> let p' = M.insert repy repx p- 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) keys val) r- in DisjointMap p' r'-{-|+ LT ->+ let p' = M.insert repx repy p+ 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 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) keys val) r+ in DisjointMap p' r'++{- | Create an equivalence relation between x and y. If both x and y are missing, do not create either of them. Otherwise, they will both exist in the map.@@ -182,19 +191,21 @@ Nothing -> pure () Just repy -> do DisjointMap p r <- lift get- lift $ put $- let p' = M.insert x repy p- Ranked ranky keys val = fromMaybe (error "Data.DisjointMap.unionWeakly") (M.lookup repy r)- r' = M.insert repy (Ranked ranky (S.insert x keys) val) r- in DisjointMap p' r'+ lift $+ put $+ let p' = M.insert x repy p+ Ranked ranky keys val = fromMaybe (error "Data.DisjointMap.unionWeakly") (M.lookup repy r)+ r' = M.insert repy (Ranked ranky (S.insert x keys) val) r+ in DisjointMap p' r' Just repx -> case my of Nothing -> do DisjointMap p r <- lift get- lift $ put $- let p' = M.insert y repx p- Ranked rankx keys val = fromMaybe (error "Data.DisjointMap.unionWeakly") (M.lookup repx r)- r' = M.insert repx (Ranked rankx (S.insert y keys) val) r- in DisjointMap p' r'+ lift $+ put $+ let p' = M.insert y repx p+ Ranked rankx keys val = fromMaybe (error "Data.DisjointMap.unionWeakly") (M.lookup repx r)+ r' = M.insert repx (Ranked rankx (S.insert y keys) val) r+ in DisjointMap p' r' Just repy -> do guard $ repx /= repy DisjointMap p r <- lift get@@ -203,24 +214,27 @@ let val = valx <> valy let 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 keys val) r- in DisjointMap p' r'- GT -> let p' = M.insert repy repx p- 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) keys val) r- in DisjointMap p' r'+ LT ->+ let p' = M.insert repx repy p+ 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 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) keys val) r+ in DisjointMap p' r' -{-|+{- | 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 :: (Ord k) => k -> DisjointMap k v -> Maybe k representative = find -{-| Insert a key-value pair into the disjoint map. If the key+{- | 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. The new value is on the left side of the append, and the old value is@@ -238,86 +252,91 @@ let (l, p') = M.insertLookupWithKey (\_ _ old -> old) x x p in case l of Just _ ->- let (m,DisjointMap p2 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 p2 (M.adjust (\(Ranked rank oldKs vOld) -> Ranked rank (mappend oldKs ks) (v <> vOld)) root r') Nothing -> let r' = M.insert x (Ranked 0 ks v) r- in DisjointMap p' r'-+ in DisjointMap p' r' -{-| Create a disjoint map with one key: a singleton set. 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 (S.singleton x) v) in DisjointMap p r -{-| The empty map -}+-- | The empty map empty :: DisjointMap k v empty = DisjointMap M.empty M.empty append :: (Ord k, Semigroup v) => DisjointMap k v -> DisjointMap k v -> DisjointMap k v-append s1@(DisjointMap m1 r1) s2@(DisjointMap m2 r2) = if M.size m1 > M.size m2- then appendPhase2 (appendPhase1 r2 s1 m2) m2- else appendPhase2 (appendPhase1 r1 s2 m1) m1+append s1@(DisjointMap m1 r1) s2@(DisjointMap m2 r2) =+ if M.size m1 > M.size m2+ then appendPhase2 (appendPhase1 r2 s1 m2) m2+ else appendPhase2 (appendPhase1 r1 s2 m1) m1 -appendPhase1 :: (Ord k, Semigroup v)- => Map k (Ranked k v)- -> DisjointMap k v- -> Map k k- -> DisjointMap k v-appendPhase1 !ranks = M.foldlWithKey' $ \ds x y -> if x == y- then case M.lookup x ranks of- Nothing -> error "Data.DisjointMap.appendParents: invariant violated"- Just (Ranked _ ks v) -> F.foldl' (\dm k -> unionWeakly k x dm) (insert x v ds) ks- else ds+appendPhase1 ::+ (Ord k, Semigroup v) =>+ Map k (Ranked k v) ->+ DisjointMap k v ->+ Map k k ->+ DisjointMap k v+appendPhase1 !ranks = M.foldlWithKey' $ \ds x y ->+ if x == y+ then case M.lookup x ranks of+ Nothing -> error "Data.DisjointMap.appendParents: invariant violated"+ Just (Ranked _ ks v) -> F.foldl' (\dm k -> unionWeakly k x dm) (insert x v ds) ks+ else ds appendPhase2 :: (Ord k, Semigroup v) => DisjointMap k v -> Map k k -> DisjointMap k v-appendPhase2 = M.foldlWithKey' $ \ds x y -> if x == y- then ds- else unionWeakly x y ds+appendPhase2 = M.foldlWithKey' $ \ds x y ->+ if x == y+ then ds+ else unionWeakly x y ds -{-| Create a disjoint map with one key. Everything in the+{- | 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 :: (Eq k) => Set k -> v -> DisjointMap k v singletons s v = case setLookupMin s of Nothing -> empty Just x -> let p = M.fromSet (\_ -> x) s rank = if S.size s == 1 then 0 else 1 r = M.singleton x (Ranked rank s v)- in DisjointMap p r+ in DisjointMap p r setLookupMin :: Set a -> Maybe a-#if MIN_VERSION_containers(0,5,9) +#if MIN_VERSION_containers(0,5,9) setLookupMin = S.lookupMin #else setLookupMin s = if S.size s > 0 then Just (S.findMin s) else Nothing #endif -{-|+{- | Find the set representative for this input. Returns a new disjoint set in which the path has been compressed. -}-representative' :: Ord k => k -> DisjointMap k v -> (Maybe k, DisjointMap k v)+representative' :: (Ord k) => k -> DisjointMap k v -> (Maybe k, DisjointMap k v) representative' !x set = case find x set of- Nothing -> (Nothing, set)- Just rep -> let set' = compress rep x set- in set' `seq` (Just rep, set')+ Nothing -> (Nothing, set)+ Just rep ->+ let set' = compress rep x set+ in set' `seq` (Just rep, set') lookupCompressAdd :: (Ord k, Monoid v) => k -> DisjointMap k v -> (k, DisjointMap k v) lookupCompressAdd !x set = case find x set of Nothing -> (x, insert x mempty set)- Just rep -> let !set' = compress rep x set- in (rep, set')+ Just rep ->+ let !set' = compress rep x set+ in (rep, set') -lookupCompress :: Ord k => k -> DisjointMap k v -> (Maybe k, DisjointMap k v)+lookupCompress :: (Ord k) => k -> DisjointMap k v -> (Maybe k, DisjointMap k v) lookupCompress !x set = case find x set of Nothing -> (Nothing, set)@@ -325,25 +344,25 @@ let !set' = compress rep x set in (Just rep, set') -find :: Ord k => k -> DisjointMap k v -> Maybe k+find :: (Ord k) => k -> DisjointMap k v -> Maybe k find !x (DisjointMap p _) = do x' <- M.lookup x p return $! if x == x' then x' else find' x'- where+ where find' y = let y' = p M.! y in if y == y' then y' else find' y' -{-| Find the value associated with the set containing+{- | 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+{- | Find the value associated with the set containing the provided key. -}-lookup' :: Ord k => k -> DisjointMap k v -> Maybe v+lookup' :: (Ord k) => k -> DisjointMap k v -> Maybe v lookup' !x (DisjointMap p r) = do x' <- M.lookup x p if x == x'@@ -351,7 +370,7 @@ Nothing -> Nothing Just (Ranked _ _ v) -> Just v else find' x'- where+ where find' y = let y' = p M.! y in if y == y'@@ -362,16 +381,17 @@ -- TODO: make this smarter about recreating the parents Map. -- Currently, it will recreate it more often than needed.-compress :: Ord k => k -> k -> DisjointMap k v -> DisjointMap k v+compress :: (Ord k) => k -> k -> DisjointMap k v -> DisjointMap k v compress !rep = helper- where+ where helper !x set@(DisjointMap p r)- | x == rep = set+ | x == rep = set | otherwise = helper x' set'- where+ where x' = p M.! x- set' = let !p' = M.insert x rep p- in DisjointMap p' r+ set' =+ let !p' = M.insert x rep p+ in DisjointMap p' r {- $tutorial @@ -385,7 +405,7 @@ >>> import Data.Function ((&)) >>> data Rating = Lowest | Low | Medium | High | Highest deriving (Eq,Ord,Show) >>> instance Semigroup Rating where (<>) = min->>> instance Monoid Rating where mempty = Highest; mappend = min+>>> instance Monoid Rating where mempty = Highest; mappend = (<>) Notice that the 'Monoid' instance combines ratings by choosing the lower one. Now, we consider the data from the survey:@@ -395,7 +415,7 @@ >>> let resC = [("Lucy Hill",Highest),("Dustboro",High),("Dustville",High)] >>> let m1 = foldMap (uncurry singleton) (resA ++ resB ++ resC) >>> :t m1-m1 :: DisjointMap [Char] Rating+m1 :: DisjointMap String Rating >>> mapM_ putStrLn (prettyList m1) {"Big Lake"} -> High {"Dustboro"} -> Low@@ -422,6 +442,4 @@ Low >>> lookup "Lucy Hill" m3 High- -}-
src/Data/DisjointSet.hs view
@@ -1,11 +1,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}- {-# OPTIONS_GHC -Wall #-} -{-|-Persistent disjoint-sets. Disjoint-sets are a set of elements -with equivalence relations defined between elements, i.e. +{- |+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: @@ -18,9 +17,9 @@ 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@@ -28,6 +27,7 @@ , doubleton , insert , union+ -- * Query , equivalent , sets@@ -35,6 +35,7 @@ , equivalences , representative , representative'+ -- * Conversion , toLists , fromLists@@ -42,77 +43,79 @@ , fromSets , pretty , showInternal+ -- * Tutorial -- $tutorial ) where -import Prelude hiding (lookup)-import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Class import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State.Strict+import Prelude hiding (lookup) -import Data.Map (Map)-import Data.Set (Set)-import Data.Semigroup (Semigroup)-import Data.Maybe (fromMaybe) import Data.Foldable (foldlM)-import qualified Data.Semigroup+import qualified Data.List as L+import Data.Map (Map) import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import Data.Set (Set) import qualified Data.Set as S-import qualified Data.List as L -data DisjointSet a = DisjointSet- !(Map a a) -- parents- !(Map a (RankChildren a)) -- ranks+data DisjointSet a+ = DisjointSet+ !(Map a a) -- parents+ !(Map a (RankChildren a)) -- ranks data RankChildren a = RankChildren {-# UNPACK #-} !Int !(Set a)- deriving Show+ deriving (Show) -data RevealDisjointSet a = RevealDisjointSet- !(Map a a)- !(Map a (RankChildren a))- deriving Show+data RevealDisjointSet a+ = RevealDisjointSet+ !(Map a a)+ !(Map a (RankChildren a))+ deriving (Show) -showInternal :: Show a => DisjointSet a -> String+showInternal :: (Show a) => DisjointSet a -> String showInternal (DisjointSet p r) = show (RevealDisjointSet p r) -fromSets :: Ord a => [Set a] -> Maybe (DisjointSet a)+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 :: (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)- + 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 :: (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 = +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+instance (Ord a) => Monoid (DisjointSet a) where+ mappend = (<>) mempty = empty -instance Ord a => Semigroup (DisjointSet a) where+instance (Ord a) => Semigroup (DisjointSet a) where (<>) = append -instance Ord a => Eq (DisjointSet a) where+instance (Ord a) => Eq (DisjointSet a) where a == b = S.fromList (toSets a) == S.fromList (toSets b) -instance Ord a => Ord (DisjointSet a) where+instance (Ord a) => Ord (DisjointSet a) where compare a b = compare (S.fromList (toSets a)) (S.fromList (toSets b)) instance (Show a, Ord a) => Show (DisjointSet a) where@@ -122,13 +125,13 @@ showDisjointSet = showString "fromLists " . 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 '}'- $ []+pretty xs =+ 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 :: [a -> a] -> a -> a applyList [] = id applyList (f : fs) = f . applyList fs @@ -137,19 +140,22 @@ -- 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 :: (Ord a) => [[a]] -> DisjointSet a fromLists xs = fromMaybe empty (fromSets (map S.fromList xs)) toSets :: DisjointSet a -> [Set a]-toSets (DisjointSet _ r) = M.foldr- (\(RankChildren _ s) xs -> s : xs) [] r+toSets (DisjointSet _ r) =+ M.foldr+ (\(RankChildren _ s) xs -> s : xs)+ []+ 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. -}-union :: Ord a => a -> a -> DisjointSet a -> DisjointSet a+union :: (Ord a) => a -> a -> DisjointSet a -> DisjointSet a union !x !y set = flip execState set $ runMaybeT $ do repx <- lift $ state $ lookupCompressAdd x repy <- lift $ state $ lookupCompressAdd y@@ -159,147 +165,160 @@ 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 $! M.insert repy (RankChildren ranky keys) r- in DisjointSet p' r'- GT -> let p' = M.insert repy repx p- 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 (RankChildren (ranky + 1) keys) r- in DisjointSet p' r'+ LT ->+ let p' = M.insert repx repy p+ 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 $! 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 (RankChildren (ranky + 1) keys) r+ in DisjointSet p' r' -{-|+{- | Find the set representative for this input. -}-representative :: Ord a => a -> DisjointSet a -> Maybe a+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+-- | 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) -{-| All elements the are considered equal to the value. In the event+{- | 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 :: (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 :: (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+ Just a' ->+ if a == a'+ then a+ else lookupUntilRoot a' m -{-| Count the number of disjoint sets -}+-- | 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 -}+-- | 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,+{- | Insert x into the disjoint set. If it is already a member, then do nothing, otherwise x has no equivalence relations. O(logn). -}-insert :: Ord a => a -> DisjointSet a -> DisjointSet a+insert :: (Ord a) => a -> DisjointSet a -> DisjointSet a insert !x set@(DisjointSet p r) =- let (l, p') = M.insertLookupWithKey (\_ _ old -> old) x x p- in case l of- Just _ -> set- Nothing ->- let r' = M.insert x (RankChildren 0 (S.singleton x)) r- in DisjointSet p' r'+ let (l, p') = M.insertLookupWithKey (\_ _ old -> old) x x p+ in case l of+ Just _ -> set+ Nothing ->+ let r' = M.insert x (RankChildren 0 (S.singleton x)) r+ in DisjointSet p' r' -{-| Create a disjoint set with one member. O(1). -}+-- | 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 (RankChildren 0 (S.singleton x)) in DisjointSet p r -{-| Create a disjoint set with a single set containing two members -}-doubleton :: Ord a => a -> a -> DisjointSet a+-- | 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. -}+-- | The empty set of disjoint sets. empty :: DisjointSet a empty = DisjointSet M.empty M.empty -append :: Ord a => DisjointSet a -> DisjointSet a -> DisjointSet a-append s1@(DisjointSet m1 _) s2@(DisjointSet m2 _) = if M.size m1 > M.size m2- then appendParents s1 m2- else appendParents s2 m1+append :: (Ord a) => DisjointSet a -> DisjointSet a -> DisjointSet a+append s1@(DisjointSet m1 _) s2@(DisjointSet m2 _) =+ if M.size m1 > M.size m2+ then appendParents s1 m2+ else appendParents s2 m1 -appendParents :: Ord a => DisjointSet a -> Map a a -> DisjointSet a-appendParents = M.foldlWithKey' $ \ds x y -> if x == y- then insert x ds- else union x y ds+appendParents :: (Ord a) => DisjointSet a -> Map a a -> DisjointSet a+appendParents = M.foldlWithKey' $ \ds x y ->+ if x == y+ then insert x ds+ else union x y ds -{-| Create a disjoint set where all members are equal. -}-singletons :: Eq a => Set a -> DisjointSet a+-- | Create a disjoint set where all members are equal.+singletons :: (Eq a) => Set a -> DisjointSet a singletons s = case setLookupMin s of Nothing -> empty Just x -> let p = M.fromSet (\_ -> x) s rank = if S.size s == 1 then 0 else 1 r = M.singleton x (RankChildren rank s)- in DisjointSet p r+ in DisjointSet p r setLookupMin :: Set a -> Maybe a-#if MIN_VERSION_containers(0,5,9) +#if MIN_VERSION_containers(0,5,9) setLookupMin = S.lookupMin #else setLookupMin s = if S.size s > 0 then Just (S.findMin s) else Nothing #endif -{-|+{- | Find the set representative for this input. Returns a new disjoint set in which the path has been compressed. -}-representative' :: Ord a => a -> DisjointSet a -> (Maybe a, DisjointSet a)+representative' :: (Ord a) => a -> DisjointSet a -> (Maybe a, DisjointSet a) representative' !x set = case find x set of- Nothing -> (Nothing, set)- Just rep -> let set' = compress rep x set- in set' `seq` (Just rep, set')+ Nothing -> (Nothing, set)+ Just rep ->+ let set' = compress rep x set+ in set' `seq` (Just rep, set') -lookupCompressAdd :: Ord a => a -> DisjointSet a -> (a, DisjointSet a)+lookupCompressAdd :: (Ord a) => a -> DisjointSet a -> (a, DisjointSet a) lookupCompressAdd !x set = case find x set of Nothing -> (x, insert x set)- Just rep -> let set' = compress rep x set- in set' `seq` (rep, set')+ Just rep ->+ let set' = compress rep x set+ in set' `seq` (rep, set') -find :: Ord a => a -> DisjointSet a -> Maybe a+find :: (Ord a) => a -> DisjointSet a -> Maybe a find !x (DisjointSet p _) =- do x' <- M.lookup x p- return $! if x == x' then x' else find' x'- where find' y = let y' = p M.! y- in if y == y' then y' else find' y'--+ do+ x' <- M.lookup x p+ return $! if x == x' then x' else find' x'+ 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+compress :: (Ord a) => a -> a -> DisjointSet a -> DisjointSet a compress !rep = helper- where helper !x set@(DisjointSet p r)- | x == rep = set- | otherwise = helper x' set'- where x' = p M.! x- set' = let p' = M.insert x rep p- in p' `seq` DisjointSet p' r+ where+ helper !x set@(DisjointSet p r)+ | x == rep = set+ | otherwise = helper x' set'+ where+ x' = p M.! x+ set' =+ let p' = M.insert x rep p+ in p' `seq` DisjointSet p' r {- $tutorial @@ -367,6 +386,4 @@ With Laura's shared findings, we now see that there are really only (at most) two spies that we are dealing with.- -}-
test/Doctest.hs view
@@ -1,7 +1,8 @@ import Test.DocTest main :: IO ()-main = doctest- [ "src/Data/DisjointSet.hs"- , "src/Data/DisjointMap.hs"- ]+main =+ doctest+ [ "src/Data/DisjointSet.hs"+ , "src/Data/DisjointMap.hs"+ ]
test/Spec.hs view
@@ -1,21 +1,20 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-} -import Data.Bifunctor (first) import Data.DisjointMap (DisjointMap) import Data.DisjointSet (DisjointSet)-import Data.Enum.Types (C,E,G,H)-import Test.QuickCheck.Instances.Enum ()+import Data.Enum.Types (C, E, G) import Data.Foldable (toList) import Data.Maybe (mapMaybe) import Data.Monoid-import Data.Proxy (Proxy(..))+import Data.Proxy (Proxy (..)) import Data.Set (Set) import Data.Word import Test.QuickCheck-import Test.QuickCheck.Classes (Laws(..))-import Test.Tasty (TestTree,defaultMain,testGroup)+import Test.QuickCheck.Instances.Enum ()+import Test.Tasty (TestTree, defaultMain, testGroup) import qualified Data.DisjointMap as DM import qualified Data.DisjointSet as DS@@ -29,28 +28,34 @@ main = defaultMain tests tests :: TestTree-tests = testGroup "Data"- [ testGroup "DisjointSet"- [ testGroup "union"- [ TQC.testProperty "all" propUnionAll- , TQC.testProperty "append" propUnionAll- ]- , TQC.testProperty "singletons" propSingletons- , TQC.testProperty "equivalences" propEquivalances- , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DisjointSet Integer)))- , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DisjointSet Integer)))- ]- , testGroup "DisjointMap"- [ testGroup "union"- [ TQC.testProperty "append" propMapUnionAppend- , TQC.testProperty "order" propMapUnionOrder- , TQC.testProperty "extra" propMapInsertUnionOrder- ]- , TQC.testProperty "insert" propMapInsertOrder- , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DisjointMap Word8 G)))- , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DisjointMap Word8 G)))+tests =+ testGroup+ "Data"+ [ testGroup+ "DisjointSet"+ [ testGroup+ "union"+ [ TQC.testProperty "all" propUnionAll+ , TQC.testProperty "append" propUnionAll+ ]+ , TQC.testProperty "singletons" propSingletons+ , TQC.testProperty "equivalences" propEquivalances+ , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DisjointSet Integer)))+ , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DisjointSet Integer)))+ ]+ , testGroup+ "DisjointMap"+ [ testGroup+ "union"+ [ TQC.testProperty "append" propMapUnionAppend+ , TQC.testProperty "order" propMapUnionOrder+ , TQC.testProperty "extra" propMapInsertUnionOrder+ ]+ , TQC.testProperty "insert" propMapInsertOrder+ , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (DisjointMap Word8 G)))+ , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (DisjointMap Word8 G)))+ ] ]- ] lawsToTest :: QCC.Laws -> TestTree lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)@@ -58,73 +63,65 @@ propMapUnionOrder :: C -> [Integer] -> C -> [Integer] -> Property propMapUnionOrder x xs y ys = (x /= y)- ==>- DM.lookup x (DM.union x y (DM.singleton x xs <> DM.singleton y ys))- ===- (xs ++ ys)+ ==> DM.lookup x (DM.union x y (DM.singleton x xs <> DM.singleton y ys))+ === (xs ++ ys) propMapInsertOrder :: C -> C -> [Integer] -> [Integer] -> [Integer] -> Property propMapInsertOrder k j xs ys zs = (k /= j)- ==> - DM.lookup k (DM.insert k xs $ DM.insert j ys $ DM.insert k zs $ mempty)- ===- (xs ++ zs)+ ==> DM.lookup k (DM.insert k xs $ DM.insert j ys $ DM.insert k zs mempty)+ === (xs ++ zs) propMapInsertUnionOrder :: E -> E -> E -> [Integer] -> [Integer] -> [Integer] -> Property propMapInsertUnionOrder a b c xs ys zs = (a /= b)- ==> - (b /= c)- ==> - (c /= a)- ==> - DM.lookup a (DM.union a c (DM.insert a xs $ DM.insert b ys $ DM.insert c zs $ mempty))- ===- (xs ++ zs)+ ==> (b /= c)+ ==> (c /= a)+ ==> DM.lookup a (DM.union a c (DM.insert a xs $ DM.insert b ys $ DM.insert c zs mempty))+ === (xs ++ zs) propUnionAll :: [Word] -> Bool propUnionAll xs = let pairs = zip xs (drop 1 xs)- ds = L.foldl' (\s (a,b) -> DS.union a b s) DS.empty pairs+ ds = L.foldl' (\s (a, b) -> DS.union a b s) DS.empty pairs roots = mapM (\x -> DS.representative x ds) xs in case roots of Nothing -> L.length xs == 1 Just [] -> L.null xs Just (y : ys) -> L.all (== y) ys -propUnionAppend :: [(Word,Word)] -> Bool-propUnionAppend xs = +_propUnionAppend :: [(Word, Word)] -> Bool+_propUnionAppend xs = let r1 = unionPairs xs- (xs1,xs2) = splitList xs+ (xs1, xs2) = splitList xs r2 = unionPairs xs1 <> unionPairs xs2 in r1 == r2 -propMapUnionAppend :: [(Word8,Word8)] -> [(Word8,G)] -> Property-propMapUnionAppend xs ys = +propMapUnionAppend :: [(Word8, Word8)] -> [(Word8, G)] -> Property+propMapUnionAppend xs ys = let r1 = unionMapPairs xs <> mapFromPairs ys- (xs1,xs2) = splitList xs- (ys1,ys2) = splitList ys+ (xs1, xs2) = splitList xs+ (ys1, ys2) = splitList ys r2 = unionMapPairs xs1 <> mapFromPairs ys1 <> unionMapPairs xs2 <> mapFromPairs ys2 in r1 === r2 propSingletons :: [Set Word] -> Bool propSingletons xs = foldMap unionFoldable xs == foldMap DS.singletons xs -propEquivalances :: [(Word,Word)] -> Bool+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+ 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 :: [a] -> ([a], [a]) splitList xs = let halfLen = div (L.length xs) 2 xs1 = L.drop halfLen xs xs2 = L.take halfLen xs- in (xs1,xs2)+ in (xs1, xs2) -unionFoldable :: Ord a => Foldable t => t a -> DisjointSet a+unionFoldable :: (Ord a) => (Foldable t) => t a -> DisjointSet a unionFoldable xs = let ys = toList xs pairs = zip ys (drop 1 ys)@@ -132,28 +129,28 @@ [] -> DS.empty z : _ -> unionPairsGo pairs (DS.singleton z) -mapFromPairs :: (Ord k, Monoid v) => Foldable t => t (k,v) -> DisjointMap k v-mapFromPairs = F.foldl' (\dm (k,v) -> DM.insert k v dm) DM.empty+mapFromPairs :: (Ord k, Monoid v) => (Foldable t) => t (k, v) -> DisjointMap k v+mapFromPairs = F.foldl' (\dm (k, v) -> DM.insert k v dm) DM.empty -unionPairs :: Ord a => [(a,a)] -> DisjointSet a+unionPairs :: (Ord a) => [(a, a)] -> DisjointSet a unionPairs xs = unionPairsGo xs DS.empty -unionPairsGo :: Ord a => [(a,a)] -> DisjointSet a -> DisjointSet a+unionPairsGo :: (Ord a) => [(a, a)] -> DisjointSet a -> DisjointSet a unionPairsGo [] !ds = ds-unionPairsGo ((a,b):xs) !ds = unionPairsGo xs (DS.union a b ds)+unionPairsGo ((a, b) : xs) !ds = unionPairsGo xs (DS.union a b ds) -unionMapPairs :: (Ord k, Monoid v) => [(k,k)] -> DisjointMap k v+unionMapPairs :: (Ord k, Monoid v) => [(k, k)] -> DisjointMap k v unionMapPairs xs = unionMapPairsGo xs DM.empty -unionMapPairsGo :: (Ord k, Monoid v) => [(k,k)] -> DisjointMap k v -> DisjointMap k v+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)+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)])+ let s1 = foldMap (\(a, b) -> DS.doubleton a b) (xs :: [(a, a)]) s2 = foldMap DS.singleton (ys :: [a]) return (s1 <> s2) @@ -161,26 +158,26 @@ arbitrary = do SmallList xs <- arbitrary SmallList 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)])+ 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) shrink = mapMaybe DM.fromSets . shrink . DM.toSets newtype WrapWord8 = WrapWord8 Word8- deriving (Show,Eq,Arbitrary,Ord)+ deriving (Show, Eq, Arbitrary, Ord) instance Semigroup WrapWord8 where WrapWord8 a <> WrapWord8 b = WrapWord8 (a + b) instance Monoid WrapWord8 where mempty = WrapWord8 0- mappend (WrapWord8 a) (WrapWord8 b) = WrapWord8 (a + b)+ mappend = (<>) -newtype SmallList a = SmallList { getSmallList :: [a] }+newtype SmallList a = SmallList {getSmallList :: [a]} -instance Arbitrary a => Arbitrary (SmallList a) where+instance (Arbitrary a) => Arbitrary (SmallList a) where arbitrary = do- n <- choose (0,20)+ n <- choose (0, 20) xs <- vector n return (SmallList xs) shrink = map SmallList . shrink . getSmallList