Crossing a river with Haskell

river.lhs

> {-# OPTIONS -Wall -XMultiParamTypeClasses -XFunctionalDependencies -XTypeSynonymInstances #-}
> module Main where

8 people are standing on a west bank of a river and must cross to the
other side using a boat. However,

  - the boat carries at most 2 people at a time,
  - the father can't be left with the girls without the mother,
  - the mother can't be left with the boys without the father,
  - the prisoner can't be left with any family members without the police,
  - only the father, the mother and the police can steer the boat.

This is a literate Haskell program that solves this puzzle. Lines starting
with '>' are Haskell code; all other lines are comments. You can save this
file to "River.lhs" and run it in a Haskell environment. The program has
only been tested with GHC (Glasgow Haskell Compiler).

First we'll import a few helpful functions from the standard library:

> import Data.List (sort, tails, (\\))
> import Control.Monad (guard)

A good way to get started on problems like these is to model the concepts
in the puzzle using data types. There are eight people on the puzzle, but
since the two boys and two girls are identical, we'll only need six different
types of people:

> data Person = Father | Boy | Mother | Girl | Police | Prisoner
>    deriving (Eq, Show, Ord)

In addition to defining the enumerated values of Person-type, we also
told the Haskell compiler to generate default implementations for
Eq, Show, and Ord -classes to this type (these classes define functions
that are equivalent to Java's equals, toString, and compareTo methods.)

Now, to model side of the river the boat currently is, we'll define a
type called Side. We'll also kindly ask for default instances of Eq and
Show, but since we don't need to sort sides, we don't bother with Ord:

> data Side = West | East deriving (Eq, Show)

Now that we have a type for representing people and a type for representing
the boat's position, modelling the current state of the game is easy:

> data Game = G Side [Person] [Person]

This definition says that the state of the Game is determined by three things:

  - the current side of the boat
  - list of people on the west side of the river
  - list of people on the east side of the river

Technically we could, of course, get rid of the list of people on the east
side, since it's inferrable from the list of people on the west side. However,
having both in the state simplifies the code a bit, so we'll keep them. We
also didn't define any default implementations of classes: we don't plan to
print games, so we don't need Show and the default Eq is not quite right for
us, so we'll implement it ourselves.

The problem with default implementation of Eq (i.e. == and /= operators)
is that it considers two games different if the people on one side of a
river are standing in different order. This, in turn, will greatly 
increase the size of the search space. So first we'll implement our own
order-insensitive equality operator for lists and then use that to implement
equality for games:

> (=~)                   :: Ord a => [a] -> [a] -> Bool
> xs =~ ys               = sort xs == sort ys

> instance Eq Game where
>     (G s1 w1 e1) == (G s2 w2 e2) = s1 == s2 && w1 =~ w2 && e1 =~ e2

The moves are represented by just a list of people who are moved from
one side to another. Since the location of the boat is known at the start
of the move and the boat can only go one way, we don't bother storing the
direction of move.

> type Move = [Person]

If you were paying attention, you probably noticed that while the previous
definitions were 'data'-definitions, this one says 'type'. The difference
is that 'data'-definition declares a new type whereas 'type' is just an alias.
If we'd search/replace the whole program and changed every occurrence of
'Move' to '[Person]', everything would still work the same.


Ok, now that are data types are defined, we can start to write some functions
that work on them.

When the game starts, the boat and all the people are on the west bank of
the river:

> initialGame            :: Game
> initialGame            = G West people []
>    where people = [Father, Boy, Boy, Mother, Girl, Girl, Police, Prisoner]

Dually, when the boat and all the people are on the east bank, the game
has ended:

> isGameEnded            :: Game -> Bool
> isGameEnded (G s w e)  = s == East && length w == 0 && length e == 8

If the boat is on the west side, candidates for the next move are those
people who are standing on the west side. Similarly, if the boat is on
the east side, the candidates are people on the east side:

> candidatePeople        :: Game -> [Person]
> candidatePeople (G West w _) = w
> candidatePeople (G East _ e) = e

Only the father, the mother and the police can use the boat:

> canUseBoat             :: Person -> Bool
> canUseBoat p           = p `elem` [Father, Mother, Police]
 
After moving people 'm' from west, the boat is on east, 'm' will be
removed from west side and added to east side. Similarly for the
opposite direction:

> move                   :: Game -> Move -> Game
> move (G West w e) m    = G East (w \\ m) (e ++ m)
> move (G East w e) m    = G West (w ++ m) (e \\ m)

An operator for logical implication is not defined by the standard
libraries, so we'll have to define it ourselves. As we remember,
a false premise implies anything, but a true premise requires a
true conclusion:

> (==>)                  :: Bool -> Bool -> Bool
> True  ==> b            = b
> False ==> _            = True

We also manually define the precedence of our new operator so
that it has lower precedence than our other logical operators and
we need less parentheses in our expressions:

> infixr 3 ==>

Armed with our cool new operator, we can go ahead and define the rules
for checking if a group of people can exist in a same bank:

> canShareBank           :: [Person] -> Bool
> canShareBank ps        = fatherOk && motherOk && prisonerOk
>   where 
>     fatherOk      = onBank Father   ==> onBank Mother || not (onBank Girl)
>     motherOk      = onBank Mother   ==> onBank Father || not (onBank Boy)
>     prisonerOk    = onBank Prisoner ==> onBank Police || isAlone Prisoner
>     onBank p      = p `elem` ps
>     isAlone p     = [p] == ps

The fatherOk-rule says "if father is on the bank, then the mother must
also be there, or no girls must be there." The motherOk is analogous.
Finally, if prisoner is on a bank, then the police must be there, or
the prisoner must be on the bank all by himself.

The game state is valid if both banks of the river are valid:

> validState             :: Game -> Bool
> validState (G _ w e)   = canShareBank w && canShareBank e

A move is valid if any of the movers can operate the boat and the game
state is valid after the move. (The function assumes that it won't be
called with people who are on the wrong bank to start with.)

> isValidMove            :: Game -> Move -> Bool
> isValidMove g m        = any canUseBoat m && validState (move g m)

Now we'll define another useful helper function. 'pairs' will return all
unique pairs formed by given list, excluding the identity pairs (e.g. (2,2))
and symmetric pairs (e.g. it will only return "(1,2)" or "(2,1)", but not
both). 'pairs' uses list comprehension to achieve it's goal. List 
comprehensions are similar to the set comprehensions of mathematics.

> pairs                  :: [a] -> [(a,a)]
> pairs xs               = [ (y,z) | (y:ys) <- tails xs, z <- ys]

Finally, validMoves returns all moves that can be made in a given state
in game. It builds all moves having one people and all moves having two
people and then filters away those that are not valid:

> validMoves             :: Game -> [Move]
> validMoves g           = filter (isValidMove g) (singleMoves ++ pairMoves)
>   where
>     singleMoves   = [ [p] | p <- people ]
>     pairMoves     = [ [x,y] | (x,y) <- pairs people ]
>     people        = candidatePeople g



Now we have represented all the rules of the game as code and could implement
a search algorithm that uses these rules to make sure that the moves are
valid. If, however, we take a step back, we can see that such an algorithm
would be useful for other similar games as well. Are we able to abstract
all these games into a common framework?

If we look at our game in details, we can see that there is an initial state
(initialGame), there's a solution state (isGameEnded), and there are
transitions between states (validMoves). When taking a transition, we are
interested in the resulting state, but also in the transition itself, so
that we can keep a record of transitions we have made. This suggests the
following class definition:

> class Eq s => SearchSpace s t | s -> t where
>     initialState     :: s
>     isSolution       :: s -> Bool
>     transitions      :: s -> [(s,t)]

This says that a search-space is a class parametrized by two types: 's' 
(standing for 'state') and 't' (standing for 'transition'). Moreover,
the SearchSpace requires that 's' implements equality so we can compare
different states to each others.

A space has an initial state of type 's', a predicate for asking whether
given state is the solution and a function returning the next possible states 
along with transitions needed to reach them.

How do we implement this class in terms of our previous functions? The first
two functions map neatly into functions that we've already defined, so we'll
just associate them with the class. For transitions, we'll use a combination
of 'validMoves' and 'move' to return a list of moves and the next game states
resulting from taking those moves.

> instance SearchSpace Game Move where
>     initialState    = initialGame
>     isSolution      = isGameEnded
>     transitions g   = [ (move g m,m) | m <- validMoves g ]

This definition says that our states are of type 'Game' and our transitions
are of type 'Move' and then defines the members of the class.


Now we can implement a simple, but general depth-first solver that not
only solves our Games, but any instances of SearchSpace:

> depthFirstSolve        :: SearchSpace s t => [(s,[t])]
> depthFirstSolve        = solve [initialState] [] initialState
>   where
>      solve vs ts s | isSolution s = [(s, reverse ts)]
>                    | otherwise    = do (s',t) <- transitions s
>                                        guard (s' `notElem` vs)
>                                        solve (s':vs) (t:ts) s'

The solver keeps track of states it has already visited so that it doesn't
get in an infinite loop.

We could also implement more sophisticated searches through the search space
using the same generic interface, but this works good enough for this simple
problem.



Next we define a simple function that prints a solution that has been found:

> printSolution          :: (Game,[Move]) -> IO ()
> printSolution (_,ms) =
>     do putStrLn "solution:"
>        mapM_ putStrLn $ zipWith format ms (cycle ["-->","<--"])
>   where 
>     format mv arr = "   " ++ arr ++ " " ++ show mv

Finally, we define the entry-point of our program: a main function that
just prints the first solution to the puzzle:

> main                   :: IO ()
> main                   = printSolution (head depthFirstSolve)

That's it! In less than 80 lines of Haskell (not counting comments and
empty lines) we have implemented a general framework for search problems
and a solution for one specific search problem in terms of this framework.