packages feed

disjoint-containers (empty) → 0.1.0

raw patch · 7 files changed

+530/−0 lines, 7 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, disjoint-containers, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# disjoint-containers
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ disjoint-containers.cabal view
@@ -0,0 +1,40 @@+name: disjoint-containers+version: 0.1.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++library+  hs-source-dirs: src+  exposed-modules:+    Data.DisjointSet+    Data.DisjointMap+  build-depends:+      base >= 4.7 && < 5+    , transformers >= 0.5 && < 0.6+    , containers >= 0.5.10 && < 0.6+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Spec.hs+  build-depends:+      base+    , disjoint-containers+    , containers+    , QuickCheck+  default-language: Haskell2010++source-repository head+  type: git+  location: https://github.com/andrewthad/disjoint-containers
+ src/Data/DisjointMap.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -Wall #-}++module Data.DisjointMap+  ( DisjointMap+  , empty+  , singleton+  , singletons+  , insert+  , union+  , lookup+  , representative+  , representative'+  , toLists+  ) 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 Data.Map (Map)+import Data.Set (Set)+import Data.Bifunctor (first)+import qualified Data.Map.Strict as M+import qualified Data.Map.Merge.Strict as MM+import qualified Data.Set as S++data DisjointMap k v = DisjointMap+  !(Map k k) -- parents and values+  !(Map k (Ranked v)) -- ranks++data Ranked b = Ranked {-# UNPACK #-} !Int !b++instance (Ord k, Monoid v) => Monoid (DisjointMap k v) where+  mappend = append+  mempty = empty++-- technically, it should be possible to weaken the Ord constraint on v to+-- an Eq constraint+instance (Ord k, Ord v) => Eq (DisjointMap k v) where+  a == b = S.fromList (toSets a) == S.fromList (toSets b)++instance (Ord k, Ord v) => Ord (DisjointMap k v) where+  compare a b = compare (S.fromList (toSets a)) (S.fromList (toSets b))++instance (Show k, Ord k, Show v) => Show (DisjointMap k v) where+  show = showDisjointSet++showDisjointSet :: (Show k, Ord k, Show v) => DisjointMap k v -> String+showDisjointSet = show . toLists++toLists :: Ord k => 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++-- 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)++{-|+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 k, Monoid v) => k -> k -> DisjointMap k v -> DisjointMap k v+union !x !y set = flip execState set $ runMaybeT $ do+  repx <- lift $ state $ lookupCompressAdd x+  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 val = mappend valx valy+  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+          in  DisjointMap p' r'+    GT -> let p' = M.insert repy repx p+              r' = M.delete repy $! M.insert repx (Ranked rankx 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+          in  DisjointMap p' r'++{-|+Find the set representative for this input.+-}+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 :: (Ord k, Monoid v) => k -> v -> DisjointMap k v -> DisjointMap k v+insert !x !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+           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')+        Nothing ->+          let r' = M.insert x (Ranked 0 v) r+          in  DisjointMap p' r'++{-| Create a disjoint set with one member. O(1). -}+singleton :: k -> v -> DisjointMap k v+singleton !x !v =+  let p = M.singleton x x+      r = M.singleton x (Ranked 0 v)+   in DisjointMap p r++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 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++appendParents :: (Ord k, Monoid v) => Map k (Ranked 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+  else union x y ds++{-| Create a disjoint set where all members are equal. -}+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)+    in DisjointMap p r++{-|+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' !x set =+  case find x set of+    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  set' `seq` (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'++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'++-- 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 !rep = helper+  where+  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++
+ src/Data/DisjointSet.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -Wall #-}++module Data.DisjointSet+  ( DisjointSet+  , empty+  , singleton+  , singletons+  , insert+  , union+  , representative+  , representative'+  , toLists+  ) 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 Data.Map (Map)+import Data.Set (Set)+import Data.Semigroup (Semigroup)+import qualified Data.Semigroup+import qualified Data.Map.Strict as M+import qualified Data.Set as S++data DisjointSet a = DisjointSet+  !(Map a a) -- parents+  !(Map a Int) -- ranks++instance Ord a => Monoid (DisjointSet a) where+  mappend = append+  mempty = empty++instance Ord a => Semigroup (DisjointSet a) where+  (<>) = append++instance Ord a => Eq (DisjointSet a) where+  a == b = S.fromList (toSets a) == S.fromList (toSets b)++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+  show = showDisjointSet++showDisjointSet :: (Show a, Ord a) => DisjointSet a -> String+showDisjointSet = show . toLists++toLists :: Ord a => DisjointSet a -> [[a]]+toLists = map S.toList . toSets++toSets :: Ord a => DisjointSet a -> [Set a]+toSets = M.elems . flatten++-- 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)++{-|+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 !x !y set = flip execState set $ runMaybeT $ do+  repx <- lift $ state $ lookupCompressAdd x+  repy <- lift $ state $ lookupCompressAdd y+  guard $ repx /= repy+  DisjointSet p r <- lift get+  let rankx = r M.! repx+  let ranky = r M.! repy+  lift $ put $! case compare rankx ranky of+    LT -> let p' = M.insert repx repy p+              r' = M.delete repx r+          in  DisjointSet p' r'+    GT -> let p' = M.insert repy repx p+              r' = M.delete repy r+          in  DisjointSet p' r'+    EQ -> let p' = M.insert repx repy p+              r' = M.delete repx $! M.insert repy (ranky + 1) r+          in  DisjointSet p' r'++{-|+Find the set representative for this input.+-}+representative :: Ord a => a -> DisjointSet a -> Maybe a+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 :: 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 0 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+   in DisjointSet p r++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++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+singletons s = case S.lookupMin s of+  Nothing -> empty+  Just x ->+    let p = M.fromSet (\_ -> x) s+        r = M.singleton x 1+    in DisjointSet p r++{-|+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' !x set =+  case find x set of+    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 !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')++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'++-- 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 !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+
+ test/Spec.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE BangPatterns #-}++import Test.QuickCheck+import Data.Word+import Data.Monoid+import Data.DisjointSet (DisjointSet)+import Data.DisjointMap (DisjointMap)+import Data.Set (Set)+import Data.Foldable (toList)+import qualified Data.Foldable as F+import qualified Data.DisjointSet as DS+import qualified Data.DisjointMap as DM+import qualified GHC.OldList as L++main :: IO ()+main = do+  putStrLn "\nBeginning QuickCheck Tests"+  quickCheck propUnionAll+  quickCheck propUnionAppend+  quickCheck propSingletons+  quickCheck propMapUnionAppend++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+      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 = +  let r1 = unionPairs xs+      (xs1,xs2) = splitList xs+      r2 = unionPairs xs1 <> unionPairs xs2+   in r1 == r2++propMapUnionAppend :: [(Word,Word)] -> [(Word,Sum Word)] -> Bool+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++propSingletons :: [Set Word] -> Bool+propSingletons xs = foldMap unionFoldable xs == foldMap DS.singletons xs++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)++unionFoldable :: Ord a => Foldable t => t a -> DisjointSet a+unionFoldable xs =+  let ys = toList xs+      pairs = zip ys (drop 1 ys)+   in case ys of+        [] -> 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++unionPairs :: Ord a => [(a,a)] -> DisjointSet a+unionPairs xs = unionPairsGo xs DS.empty++unionPairsGo :: Ord a => [(a,a)] -> DisjointSet a -> DisjointSet a+unionPairsGo [] !ds = ds+unionPairsGo ((a,b):xs) !ds = unionPairsGo xs (DS.union a b ds)++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 [] !ds = ds+unionMapPairsGo ((a,b):xs) !ds = unionMapPairsGo xs (DM.union a b ds)