disjoint-containers 0.2.3 → 0.2.4

raw patch · 4 files changed

+227/−72 lines, 4 filesdep +enum-typesdep +quickcheck-enum-instancesdep +tastydep ~QuickCheckdep ~aesondep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: enum-types, quickcheck-enum-instances, tasty, tasty-quickcheck

Dependency ranges changed: QuickCheck, aeson, base, containers, quickcheck-classes

API changes (from Hackage documentation)

Files

• README.md +12/−0
• disjoint-containers.cabal +10/−6
• src/Data/DisjointMap.hs +113/−38
• test/Spec.hs +92/−28

@@ -1,1 +1,13 @@ # disjoint-containers++`disjoint-containers` has two new data structures: `DisjointSet` and `DisjointMap`++`DisjointSet`:++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.++`DisjointMap`:++Maps with disjoint sets as the key.

@@ -1,5 +1,5 @@ name: disjoint-containers-version: 0.2.3+version: 0.2.4 synopsis: Disjoint containers description: Disjoint containers homepage: https://github.com/andrewthad/disjoint-containers#readme@@ -19,10 +19,10 @@     Data.DisjointSet     Data.DisjointMap   build-depends:-      base >= 4.7 && < 5+      base >= 4.11.1 && < 5     , transformers >= 0.5 && < 0.6-    , containers >= 0.5 && < 0.6-    , aeson >= 0.11 && < 1.3+    , containers >= 0.5 && < 0.7+    , aeson >= 0.11 && < 1.5   default-language: Haskell2010  test-suite test@@ -33,8 +33,12 @@       base     , disjoint-containers     , containers-    , QuickCheck-    , quickcheck-classes >= 0.1 && < 0.3+    , QuickCheck >= 2.11+    , quickcheck-classes >= 0.4.14.1+    , tasty+    , tasty-quickcheck+    , enum-types+    , quickcheck-enum-instances     , aeson     , semigroups   default-language: Haskell2010

