Detecting cycles in a directed graph without using mutable sets of nodes

Question

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.

Answer 1

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