Valid HTML 4.0! Valid CSS!

A Puzzle: Priests and Cannibals

by 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:

Out there in the Carribean, there are two islands - Santa Maria and El Paradiso. Those two islands are separated by a dangerous reef that can only be navigated by a small skiff.

On the island Santa Maria, there are the three cannibals Alugul, Belugul and Celugul aswell as the three priestes Adam, Berthold and Christoph. There's also an active volcano on that island, and now the three cannibals and three priests must save themselves by escaping to El Paradiso. There is a small boat available, but it can only take two people at a time.

Now this wouldn't be difficult if there weren't these constraints:

  1. There must never be more cannibals than priests on any island, since then the cannibals would be able to overpower the unlucky priests. Even if the boat just makes a landfall to exchange passengers, the cannibals in the boat and those that are already on the island could unite and slay the minority of priests.

  2. Each of the three priests knows how to navigate the dangerous reef and is thus qualified to steer the boat. Of the cannibals, only Algul knows how the way around the shallows. The other two cannibals don't know the way through the reef, so that they must be ferried over by somebody else.

>Your task is to figure out in which order the six people ferry over from Santa Maria to Insel El Paradiso.

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, [] );                                                 
                                                                    

(show output)

(download source code)

 


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


Thomas Bätzler, Thomas@Baetzler.de
$Id$