U2 puzzle in Haskell

Question

Here is a puzzle:

U2 has a concert that starts in 17 minutes and they must all cross a bridge to get there. All four men begin on the same side of the bridge. You must help them across to the other side. It is night. There is one flashlight. A maximum of two people can cross at one time. Any party who crosses, either 1 or 2 people, must have the flashlight with them. The flashlight must be walked back and forth, it cannot be thrown, etc. Each band member walks at a different speed. A pair must walk together at the rate of the slower man`s pace:

Bono - 1 minute to cross

Edge - 2 minutes to cross

Adam - 5 minutes to cross

Larry - 10 minutes to cross

For example: If Bono and Larry walk across first, 10 minutes have elapsed when they get to the other side of the bridge. If Larry then returns with the flashlight, a total of 20 minutes have passed and you have failed the mission. Your goal is to get all the men across in 17 mins or less.

My approach was to generate all possible solutions in a tree, and do a fold across the tree to accumulate the results.

Suggestions on style, better approaches, or whatever, are welcome.

import Data.List
import Data.Maybe
import Text.Printf

data Person = Bono | Edge | Adam | Larry 
    deriving (Eq, Show)

data LastMove = ToLeftSide | ToRightSide
    deriving (Show)

data State = State {
    leftSide    :: [Person],
    rightSide   :: [Person],
    lastMove    :: LastMove,
    moveSeq     :: [[Person]]
} deriving (Show)

data Tree = Node State [Tree] 
    deriving (Show)

-- List of Persons "here" and "there" relative to the last move.
personsHereThere :: State -> ([Person], [Person])
personsHereThere s@State {lastMove = ToLeftSide}  = (leftSide  s, rightSide s)
personsHereThere s@State {lastMove = ToRightSide} = (rightSide s, leftSide  s)

-- List of Persons on left and right side given Persons "here" and "there".
personsLeftRight :: LastMove -> [Person] -> [Person] -> ([Person], [Person])
personsLeftRight ToLeftSide  here there = (here, there)
personsLeftRight ToRightSide here there = (there, here)

-- Swap the direction of movement.
flipDir :: LastMove -> LastMove
flipDir ToLeftSide = ToRightSide
flipDir ToRightSide = ToLeftSide

-- Takes a State and some movers, and returns the new state.
move :: State -> [Person] -> State
move state movers =
    let (h, t) = personsHereThere state
        h' = h \\ movers
        t' = t ++ movers
        (left, right) = personsLeftRight (lastMove state) h' t'
        dir = flipDir $ lastMove state
        moveSeq' = movers : moveSeq state
    in
        State {
            leftSide = left, rightSide = right, lastMove = dir, moveSeq = moveSeq'
        }

-- The time taken by the slowest Person in the list.
maxTime :: [Person] -> Int
maxTime s = maximum $ map (fromJust . flip lookup times) s

-- The sum of the times of the given movers.
totalTime :: [[Person]] -> Int
totalTime = foldr ((+) . maxTime) 0

-- List of all possible combinations of walkers.
walkers :: [Person] -> [[Person]]
walkers candidates = 
    [[x] | [x] <- movers] ++ [[x, y] | [x, y] <- movers]
    where
        movers = subsequences candidates

-- Is success if no one left on left side.
isSuccess :: State -> Bool
isSuccess s = null $ leftSide s

-- True if we haven't gone overtime.
isContinue :: State -> Bool
isContinue State {moveSeq = ms} = totalTime ms <= 17

-- The solution space.
makeTree :: State -> Tree
makeTree s =
    let 
        (h, _) = personsHereThere s
        ww = walkers h
        childStates = map (move s) ww
        childNodes = map makeTree childStates
    in
        Node s childNodes

-- Search the solution space for solutions and return them in a list.
-- Each solution is in reverse order (last movers are at the head).
foldTree :: Tree -> [[[Person]]]
foldTree (Node state childNodes) 
    | not $ isContinue state = []
    | isSuccess state        = [moveSeq state]
    | otherwise              = concatMap foldTree childNodes

-- Sequence of movers and the time they took as a string for display.
showResult :: [[Person]] -> String
showResult moveSequence = 
    let t = totalTime moveSequence
        r = intercalate "," $ reverse $ map show moveSequence in
        printf "%s : %d minutes" r t

-- Constants.
times = [(Bono,1), (Edge,2), (Adam,5), (Larry,10)]
startList = [Bono, Edge, Adam, Larry]
startState = State {
    leftSide = startList, rightSide = [], lastMove = ToLeftSide, moveSeq = []
}

main :: IO ()
main = do
    let tree = makeTree startState
    let result = foldTree tree
    putStrLn $ intercalate "\n" $ map showResult result

Answer 1

Nice code: it is readable, well-structured, with consistent style, with self-explanatory function names and data types.

---

totalTime = foldr ((+) . maxTime) 0 is the same as sum . map maxTime.

Also you can read about foldr vs. foldl'

---

Storing times in a Data.Map could be a bit more efficient and it makes maxTime a bit shorter:

maxTime = maximum . map (times `Map.!`)

---

While generating walkers for the next journey you traverse list of subsequences twice. This could be not very efficient as there are 2^n subsequences for the list of length n.
Here is less readable but more efficient approach:

allPairs xs = [[x,y] | x:ys <- tails xs, y <- ys]
walkers candidates = map (:[]) candidates ++ allPairs candidates

---

The code seems a bit too verbose because of explicit search tree construction. It is possible to make it more concise by using list monad for building search space.

Here is my attempt to rewrite it:

{-# LANGUAGE RecordWildCards #-}
import Data.List (tails, (\\))
import Control.Monad (guard, (>=>))
import qualified Data.Map as Map


data Person = Bono | Edge | Adam | Larry deriving (Eq, Ord, Show)

times :: Map.Map Person Int
times = Map.fromList [(Bono,1), (Edge,2), (Adam,5), (Larry,10)]


data State = State
  { here          :: [Person] -- persons on the side with flashlight
  , there         :: [Person] -- persons on the side without flashlight
  , finalPosition :: Bool     -- flashlight is on the right side
  , moves         :: [[Person]]
  }

initialState :: State
initialState = State [Bono, Edge, Adam, Larry] [] False []


nextMove :: State -> [State]
nextMove State{..} = do
  let allPairs xs = [[x,y] | x:ys <- tails xs, y <- ys]
  walkers <- map (:[]) here ++ allPairs here
  return $ State
    (there ++ walkers)
    (here \\ walkers)
    (not finalPosition)
    (walkers : moves)


loop :: State -> [State]
loop = nextMove >=> \st@State{..} -> do
  let maxTime = maximum . map (times Map.!)
  let totalTime = sum $ map maxTime moves
  guard $ totalTime <= 17
  if finalPosition && null there
    then return st
    else loop st


main :: IO ()
main = mapM_ (print . reverse . moves) $ loop initialState

Answer 2

This is almost 20 years old now. State Directed Graphs are very popular for game(chess, say) / network traversal (think GPS) etc. Indeed this was reputed to be a Microsoft interview question when it was doing the rounds.

In an interview, the problem solving approach was more important. The candidates were told that the problem was solvable and fairly stated, and that there were two solutions (suggesting symmetry).

In fact it is a self evident truth that Larry can cross only once, "Critical Path Method" suggests that Adam and Larry should cross together, only once, and not first. Immediate solution. The symmetry occurs where for one solution Bono makes the initial return trip.

Your solution is good, possibly the "token" should be promoted to a "person" (or some neutral name). You may want to recognise loops, or return to a previous state (to prevent backtracking). Given there are more than 1 way to arrive at a state. It is very good that you test for over time.

I would personally define the state as two lists, because that is how I would notate them in an written solution or in a character "trace". You can even use values (time cost) instead of the names.

 0|-          -|0
 1|-   (2)    -|1 
 2|-  ====>   -|2  ===>  etc. 
 5|-          5|-
10|-         10|-

Finding the solution is ok, finding a way to show it is better. Of course you were probably only required to return the list of solutions.

[Bono,Edge],[Bono],[Adam,Larry],[Edge],[Bono,Edge] : 17 minutes
[Bono,Edge],[Edge],[Adam,Larry],[Bono],[Edge,Bono] : 17 minutes

...is fine for this solution, I was not trying to be critical, just thinking obout how this would scale, rather than semantics. Logo/Turtle style is fine. Similarly for backtracking I was thinking of larger problems and an LZ77-like vector map.