@@ -29,6 +29,7 @@   , singletons   , insert   , union+  , unionWeakly     -- * Query   , lookup   , lookup'@@ -36,6 +37,8 @@   , representative'     -- * Conversion   , toLists+  , toSets+  , fromSets   , pretty   , prettyList   , foldlWithKeys'@@ -60,6 +63,7 @@ import qualified Data.Map.Strict as M 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.@@ -74,10 +78,11 @@   deriving (Functor,Foldable,Traversable)  instance (Ord k, Monoid v) => Monoid (DisjointMap k v) where-  mappend = append   mempty = empty -instance (Ord k, Monoid v) => SG.Semigroup (DisjointMap k v) where+-- | 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  -- technically, it should be possible to weaken the Ord constraint on v to@@ -151,7 +156,7 @@  {-| Create an equivalence relation between x and y. If either x or y-are not already is the disjoint set, they are first created+are not already in the disjoint set, they are first created as singletons with a value that is 'mempty'. -} union :: (Ord k, Monoid v) => k -> k -> DisjointMap k v -> DisjointMap k v@@ -174,6 +179,50 @@     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.+-}+unionWeakly :: (Ord k, Semigroup v) => k -> k -> DisjointMap k v -> DisjointMap k v+unionWeakly !x !y set = flip execState set $ runMaybeT $ do+  mx <- lift $ state $ lookupCompress x+  my <- lift $ state $ lookupCompress y+  case mx of+    Nothing -> case my of+      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'+    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'+      Just repy -> do+        guard $ repx /= repy+        DisjointMap p r <- lift get+        let Ranked rankx keysx valx = r M.! repx+        let Ranked ranky keysy valy = r M.! repy+        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'  {-| Find the set representative for this input. This function@@ -184,14 +233,18 @@  {-| 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.+    monoidally with the value belonging to it. The new value+    is on the left side of the append, and the old value is+    on the right.     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 :: (Ord k, Semigroup v) => k -> v -> DisjointMap k v -> DisjointMap k v insert !x = insertInternal x (S.singleton x) -insertInternal :: (Ord k, Monoid v) => k -> Set k -> v -> DisjointMap k v -> DisjointMap k v+-- Precondition: Nothing in ks already exists in the disjoint map.+-- This function should only be used by insert.+insertInternal :: (Ord k, Semigroup 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@@ -199,7 +252,7 @@           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) (mappend v vOld)) root r')+                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'@@ -216,18 +269,27 @@ empty :: DisjointMap k v empty = DisjointMap M.empty M.empty -append :: (Ord k, Monoid v) => DisjointMap k v -> DisjointMap k v -> DisjointMap k v+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 appendParents r2 s1 m2-  else appendParents r1 s2 m1+  then appendPhase2 (appendPhase1 r2 s1 m2) m2+  else appendPhase2 (appendPhase1 r1 s2 m1) m1 -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+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 "DisjointMap appendParents: invariant violated"-    Just (Ranked _ ks v) -> insertInternal x ks v ds-  else union x y ds+    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+ {-| Create a disjoint map with one key. Everything in the     'Set' argument is consider part of the same equivalence     class.@@ -263,15 +325,25 @@ lookupCompressAdd !x set =   case find x set of     Nothing -> (x, insert x mempty set)-    Just rep -> let set' = compress rep x set-                in  set' `seq` (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 !x set =+  case find x set of+    Nothing -> (Nothing, set)+    Just rep ->+      let !set' = compress rep x set+       in (Just rep, set')+ 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 find' y = let y' = p M.! y-                  in  if y == y' then y' else find' y'+find !x (DisjointMap 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'  {-| Find the value associated with the set containing     the provided key. If the key is not found, use 'mempty'.@@ -283,19 +355,21 @@     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-       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-                        else find' y'+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+    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+          else find' y'  -- TODO: make this smarter about recreating the parents Map. -- Currently, it will recreate it more often than needed.@@ -305,9 +379,10 @@   helper !x set@(DisjointMap 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` DisjointMap p' r+    where+    x' = p M.! x+    set' = let !p' = M.insert x rep p+            in DisjointMap p' r  {- $tutorial 

@@ -2,39 +2,91 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -import Test.QuickCheck-import Data.Word-import Data.Monoid-import Data.DisjointSet (DisjointSet)+import Data.Aeson (ToJSON,FromJSON)+import Data.Bifunctor (first) import Data.DisjointMap (DisjointMap)-import Data.Set (Set)+import Data.DisjointSet (DisjointSet)+import Data.Enum.Types (C,E,G,H)+import Test.QuickCheck.Instances.Enum () import Data.Foldable (toList)-import Test.QuickCheck.Classes (jsonProps)+import Data.Maybe (mapMaybe)+import Data.Monoid import Data.Proxy (Proxy(..))-import Data.Aeson (ToJSON,FromJSON)+import Data.Set (Set)+import Data.Word+import Test.QuickCheck+import Test.QuickCheck.Classes (jsonLaws,Laws(..))+import Test.Tasty (TestTree,defaultMain,testGroup)++import qualified Data.DisjointMap as DM+import qualified Data.DisjointSet as DS 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+import qualified Test.QuickCheck.Classes as QCC+import qualified Test.Tasty.QuickCheck as TQC  main :: IO ()-main = do-  putStrLn "\nBeginning QuickCheck Tests"-  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+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.jsonLaws (Proxy :: Proxy (DisjointSet Word8)))+    , lawsToTest (QCC.jsonLaws (Proxy :: Proxy (DisjointSet Word8)))+    , 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.jsonLaws (Proxy :: Proxy (DisjointMap Word8 WrapWord8)))+    , 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)++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)++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)++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)+ propUnionAll :: [Word] -> Bool propUnionAll xs =   let pairs = zip xs (drop 1 xs)@@ -52,13 +104,13 @@       r2 = unionPairs xs1 <> unionPairs xs2    in r1 == r2 -propMapUnionAppend :: [(Word,Word)] -> [(Word,Sum Word)] -> Bool+propMapUnionAppend :: [(Word8,Word8)] -> [(Word8,G)] -> Property propMapUnionAppend xs ys =    let r1 = unionMapPairs xs <> mapFromPairs ys       (xs1,xs2) = splitList xs       (ys1,ys2) = splitList ys       r2 = unionMapPairs xs1 <> mapFromPairs ys1 <> unionMapPairs xs2 <> mapFromPairs ys2-   in r1 == r2+   in r1 === r2  propSingletons :: [Set Word] -> Bool propSingletons xs = foldMap unionFoldable xs == foldMap DS.singletons xs@@ -111,16 +163,28 @@  instance (Arbitrary k, Ord k, Monoid v, Arbitrary v) => Arbitrary (DisjointMap k v) where   arbitrary = do-    xs <- arbitrary-    ys <- arbitrary+    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)])     return (s1 <> s2)+  shrink = mapMaybe DM.fromSets . shrink . DM.toSets  newtype WrapWord8 = WrapWord8 Word8   deriving (FromJSON,ToJSON,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) +newtype SmallList a = SmallList { getSmallList :: [a] }++instance Arbitrary a => Arbitrary (SmallList a) where+  arbitrary = do+    n <- choose (0,20)+    xs <- vector n+    return (SmallList xs)+  shrink = map SmallList . shrink . getSmallList