From 0e0479aaee21dd7b8e9ae303a3c897b5404b7497 Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Wed, 19 Jun 2019 23:02:45 +0200 Subject: [PATCH 01/12] Implement connectedComponents and isConnected --- src/Algebra/Graph/NonEmpty.hs | 57 ++++++++++++++++++++++++++++++++++- src/Algebra/Graph/ToGraph.hs | 10 ++++++ 2 files changed, 66 insertions(+), 1 deletion(-) diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs index 8b90fdd33..faf77969d 100644 --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -50,13 +50,17 @@ 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 Control.Applicative ((<|>)) import Algebra.Graph.Internal @@ -974,3 +978,54 @@ 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 = ccs where + underList :: Ord a => ([a] -> [a]) -> (Set.Set a -> Set.Set a) + underList = (Set.fromList .) . (. Set.toList) + + toMaybe :: Bool -> a -> Maybe a + toMaybe False _ = Nothing + toMaybe True x = Just x + + rewrite :: (a -> Maybe a) -> (a -> a) + rewrite f x = case f x of + Nothing -> x + Just x' -> rewrite f x' + + rewrites2 :: (a -> a -> Maybe a) -> ([a] -> [a]) + rewrites2 f = rewrite rewrites2' + where + rewrites2' (x1 : x2 : xs) = + ((: xs) <$> f x1 x2) <|> + ((x2 :) <$> rewrites2' (x1 : xs)) <|> + ((x1 :) <$> rewrites2' (x2 : xs)) + rewrites2' _ = Nothing + + nonEmptyCCs :: Ord a => G.Graph a -> Maybe (NonEmpty.NonEmpty (Graph a)) + nonEmptyCCs = NonEmpty.nonEmpty . Set.toList . ccs + + ccs :: Ord a => G.Graph a -> Set.Set (Graph a) + ccs G.Empty = Set.empty + ccs (G.Vertex x) = Set.singleton $ Vertex x + ccs (G.Overlay a b) = underList + (rewrites2 $ \g1 g2 -> toMaybe (T.sharesVertex g1 g2) (overlay g1 g2)) + (ccs a <> ccs b) + ccs (G.Connect a b) = case nonEmptyCCs a of + Nothing -> ccs b + Just ca -> case nonEmptyCCs b of + Nothing -> Set.fromList $ NonEmpty.toList ca + 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 diff --git a/src/Algebra/Graph/ToGraph.hs b/src/Algebra/Graph/ToGraph.hs index c010aed7d..559d1e363 100644 --- a/src/Algebra/Graph/ToGraph.hs +++ b/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 @@ -161,6 +162,15 @@ 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) where + (...) = (.) . (.) + -- | The set of vertices of a graph. Like 'vertexSet' but specialised for -- graphs with vertices of type 'Int'. -- From b0ba207417d59bc4e14a9ce18cee1e40a3e071d6 Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Wed, 19 Jun 2019 23:10:34 +0200 Subject: [PATCH 02/12] Add GG shorthand to Test/NonEmpty/Graph --- test/Algebra/Graph/Test/NonEmpty/Graph.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/Algebra/Graph/Test/NonEmpty/Graph.hs b/test/Algebra/Graph/Test/NonEmpty/Graph.hs index 14180c29f..61a1f486a 100644 --- a/test/Algebra/Graph/Test/NonEmpty/Graph.hs +++ b/test/Algebra/Graph/Test/NonEmpty/Graph.hs @@ -35,6 +35,7 @@ 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 +117,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 +180,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 From fef6f136b8c85bd5daeca0c92a22781f9dbb85e1 Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Thu, 20 Jun 2019 00:20:14 +0200 Subject: [PATCH 03/12] Add tests for NonEmpty.Graph.components --- test/Algebra/Graph/Test/NonEmpty/Graph.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/test/Algebra/Graph/Test/NonEmpty/Graph.hs b/test/Algebra/Graph/Test/NonEmpty/Graph.hs index 61a1f486a..1da9fc9d6 100644 --- a/test/Algebra/Graph/Test/NonEmpty/Graph.hs +++ b/test/Algebra/Graph/Test/NonEmpty/Graph.hs @@ -720,3 +720,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) -> Set.disjoint (vertexSet c1) (vertexSet c2)) . pairs . Set.toList $ components x From 05a8e53b94bceeb0fc93690067e09160acf86256 Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Thu, 20 Jun 2019 09:32:25 +0200 Subject: [PATCH 04/12] Formatting fixes --- src/Algebra/Graph/NonEmpty.hs | 6 +++--- test/Algebra/Graph/Test/NonEmpty/Graph.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs index faf77969d..dfd8b2d5a 100644 --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -998,9 +998,9 @@ components = ccs where rewrites2 f = rewrite rewrites2' where rewrites2' (x1 : x2 : xs) = - ((: xs) <$> f x1 x2) <|> - ((x2 :) <$> rewrites2' (x1 : xs)) <|> - ((x1 :) <$> rewrites2' (x2 : xs)) + (: xs) <$> f x1 x2 <|> + (x2 :) <$> rewrites2' (x1 : xs) <|> + (x1 :) <$> rewrites2' (x2 : xs) rewrites2' _ = Nothing nonEmptyCCs :: Ord a => G.Graph a -> Maybe (NonEmpty.NonEmpty (Graph a)) diff --git a/test/Algebra/Graph/Test/NonEmpty/Graph.hs b/test/Algebra/Graph/Test/NonEmpty/Graph.hs index 1da9fc9d6..90a7684de 100644 --- a/test/Algebra/Graph/Test/NonEmpty/Graph.hs +++ b/test/Algebra/Graph/Test/NonEmpty/Graph.hs @@ -731,8 +731,8 @@ testNonEmptyGraph = do 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 + 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] From 35443755a3c55fc77e86834f4826bace0793975b Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Thu, 20 Jun 2019 09:33:02 +0200 Subject: [PATCH 05/12] Mild refactor --- src/Algebra/Graph/NonEmpty.hs | 4 +--- test/Algebra/Graph/Test/NonEmpty/Graph.hs | 3 ++- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs index dfd8b2d5a..3313267a2 100644 --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -990,9 +990,7 @@ components = ccs where toMaybe True x = Just x rewrite :: (a -> Maybe a) -> (a -> a) - rewrite f x = case f x of - Nothing -> x - Just x' -> rewrite f x' + rewrite f x = maybe x (rewrite f) (f x) rewrites2 :: (a -> a -> Maybe a) -> ([a] -> [a]) rewrites2 f = rewrite rewrites2' diff --git a/test/Algebra/Graph/Test/NonEmpty/Graph.hs b/test/Algebra/Graph/Test/NonEmpty/Graph.hs index 90a7684de..a8feae40c 100644 --- a/test/Algebra/Graph/Test/NonEmpty/Graph.hs +++ b/test/Algebra/Graph/Test/NonEmpty/Graph.hs @@ -29,6 +29,7 @@ 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 @@ -737,4 +738,4 @@ testNonEmptyGraph = do 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) -> Set.disjoint (vertexSet c1) (vertexSet c2)) . pairs . Set.toList $ components x + all (\(c1, c2) -> not $ T.sharesVertex c1 c2) . pairs . Set.toList $ components x From 26ba8174fd9174fd9210799b2187495f236a39f9 Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Thu, 20 Jun 2019 09:38:14 +0200 Subject: [PATCH 06/12] Space change --- src/Algebra/Graph/NonEmpty.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs index 3313267a2..f9e9a48de 100644 --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -994,12 +994,12 @@ components = ccs where rewrites2 :: (a -> a -> Maybe a) -> ([a] -> [a]) rewrites2 f = rewrite rewrites2' - where - rewrites2' (x1 : x2 : xs) = - (: xs) <$> f x1 x2 <|> - (x2 :) <$> rewrites2' (x1 : xs) <|> - (x1 :) <$> rewrites2' (x2 : xs) - rewrites2' _ = Nothing + where + rewrites2' (x1 : x2 : xs) = + (: xs) <$> f x1 x2 <|> + (x2 :) <$> rewrites2' (x1 : xs) <|> + (x1 :) <$> rewrites2' (x2 : xs) + rewrites2' _ = Nothing nonEmptyCCs :: Ord a => G.Graph a -> Maybe (NonEmpty.NonEmpty (Graph a)) nonEmptyCCs = NonEmpty.nonEmpty . Set.toList . ccs From d6bf7181ff66fa231f4e5d5f81c175aed4941b82 Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Thu, 20 Jun 2019 14:04:40 +0200 Subject: [PATCH 07/12] Use faster algorithm for components Benchmarks ========== These benchmarks were done with the following program: ```haskell import Algebra.Graph (Graph) import Algebra.Graph.NonEmpty (components, vertexCount) import Algebra.Graph.Test.Arbitrary import Data.Foldable import qualified Data.Set as S import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.Random genSeed seed (MkGen g) = do let r = mkQCGen seed return (g r 30) main :: IO () main = do let gen = (resize 100 $ arbitrary) :: Gen (Graph Int) for_ [1..1000] $ \seed -> do g <- genSeed seed gen print (vertexCount <$> (S.toList $ components g)) ``` Ran on my own laptop. Not very scientific, but better than nothing, and the improvement is clear. The improvements mostly seem to be in the worst-case performance. When not using a fixed seed, times varied drastically. This does introduce a new dependency, but I think the speed improvement is worth it. 5 graphs of depth 1000 ---------------------- **New** 14.91user 0.04system 0:14.96elapsed 99%CPU (0avgtext+0avgdata 30688maxresident)k 0inputs+0outputs (0major+19991minor)pagefaults 0swaps **Old** 188.67user 0.44system 3:09.12elapsed 99%CPU (0avgtext+0avgdata 31592maxresident)k 0inputs+0outputs (0major+18148minor)pagefaults 0swaps 12x improvement 1000 graphs of depth 100 ------------------------ **New** 3.55user 0.02system 0:03.57elapsed 99%CPU (0avgtext+0avgdata 7408maxresident)k 0inputs+0outputs (0major+945minor)pagefaults 0swaps **Old** 98.67user 0.21system 1:38.91elapsed 99%CPU (0avgtext+0avgdata 7352maxresident)k 0inputs+0outputs (0major+942minor)pagefaults 0swaps 27x improvement --- algebraic-graphs.cabal | 3 +- src/Algebra/Graph/NonEmpty.hs | 57 ++++++++++++++++++++++++----------- 2 files changed, 41 insertions(+), 19 deletions(-) diff --git a/algebraic-graphs.cabal b/algebraic-graphs.cabal index 85815eba0..635636ead 100644 --- a/algebraic-graphs.cabal +++ b/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 diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs index f9e9a48de..08fa7107f 100644 --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor, PartialTypeSignatures #-} + +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} ----------------------------------------------------------------------------- -- | -- Module : Algebra.Graph.NonEmpty @@ -60,7 +62,8 @@ import Control.DeepSeq import Control.Monad.State import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup ((<>)) -import Control.Applicative ((<|>)) +import Data.Array ((!)) +import Data.Traversable (for) import Algebra.Graph.Internal @@ -68,6 +71,8 @@ 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.Array as Array +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 @@ -985,21 +990,37 @@ components = ccs where underList :: Ord a => ([a] -> [a]) -> (Set.Set a -> Set.Set a) underList = (Set.fromList .) . (. Set.toList) - toMaybe :: Bool -> a -> Maybe a - toMaybe False _ = Nothing - toMaybe True x = Just x - - rewrite :: (a -> Maybe a) -> (a -> a) - rewrite f x = maybe x (rewrite f) (f x) - - rewrites2 :: (a -> a -> Maybe a) -> ([a] -> [a]) - rewrites2 f = rewrite rewrites2' - where - rewrites2' (x1 : x2 : xs) = - (: xs) <$> f x1 x2 <|> - (x2 :) <$> rewrites2' (x1 : xs) <|> - (x1 :) <$> rewrites2' (x2 : xs) - rewrites2' _ = Nothing + 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 + len = length xs + -- 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 == []! + arr = Array.listArray (0, len) 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 (arr !) (+) $ do + s <- foldM update (IntSet.fromList indices) combis + classes <- for (IntSet.toList s) EQ.classDesc + pure classes nonEmptyCCs :: Ord a => G.Graph a -> Maybe (NonEmpty.NonEmpty (Graph a)) nonEmptyCCs = NonEmpty.nonEmpty . Set.toList . ccs @@ -1008,7 +1029,7 @@ components = ccs where ccs G.Empty = Set.empty ccs (G.Vertex x) = Set.singleton $ Vertex x ccs (G.Overlay a b) = underList - (rewrites2 $ \g1 g2 -> toMaybe (T.sharesVertex g1 g2) (overlay g1 g2)) + (mergeEquivalent T.sharesVertex overlay) (ccs a <> ccs b) ccs (G.Connect a b) = case nonEmptyCCs a of Nothing -> ccs b From c6613231aaac50d4911f7cd8b52c453ffff41bab Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Fri, 21 Jun 2019 13:50:08 +0200 Subject: [PATCH 08/12] Move blackbird to Algebra.Graph.Internal --- src/Algebra/Graph/Internal.hs | 6 +++++- src/Algebra/Graph/ToGraph.hs | 5 +++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Algebra/Graph/Internal.hs b/src/Algebra/Graph/Internal.hs index 946cb32ac..77ea89863 100644 --- a/src/Algebra/Graph/Internal.hs +++ b/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 +(...) = (.) . (.) diff --git a/src/Algebra/Graph/ToGraph.hs b/src/Algebra/Graph/ToGraph.hs index 559d1e363..b09d38487 100644 --- a/src/Algebra/Graph/ToGraph.hs +++ b/src/Algebra/Graph/ToGraph.hs @@ -71,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. @@ -168,8 +170,7 @@ class ToGraph t where -- sharesVertex x empty == False -- @ sharesVertex :: Ord (ToVertex t) => t -> t -> Bool - sharesVertex = not ... (Set.disjoint `on` vertexSet) where - (...) = (.) . (.) + sharesVertex = not ... (Set.disjoint `on` vertexSet) -- | The set of vertices of a graph. Like 'vertexSet' but specialised for -- graphs with vertices of type 'Int'. From bee8624a7776839591a6e655b46fb4e11218ce81 Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Fri, 21 Jun 2019 13:55:15 +0200 Subject: [PATCH 09/12] Refactor components in terms of foldg --- src/Algebra/Graph/NonEmpty.hs | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs index 08fa7107f..8d7529fca 100644 --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -986,7 +986,13 @@ sparsifyKL n graph = KL.buildG (1, next - 1) ((n + 1, n + 2) : Exts.toList (res components :: Ord a => G.Graph a -> Set.Set (Graph a) -components = ccs where +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) @@ -1022,19 +1028,14 @@ components = ccs where classes <- for (IntSet.toList s) EQ.classDesc pure classes - nonEmptyCCs :: Ord a => G.Graph a -> Maybe (NonEmpty.NonEmpty (Graph a)) - nonEmptyCCs = NonEmpty.nonEmpty . Set.toList . ccs - - ccs :: Ord a => G.Graph a -> Set.Set (Graph a) - ccs G.Empty = Set.empty - ccs (G.Vertex x) = Set.singleton $ Vertex x - ccs (G.Overlay a b) = underList - (mergeEquivalent T.sharesVertex overlay) - (ccs a <> ccs b) - ccs (G.Connect a b) = case nonEmptyCCs a of - Nothing -> ccs b - Just ca -> case nonEmptyCCs b of - Nothing -> Set.fromList $ NonEmpty.toList ca + 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 From a2cbdf43668663c342cf1414bca397c28d482d40 Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Fri, 21 Jun 2019 14:02:30 +0200 Subject: [PATCH 10/12] Simplify mergeEquivalent --- src/Algebra/Graph/NonEmpty.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Algebra/Graph/NonEmpty.hs b/src/Algebra/Graph/NonEmpty.hs index 8d7529fca..3b08b6d49 100644 --- a/src/Algebra/Graph/NonEmpty.hs +++ b/src/Algebra/Graph/NonEmpty.hs @@ -62,7 +62,6 @@ import Control.DeepSeq import Control.Monad.State import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup ((<>)) -import Data.Array ((!)) import Data.Traversable (for) import Algebra.Graph.Internal @@ -71,7 +70,6 @@ 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.Array as Array import qualified Data.Equivalence.Monad as EQ import qualified Data.Graph as KL import qualified Data.IntSet as IntSet @@ -1002,10 +1000,8 @@ components = G.foldg mergeEquivalent :: (Ord a) => (a -> a -> Bool) -> (a -> a -> a) -> ([a] -> [a]) mergeEquivalent (===) (+) xs = let - len = length xs -- 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 == []! - arr = Array.listArray (0, len) xs combis = pairs indices update :: IntSet.IntSet -> (Int, Int) -> EQ.EquivM _ _ Int IntSet.IntSet @@ -1023,7 +1019,7 @@ components = G.foldg else pure s - in EQ.runEquivM (arr !) (+) $ do + in EQ.runEquivM (xs !!) (+) $ do s <- foldM update (IntSet.fromList indices) combis classes <- for (IntSet.toList s) EQ.classDesc pure classes From 36f95b5f2e753dd7dbb30abb5304ddee608bd694 Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Fri, 21 Jun 2019 14:20:27 +0200 Subject: [PATCH 11/12] AUTHORS.md: fix trailing whitespace --- AUTHORS.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/AUTHORS.md b/AUTHORS.md index 8d689f970..21375eda2 100644 --- a/AUTHORS.md +++ b/AUTHORS.md @@ -9,12 +9,12 @@ but over time many contributors helped make it much better, including (among oth * [Armando Santos](mailto:armandoifsantos@gmail.com) [@bolt12](https://github.com/bolt12) * [Piotr Gawryś](mailto:pgawrys2@gmail.com) [@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 From 8e13aa55976785789be12adfc61abb9a58b18c77 Mon Sep 17 00:00:00 2001 From: Patrick Hilhorst Date: Fri, 21 Jun 2019 14:20:57 +0200 Subject: [PATCH 12/12] Add Synthetica9 to AUTHORS.md --- AUTHORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/AUTHORS.md b/AUTHORS.md index 21375eda2..349b05fd2 100644 --- a/AUTHORS.md +++ b/AUTHORS.md @@ -7,6 +7,7 @@ but over time many contributors helped make it much better, including (among oth * [Adithya Obilisetty](mailto:adi.obilisetty@gmail.com) [@adithyaov](https://github.com/adithyaov) * [Alexandre Moine](mailto:alexandre@moine.me) [@nobrakal](https://github.com/nobrakal) * [Armando Santos](mailto:armandoifsantos@gmail.com) [@bolt12](https://github.com/bolt12) +* Patrick Hilhorst [@Synthetica9](https://github.com/synthetica9) * [Piotr Gawryś](mailto:pgawrys2@gmail.com) [@Avasil](https://github.com/Avasil) If you are not on this list, it's not because your contributions are not appreciated, but