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

In the list monad a line of the form:

x <- f y

expects f to return a list. x is going to get instantiated with each value of the list in turn, so the rest of the do clause will be run with each of those values.

You will see that adjacentNodes returns a list of nodes. So starting from n you can consider each node that it connects to like this:

nextNode <- adjacentNode n allNodes

Write this function:

steps :: [Nodes] -> Path -> [Path]
steps _ [] = fail "Need a node to start with."
steps ns path@(n:rest) = do
   nextNode <- adjacentNode n ns
   guard $ not $ elem nextNode path   -- Stop if we've already visited this node.
   return $ nextNode : path

You can imagine this as the algorithm for finding a single path, which (thanks to the list monad) magically finds all the possible paths. This isn't the whole answer, but it should give you enough to get started with.

(Note: I haven't actually tested this code.)

Answer 2

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)