From 5996a243d57b75af906bfaaa1fefbcb84beb1c5e Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Wed, 3 May 2017 14:59:17 +0200 Subject: [PATCH 01/29] Added algorithms for finding strong components and cycles. --- Data/Graph/Inductive/Query/Cycles.hs | 280 +++++++++++++++++++++++++++ fgl.cabal | 1 + 2 files changed, 281 insertions(+) create mode 100644 Data/Graph/Inductive/Query/Cycles.hs diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs new file mode 100644 index 0000000..1cc06da --- /dev/null +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -0,0 +1,280 @@ +{- | + Module : Data.Graph.Inductive.Query.Cycles + Description : Algorithms for finding all cycles. + Copyright : (c) Gabriel Hjort Blindell 2017 + License : 2-Clause BSD + Maintainer : gabriel.hjort.blindell@gmail.com + + Defines algorithms that find all cycles in a given graph. + -} +module Data.Graph.Inductive.Query.Cycles + ( cyclesIn + , cyclesIn' + , strongComponentsOf + , uniqueCycles + , uniqueCycles' + ) +where + +import Data.Graph.Inductive.Graph + +import Data.List + ( (\\) + , delete + , tails + ) +import Data.Maybe + ( fromJust ) +import Control.Monad + ( ap ) +import qualified Data.Map as M + + + +-- | Obtain the labels for a list of 'Node's. +-- It is assumed that each 'Node' is indeed present in the given graph. +addLabels :: (Graph g) => g a b -> [Node] -> [LNode a] +addLabels gr = map (ap (,) (fromJust . lab gr)) + +twoCycle :: (Graph g) => g a b -> Node -> [Node] +twoCycle gr n = filter (elem n . suc gr) (delete n $ suc gr n) + +-- | Determines if the list of nodes represents a regular subgraph. +isRegular :: (Graph g) => g a b -> [Node] -> Bool +isRegular g ns = all allTwoCycle split + where + -- Node + Rest of list + split = zip ns tns' + tns' = tail $ tails ns + allTwoCycle (n,rs) = null $ rs \\ twoCycle g n + +-- | Contains the necessary data structures used by 'strongComponentsOf'. +data SCCState g a b + = SCCState + { sccComponents :: [g a b] + -- ^ The components found so far. + , sccCurrentIndex :: Int + -- ^ The current index. + , sccStack :: [Node] + -- ^ The node stack. + , sccNodeInfo :: M.Map Node (Bool, Int, Int) + -- ^ Node information as a tuple (whether the node is on the stack, its + -- index, and its low link). + , sccGraph :: g a b + -- ^ The input graph. + } + +-- | Find all strongly connected components of a graph. Implements Tarjan's +-- algorithm. Returned list is sorted in topological order. +strongComponentsOf :: (DynGraph g) => g a b -> [g a b] +strongComponentsOf g = + sccComponents $ + foldr ( \n st -> + let (_, i, _) = sccNodeInfo st M.! n + in if i < 0 then findSCCFor n st else st + ) + (mkInitSCCState g) + (nodes g) + +findSCCFor :: (DynGraph g) => Node -> SCCState g a b -> SCCState g a b +findSCCFor n st0 = + let i = sccCurrentIndex st0 + st1 = st0 { sccCurrentIndex = i + 1 + , sccStack = (n:sccStack st0) + , sccNodeInfo = M.insert n (True, i, i) (sccNodeInfo st0) + } + g = sccGraph st1 + st2 = foldr ( \m st -> + let st_ni = sccNodeInfo st + (m_on_stack, m_index, _) = st_ni M.! m + in if m_index < 0 + then let st' = findSCCFor m st + st_ni' = sccNodeInfo st' + (n_on_stack', n_index', n_lowlink') = + st_ni' M.! n + (_, _, m_lowlink) = st_ni' M.! m + new_n_ni = ( n_on_stack' + , n_index' + , min n_lowlink' m_lowlink + ) + in st' { sccNodeInfo = + M.insert n new_n_ni st_ni' + } + else if m_on_stack + then let (n_on_stack', n_index', n_lowlink') = + st_ni M.! n + new_n_ni = ( n_on_stack' + , n_index' + , min n_lowlink' m_index + ) + in st { sccNodeInfo = + M.insert n new_n_ni st_ni + } + else st + ) + st1 + (suc g n) + (_, n_index, n_lowlink) = sccNodeInfo st2 M.! n + st3 = if n_index == n_lowlink + then let stack = sccStack st2 + (p0, p1) = span (/= n) stack + comp_ns = (head p1:p0) + new_stack = tail p1 + new_ni = foldr ( \n' ni -> + let (_, n_index', n_lowlink') = ni M.! n' + new_n_ni = ( False + , n_index' + , n_lowlink' + ) + in M.insert n' new_n_ni ni + ) + (sccNodeInfo st2) + comp_ns + comp = nfilter (`elem` comp_ns) (sccGraph st2) + new_cs = (comp:sccComponents st2) + in st2 { sccComponents = new_cs + , sccStack = new_stack + , sccNodeInfo = new_ni + } + else st2 + in st3 + +mkInitSCCState :: (DynGraph g) => g a b -> SCCState g a b +mkInitSCCState g = + let ns = nodes g + in SCCState { sccComponents = [] + , sccCurrentIndex = 0 + , sccStack = [] + , sccNodeInfo = M.fromList $ zip ns (repeat (False, -1, -1)) + , sccGraph = g + } + +-- | Contains the necessary data structures used by 'cyclesIn'. +data CyclesInState g a b + = CyclesInState + { cisCycles :: [[Node]] + -- ^ The cycles found so far, in topological order. + , cisBlocked :: M.Map Node Bool + -- ^ The nodes which are currently blocked. + , cisBlockMap :: M.Map Node [Node] + -- ^ The B set. + , cisStack :: [Node] + -- ^ The node stack. + , cisS :: Maybe Node + -- ^ The current S value. + , cisCurrentComp :: Maybe (g a b) + -- ^ The component currently being processed. + , cisComponents :: [g a b] + -- ^ The components of the input graph. + , cisGraph :: g a b + -- ^ The input graph. + } + +-- | Finds all cycles in a given graph using Johnson's algorithm. +-- +-- See Donald B. Johnson: Finding All the Elementary Circuits of a Directed +-- Graph. SIAM Journal on Computing. Volumne 4, Nr. 1 (1975), pp. 77-84. +cyclesIn :: (DynGraph g) => g a b -> [[LNode a]] +cyclesIn g = map (addLabels g) (cyclesIn' g) + +-- | Finds all cycles in a given graph using Johnson's algorithm. +-- +-- See Donald B. Johnson: Finding All the Elementary Circuits of a Directed +-- Graph. SIAM Journal on Computing. Volumne 4, Nr. 1 (1975), pp. 77-84. +cyclesIn' :: (DynGraph g) => g a b -> [[Node]] +cyclesIn' g = + cisCycles $ + foldr cyclesFor (mkInitCyclesInState g) (nodes g) + +-- | Find all cycles in the given graph, excluding those that are also cliques. +uniqueCycles :: (DynGraph g) => g a b -> [[LNode a]] +uniqueCycles g = map (addLabels g) (uniqueCycles' g) + +-- | Find all cycles in the given graph, excluding those that are also cliques. +uniqueCycles' :: (DynGraph g) => g a b -> [[Node]] +uniqueCycles' g = filter (not . isRegular g) (cyclesIn' g) + +cyclesFor :: (DynGraph g) => Node -> CyclesInState g a b -> CyclesInState g a b +cyclesFor n st0 = + let n_comp = head $ + filter (\c -> n `gelem` c) $ + cisComponents st0 + in if noNodes n_comp > 1 + then let st1 = st0 { cisS = Just n + , cisCurrentComp = Just n_comp + } + st2 = fst $ cCircuits n st1 + g = cisGraph st2 + new_g = delNode n g + new_comps = strongComponentsOf new_g + st3 = st2 { cisGraph = new_g + , cisComponents = new_comps + } + in st3 + else st0 -- Skip to next node + +cCircuits :: (DynGraph g) => Node -> CyclesInState g a b -> + (CyclesInState g a b, Bool) +cCircuits n st0 = + let st1 = st0 { cisBlocked = M.insert n True (cisBlocked st0) + , cisStack = (n:cisStack st0) + } + c = fromJust $ cisCurrentComp st1 + n_suc = suc c n + (st2, f) = + foldr ( \m (st, f') -> + if m == fromJust (cisS st) + then let new_cycle = reverse (m:cisStack st) + st' = st { cisCycles = (new_cycle:cisCycles st) } + in (st', True) + else if not (cisBlocked st M.! m) + then let (st', f'') = cCircuits m st + in (st', f' || f'') + else (st, f') + ) + (st1, False) + n_suc + st3 = if f + then cUnblock n st2 + else foldr ( \m st -> + let bm = cisBlockMap st + m_blocked = bm M.! m + new_m_blocked = (n:m_blocked) + in if n `notElem` m_blocked + then st { cisBlockMap = + M.insert m new_m_blocked bm + } + else st + ) + st2 + n_suc + st4 = st3 { cisStack = tail $ cisStack st3 } + in (st4, f) + +cUnblock :: (DynGraph g) => Node -> CyclesInState g a b -> CyclesInState g a b +cUnblock n st0 = + let n_blocked = cisBlockMap st0 M.! n + st1 = st0 { cisBlocked = M.insert n False (cisBlocked st0) + , cisBlockMap = M.insert n [] (cisBlockMap st0) + } + st2 = foldr ( \m st -> + if cisBlocked st M.! m + then cUnblock m st + else st + ) + st1 + n_blocked + in st2 + +mkInitCyclesInState :: (DynGraph g) => g a b -> CyclesInState g a b +mkInitCyclesInState g = + let ns = nodes g + in CyclesInState { cisCycles = [] + , cisBlocked = M.fromList $ zip ns (repeat False) + , cisBlockMap = M.fromList $ zip ns (repeat []) + , cisStack = [] + , cisS = Nothing + , cisCurrentComp = Nothing + , cisComponents = strongComponentsOf g + , cisGraph = g + } diff --git a/fgl.cabal b/fgl.cabal index 5b88d3d..5be45c3 100644 --- a/fgl.cabal +++ b/fgl.cabal @@ -50,6 +50,7 @@ library { Data.Graph.Inductive.Query.ArtPoint, Data.Graph.Inductive.Query.BCC, Data.Graph.Inductive.Query.BFS, + Data.Graph.Inductive.Query.Cycles, Data.Graph.Inductive.Query.DFS, Data.Graph.Inductive.Query.Dominators, Data.Graph.Inductive.Query.GVD, From ca867a9a3b81eb8414259608238c7fdd1054881b Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 10:56:13 +0200 Subject: [PATCH 02/29] Removed header. --- Data/Graph/Inductive/Query/Cycles.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index 1cc06da..ff8124c 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -1,12 +1,5 @@ -{- | - Module : Data.Graph.Inductive.Query.Cycles - Description : Algorithms for finding all cycles. - Copyright : (c) Gabriel Hjort Blindell 2017 - License : 2-Clause BSD - Maintainer : gabriel.hjort.blindell@gmail.com +-- Implemented by Gabriel Hjort Blindell - Defines algorithms that find all cycles in a given graph. - -} module Data.Graph.Inductive.Query.Cycles ( cyclesIn , cyclesIn' From 205af436bde0f770dfca5ba2b452b99e3616d807 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 10:56:36 +0200 Subject: [PATCH 03/29] Added comment about functions copied from other packages. --- Data/Graph/Inductive/Query/Cycles.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index ff8124c..3af5816 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -24,8 +24,10 @@ import qualified Data.Map as M --- | Obtain the labels for a list of 'Node's. --- It is assumed that each 'Node' is indeed present in the given graph. +-- The following functions were copied from the Graphalyze package. + +-- | Obtain the labels for a list of 'Node's. It is assumed that each 'Node' is +-- indeed present in the given graph. addLabels :: (Graph g) => g a b -> [Node] -> [LNode a] addLabels gr = map (ap (,) (fromJust . lab gr)) @@ -41,6 +43,10 @@ isRegular g ns = all allTwoCycle split tns' = tail $ tails ns allTwoCycle (n,rs) = null $ rs \\ twoCycle g n +-- End of copied functions. + + + -- | Contains the necessary data structures used by 'strongComponentsOf'. data SCCState g a b = SCCState From b9019fee804c2dacaefdcb78db115374cead65f5 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 10:57:19 +0200 Subject: [PATCH 04/29] Put import blocks on the same line, according to coding convention. --- Data/Graph/Inductive/Query/Cycles.hs | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index 3af5816..52925ec 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -11,15 +11,9 @@ where import Data.Graph.Inductive.Graph -import Data.List - ( (\\) - , delete - , tails - ) -import Data.Maybe - ( fromJust ) -import Control.Monad - ( ap ) +import Data.List ((\\), delete, tails) +import Data.Maybe (fromJust) +import Control.Monad (ap) import qualified Data.Map as M From 6ce6e5d8953511866ad15d9d6d4af3bd1bad345c Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 11:26:26 +0200 Subject: [PATCH 05/29] Replaced use of Map with IntMap. --- Data/Graph/Inductive/Query/Cycles.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index 52925ec..ac907f2 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -14,7 +14,7 @@ import Data.Graph.Inductive.Graph import Data.List ((\\), delete, tails) import Data.Maybe (fromJust) import Control.Monad (ap) -import qualified Data.Map as M +import qualified Data.IntMap as M @@ -50,9 +50,8 @@ data SCCState g a b -- ^ The current index. , sccStack :: [Node] -- ^ The node stack. - , sccNodeInfo :: M.Map Node (Bool, Int, Int) - -- ^ Node information as a tuple (whether the node is on the stack, its - -- index, and its low link). + , sccNodeInfo :: M.IntMap SCCNodeInfo + -- ^ Node information. , sccGraph :: g a b -- ^ The input graph. } @@ -147,9 +146,9 @@ data CyclesInState g a b = CyclesInState { cisCycles :: [[Node]] -- ^ The cycles found so far, in topological order. - , cisBlocked :: M.Map Node Bool + , cisBlocked :: M.IntMap Bool -- ^ The nodes which are currently blocked. - , cisBlockMap :: M.Map Node [Node] + , cisBlockMap :: M.IntMap [Node] -- ^ The B set. , cisStack :: [Node] -- ^ The node stack. From 73707fe9a51d38686986ec889432b31afd7aef4b Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 11:27:28 +0200 Subject: [PATCH 06/29] Replaced use of tuple with a new data type. --- Data/Graph/Inductive/Query/Cycles.hs | 76 ++++++++++++++++++---------- 1 file changed, 48 insertions(+), 28 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index ac907f2..f5dfb2e 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -41,6 +41,15 @@ isRegular g ns = all allTwoCycle split +-- | Node information (whether the node is on the stack, its index, and its low +-- link), which is used as part of 'SCCState'. +data SCCNodeInfo + = SCCNodeInfo + { sccIsNodeOnStack :: Bool + , sccNodeIndex :: Int + , sccNodeLowLink :: Int + } + -- | Contains the necessary data structures used by 'strongComponentsOf'. data SCCState g a b = SCCState @@ -62,7 +71,7 @@ strongComponentsOf :: (DynGraph g) => g a b -> [g a b] strongComponentsOf g = sccComponents $ foldr ( \n st -> - let (_, i, _) = sccNodeInfo st M.! n + let i = sccNodeIndex $ sccNodeInfo st M.! n in if i < 0 then findSCCFor n st else st ) (mkInitSCCState g) @@ -73,51 +82,61 @@ findSCCFor n st0 = let i = sccCurrentIndex st0 st1 = st0 { sccCurrentIndex = i + 1 , sccStack = (n:sccStack st0) - , sccNodeInfo = M.insert n (True, i, i) (sccNodeInfo st0) + , sccNodeInfo = M.insert n + (SCCNodeInfo True i i) + (sccNodeInfo st0) } g = sccGraph st1 st2 = foldr ( \m st -> let st_ni = sccNodeInfo st - (m_on_stack, m_index, _) = st_ni M.! m + m_ni = st_ni M.! m + m_on_stack = sccIsNodeOnStack m_ni + m_index = sccNodeIndex m_ni in if m_index < 0 then let st' = findSCCFor m st st_ni' = sccNodeInfo st' - (n_on_stack', n_index', n_lowlink') = - st_ni' M.! n - (_, _, m_lowlink) = st_ni' M.! m - new_n_ni = ( n_on_stack' - , n_index' - , min n_lowlink' m_lowlink - ) - in st' { sccNodeInfo = - M.insert n new_n_ni st_ni' - } + n_ni' = st_ni' M.! n + n_on_stack' = sccIsNodeOnStack n_ni' + n_index' = sccNodeIndex n_ni' + n_lowlink' = sccNodeLowLink n_ni' + m_lowlink = sccNodeLowLink $ st_ni' M.! m + new_n_ni = SCCNodeInfo n_on_stack' + n_index' + ( min n_lowlink' + m_lowlink + ) + in st' { sccNodeInfo = M.insert n new_n_ni st_ni' } else if m_on_stack - then let (n_on_stack', n_index', n_lowlink') = - st_ni M.! n - new_n_ni = ( n_on_stack' - , n_index' - , min n_lowlink' m_index - ) - in st { sccNodeInfo = - M.insert n new_n_ni st_ni + then let n_ni' = st_ni M.! n + n_on_stack' = sccIsNodeOnStack n_ni' + n_index' = sccNodeIndex n_ni' + n_lowlink' = sccNodeLowLink n_ni' + new_n_ni = SCCNodeInfo n_on_stack' + n_index' + ( min n_lowlink' + m_index + ) + in st { sccNodeInfo = M.insert n new_n_ni st_ni } else st ) st1 (suc g n) - (_, n_index, n_lowlink) = sccNodeInfo st2 M.! n + n_ni = sccNodeInfo st2 M.! n + n_index = sccNodeIndex n_ni + n_lowlink = sccNodeLowLink n_ni st3 = if n_index == n_lowlink then let stack = sccStack st2 (p0, p1) = span (/= n) stack comp_ns = (head p1:p0) new_stack = tail p1 new_ni = foldr ( \n' ni -> - let (_, n_index', n_lowlink') = ni M.! n' - new_n_ni = ( False - , n_index' - , n_lowlink' - ) + let n_ni' = ni M.! n' + n_index' = sccNodeIndex n_ni' + n_lowlink' = sccNodeLowLink n_ni' + new_n_ni = SCCNodeInfo False + n_index' + n_lowlink' in M.insert n' new_n_ni ni ) (sccNodeInfo st2) @@ -134,10 +153,11 @@ findSCCFor n st0 = mkInitSCCState :: (DynGraph g) => g a b -> SCCState g a b mkInitSCCState g = let ns = nodes g + init_ni = SCCNodeInfo False (-1) (-1) in SCCState { sccComponents = [] , sccCurrentIndex = 0 , sccStack = [] - , sccNodeInfo = M.fromList $ zip ns (repeat (False, -1, -1)) + , sccNodeInfo = M.fromList $ zip ns (repeat init_ni) , sccGraph = g } From 6d51e8b58fe5b8b43993971acf1dbfadbbf58e37 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 11:27:41 +0200 Subject: [PATCH 07/29] Added instances to data types. --- Data/Graph/Inductive/Query/Cycles.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index f5dfb2e..87c634f 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -49,6 +49,7 @@ data SCCNodeInfo , sccNodeIndex :: Int , sccNodeLowLink :: Int } + deriving (Show, Read, Eq) -- | Contains the necessary data structures used by 'strongComponentsOf'. data SCCState g a b @@ -64,6 +65,7 @@ data SCCState g a b , sccGraph :: g a b -- ^ The input graph. } + deriving (Show, Read, Eq) -- | Find all strongly connected components of a graph. Implements Tarjan's -- algorithm. Returned list is sorted in topological order. @@ -181,6 +183,7 @@ data CyclesInState g a b , cisGraph :: g a b -- ^ The input graph. } + deriving (Show, Read, Eq) -- | Finds all cycles in a given graph using Johnson's algorithm. -- From 003c96ce362dcf7940ed64e0a15b7c9853231d6c Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 11:29:19 +0200 Subject: [PATCH 08/29] Added wiki link to Tarjan's SCC algorithm. --- Data/Graph/Inductive/Query/Cycles.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index 87c634f..08b7057 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -67,8 +67,11 @@ data SCCState g a b } deriving (Show, Read, Eq) --- | Find all strongly connected components of a graph. Implements Tarjan's --- algorithm. Returned list is sorted in topological order. +-- | Find all strongly connected components of a graph. Returned list is sorted +-- in topological order. +-- +-- Implements Tarjan's algorithm: +-- https://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm strongComponentsOf :: (DynGraph g) => g a b -> [g a b] strongComponentsOf g = sccComponents $ From c8649fae022609bc206608b048d00686eee1ad8b Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 11:51:39 +0200 Subject: [PATCH 09/29] Broken out large anonymous functions into named functions. --- Data/Graph/Inductive/Query/Cycles.hs | 107 +++++++++++++-------------- 1 file changed, 51 insertions(+), 56 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index 08b7057..ba78cef 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -92,68 +92,63 @@ findSCCFor n st0 = (sccNodeInfo st0) } g = sccGraph st1 - st2 = foldr ( \m st -> - let st_ni = sccNodeInfo st - m_ni = st_ni M.! m - m_on_stack = sccIsNodeOnStack m_ni - m_index = sccNodeIndex m_ni - in if m_index < 0 - then let st' = findSCCFor m st - st_ni' = sccNodeInfo st' - n_ni' = st_ni' M.! n - n_on_stack' = sccIsNodeOnStack n_ni' - n_index' = sccNodeIndex n_ni' - n_lowlink' = sccNodeLowLink n_ni' - m_lowlink = sccNodeLowLink $ st_ni' M.! m - new_n_ni = SCCNodeInfo n_on_stack' - n_index' - ( min n_lowlink' - m_lowlink - ) - in st' { sccNodeInfo = M.insert n new_n_ni st_ni' } - else if m_on_stack - then let n_ni' = st_ni M.! n - n_on_stack' = sccIsNodeOnStack n_ni' - n_index' = sccNodeIndex n_ni' - n_lowlink' = sccNodeLowLink n_ni' - new_n_ni = SCCNodeInfo n_on_stack' - n_index' - ( min n_lowlink' - m_index - ) - in st { sccNodeInfo = M.insert n new_n_ni st_ni - } - else st - ) - st1 - (suc g n) + st2 = foldr computeLowLinks st1 (suc g n) n_ni = sccNodeInfo st2 M.! n n_index = sccNodeIndex n_ni n_lowlink = sccNodeLowLink n_ni st3 = if n_index == n_lowlink - then let stack = sccStack st2 - (p0, p1) = span (/= n) stack - comp_ns = (head p1:p0) - new_stack = tail p1 - new_ni = foldr ( \n' ni -> - let n_ni' = ni M.! n' - n_index' = sccNodeIndex n_ni' - n_lowlink' = sccNodeLowLink n_ni' - new_n_ni = SCCNodeInfo False - n_index' - n_lowlink' - in M.insert n' new_n_ni ni - ) - (sccNodeInfo st2) - comp_ns - comp = nfilter (`elem` comp_ns) (sccGraph st2) - new_cs = (comp:sccComponents st2) - in st2 { sccComponents = new_cs - , sccStack = new_stack - , sccNodeInfo = new_ni - } + then produceSCC st2 else st2 in st3 + where + computeLowLinks m st + | isIndexUndefined = + let st' = findSCCFor m st + st_ni' = sccNodeInfo st' + n_ni' = st_ni' M.! n + n_on_stack' = sccIsNodeOnStack n_ni' + n_index' = sccNodeIndex n_ni' + n_lowlink' = sccNodeLowLink n_ni' + m_lowlink = sccNodeLowLink $ st_ni' M.! m + new_n_ni = SCCNodeInfo n_on_stack' + n_index' + (min n_lowlink' m_lowlink) + in st' { sccNodeInfo = M.insert n new_n_ni st_ni' } + | isOnStack = + let st_ni = sccNodeInfo st + m_index = sccNodeIndex $ st_ni M.! m + n_ni' = st_ni M.! n + n_on_stack' = sccIsNodeOnStack n_ni' + n_index' = sccNodeIndex n_ni' + n_lowlink' = sccNodeLowLink n_ni' + new_n_ni = SCCNodeInfo n_on_stack' + n_index' + (min n_lowlink' m_index) + in st { sccNodeInfo = M.insert n new_n_ni st_ni } + | otherwise = st + where isIndexUndefined = let i = sccNodeIndex $ (sccNodeInfo st) M.! m + in i < 0 + isOnStack = sccIsNodeOnStack $ (sccNodeInfo st) M.! m + produceSCC st = + let stack = sccStack st + (p0, p1) = span (/= n) stack + comp_ns = (head p1:p0) + new_stack = tail p1 + new_ni = foldr ( \n' ni -> + let n_ni' = ni M.! n' + n_index' = sccNodeIndex n_ni' + n_lowlink' = sccNodeLowLink n_ni' + new_n_ni = SCCNodeInfo False n_index' n_lowlink' + in M.insert n' new_n_ni ni + ) + (sccNodeInfo st) + comp_ns + comp = nfilter (`elem` comp_ns) (sccGraph st) + new_cs = (comp:sccComponents st) + in st { sccComponents = new_cs + , sccStack = new_stack + , sccNodeInfo = new_ni + } mkInitSCCState :: (DynGraph g) => g a b -> SCCState g a b mkInitSCCState g = From ab5064af4da01c29927677136ea48ee5f08bd59d Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 11:53:39 +0200 Subject: [PATCH 10/29] Put short if-then-else statement on the same line. --- Data/Graph/Inductive/Query/Cycles.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index ba78cef..4325ba2 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -96,9 +96,7 @@ findSCCFor n st0 = n_ni = sccNodeInfo st2 M.! n n_index = sccNodeIndex n_ni n_lowlink = sccNodeLowLink n_ni - st3 = if n_index == n_lowlink - then produceSCC st2 - else st2 + st3 = if n_index == n_lowlink then produceSCC st2 else st2 in st3 where computeLowLinks m st @@ -271,9 +269,7 @@ cUnblock n st0 = , cisBlockMap = M.insert n [] (cisBlockMap st0) } st2 = foldr ( \m st -> - if cisBlocked st M.! m - then cUnblock m st - else st + if cisBlocked st M.! m then cUnblock m st else st ) st1 n_blocked From 514151b9c4397aaefc90a7d0d5cf7da6603e8233 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 12:20:16 +0200 Subject: [PATCH 11/29] Code refactoring. --- Data/Graph/Inductive/Query/Cycles.hs | 56 +++++++++++----------------- 1 file changed, 22 insertions(+), 34 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index 4325ba2..fa44c07 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -93,36 +93,26 @@ findSCCFor n st0 = } g = sccGraph st1 st2 = foldr computeLowLinks st1 (suc g n) - n_ni = sccNodeInfo st2 M.! n - n_index = sccNodeIndex n_ni - n_lowlink = sccNodeLowLink n_ni - st3 = if n_index == n_lowlink then produceSCC st2 else st2 + ni = sccNodeInfo st2 M.! n + index = sccNodeIndex ni + lowlink = sccNodeLowLink ni + st3 = if index == lowlink then produceSCC st2 else st2 in st3 where computeLowLinks m st | isIndexUndefined = let st' = findSCCFor m st - st_ni' = sccNodeInfo st' - n_ni' = st_ni' M.! n - n_on_stack' = sccIsNodeOnStack n_ni' - n_index' = sccNodeIndex n_ni' - n_lowlink' = sccNodeLowLink n_ni' - m_lowlink = sccNodeLowLink $ st_ni' M.! m - new_n_ni = SCCNodeInfo n_on_stack' - n_index' - (min n_lowlink' m_lowlink) - in st' { sccNodeInfo = M.insert n new_n_ni st_ni' } + ni = sccNodeInfo st' M.! n + n_lowlink = sccNodeLowLink ni + m_lowlink = sccNodeLowLink $ sccNodeInfo st' M.! m + new_ni = ni { sccNodeLowLink = min n_lowlink m_lowlink } + in st' { sccNodeInfo = M.insert n new_ni (sccNodeInfo st') } | isOnStack = - let st_ni = sccNodeInfo st - m_index = sccNodeIndex $ st_ni M.! m - n_ni' = st_ni M.! n - n_on_stack' = sccIsNodeOnStack n_ni' - n_index' = sccNodeIndex n_ni' - n_lowlink' = sccNodeLowLink n_ni' - new_n_ni = SCCNodeInfo n_on_stack' - n_index' - (min n_lowlink' m_index) - in st { sccNodeInfo = M.insert n new_n_ni st_ni } + let ni = sccNodeInfo st M.! n + n_lowlink = sccNodeLowLink ni + m_index = sccNodeIndex $ sccNodeInfo st M.! m + new_ni = ni { sccNodeLowLink = min n_lowlink m_index } + in st { sccNodeInfo = M.insert n new_ni (sccNodeInfo st) } | otherwise = st where isIndexUndefined = let i = sccNodeIndex $ (sccNodeInfo st) M.! m in i < 0 @@ -132,20 +122,18 @@ findSCCFor n st0 = (p0, p1) = span (/= n) stack comp_ns = (head p1:p0) new_stack = tail p1 - new_ni = foldr ( \n' ni -> - let n_ni' = ni M.! n' - n_index' = sccNodeIndex n_ni' - n_lowlink' = sccNodeLowLink n_ni' - new_n_ni = SCCNodeInfo False n_index' n_lowlink' - in M.insert n' new_n_ni ni - ) - (sccNodeInfo st) - comp_ns + new_map = foldr ( \n' ni_map -> + let ni = ni_map M.! n' + new_ni = ni { sccIsNodeOnStack = False } + in M.insert n' new_ni ni_map + ) + (sccNodeInfo st) + comp_ns comp = nfilter (`elem` comp_ns) (sccGraph st) new_cs = (comp:sccComponents st) in st { sccComponents = new_cs , sccStack = new_stack - , sccNodeInfo = new_ni + , sccNodeInfo = new_map } mkInitSCCState :: (DynGraph g) => g a b -> SCCState g a b From f2e043e3b69cacabddcec04994ee4b2ef4957517 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 13:58:41 +0200 Subject: [PATCH 12/29] Broken out SCC parts from Cycles into its own module. Also renamed 'cyclesIn' to 'cycles'. --- Data/Graph/Inductive/Query.hs | 2 + Data/Graph/Inductive/Query/Cycles.hs | 124 ++------------------------- Data/Graph/Inductive/Query/SCC.hs | 122 ++++++++++++++++++++++++++ fgl.cabal | 1 + 4 files changed, 134 insertions(+), 115 deletions(-) create mode 100644 Data/Graph/Inductive/Query/SCC.hs diff --git a/Data/Graph/Inductive/Query.hs b/Data/Graph/Inductive/Query.hs index 5a6c873..989649d 100644 --- a/Data/Graph/Inductive/Query.hs +++ b/Data/Graph/Inductive/Query.hs @@ -3,6 +3,7 @@ module Data.Graph.Inductive.Query (module Q) where import Data.Graph.Inductive.Query.ArtPoint as Q import Data.Graph.Inductive.Query.BCC as Q import Data.Graph.Inductive.Query.BFS as Q +import Data.Graph.Inductive.Query.Cycles as Q import Data.Graph.Inductive.Query.DFS as Q import Data.Graph.Inductive.Query.Dominators as Q import Data.Graph.Inductive.Query.GVD as Q @@ -11,5 +12,6 @@ import Data.Graph.Inductive.Query.MaxFlow as Q import Data.Graph.Inductive.Query.MaxFlow2 as Q import Data.Graph.Inductive.Query.Monad as Q import Data.Graph.Inductive.Query.MST as Q +import Data.Graph.Inductive.Query.SCC as Q import Data.Graph.Inductive.Query.SP as Q import Data.Graph.Inductive.Query.TransClos as Q diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index fa44c07..b60ff76 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -1,15 +1,15 @@ -- Implemented by Gabriel Hjort Blindell module Data.Graph.Inductive.Query.Cycles - ( cyclesIn - , cyclesIn' - , strongComponentsOf + ( cycles + , cycles' , uniqueCycles , uniqueCycles' ) where import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Query.SCC import Data.List ((\\), delete, tails) import Data.Maybe (fromJust) @@ -41,113 +41,7 @@ isRegular g ns = all allTwoCycle split --- | Node information (whether the node is on the stack, its index, and its low --- link), which is used as part of 'SCCState'. -data SCCNodeInfo - = SCCNodeInfo - { sccIsNodeOnStack :: Bool - , sccNodeIndex :: Int - , sccNodeLowLink :: Int - } - deriving (Show, Read, Eq) - --- | Contains the necessary data structures used by 'strongComponentsOf'. -data SCCState g a b - = SCCState - { sccComponents :: [g a b] - -- ^ The components found so far. - , sccCurrentIndex :: Int - -- ^ The current index. - , sccStack :: [Node] - -- ^ The node stack. - , sccNodeInfo :: M.IntMap SCCNodeInfo - -- ^ Node information. - , sccGraph :: g a b - -- ^ The input graph. - } - deriving (Show, Read, Eq) - --- | Find all strongly connected components of a graph. Returned list is sorted --- in topological order. --- --- Implements Tarjan's algorithm: --- https://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm -strongComponentsOf :: (DynGraph g) => g a b -> [g a b] -strongComponentsOf g = - sccComponents $ - foldr ( \n st -> - let i = sccNodeIndex $ sccNodeInfo st M.! n - in if i < 0 then findSCCFor n st else st - ) - (mkInitSCCState g) - (nodes g) - -findSCCFor :: (DynGraph g) => Node -> SCCState g a b -> SCCState g a b -findSCCFor n st0 = - let i = sccCurrentIndex st0 - st1 = st0 { sccCurrentIndex = i + 1 - , sccStack = (n:sccStack st0) - , sccNodeInfo = M.insert n - (SCCNodeInfo True i i) - (sccNodeInfo st0) - } - g = sccGraph st1 - st2 = foldr computeLowLinks st1 (suc g n) - ni = sccNodeInfo st2 M.! n - index = sccNodeIndex ni - lowlink = sccNodeLowLink ni - st3 = if index == lowlink then produceSCC st2 else st2 - in st3 - where - computeLowLinks m st - | isIndexUndefined = - let st' = findSCCFor m st - ni = sccNodeInfo st' M.! n - n_lowlink = sccNodeLowLink ni - m_lowlink = sccNodeLowLink $ sccNodeInfo st' M.! m - new_ni = ni { sccNodeLowLink = min n_lowlink m_lowlink } - in st' { sccNodeInfo = M.insert n new_ni (sccNodeInfo st') } - | isOnStack = - let ni = sccNodeInfo st M.! n - n_lowlink = sccNodeLowLink ni - m_index = sccNodeIndex $ sccNodeInfo st M.! m - new_ni = ni { sccNodeLowLink = min n_lowlink m_index } - in st { sccNodeInfo = M.insert n new_ni (sccNodeInfo st) } - | otherwise = st - where isIndexUndefined = let i = sccNodeIndex $ (sccNodeInfo st) M.! m - in i < 0 - isOnStack = sccIsNodeOnStack $ (sccNodeInfo st) M.! m - produceSCC st = - let stack = sccStack st - (p0, p1) = span (/= n) stack - comp_ns = (head p1:p0) - new_stack = tail p1 - new_map = foldr ( \n' ni_map -> - let ni = ni_map M.! n' - new_ni = ni { sccIsNodeOnStack = False } - in M.insert n' new_ni ni_map - ) - (sccNodeInfo st) - comp_ns - comp = nfilter (`elem` comp_ns) (sccGraph st) - new_cs = (comp:sccComponents st) - in st { sccComponents = new_cs - , sccStack = new_stack - , sccNodeInfo = new_map - } - -mkInitSCCState :: (DynGraph g) => g a b -> SCCState g a b -mkInitSCCState g = - let ns = nodes g - init_ni = SCCNodeInfo False (-1) (-1) - in SCCState { sccComponents = [] - , sccCurrentIndex = 0 - , sccStack = [] - , sccNodeInfo = M.fromList $ zip ns (repeat init_ni) - , sccGraph = g - } - --- | Contains the necessary data structures used by 'cyclesIn'. +-- | Contains the necessary data structures used by 'cycles'. data CyclesInState g a b = CyclesInState { cisCycles :: [[Node]] @@ -173,15 +67,15 @@ data CyclesInState g a b -- -- See Donald B. Johnson: Finding All the Elementary Circuits of a Directed -- Graph. SIAM Journal on Computing. Volumne 4, Nr. 1 (1975), pp. 77-84. -cyclesIn :: (DynGraph g) => g a b -> [[LNode a]] -cyclesIn g = map (addLabels g) (cyclesIn' g) +cycles :: (DynGraph g) => g a b -> [[LNode a]] +cycles g = map (addLabels g) (cycles' g) -- | Finds all cycles in a given graph using Johnson's algorithm. -- -- See Donald B. Johnson: Finding All the Elementary Circuits of a Directed -- Graph. SIAM Journal on Computing. Volumne 4, Nr. 1 (1975), pp. 77-84. -cyclesIn' :: (DynGraph g) => g a b -> [[Node]] -cyclesIn' g = +cycles' :: (DynGraph g) => g a b -> [[Node]] +cycles' g = cisCycles $ foldr cyclesFor (mkInitCyclesInState g) (nodes g) @@ -191,7 +85,7 @@ uniqueCycles g = map (addLabels g) (uniqueCycles' g) -- | Find all cycles in the given graph, excluding those that are also cliques. uniqueCycles' :: (DynGraph g) => g a b -> [[Node]] -uniqueCycles' g = filter (not . isRegular g) (cyclesIn' g) +uniqueCycles' g = filter (not . isRegular g) (cycles' g) cyclesFor :: (DynGraph g) => Node -> CyclesInState g a b -> CyclesInState g a b cyclesFor n st0 = diff --git a/Data/Graph/Inductive/Query/SCC.hs b/Data/Graph/Inductive/Query/SCC.hs new file mode 100644 index 0000000..2bf5bfa --- /dev/null +++ b/Data/Graph/Inductive/Query/SCC.hs @@ -0,0 +1,122 @@ +{- | + Module : Data.Graph.Inductive.Query.SCC + Description : Finds all strongly connected components. + Copyright : (c) Gabriel Hjort Blindell + License : BSD3 +-} + +module Data.Graph.Inductive.Query.SCC + ( strongComponentsOf ) +where + +import Data.Graph.Inductive.Graph + +import qualified Data.IntMap as M + + + +-- | Node information (whether the node is on the stack, its index, and its low +-- link), which is used as part of 'SCCState'. +data SCCNodeInfo + = SCCNodeInfo + { sccIsNodeOnStack :: Bool + , sccNodeIndex :: Int + , sccNodeLowLink :: Int + } + deriving (Show, Read, Eq) + +-- | Contains the necessary data structures used by 'strongComponentsOf'. +data SCCState g a b + = SCCState + { sccComponents :: [g a b] + -- ^ The components found so far. + , sccCurrentIndex :: Int + -- ^ The current index. + , sccStack :: [Node] + -- ^ The node stack. + , sccNodeInfo :: M.IntMap SCCNodeInfo + -- ^ Node information. + , sccGraph :: g a b + -- ^ The input graph. + } + deriving (Show, Read, Eq) + +-- | Find all strongly connected components of a graph. Returned list is sorted +-- in topological order. +-- +-- Implements Tarjan's algorithm: +-- https://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm +strongComponentsOf :: (DynGraph g) => g a b -> [g a b] +strongComponentsOf g = + sccComponents $ + foldr ( \n st -> + let i = sccNodeIndex $ sccNodeInfo st M.! n + in if i < 0 then findSCCFor n st else st + ) + (mkInitSCCState g) + (nodes g) + +findSCCFor :: (DynGraph g) => Node -> SCCState g a b -> SCCState g a b +findSCCFor n st0 = + let i = sccCurrentIndex st0 + st1 = st0 { sccCurrentIndex = i + 1 + , sccStack = (n:sccStack st0) + , sccNodeInfo = M.insert n + (SCCNodeInfo True i i) + (sccNodeInfo st0) + } + g = sccGraph st1 + st2 = foldr computeLowLinks st1 (suc g n) + ni = sccNodeInfo st2 M.! n + index = sccNodeIndex ni + lowlink = sccNodeLowLink ni + st3 = if index == lowlink then produceSCC st2 else st2 + in st3 + where + computeLowLinks m st + | isIndexUndefined = + let st' = findSCCFor m st + ni = sccNodeInfo st' M.! n + n_lowlink = sccNodeLowLink ni + m_lowlink = sccNodeLowLink $ sccNodeInfo st' M.! m + new_ni = ni { sccNodeLowLink = min n_lowlink m_lowlink } + in st' { sccNodeInfo = M.insert n new_ni (sccNodeInfo st') } + | isOnStack = + let ni = sccNodeInfo st M.! n + n_lowlink = sccNodeLowLink ni + m_index = sccNodeIndex $ sccNodeInfo st M.! m + new_ni = ni { sccNodeLowLink = min n_lowlink m_index } + in st { sccNodeInfo = M.insert n new_ni (sccNodeInfo st) } + | otherwise = st + where isIndexUndefined = let i = sccNodeIndex $ (sccNodeInfo st) M.! m + in i < 0 + isOnStack = sccIsNodeOnStack $ (sccNodeInfo st) M.! m + produceSCC st = + let stack = sccStack st + (p0, p1) = span (/= n) stack + comp_ns = (head p1:p0) + new_stack = tail p1 + new_map = foldr ( \n' ni_map -> + let ni = ni_map M.! n' + new_ni = ni { sccIsNodeOnStack = False } + in M.insert n' new_ni ni_map + ) + (sccNodeInfo st) + comp_ns + comp = nfilter (`elem` comp_ns) (sccGraph st) + new_cs = (comp:sccComponents st) + in st { sccComponents = new_cs + , sccStack = new_stack + , sccNodeInfo = new_map + } + +mkInitSCCState :: (DynGraph g) => g a b -> SCCState g a b +mkInitSCCState g = + let ns = nodes g + init_ni = SCCNodeInfo False (-1) (-1) + in SCCState { sccComponents = [] + , sccCurrentIndex = 0 + , sccStack = [] + , sccNodeInfo = M.fromList $ zip ns (repeat init_ni) + , sccGraph = g + } diff --git a/fgl.cabal b/fgl.cabal index 5be45c3..87479ff 100644 --- a/fgl.cabal +++ b/fgl.cabal @@ -59,6 +59,7 @@ library { Data.Graph.Inductive.Query.MaxFlow, Data.Graph.Inductive.Query.MaxFlow2, Data.Graph.Inductive.Query.Monad, + Data.Graph.Inductive.Query.SCC, Data.Graph.Inductive.Query.SP, Data.Graph.Inductive.Query.TransClos, Data.Graph.Inductive From 8e4102c6a73ab762c17f239aff6022042f6e201d Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 13:59:39 +0200 Subject: [PATCH 13/29] Added header. --- Data/Graph/Inductive/Query/Cycles.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index b60ff76..b6a6c97 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -1,4 +1,10 @@ --- Implemented by Gabriel Hjort Blindell +{- | + Module : Data.Graph.Inductive.Query.Cycles + Description : Finds all cycles. + Copyright : (c) Gabriel Hjort Blindell + Ivan Lazar Miljenovic + License : BSD3 +-} module Data.Graph.Inductive.Query.Cycles ( cycles From 874da104725b60b6cd9f662d1d95b542ce5380c0 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 14:20:32 +0200 Subject: [PATCH 14/29] Cycles and SCC modules no longer require the graphs to be of DynGraph class type. --- Data/Graph/Inductive/Query/Cycles.hs | 16 ++++++++-------- Data/Graph/Inductive/Query/SCC.hs | 18 ++++++++++++------ 2 files changed, 20 insertions(+), 14 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index b6a6c97..f125ae2 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -73,27 +73,27 @@ data CyclesInState g a b -- -- See Donald B. Johnson: Finding All the Elementary Circuits of a Directed -- Graph. SIAM Journal on Computing. Volumne 4, Nr. 1 (1975), pp. 77-84. -cycles :: (DynGraph g) => g a b -> [[LNode a]] +cycles :: (Graph g) => g a b -> [[LNode a]] cycles g = map (addLabels g) (cycles' g) -- | Finds all cycles in a given graph using Johnson's algorithm. -- -- See Donald B. Johnson: Finding All the Elementary Circuits of a Directed -- Graph. SIAM Journal on Computing. Volumne 4, Nr. 1 (1975), pp. 77-84. -cycles' :: (DynGraph g) => g a b -> [[Node]] +cycles' :: (Graph g) => g a b -> [[Node]] cycles' g = cisCycles $ foldr cyclesFor (mkInitCyclesInState g) (nodes g) -- | Find all cycles in the given graph, excluding those that are also cliques. -uniqueCycles :: (DynGraph g) => g a b -> [[LNode a]] +uniqueCycles :: (Graph g) => g a b -> [[LNode a]] uniqueCycles g = map (addLabels g) (uniqueCycles' g) -- | Find all cycles in the given graph, excluding those that are also cliques. -uniqueCycles' :: (DynGraph g) => g a b -> [[Node]] +uniqueCycles' :: (Graph g) => g a b -> [[Node]] uniqueCycles' g = filter (not . isRegular g) (cycles' g) -cyclesFor :: (DynGraph g) => Node -> CyclesInState g a b -> CyclesInState g a b +cyclesFor :: (Graph g) => Node -> CyclesInState g a b -> CyclesInState g a b cyclesFor n st0 = let n_comp = head $ filter (\c -> n `gelem` c) $ @@ -112,7 +112,7 @@ cyclesFor n st0 = in st3 else st0 -- Skip to next node -cCircuits :: (DynGraph g) => Node -> CyclesInState g a b -> +cCircuits :: (Graph g) => Node -> CyclesInState g a b -> (CyclesInState g a b, Bool) cCircuits n st0 = let st1 = st0 { cisBlocked = M.insert n True (cisBlocked st0) @@ -150,7 +150,7 @@ cCircuits n st0 = st4 = st3 { cisStack = tail $ cisStack st3 } in (st4, f) -cUnblock :: (DynGraph g) => Node -> CyclesInState g a b -> CyclesInState g a b +cUnblock :: (Graph g) => Node -> CyclesInState g a b -> CyclesInState g a b cUnblock n st0 = let n_blocked = cisBlockMap st0 M.! n st1 = st0 { cisBlocked = M.insert n False (cisBlocked st0) @@ -163,7 +163,7 @@ cUnblock n st0 = n_blocked in st2 -mkInitCyclesInState :: (DynGraph g) => g a b -> CyclesInState g a b +mkInitCyclesInState :: (Graph g) => g a b -> CyclesInState g a b mkInitCyclesInState g = let ns = nodes g in CyclesInState { cisCycles = [] diff --git a/Data/Graph/Inductive/Query/SCC.hs b/Data/Graph/Inductive/Query/SCC.hs index 2bf5bfa..45eee81 100644 --- a/Data/Graph/Inductive/Query/SCC.hs +++ b/Data/Graph/Inductive/Query/SCC.hs @@ -46,7 +46,7 @@ data SCCState g a b -- -- Implements Tarjan's algorithm: -- https://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm -strongComponentsOf :: (DynGraph g) => g a b -> [g a b] +strongComponentsOf :: (Graph g) => g a b -> [g a b] strongComponentsOf g = sccComponents $ foldr ( \n st -> @@ -56,7 +56,7 @@ strongComponentsOf g = (mkInitSCCState g) (nodes g) -findSCCFor :: (DynGraph g) => Node -> SCCState g a b -> SCCState g a b +findSCCFor :: (Graph g) => Node -> SCCState g a b -> SCCState g a b findSCCFor n st0 = let i = sccCurrentIndex st0 st1 = st0 { sccCurrentIndex = i + 1 @@ -94,7 +94,10 @@ findSCCFor n st0 = produceSCC st = let stack = sccStack st (p0, p1) = span (/= n) stack - comp_ns = (head p1:p0) + ns = (head p1:p0) + lab_ns = filter (\(n', _) -> n' `elem` ns) $ + labNodes $ + sccGraph st new_stack = tail p1 new_map = foldr ( \n' ni_map -> let ni = ni_map M.! n' @@ -102,15 +105,18 @@ findSCCFor n st0 = in M.insert n' new_ni ni_map ) (sccNodeInfo st) - comp_ns - comp = nfilter (`elem` comp_ns) (sccGraph st) + ns + lab_es = filter (\(n', m', _) -> n' `elem` ns || m' `elem` ns) $ + labEdges $ + sccGraph st + comp = mkGraph lab_ns lab_es new_cs = (comp:sccComponents st) in st { sccComponents = new_cs , sccStack = new_stack , sccNodeInfo = new_map } -mkInitSCCState :: (DynGraph g) => g a b -> SCCState g a b +mkInitSCCState :: (Graph g) => g a b -> SCCState g a b mkInitSCCState g = let ns = nodes g init_ni = SCCNodeInfo False (-1) (-1) From 73694ef049cf6f018d2dae17576e6b7360b6177c Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 14:21:20 +0200 Subject: [PATCH 15/29] Added tests for SCC module. --- test/Data/Graph/Inductive/Query/Properties.hs | 9 +++++++++ test/TestSuite.hs | 2 ++ 2 files changed, 11 insertions(+) diff --git a/test/Data/Graph/Inductive/Query/Properties.hs b/test/Data/Graph/Inductive/Query/Properties.hs index f2e001b..4003867 100644 --- a/test/Data/Graph/Inductive/Query/Properties.hs +++ b/test/Data/Graph/Inductive/Query/Properties.hs @@ -304,6 +304,15 @@ test_msTree _ cg = ns == mstNs && S.isSubsetOf mstEs es toE (w,l) (v,_) = (v,w,l) +-- ----------------------------------------------------------------------------- +-- SCC + +-- | The strongly connected components should be a partitioning of the nodes of +-- a graph. +test_strongComponentsOf :: (Graph gr) => Proxy (gr a b) -> gr a b -> Bool +test_strongComponentsOf _ g = + sort (concatMap nodes (strongComponentsOf g)) == sort (nodes g) + -- ----------------------------------------------------------------------------- -- SP diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 1353ef3..0274f6e 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -116,6 +116,8 @@ queryTests = describe "Queries" $ do test_maxFlow2 test_maxFlow propP "msTree" test_msTree + describe "SCC" $ do + propP "strongComponentsOf" test_strongComponentsOf describe "SP" $ do propP "sp" test_sp propP "sp_Just" test_sp_Just From a8b439b4fd2018abae8e50f1623efe9880c84f5d Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 14:56:05 +0200 Subject: [PATCH 16/29] Added tests for the Cycles module. --- test/Data/Graph/Inductive/Query/Properties.hs | 37 ++++++++++++++++++- test/TestSuite.hs | 3 ++ 2 files changed, 39 insertions(+), 1 deletion(-) diff --git a/test/Data/Graph/Inductive/Query/Properties.hs b/test/Data/Graph/Inductive/Query/Properties.hs index 4003867..ee27276 100644 --- a/test/Data/Graph/Inductive/Query/Properties.hs +++ b/test/Data/Graph/Inductive/Query/Properties.hs @@ -26,7 +26,7 @@ import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, import Test.QuickCheck import Control.Arrow (second) -import Data.List (delete, sort, unfoldr, group, (\\)) +import Data.List (delete, sort, sortBy, unfoldr, group, (\\)) import Data.Maybe (fromJust, isJust, isNothing) import qualified Data.Set as S @@ -85,6 +85,41 @@ test_level _ cg = sort expect == sort (level cn g) -- esp tested as part of test_sp +-- ----------------------------------------------------------------------------- +-- Cycles + +test_cycles :: Spec +test_cycles = + it "cycles" $ + sortCycles (cycles cyclesGraph) `shouldMatchList` [ [4, 5] + , [1, 2, 3] + , [0, 1, 2, 3, 4] + ] + +test_uniqueCycles :: Spec +test_uniqueCycles = + it "uniqueCycles" $ + sortCycles (uniqueCycles cyclesGraph) `shouldMatchList` [ [1, 2, 3] + , [0, 1, 2, 3, 4] + ] + +sortCycles :: [[LNode ()]] -> [[Node]] +sortCycles cs = map (map fst . sort) $ + sortBy (\c1 c2 -> compare (length c1) (length c2)) $ + cs + +cyclesGraph :: Gr () () +cyclesGraph = mkUGraph [0..6] + [ (0,1) + , (1,2) + , (2,3) + , (3,1) + , (3,4) + , (3,6) + , (4,0) + , (4,5) + ] + -- ----------------------------------------------------------------------------- -- DFS diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 0274f6e..1ba0474 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -96,6 +96,9 @@ queryTests = describe "Queries" $ do describe "BFS" $ do propP "bfs" test_bfs propP "level" test_level + describe "Cycles" $ do + test_cycles + test_uniqueCycles describe "DFS" $ do propP "components" test_components propP "scc" test_scc From ed7df2705e32384d8b8ebb295755a1453f5464c6 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 15:12:10 +0200 Subject: [PATCH 17/29] Improved documentation. Lists returned from cycles no longer contains duplicate nodes (hence the node indicating the start and end of a cycle appears only once). --- Data/Graph/Inductive/Query/Cycles.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index f125ae2..594d22b 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -69,28 +69,29 @@ data CyclesInState g a b } deriving (Show, Read, Eq) --- | Finds all cycles in a given graph using Johnson's algorithm. +-- | Finds all cycles in a given graph. The returned lists contains the nodes +-- appearing in the cycles, in successor order (although it is undefined which +-- node appears first). -- --- See Donald B. Johnson: Finding All the Elementary Circuits of a Directed --- Graph. SIAM Journal on Computing. Volumne 4, Nr. 1 (1975), pp. 77-84. +-- Implemented using Johnson's algorithm. See Donald B. Johnson: Finding All the +-- Elementary Circuits of a Directed Graph. SIAM Journal on Computing. Volumne +-- 4, Nr. 1 (1975), pp. 77-84. cycles :: (Graph g) => g a b -> [[LNode a]] cycles g = map (addLabels g) (cycles' g) --- | Finds all cycles in a given graph using Johnson's algorithm. --- --- See Donald B. Johnson: Finding All the Elementary Circuits of a Directed --- Graph. SIAM Journal on Computing. Volumne 4, Nr. 1 (1975), pp. 77-84. +-- | Same as 'cycles' but for unlabeled graphs. cycles' :: (Graph g) => g a b -> [[Node]] cycles' g = cisCycles $ foldr cyclesFor (mkInitCyclesInState g) (nodes g) --- | Find all cycles in the given graph, excluding those that are also cliques. -uniqueCycles :: (Graph g) => g a b -> [[LNode a]] +-- | Find all cycles in the given graph (using 'cycles'), excluding those that +-- are also cliques. +uniqueCycles :: (Graph g) => g a b -> [[LNode a]] uniqueCycles g = map (addLabels g) (uniqueCycles' g) --- | Find all cycles in the given graph, excluding those that are also cliques. -uniqueCycles' :: (Graph g) => g a b -> [[Node]] +-- | Same as 'uniqueCycles' but for unlabeled graphs. +uniqueCycles' :: (Graph g) => g a b -> [[Node]] uniqueCycles' g = filter (not . isRegular g) (cycles' g) cyclesFor :: (Graph g) => Node -> CyclesInState g a b -> CyclesInState g a b @@ -123,7 +124,7 @@ cCircuits n st0 = (st2, f) = foldr ( \m (st, f') -> if m == fromJust (cisS st) - then let new_cycle = reverse (m:cisStack st) + then let new_cycle = reverse $ cisStack st st' = st { cisCycles = (new_cycle:cisCycles st) } in (st', True) else if not (cisBlocked st M.! m) From 112309d845dec583e4055f7ccbdc0f874bb32a16 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 15:33:33 +0200 Subject: [PATCH 18/29] Fixed bug. --- Data/Graph/Inductive/Query/SCC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Data/Graph/Inductive/Query/SCC.hs b/Data/Graph/Inductive/Query/SCC.hs index 45eee81..cbde996 100644 --- a/Data/Graph/Inductive/Query/SCC.hs +++ b/Data/Graph/Inductive/Query/SCC.hs @@ -106,7 +106,7 @@ findSCCFor n st0 = ) (sccNodeInfo st) ns - lab_es = filter (\(n', m', _) -> n' `elem` ns || m' `elem` ns) $ + lab_es = filter (\(n', m', _) -> n' `elem` ns && m' `elem` ns) $ labEdges $ sccGraph st comp = mkGraph lab_ns lab_es From 0dc411a7eec807390bb52be9d28ffab219aa3f9e Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Thu, 4 May 2017 15:38:58 +0200 Subject: [PATCH 19/29] Fixed test case. --- test/Data/Graph/Inductive/Query/Properties.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Data/Graph/Inductive/Query/Properties.hs b/test/Data/Graph/Inductive/Query/Properties.hs index ee27276..faf937c 100644 --- a/test/Data/Graph/Inductive/Query/Properties.hs +++ b/test/Data/Graph/Inductive/Query/Properties.hs @@ -118,6 +118,7 @@ cyclesGraph = mkUGraph [0..6] , (3,6) , (4,0) , (4,5) + , (5,4) ] -- ----------------------------------------------------------------------------- From bd818d2fb49785873df2591d2e7575a391054f84 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Tue, 3 Oct 2017 09:34:21 +0200 Subject: [PATCH 20/29] Broken down cCircuits into several smaller functions. --- Data/Graph/Inductive/Query/Cycles.hs | 49 ++++++++++++++-------------- 1 file changed, 24 insertions(+), 25 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index 594d22b..c879018 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -121,36 +121,35 @@ cCircuits n st0 = } c = fromJust $ cisCurrentComp st1 n_suc = suc c n - (st2, f) = - foldr ( \m (st, f') -> - if m == fromJust (cisS st) - then let new_cycle = reverse $ cisStack st - st' = st { cisCycles = (new_cycle:cisCycles st) } - in (st', True) - else if not (cisBlocked st M.! m) - then let (st', f'') = cCircuits m st - in (st', f' || f'') - else (st, f') - ) - (st1, False) - n_suc + (st2, f) = foldr cCircuitsVisit (st1, False) n_suc st3 = if f then cUnblock n st2 - else foldr ( \m st -> - let bm = cisBlockMap st - m_blocked = bm M.! m - new_m_blocked = (n:m_blocked) - in if n `notElem` m_blocked - then st { cisBlockMap = - M.insert m new_m_blocked bm - } - else st - ) - st2 - n_suc + else foldr (cCircuitsBlock n) st2 n_suc st4 = st3 { cisStack = tail $ cisStack st3 } in (st4, f) +cCircuitsVisit :: (Graph g) => Node -> (CyclesInState g a b, Bool) -> + (CyclesInState g a b, Bool) +cCircuitsVisit n (st0, f0) = + if n == fromJust (cisS st0) + then let new_cycle = reverse $ cisStack st0 + st1 = st0 { cisCycles = (new_cycle:cisCycles st0) } + in (st1, True) + else if not (cisBlocked st0 M.! n) + then let (st1, f1) = cCircuits n st0 + in (st1, f0 || f1) + else (st0, f0) + +cCircuitsBlock :: (Graph g) => Node -> Node -> CyclesInState g a b -> + CyclesInState g a b +cCircuitsBlock n m st0 = + let bm = cisBlockMap st0 + m_blocked = bm M.! m + new_m_blocked = (n:m_blocked) + in if n `notElem` m_blocked + then st0 { cisBlockMap = M.insert m new_m_blocked bm } + else st0 + cUnblock :: (Graph g) => Node -> CyclesInState g a b -> CyclesInState g a b cUnblock n st0 = let n_blocked = cisBlockMap st0 M.! n From 99948d3002e546cd150ab2133f87cdef6ffc6623 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Tue, 3 Oct 2017 09:41:12 +0200 Subject: [PATCH 21/29] Fixed erronous function descriptions of cycles' and uniqueCycles'. --- Data/Graph/Inductive/Query/Cycles.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index c879018..5971524 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -79,7 +79,7 @@ data CyclesInState g a b cycles :: (Graph g) => g a b -> [[LNode a]] cycles g = map (addLabels g) (cycles' g) --- | Same as 'cycles' but for unlabeled graphs. +-- | Same as 'cycles' but does not return the node labels. cycles' :: (Graph g) => g a b -> [[Node]] cycles' g = cisCycles $ @@ -90,7 +90,7 @@ cycles' g = uniqueCycles :: (Graph g) => g a b -> [[LNode a]] uniqueCycles g = map (addLabels g) (uniqueCycles' g) --- | Same as 'uniqueCycles' but for unlabeled graphs. +-- | Same as 'uniqueCycles' but does not return the node labels. uniqueCycles' :: (Graph g) => g a b -> [[Node]] uniqueCycles' g = filter (not . isRegular g) (cycles' g) From 766a4f228d10fa85c2575571561582b1dcec246c Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Tue, 3 Oct 2017 09:42:45 +0200 Subject: [PATCH 22/29] Added missing bang patterns to CyclesInState. --- Data/Graph/Inductive/Query/Cycles.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index 5971524..f73d7dd 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -50,21 +50,21 @@ isRegular g ns = all allTwoCycle split -- | Contains the necessary data structures used by 'cycles'. data CyclesInState g a b = CyclesInState - { cisCycles :: [[Node]] + { cisCycles :: ![[Node]] -- ^ The cycles found so far, in topological order. - , cisBlocked :: M.IntMap Bool + , cisBlocked :: !(M.IntMap Bool) -- ^ The nodes which are currently blocked. - , cisBlockMap :: M.IntMap [Node] + , cisBlockMap :: !(M.IntMap [Node]) -- ^ The B set. - , cisStack :: [Node] + , cisStack :: ![Node] -- ^ The node stack. - , cisS :: Maybe Node + , cisS :: !(Maybe Node) -- ^ The current S value. - , cisCurrentComp :: Maybe (g a b) + , cisCurrentComp :: !(Maybe (g a b)) -- ^ The component currently being processed. - , cisComponents :: [g a b] + , cisComponents :: ![g a b] -- ^ The components of the input graph. - , cisGraph :: g a b + , cisGraph :: !(g a b) -- ^ The input graph. } deriving (Show, Read, Eq) From 3ce62ca7f5098ed83510448a92fd7f6ee54797b3 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Tue, 3 Oct 2017 09:49:10 +0200 Subject: [PATCH 23/29] Added missing bang patterns to SCCState. --- Data/Graph/Inductive/Query/SCC.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Data/Graph/Inductive/Query/SCC.hs b/Data/Graph/Inductive/Query/SCC.hs index cbde996..a36ad83 100644 --- a/Data/Graph/Inductive/Query/SCC.hs +++ b/Data/Graph/Inductive/Query/SCC.hs @@ -28,15 +28,15 @@ data SCCNodeInfo -- | Contains the necessary data structures used by 'strongComponentsOf'. data SCCState g a b = SCCState - { sccComponents :: [g a b] + { sccComponents :: !([g a b]) -- ^ The components found so far. - , sccCurrentIndex :: Int + , sccCurrentIndex :: !Int -- ^ The current index. - , sccStack :: [Node] + , sccStack :: ![Node] -- ^ The node stack. - , sccNodeInfo :: M.IntMap SCCNodeInfo + , sccNodeInfo :: !(M.IntMap SCCNodeInfo) -- ^ Node information. - , sccGraph :: g a b + , sccGraph :: !(g a b) -- ^ The input graph. } deriving (Show, Read, Eq) From c06f25c8ed41c7c46cd50da4be29f9ce8e0bce82 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Tue, 3 Oct 2017 10:12:26 +0200 Subject: [PATCH 24/29] Fixed typo. --- Data/Graph/Inductive/Query/SP.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Data/Graph/Inductive/Query/SP.hs b/Data/Graph/Inductive/Query/SP.hs index 96b2588..ca5fd57 100644 --- a/Data/Graph/Inductive/Query/SP.hs +++ b/Data/Graph/Inductive/Query/SP.hs @@ -63,7 +63,7 @@ spLength s t = getDistance t . spTree s -- | Shortest path between two nodes, if any. -- --- Returns 'Nothing' if the destination is not reachable from teh +-- Returns 'Nothing' if the destination is not reachable from the -- start node, and @'Just' @ otherwise. -- -- The edge labels of type @b@ are the edge weights; negative edge From a60460edc85c16197a366f09b8d5b9705f4d5ee7 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Tue, 3 Oct 2017 10:20:27 +0200 Subject: [PATCH 25/29] Expanded test_strongComponentsOf to check that there exists no cycle between any two nodes belonging to separate components. --- test/Data/Graph/Inductive/Query/Properties.hs | 23 +++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/test/Data/Graph/Inductive/Query/Properties.hs b/test/Data/Graph/Inductive/Query/Properties.hs index faf937c..bc1ccd9 100644 --- a/test/Data/Graph/Inductive/Query/Properties.hs +++ b/test/Data/Graph/Inductive/Query/Properties.hs @@ -344,10 +344,29 @@ test_msTree _ cg = ns == mstNs && S.isSubsetOf mstEs es -- SCC -- | The strongly connected components should be a partitioning of the nodes of --- a graph. +-- a graph and there should be no cycle between any pair of nodes from two +-- separate partitions. test_strongComponentsOf :: (Graph gr) => Proxy (gr a b) -> gr a b -> Bool test_strongComponentsOf _ g = - sort (concatMap nodes (strongComponentsOf g)) == sort (nodes g) + let cs = strongComponentsOf g + + -- Get set of unordered pairs of components, excluding reflexive + -- pairs + numbered_cs = zip ([0..] :: [Int]) cs + cs_pairs = map (\((_, c), (_, d)) -> (c, d)) $ + filter (\((n, _), (m, _)) -> n < m) $ + [ (x, y) | x <- numbered_cs, y <- numbered_cs ] + + -- Tests that there exist no cycle between two nodes + test_no_cycle (n, m) = let n_to_m = m `elem` reachable n g + m_to_n = n `elem` reachable m g + in not (n_to_m && m_to_n) + + in sort (concatMap nodes cs) == sort (nodes g) + && all ( \(c, d) -> all test_no_cycle + [ (n, m) | n <- nodes c, m <- nodes d ] + ) + cs_pairs -- ----------------------------------------------------------------------------- -- SP From 0fd7130485a9b1675879abd59559322fb6b91862 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Tue, 3 Oct 2017 10:38:24 +0200 Subject: [PATCH 26/29] Rewrote cCircuitsVisit using guards. --- Data/Graph/Inductive/Query/Cycles.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index f73d7dd..964f509 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -130,15 +130,15 @@ cCircuits n st0 = cCircuitsVisit :: (Graph g) => Node -> (CyclesInState g a b, Bool) -> (CyclesInState g a b, Bool) -cCircuitsVisit n (st0, f0) = - if n == fromJust (cisS st0) - then let new_cycle = reverse $ cisStack st0 - st1 = st0 { cisCycles = (new_cycle:cisCycles st0) } - in (st1, True) - else if not (cisBlocked st0 M.! n) - then let (st1, f1) = cCircuits n st0 - in (st1, f0 || f1) - else (st0, f0) +cCircuitsVisit n (st0, f0) + | n == fromJust (cisS st0) = + let new_cycle = reverse $ cisStack st0 + st1 = st0 { cisCycles = (new_cycle:cisCycles st0) } + in (st1, True) + | not (cisBlocked st0 M.! n) = + let (st1, f1) = cCircuits n st0 + in (st1, f0 || f1) + | otherwise = (st0, f0) cCircuitsBlock :: (Graph g) => Node -> Node -> CyclesInState g a b -> CyclesInState g a b From d3e2a0f23f24eaa0c46413a42122dc41963ab722 Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Tue, 3 Oct 2017 10:53:38 +0200 Subject: [PATCH 27/29] Removed cisS field from CyclesInState, and now passing that value as function parameter instead (this removes the need for using Maybe, which could fail). --- Data/Graph/Inductive/Query/Cycles.hs | 22 +++++++++------------- 1 file changed, 9 insertions(+), 13 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index 964f509..3a93ac7 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -58,8 +58,6 @@ data CyclesInState g a b -- ^ The B set. , cisStack :: ![Node] -- ^ The node stack. - , cisS :: !(Maybe Node) - -- ^ The current S value. , cisCurrentComp :: !(Maybe (g a b)) -- ^ The component currently being processed. , cisComponents :: ![g a b] @@ -100,10 +98,9 @@ cyclesFor n st0 = filter (\c -> n `gelem` c) $ cisComponents st0 in if noNodes n_comp > 1 - then let st1 = st0 { cisS = Just n - , cisCurrentComp = Just n_comp + then let st1 = st0 { cisCurrentComp = Just n_comp } - st2 = fst $ cCircuits n st1 + st2 = fst $ cCircuits n n st1 g = cisGraph st2 new_g = delNode n g new_comps = strongComponentsOf new_g @@ -113,30 +110,30 @@ cyclesFor n st0 = in st3 else st0 -- Skip to next node -cCircuits :: (Graph g) => Node -> CyclesInState g a b -> +cCircuits :: (Graph g) => Node -> Node -> CyclesInState g a b -> (CyclesInState g a b, Bool) -cCircuits n st0 = +cCircuits s n st0 = let st1 = st0 { cisBlocked = M.insert n True (cisBlocked st0) , cisStack = (n:cisStack st0) } c = fromJust $ cisCurrentComp st1 n_suc = suc c n - (st2, f) = foldr cCircuitsVisit (st1, False) n_suc + (st2, f) = foldr (cCircuitsVisit s) (st1, False) n_suc st3 = if f then cUnblock n st2 else foldr (cCircuitsBlock n) st2 n_suc st4 = st3 { cisStack = tail $ cisStack st3 } in (st4, f) -cCircuitsVisit :: (Graph g) => Node -> (CyclesInState g a b, Bool) -> +cCircuitsVisit :: (Graph g) => Node -> Node -> (CyclesInState g a b, Bool) -> (CyclesInState g a b, Bool) -cCircuitsVisit n (st0, f0) - | n == fromJust (cisS st0) = +cCircuitsVisit s n (st0, f0) + | n == s = let new_cycle = reverse $ cisStack st0 st1 = st0 { cisCycles = (new_cycle:cisCycles st0) } in (st1, True) | not (cisBlocked st0 M.! n) = - let (st1, f1) = cCircuits n st0 + let (st1, f1) = cCircuits s n st0 in (st1, f0 || f1) | otherwise = (st0, f0) @@ -170,7 +167,6 @@ mkInitCyclesInState g = , cisBlocked = M.fromList $ zip ns (repeat False) , cisBlockMap = M.fromList $ zip ns (repeat []) , cisStack = [] - , cisS = Nothing , cisCurrentComp = Nothing , cisComponents = strongComponentsOf g , cisGraph = g From 77e2d30bab1e36bebee6a1f6dc95aaf9a6f1166a Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Tue, 3 Oct 2017 10:57:45 +0200 Subject: [PATCH 28/29] Removed cisCurrentComp field from CyclesInState, and now passing that value as function parameter instead (this removes the need for using Maybe, which could fail). --- Data/Graph/Inductive/Query/Cycles.hs | 28 +++++++++++----------------- 1 file changed, 11 insertions(+), 17 deletions(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index 3a93ac7..ef3e44a 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -58,8 +58,6 @@ data CyclesInState g a b -- ^ The B set. , cisStack :: ![Node] -- ^ The node stack. - , cisCurrentComp :: !(Maybe (g a b)) - -- ^ The component currently being processed. , cisComponents :: ![g a b] -- ^ The components of the input graph. , cisGraph :: !(g a b) @@ -98,42 +96,39 @@ cyclesFor n st0 = filter (\c -> n `gelem` c) $ cisComponents st0 in if noNodes n_comp > 1 - then let st1 = st0 { cisCurrentComp = Just n_comp - } - st2 = fst $ cCircuits n n st1 - g = cisGraph st2 + then let st1 = fst $ cCircuits n_comp n n st0 + g = cisGraph st1 new_g = delNode n g new_comps = strongComponentsOf new_g - st3 = st2 { cisGraph = new_g + st2 = st1 { cisGraph = new_g , cisComponents = new_comps } - in st3 + in st2 else st0 -- Skip to next node -cCircuits :: (Graph g) => Node -> Node -> CyclesInState g a b -> +cCircuits :: (Graph g) => (g a b) -> Node -> Node -> CyclesInState g a b -> (CyclesInState g a b, Bool) -cCircuits s n st0 = +cCircuits c s n st0 = let st1 = st0 { cisBlocked = M.insert n True (cisBlocked st0) , cisStack = (n:cisStack st0) } - c = fromJust $ cisCurrentComp st1 n_suc = suc c n - (st2, f) = foldr (cCircuitsVisit s) (st1, False) n_suc + (st2, f) = foldr (cCircuitsVisit c s) (st1, False) n_suc st3 = if f then cUnblock n st2 else foldr (cCircuitsBlock n) st2 n_suc st4 = st3 { cisStack = tail $ cisStack st3 } in (st4, f) -cCircuitsVisit :: (Graph g) => Node -> Node -> (CyclesInState g a b, Bool) -> - (CyclesInState g a b, Bool) -cCircuitsVisit s n (st0, f0) +cCircuitsVisit :: (Graph g) => (g a b) -> Node -> Node -> + (CyclesInState g a b, Bool) -> (CyclesInState g a b, Bool) +cCircuitsVisit c s n (st0, f0) | n == s = let new_cycle = reverse $ cisStack st0 st1 = st0 { cisCycles = (new_cycle:cisCycles st0) } in (st1, True) | not (cisBlocked st0 M.! n) = - let (st1, f1) = cCircuits s n st0 + let (st1, f1) = cCircuits c s n st0 in (st1, f0 || f1) | otherwise = (st0, f0) @@ -167,7 +162,6 @@ mkInitCyclesInState g = , cisBlocked = M.fromList $ zip ns (repeat False) , cisBlockMap = M.fromList $ zip ns (repeat []) , cisStack = [] - , cisCurrentComp = Nothing , cisComponents = strongComponentsOf g , cisGraph = g } From 4dd06b74225682d0717e6fdb45e7cb31f2bf835f Mon Sep 17 00:00:00 2001 From: Gabriel Hjort Blindell Date: Tue, 3 Oct 2017 11:33:52 +0200 Subject: [PATCH 29/29] Replaced use of noNodes with another method that only takes O(1) instead of potentially O(n). --- Data/Graph/Inductive/Query/Cycles.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Data/Graph/Inductive/Query/Cycles.hs b/Data/Graph/Inductive/Query/Cycles.hs index ef3e44a..1db024b 100644 --- a/Data/Graph/Inductive/Query/Cycles.hs +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -95,7 +95,8 @@ cyclesFor n st0 = let n_comp = head $ filter (\c -> n `gelem` c) $ cisComponents st0 - in if noNodes n_comp > 1 + in if (not $ null $ drop 1 $ nodes n_comp) -- Same as (noNodes n_comp) > 1 but + -- only takes O(1) instead of O(n) then let st1 = fst $ cCircuits n_comp n n st0 g = cisGraph st1 new_g = delNode n g