12
\$\begingroup\$

I recently came across the classic algorithm for detecting cycles in a directed graph using recursive DFS. This implementation makes use of a stack to track nodes currently being visited and an extra set of nodes which have already been explored. The second set is not strictly required, but it is an optimization to prevent iterating over path suffixes that have previously been determined not to be part of a cycle.

I had no trouble implementing this in Python by simply creating a (mutable) set object and sharing it between all branches of the recursion.

My attempt to reimplement this algorithm in Haskell turned out to be much worse (and still isn't as efficient as the original).

I would like some pointers about how to restructure this so that it isn't a mess of recursive folds, but without giving up the set of visited, nodes, which lets me avoid taking branches that have already been explored.

import Data.Maybe
import qualified Data.IntMap.Strict as M
import qualified Data.Char as C

import Debug.Trace


edges :: String
edges =
  "a b\n\
  \a c\n\
  \b c\n\
  \b d\n\
  \c d\n\
  \c e\n\
  \e f\n\
  \e g\n\
  \f g\n\
  \g c"

type Node = Int

parseGraph :: String -> M.IntMap [Node]
parseGraph = foldr go M.empty . lines
  where go line m = let [key, rule] = map ruleToKey (words line)
                    in M.insertWith inserter key [rule] m
        inserter [rule] olds = rule:olds

ruleToKey :: String -> Node
ruleToKey rule = C.ord (head rule) - 97

keyToRule :: Node -> String
keyToRule key = return $ C.chr (key + 97)

hasCycle :: M.IntMap [Node] -> Maybe [Node]
hasCycle m = reverse <$> ret
  where dummyM = M.insert phantom (reverse $ M.keys m) m
        phantom = -1
        (_, _, ret) = hasCycleHelper dummyM phantom ([], [], Nothing)

hasCycleHelper :: M.IntMap [Node] -> Node -> ([Node], [Node], Maybe [Node]) -> ([Node], [Node], Maybe [Node])
hasCycleHelper rules rule (visited', visiting', cyc) =
  trace rendered $
    case () of
      _ | isJust cyc || rule `elem` visited' -> (visited', visiting', cyc)
        | rule `elem` visiting' -> ([], [], Just (takeWhile (/= rule) visiting' ++ [rule]))
        | otherwise ->  returned
  where
    children = M.findWithDefault [] rule rules
    (visited, _, ret) = foldr (hasCycleHelper rules) acc children
    returned = (rule:visited, visiting', ret)
    acc = (visited', rule:visiting', Nothing)
    rendered =    "Current '" ++ keyToRule rule ++ "', "
               ++ "Visiting '" ++ map (head . keyToRule) visiting' ++ "', "
               ++ "Visited '" ++ map (head . keyToRule) visited' ++ "', "
               ++ "Found " ++ show (map (head . keyToRule) <$> cyc)

main :: IO ()
main = do
  let rules = parseGraph edges
      cyc = map keyToRule <$> hasCycle rules
  print cyc

With output:

Current '`', Visiting '', Visited '', Found Nothing
Current 'a', Visiting '`', Visited '', Found Nothing
Current 'c', Visiting 'a`', Visited '', Found Nothing
Current 'e', Visiting 'ca`', Visited '', Found Nothing
Current 'g', Visiting 'eca`', Visited '', Found Nothing
Current 'c', Visiting 'geca`', Visited '', Found Nothing
Current 'f', Visiting 'eca`', Visited 'g', Found Just "gec"
Current 'd', Visiting 'ca`', Visited 'eg', Found Just "gec"
Current 'b', Visiting 'a`', Visited 'ceg', Found Just "gec"
Current 'b', Visiting '`', Visited 'aceg', Found Just "gec"
Current 'c', Visiting '`', Visited 'aceg', Found Just "gec"
Current 'e', Visiting '`', Visited 'aceg', Found Just "gec"
Current 'f', Visiting '`', Visited 'aceg', Found Just "gec"
Current 'g', Visiting '`', Visited 'aceg', Found Just "gec"
Just ["c","e","g"]

Because I'm using foldr, it can't abort the search after discovering a cycle. It has to iterate over all the nodes in the graph at the top level, carrying along the result. I think that's pretty miserable, but I thought I'd ask about it before rewriting everything.

\$\endgroup\$
3
\$\begingroup\$

An easy way to detect a cycle is through the implementation of a disjoint set structure, sometimes called a Union-Find structure.

You start with a source node and attempt to add a node to that set. If your Find() call for the source node and the other node returns the same root node, then a cycle world result if the nodes are unioned.

UPDATE:

You could implement a topological sort, arranging the nodes with edges going from left to right. A topological sort can only be completed successfully if and only if the graph is a Directed Acyclic Graph. So, if the algorithm detects any cycles, it will stop.

The runtime is O(|V| + |E|), which is better than DFS, in the case that repetition occurs during traversal.

Topological Sorting

\$\endgroup\$
  • 1
    \$\begingroup\$ Just realized you wanted Ann answer about not using mutable sets. I'll update shortly \$\endgroup\$ – Evan Bechtol May 17 '15 at 21:17
  • \$\begingroup\$ Interesting! I'll think about this. What I'm really asking here is about imperative algorithms that use recursion but have some kind of mutable state that is universal and not tied to the current call stack. What I'm doing with folds and passing accumulators up and down works, but it hard to read and hard to convince yourself that it's correct. \$\endgroup\$ – John Tyree May 17 '15 at 22:45
  • \$\begingroup\$ I didn't realize at the time, but I think you're referring to an algorithm for finding cycles in an undirected graph. In this case the graph is a directed graph, which is why I'm using DFS. \$\endgroup\$ – John Tyree May 17 '15 at 23:07
  • \$\begingroup\$ @JohnTyree Check out my update, I did some digging on topological sorts that may be of interest to you. \$\endgroup\$ – Evan Bechtol May 17 '15 at 23:39

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.