A Puzzle: Priests and Cannibalsby Thomas Bätzler, <thomas@baetzler.de> A paper for the Karlsruhe PerlMongers (when they finally manage to set up a meeting :)) The other day, a friend emailed me this puzzle:
Of course I could have solved this puzzle using just my brain and maybe a pen and a piece of paper  but letting the computer figure out the solution is much more fun. So I start my trusty editor and soon, I've typed in the first declarations that I ahve derived from the specification above: #!/usr/bin/perl w use strict; ## ## Global Variables ## # Start Position: # 1st Island: 3 Priests, 1 Cannibal/Naviagtor, 2 Cannibals # 2nd Island: nobody my @start = ( 3, 1, 2, '>', 0, 0, 0 ); # End Position: # Everybody on the second island my $dest = join ',', ( @start[4..6], '<', @start[0..2] ); We're not really interested in the names of the priests and cannibals, since they're basically interchangeable  we're only interested in their function, the class they belong to. Of those there are three : the priests, who all can navigate, the cannibals who can't naviagte and the one cannibal who can steer the boat. As a starting point, I choose a recursive search. At the begin of the recursion, I first check to see if I've arrived at the solution already. Otherwise, I check to see wether I have reached the current state previously. If yes, I can stop checking, too. Otherwise, I generate a list of all possible boat crews, which I then try out recursively. So at first, I define a global hash that I use to keep track of visited positions and a subroutine that creates a list of all currently possible boat crews: # This hash will be used to keep track of positions my %triedthis; # # Create a list of all valid boat crews which could row from # the one island to the other. $sp, $sn and $sc are the numbers # of priests, navigatior/cannibals and cannibals on the "source" # island, while $dp, $dn and $dc are the numbers on the "target" # island. # sub makecrews { my( $sp, $sn, $sc, $dp, $dn, $dc ) = @_; my @crews = (); if( $sp > 0 ){ push @crews, [ 1, 0, 0 ] unless $sp  1 > 0 && $sn + $sc > $sp  1  $dp + 1 < $dn + $dc; if( $sp > 1 ){ push @crews, [ 2, 0, 0 ] unless $sp  2 > 0 && $sn + $sc > $sp  2  $dp + 2 < $dn + $dc; } if( $sn > 0 ){ push @crews, [ 1, 1, 0 ] unless $sp  1 > 0 && $sn + $sc  1 > $sp  1  $dp + 1 < $dn + $dc + 1; } if( $sc > 0 ){ push @crews, [ 1, 0, 1 ] unless $sp  1 > 0 && $sn + $sc  1 > $sp  1  $dp + 1 < $dn + $dc + 1; } } if( $sn > 0 ){ push @crews, [ 0, 1, 0 ] unless $dp > 0 && $dp < $dn + $dc + 1; if( $sn > 1 ){ push @crews, [ 0, 2, 0 ] unless $dp > 0 && $dp < $dn + $dc + 2; } if( $sc > 0 ){ push @crews, [ 0, 1, 1 ] unless $dp > 0 && $dp < $dn + $dc + 2; } } return( @crews ); } Of course one could have generated all of the possible permutations algorithmically, but in this case I decided to be cheap and just hard code them. Further on, we need another support routine, which prints a solution once we have found it. Since we're really looking for a sequence of boat transfers, we print those step by step. # # Print a solution # (more or less pretty) # sub print_solution { my $ref = $_[0]; my $dir = '>'; print "\n\nSolution found:\n"; my @st = @start; print "[", 'P'x$st[0], 'S'x$st[1], 'K'x$st[2], "]\n"; foreach my $crew ( @{$ref} ){ if( $st[3] eq '>' ){ $st[0] = $$crew[0]; $st[1] = $$crew[1]; $st[2] = $$crew[2]; print "[", 'P'x$st[0], 'S'x$st[1], 'K'x$st[2], "] ", ">", 'P'x$$crew[0], 'S'x$$crew[1], 'K'x$$crew[2], ">", "[", 'P'x$st[4], 'S'x$st[5], 'K'x$st[6], "]\n"; $st[3] = '<'; $st[4] += $$crew[0]; $st[5] += $$crew[1]; $st[6] += $$crew[2]; } else { $st[4] = $$crew[0]; $st[5] = $$crew[1]; $st[6] = $$crew[2]; print "[", 'P'x$st[0], 'S'x$st[1], 'K'x$st[2], "]", "<", 'P'x$$crew[0], 'S'x$$crew[1], 'K'x$$crew[2], "< ", "[", 'P'x$st[4], 'S'x$st[5], 'K'x$st[6], "]\n"; $st[3] = '>'; $st[0] += $$crew[0]; $st[1] += $$crew[1]; $st[2] += $$crew[2]; } } } Finally, we also need a subroutine that performs the recursive search: # # search recursively for a solution # sub row { # Our attempted solution is saved as a list of choices, which # is passed to the subroutine as a list reference. We convert # that reference to a "real" list again, thus making a copy # that we can modify without breaking the original. my @solution = @{pop @_}; # The other arguments are the "state" that we will achive in # this iteration. my( $sp, $sn, $sc, $dir, $dp, $dn, $dc ) = @_; # We convert that "state" to a scalar value in order to be able # to compare it against the target specification. my $desc = join( ',', @_ ); # If the current state matches the target, we have a solution. if( $desc eq $dest ){ print_solution( \@solution ); return; } # Otherwise, we check if we have visited this state previously. # If yes, we bail out, since further recursion would lead to # a loop. return if ++$triedthis{ $desc } > 1; # Now, depending on wether we row to or from the second island, if( $dir eq '>' ){ # we get a list of all potential crews... my @crews = makecrews( $sp, $sn, $sc, $dp, $dn, $dc ); # ... that we now try out one after the other, appending each # crew in turn to the solution path. foreach my $crew ( @crews ){ row( $sp  $$crew[0], $sn  $$crew[1], $sc  $$crew[2], '<', $dp + $$crew[0], $dn + $$crew[1], $dc + $$crew[2], [ @solution, $crew ] ); } } else { my @crews = makecrews( $dp, $dn, $dc, $sp, $sn, $sc ); foreach my $crew ( @crews ){ row( $sp + $$crew[0], $sn + $$crew[1], $sc + $$crew[2], '>', $dp  $$crew[0], $dn  $$crew[1], $dc  $$crew[2], [ @solution, $crew ] ) } } # No further solutions on this path. return; } Now that we've defined all important parts of the code, we only need a main program. Since we've delegated all of the work, it's rather simple: # # Main program :) # row( @start, [] );

Links: Imprint,
thb's Perl Corner,
my homepage.
$Id$