#!/usr/bin/perl -w

use strict;

print <<'EOF';
#
# row.pl - Solve the puzzle with the priests and cannibals
#
# Info: http://baetzler.de/perl/row.var
#
# Questions, comments, suggestions? Email thomas@baetzler.de
#
EOF

##
## 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] );


# 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 );
}


#
# 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];

    }
  }
}

#
# 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;
}

#
# Main program :-)
#

row( @start, [] );