Implement connectedComponents and isConnected

AUTHORS.md

@@ -7,14 +7,15 @@ but over time many contributors helped make it much better, including (among oth
 * [Adithya Obilisetty](mailto:[email protected]) [@adithyaov](https://github.com/adithyaov)
 * [Alexandre Moine](mailto:[email protected]) [@nobrakal](https://github.com/nobrakal)
 * [Armando Santos](mailto:[email protected]) [@bolt12](https://github.com/bolt12)
+* Patrick Hilhorst [@Synthetica9](https://github.com/synthetica9)
 * [Piotr Gawryś](mailto:[email protected]) [@Avasil](https://github.com/Avasil)
 
-If you are not on this list, it's not because your contributions are not appreciated, but 
+If you are not on this list, it's not because your contributions are not appreciated, but
 because I didn't want to add your name and contact details without your consent. Please fix this
 by sending a PR, keeping the list alphabetical.
 
 Also see the autogenerated yet still possibly incomplete
 [list of contributors](https://github.com/snowleopard/alga/graphs/contributors).
 
-Thank you all for your help!  
+Thank you all for your help!
 Andrey

algebraic-graphs.cabal

@@ -94,7 +94,8 @@ library
                         base        >= 4.7     && < 5,
                         containers  >= 0.5.5.1 && < 0.8,
                         deepseq     >= 1.3.0.1 && < 1.5,
-                        mtl         >= 2.1     && < 2.3
+                        mtl         >= 2.1     && < 2.3,
+                        equivalence >= 0.3     && < 0.4
     if !impl(ghc >= 8.0)
         build-depends:  semigroups  >= 0.18.2  && < 0.18.4
     default-language:   Haskell2010

src/Algebra/Graph/Internal.hs

@@ -24,7 +24,7 @@ module Algebra.Graph.Internal (
     foldr1Safe, maybeF,
 
     -- * Utilities
-    setProduct, setProductWith
+    setProduct, setProductWith, (...)
     ) where
 
 import Data.Foldable
@@ -139,3 +139,7 @@ setProduct x y = Set.fromDistinctAscList [ (a, b) | a <- Set.toAscList x, b <- S
 -- resulting pair.
 setProductWith :: Ord c => (a -> b -> c) -> Set a -> Set b -> Set c
 setProductWith f x y = Set.fromList [ f a b | a <- Set.toAscList x, b <- Set.toAscList y ]
+
+-- | Blackbird combinator.
+(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
+(...) = (.) . (.)

src/Algebra/Graph/NonEmpty.hs

@@ -1,4 +1,6 @@
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFunctor, PartialTypeSignatures #-}
+
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module     : Algebra.Graph.NonEmpty
@@ -50,20 +52,25 @@ module Algebra.Graph.NonEmpty (
     transpose, induce1, induceJust1, simplify, sparsify, sparsifyKL,
 
     -- * Graph composition
-    box
+    box,
+
+    -- * Graph connectedness
+    components, isConnected,
     ) where
 
 import Control.DeepSeq
 import Control.Monad.State
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Semigroup ((<>))
+import Data.Traversable (for)
 
 import Algebra.Graph.Internal
 
 import qualified Algebra.Graph                 as G
 import qualified Algebra.Graph.ToGraph         as T
 import qualified Algebra.Graph.AdjacencyMap    as AM
 import qualified Algebra.Graph.AdjacencyIntMap as AIM
+import qualified Data.Equivalence.Monad        as EQ
 import qualified Data.Graph                    as KL
 import qualified Data.IntSet                   as IntSet
 import qualified Data.List.NonEmpty            as NonEmpty
@@ -974,3 +981,67 @@ sparsifyKL n graph = KL.buildG (1, next - 1) ((n + 1, n + 2) : Exts.toList (res
         m <- get
         put (m + 1)
         (\xs ys -> Exts.fromList [(s,m), (m,t)] <> xs <> ys) <$> s `x` m <*> m `y` t
+
+
+components :: Ord a => G.Graph a -> Set.Set (Graph a)
+components = G.foldg
+    Set.empty
+    (Set.singleton . Vertex)
+    (underList (mergeEquivalent T.sharesVertex overlay) ... Set.union)
+    connectCCs
+  where
+  -- TODO: move some of these definitions to src/Algebra/Graph/Internal.hs?
+  underList :: Ord a => ([a] -> [a]) -> (Set.Set a -> Set.Set a)
+  underList = (Set.fromList .) . (. Set.toList)
+
+  pairs :: Eq a => [a] -> [(a, a)]
+  pairs [] = []
+  pairs (x: xs) = ((x,) <$> xs) ++ pairs xs
+
+  mergeEquivalent :: (Ord a) => (a -> a -> Bool) -> (a -> a -> a) -> ([a] -> [a])
+  mergeEquivalent (===) (+) xs = let
+      -- https://github.com/quchen/articles/blob/master/2018-11-22_zipWith_const.md
+      indices = zipWith const [0..] xs -- Because just [0..len] generates [0] when xs == []!
+      combis = pairs indices
+
+      update :: IntSet.IntSet -> (Int, Int) -> EQ.EquivM _ _ Int IntSet.IntSet
+      update = \s (i1, i2) -> do
+        eq <- EQ.equivalent i1 i2
+        if eq
+          then pure s
+          else do
+            x1 <- EQ.classDesc i1
+            x2 <- EQ.classDesc i2
+            if (x1 === x2)
+              then do
+                EQ.equate i1 i2
+                pure $ IntSet.delete i1 s
+              else
+                pure s
+
+    in EQ.runEquivM (xs !!) (+) $ do
+      s <- foldM update (IntSet.fromList indices) combis
+      classes <- for (IntSet.toList s) EQ.classDesc
+      pure classes
+
+  nonEmptySet :: Set.Set a -> Maybe (NonEmpty a)
+  nonEmptySet = NonEmpty.nonEmpty . Set.toList
+
+  connectCCs :: Set.Set (Graph a) -> Set.Set (Graph a) -> Set.Set (Graph a)
+  connectCCs a b = case nonEmptySet a of
+    Nothing -> b
+    Just ca -> case nonEmptySet b of
+      Nothing -> a
+      Just cb -> Set.singleton $ overlays1 $ connect <$> ca <*> cb
+
+
+-- | Does the graph have exactly one connected component?
+-- @
+-- isConnected empty == False
+-- isConnected $ vertex x == True
+-- isConnected $ vertex x + vertex y == False
+-- @
+isConnected :: Ord a => G.Graph a -> Bool
+isConnected g = case Set.toList $ components g of
+  [_] -> True
+  _   -> False

src/Algebra/Graph/ToGraph.hs

@@ -53,6 +53,7 @@ import Data.IntMap (IntMap)
 import Data.IntSet (IntSet)
 import Data.Map    (Map)
 import Data.Set    (Set)
+import Data.Function (on)
 import Data.Tree
 
 import qualified Algebra.Graph                                as G
@@ -70,6 +71,8 @@ import qualified Data.IntSet                                  as IntSet
 import qualified Data.Map                                     as Map
 import qualified Data.Set                                     as Set
 
+import Algebra.Graph.Internal
+
 -- | The 'ToGraph' type class captures data types that can be converted to
 -- algebraic graphs. Instances of this type class should satisfy the laws
 -- specified by the default method definitions.
@@ -161,6 +164,14 @@ class ToGraph t where
     vertexSet :: Ord (ToVertex t) => t -> Set (ToVertex t)
     vertexSet = foldg Set.empty Set.singleton Set.union Set.union
 
+    -- | Check if two graphs share any vertices
+    --
+    -- @
+    -- sharesVertex x empty  == False
+    -- @
+    sharesVertex :: Ord (ToVertex t) => t -> t -> Bool
+    sharesVertex = not ... (Set.disjoint `on` vertexSet)
+
     -- | The set of vertices of a graph. Like 'vertexSet' but specialised for
     -- graphs with vertices of type 'Int'.
     --

test/Algebra/Graph/Test/NonEmpty/Graph.hs

@@ -29,12 +29,14 @@ import Algebra.Graph.Test hiding (axioms, theorems)
 import Algebra.Graph.ToGraph (reachable, toGraph)
 
 import qualified Algebra.Graph          as G
+import qualified Algebra.Graph.ToGraph  as T
 import qualified Algebra.Graph.NonEmpty as NonEmpty
 import qualified Data.Graph             as KL
 import qualified Data.List.NonEmpty     as NonEmpty
 import qualified Data.Set               as Set
 
 type G = NonEmpty.Graph Int
+type GG = G.Graph Int
 
 axioms :: G -> G -> G -> Property
 axioms x y z = conjoin
@@ -116,7 +118,7 @@ testNonEmptyGraph = do
 
     putStrLn $ "\n============ NonEmpty.Graph.toNonEmpty ============"
     test "toNonEmpty empty       == Nothing" $
-          toNonEmpty (G.empty :: G.Graph Int) == Nothing
+          toNonEmpty (G.empty :: GG) == Nothing
 
     test "toNonEmpty (toGraph x) == Just (x :: NonEmpty.Graph a)" $ \x ->
           toNonEmpty (toGraph x) == Just (x :: G)
@@ -179,7 +181,7 @@ testNonEmptyGraph = do
     test "               overlay1 empty x == x" $ \(x :: G) ->
                          overlay1 G.empty x == x
 
-    test "x /= empty ==> overlay1 x     y == overlay (fromJust $ toNonEmpty x) y" $ \(x :: G.Graph Int) (y :: G) ->
+    test "x /= empty ==> overlay1 x     y == overlay (fromJust $ toNonEmpty x) y" $ \(x :: GG) (y :: G) ->
           x /= G.empty ==> overlay1 x   y == overlay (fromJust $ toNonEmpty x) y
 
 
@@ -719,3 +721,21 @@ testNonEmptyGraph = do
 
     test "edgeCount   (box x y)               <= vertexCount x * edgeCount y + edgeCount x * vertexCount y" $ mapSize (min 10) $ \(x :: G) (y :: G) ->
           edgeCount   (box x y)               <= vertexCount x * edgeCount y + edgeCount x * vertexCount y
+
+    putStrLn "\n============ NonEmpty.Graph.components ============"
+    test "G.edgeSet x                         == Set.unions (edgeSet <$> (Set.toList $ components x))" $ \(x :: GG) ->
+          G.edgeSet x                         == Set.unions (edgeSet <$> (Set.toList $ components x))
+
+    test "G.vertexSet x                       == Set.unions (vertexSet <$> (Set.toList $ components x))" $ \(x :: GG) ->
+          G.vertexSet x                       == Set.unions (vertexSet <$> (Set.toList $ components x))
+
+    test "all (isConnected . toGraph) $ components x" $ \(x :: GG) ->
+          all (isConnected . toGraph) $ components x
+
+    test "all (\\c -> Set.singleton c == components (toGraph c)) $ components x" $ \(x :: GG) ->
+          all (\c -> Set.singleton c == components (toGraph c)) $ components x
+
+    let pairs xs = [(x, y) | x <- xs, y <- xs, x /= y]
+
+    test "all (\\(c1, c2) -> Set.disjoint (vertexSet c1) (vertexSet c2)) . pairs . Set.toList $ components x" $ \(x :: GG) ->
+          all (\(c1, c2) -> not $ T.sharesVertex c1 c2) . pairs . Set.toList $ components x