Haskell: Compute Cycles with List Monad

Question

-- 1. Graph structure: nodes and adjacency matrix (i.e. the edges) 
data Node = A | B | C | D | E | F deriving (Show,Eq,Ord)

adj :: (Node,Node) -> Bool
adj p = case p of
  (A,B) -> True
  (A,C) -> True  
  (B,C) -> True
  (B,F) -> True
  (C,D) -> True
  (D,E) -> True
  (E,B) -> True
  (E,F) -> True
  (F,A) -> True
  (_,_) -> False

type Path = [Node]

-- 2. Auxiliary functions
adjacentNodes :: Node -> [Node] -> [Node]
adjacentNodes n ns = filter (\x -> adj(n,x)) ns

allNodes :: [Node]
allNodes = [A,B,C,D,E,F]

choice :: ([a],[a]) -> [a]
choice = uncurry (++)

-- 3. To do
addtoEnd :: Path -> [Node] -> [Path]
addtoEnd p ns = undefined

hCycles :: Node -> [Path]
hCycles n = undefined

I have got this code (it was given to us, I can't change it or the types) and need to define the function hCycles using the list monad (and the do notation). hCycles is supposed to compute the Hamiltonian Cycles for any generic node of the graph in the image.

The thing is I'm not quite sure how to do that with the list monad... Despite that, I think I have a first version of the function:

hCycles :: Node -> [Path]
hCycles n = do 
            p <- [[n]]
            nextNode <- adjacentNodes n allNodes
            if n == nextNode
            then [p]
            else addtoEnd p allNodes

Still the if/else case has a weird behaviour and, since hCycles isn't called again, I don't even think it's recursive... How can I fix that?

Answer 1

Hi I guess it's enough time to give you some version that will solve your problem:

hCycles :: Node -> [Path]
hCycles n = 
    filter isValidPathLength $ map (n:) $ go [] (adjacentNodes n allNodes)
    where
    isValidPathLength path =
        length path == length allNodes + 1
    -- note: go will only care about a path to n 
    -- but will take care of not visiting nodes two-times
    go _ [] = [] -- fail if there is no node left to discover
    go visited toVisit = do
        cur <- toVisit
        if cur == n then
            pure [n] -- found n
        else do
            let neighboursToVisit = filter (`notElem` visited) $ adjacentNodes cur allNodes
            pathToEnd <- go (cur:visited) neighboursToVisit
            pure $ cur:pathToEnd

I noticed your adj does not fit your picture so I changed it to

adj :: (Node,Node) -> Bool
adj p = case p of
  (A,B) -> True
  (A,C) -> True  
  (B,C) -> True
  (B,F) -> True
  (C,D) -> True
  (D,E) -> True
  (E,B) -> True
  (E,F) -> True
  (F,A) -> True
  (_,_) -> False

(yours seem to not be a directed graph)

with this you'll get:

> hCycles A
[[A,B,C,D,E,F,A],[A,C,D,E,B,F,A]]

Some notes:

I did not care about performance here (for example there are better data-structures to manage visited then a list) - this one does a brute-force deep-first-search - if you want you can adapt this to BFS - it's a nice exercise IMO (one you might want to get rid of the do notation stuff though ... hey you asked for it)