Cabbage-Goat-Wolf puzzle in Haskell

Question

Could you please review the following code, and point out how I can make it cleaner, more idiomatic and easier to understand?

module Cabbage (
  solve
) where

data Place = Here | There deriving (Eq, Show)

data Pos = Pos { cabb :: Place
               , goat :: Place
               , wolf :: Place
               , farmer :: Place
               } deriving (Eq, Show)

opp :: Place -> Place
opp Here = There
opp There = Here

valid :: Pos -> Bool
valid (Pos {cabb = c, goat = g, wolf = w, farmer = f}) = (c /= g && g /= w) || g == f

findMoves :: Pos -> [Pos]
findMoves pos@(Pos {cabb = c, goat = g, wolf = w, farmer = f}) =
    filter valid $ moveCabb ++ moveGoat ++ moveWolf ++ moveFarmer where
    moveCabb | c == f = [pos {cabb = opp c, farmer = opp f}] | otherwise = []
    moveGoat | g == f = [pos {goat = opp g, farmer = opp f}] | otherwise = []
    moveWolf | w == f = [pos {wolf = opp w, farmer = opp f}] | otherwise = []
    moveFarmer = [pos {farmer = opp f}]

findSolution :: Pos -> Pos -> [Pos]
findSolution from to = head $ loop [[from]] where
    loop pps = do ps <- pps
                  let moves = filter (flip notElem ps) $ findMoves $ head ps
                  if to `elem` moves
                    then return $ reverse $ to:ps
                    else loop $ map (:ps) moves

solve :: [Pos]
solve = findSolution (setAll Here) (setAll There) where
            setAll x = Pos{ cabb = x, goat = x, wolf = x, farmer = x }

IMHO the findMoves function seems to be quite verbose, and the findSolutions function looks confusing.

Thank you!

Answer 1

Haskell's record system is not really good at providing you uniform access to record entries. That is the reason your findMoves implementation has to be so verbose: You cannot generalize over the fields.

There are a number of ways to get around that. One could be using a library such as fclabels that facilitates this job for you. You set it up like follows:

import Data.Record.Label

data Pos = ....

$( mkLabels [''Pos] )

This will give you "labels" with names such as lCabb that you can use with functions such as getL or modL. Without all this boilerplate, it is possible to write a much more satisfying findMoves function:

findMoves :: Pos -> [Pos]
findMoves pos = filter valid moves
  where
    moves    = [ foldr (\obj -> modL obj opp) pos objs
               | objs <- moveComb, same $ map (`getL` pos) objs
               ]
    moveComb = [[lCabb, lFarmer], [lGoat, lFarmer], [lWolf, lFarmer], [lFarmer]]
    same xs  = all (== head xs) xs

Answer 2

I'd be inclined to change your representation. At each step, the farmer moves from his current location to the opposite location. It makes life much simpler if you just represent each state as a pair consisting of the list of things at the farmer's current location and the list of things at the other location.

My Haskell is a bit rusty, but under this scheme you get something like this:

move (withFmr, awayFromFmr) = [(awayFromFmr, withFmr) | map f withFmr]
    where f x = (x :: awayFromFmr, filter (== x) withFmr)

valid (withFmr, awayFromFmr) = 
    not (elem Goat awayFromFmr && (elem Wolf awayFromFmr || elem Cabbage awayFromFmr))

The location of withFmr for each successive state is the opposite of that for the preceding state.

Hope this helps.

Answer 3

I kept the record syntax (but it's good to know about the alternatives). This is my last version:

import Data.Maybe(catMaybes)

data Place = Here | There deriving (Eq, Show)

data Pos = Pos {cabb, goat, wolf, farmer :: Place} deriving (Eq, Show)

type Path = [Pos]

findMoves :: Path -> [Path]
findMoves path@(pos@(Pos c g w f) : prev) =
    catMaybes [ c ??? pos {cabb = opp c} , g ??? pos {goat = opp g}
              , w ??? pos {wolf = opp w} , f ??? pos ] where
    opp Here = There
    opp There = Here

    valid (Pos c g w f) = (c /= g && g /= w) || g == f

    x ??? p = let p' = p {farmer = opp f}
              in if x == f && valid p' && notElem p' prev 
                 then Just (p' : path) else Nothing

findSol :: Pos -> Path -> [Path]
findSol pos path@(p : _)  
    | p == pos = [reverse path]  
    | otherwise = findMoves path >>= findSol pos 


solve :: [Path]
solve = findSol endPos [startPos] where
   setPos place = Pos place place place place
   startPos = setPos Here
   endPos = setPos There

Answer 4

Here's my attempt using arrays and list comprehensions:

import Data.Array
import Data.List

type Pos = Array Obj Place

data Place = Here | There deriving (Eq, Show)

data Obj = Cabb | Goat | Wolf | Farmer deriving (Ord, Eq, Ix, Show, Enum)

objs = [Cabb .. Farmer]

allAre a = listArray (Cabb, Farmer) $ map (const a) objs

start = allAre Here
end = allAre There

opp Here = There
opp There = Here

valid arr = (arr ! Cabb /= arr ! Goat && arr ! Goat /= arr ! Wolf) || arr ! Goat == arr ! Farmer

move arr obj = [(o, opp (arr ! o)) | o <- [Farmer, obj]]

nextStates arr = [ nextState | obj <- objs, let nextState = arr // move arr obj, arr ! Farmer == arr ! obj, valid nextState]

nextMove paths = [nextState : path | path <- paths, nextState <- nextStates (head path)]

filterSolutions = filter (\path -> head path == end) 

shortestPath = head $ concatMap filterSolutions $ iterate nextMove [[start]]

main = print $ length shortestPath