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 new file mode 100644 index 0000000..1db024b --- /dev/null +++ b/Data/Graph/Inductive/Query/Cycles.hs @@ -0,0 +1,168 @@ +{- | + 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 + , cycles' + , uniqueCycles + , uniqueCycles' + ) +where + +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Query.SCC + +import Data.List ((\\), delete, tails) +import Data.Maybe (fromJust) +import Control.Monad (ap) +import qualified Data.IntMap as M + + + +-- 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)) + +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 + +-- End of copied functions. + + + +-- | Contains the necessary data structures used by 'cycles'. +data CyclesInState g a b + = CyclesInState + { cisCycles :: ![[Node]] + -- ^ The cycles found so far, in topological order. + , cisBlocked :: !(M.IntMap Bool) + -- ^ The nodes which are currently blocked. + , cisBlockMap :: !(M.IntMap [Node]) + -- ^ The B set. + , cisStack :: ![Node] + -- ^ The node stack. + , cisComponents :: ![g a b] + -- ^ The components of the input graph. + , cisGraph :: !(g a b) + -- ^ The input graph. + } + deriving (Show, Read, Eq) + +-- | 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). +-- +-- 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) + +-- | Same as 'cycles' but does not return the node labels. +cycles' :: (Graph g) => g a b -> [[Node]] +cycles' g = + cisCycles $ + foldr cyclesFor (mkInitCyclesInState g) (nodes g) + +-- | 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) + +-- | 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) + +cyclesFor :: (Graph 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 (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 + new_comps = strongComponentsOf new_g + st2 = st1 { cisGraph = new_g + , cisComponents = new_comps + } + in st2 + else st0 -- Skip to next node + +cCircuits :: (Graph g) => (g a b) -> Node -> Node -> CyclesInState g a b -> + (CyclesInState g a b, Bool) +cCircuits c s n st0 = + let st1 = st0 { cisBlocked = M.insert n True (cisBlocked st0) + , cisStack = (n:cisStack st0) + } + n_suc = suc c n + (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) => (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 c s n st0 + in (st1, f0 || f1) + | otherwise = (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 + 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 :: (Graph 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 = [] + , cisComponents = strongComponentsOf g + , cisGraph = g + } diff --git a/Data/Graph/Inductive/Query/SCC.hs b/Data/Graph/Inductive/Query/SCC.hs new file mode 100644 index 0000000..a36ad83 --- /dev/null +++ b/Data/Graph/Inductive/Query/SCC.hs @@ -0,0 +1,128 @@ +{- | + 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 :: (Graph 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 :: (Graph 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 + 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' + new_ni = ni { sccIsNodeOnStack = False } + in M.insert n' new_ni ni_map + ) + (sccNodeInfo 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 :: (Graph 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/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 diff --git a/fgl.cabal b/fgl.cabal index 5b88d3d..87479ff 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, @@ -58,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 diff --git a/test/Data/Graph/Inductive/Query/Properties.hs b/test/Data/Graph/Inductive/Query/Properties.hs index f2e001b..bc1ccd9 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,42 @@ 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) + , (5,4) + ] + -- ----------------------------------------------------------------------------- -- DFS @@ -304,6 +340,34 @@ 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 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 = + 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 diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 1353ef3..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 @@ -116,6 +119,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