A Puzzle: Priests and Cannibalsby Thomas Bätzler, <thomas@baetzler.de> A paper for the Karlsruhe Perl-Mongers (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$