Re: [QUIZ] Perl 'Hard' Quiz of the Whatever #2008-12-28 - Symmetric Sokoban

[NB: Sorry if anyone is getting multiple copies of this. The mail
server seems to keep rejecting my mail due to attachment content type,
so the program is now included in the message.]

Jurgen Pletinckx wrote:
>
> (I do prefer these tasks to "WDTCD?" quizzes. *And* I
> had some tuits over the holidays. Anyone else out there?)

Same here, on both counts. :-) I just finished mine, and haven't
looked at either of the two posted solutions yet, so I'm not sure how
they compare.

My general approach is pretty simple:

  - Find all valid pushes from the current spot
  - For each push:
      - Do it
      - Recurse
      - If the puzzle is solved, exit
      - Undo it

The puzzle is always stored and used as a list of lists, with
$puzzle->[$row]->[$col] containing the actual ASCII character, and
it's never converted into any other representation. Nor is it ever
rotated or transformed in any other way (other than making moves &
then reversing them).

The "find all valid pushes" piece was easier than I originally made it
out to be. I eventually settled on a non-recursive version of the
"flood fill" algorithm to radiate outward from the current point,
looking for all spots from which a box can be pushed, and storing the
path I took to get to each one.

I currently make no attempt to minimize either the number of pushes or
the total number of moves. My program is guaranteed to find a solution
if one exists, but it will almost definitely not be the minimal
solution. It also moves in a predictable order (left/right/up/down),
and will find the same solution every time, unless given the -r
command-line option (to randomize moves).

There are a few minor optimizations made at each step, like not
putting the puzzle into any state it's been in before, and not going
any further once the puzzle has been made unsolveable. Determining
"solvable" is where the real speed gains can be made. My test is
fairly simple -- just make sure each box has a position from which it
can be pushed. A more comprehensive approach would be to test for all
of the "trap" positions under SOKOBAN'S IMPOSSIBLE MOVES at:

  http://www.geocities.com/erimsever/sokoban1.htm

This would allow entire move sets to be pruned fairly quickly.

Anyway, code is below, with copious comments throughout. It supports a
few command-line arguments, mostly related to the display. If you
watch it move (the default), you'll see lots of unsolveable positions
it gets itself into, especially in -r mode.

Run with -q (the fastest option), it solves the given puzzle in about
7.2 seconds on my 3.4 GHz Linux desktop. But it takes 1192 moves / 352
pushes, which can definitely be reduced.

Just to make sure it worked, I also ran puzzle #1 from the "standard"
collection:

      #####
      #   #
      #$  #
    ###  $##
    #  $ $ #
  ### # ## #   ######
  #   # ## #####  ..#
  # $  $          ..#
  ##### ### #@##  ..#
      #     #########
      #######

It finished this one in 2.65s, using 432 moves / 161 pushes. For fun,
I tried puzzle #2 from that collection:

  ############
  #..  #     ###
  #..  # $  $  #
  #..  #$####  #
  #..    @ ##  #
  #..  # #  $ ##
  ###### ##$ $ #
    # $  $ $ $ #
    #    #     #
    ############

But after about 12 hours, I Ctrl-C'ed it. :-) I think the additional
"unsolvable" conditions would need to be added to solve this one in a
reasonable amount of time.

--
Ron Isaacson
Morgan Stanley
ron.isaacson-/PgpppG8B+R7qynMiXIxWgC/[email protected] / (212) 276-1144

-----8<-----8<-----8<-----8<-----8<-----8<-----8<-----8<-----8<-----8<-----

#!/usr/bin/perl

use strict;
use Getopt::Long;
use POSIX;
use Term::Cap;
use Time::HiRes qw(time sleep);
use List::Util  qw(shuffle);

# Constants

our ($LEFT, $RIGHT, $UP, $DOWN)                       = (-1, 1, -2, 2);
our ($WALL, $BOX, $TARGET, $FTARGET, $PLAYER, $EMPTY) = split //, '#$.X@ ';

our %MOVE =
  (
   $LEFT  => 'l',
   $RIGHT => 'r',
   $UP    => 'u',
   $DOWN  => 'd',
  );

# Globals

our $TERM;
our $QUIET  = 0;
our $DELAY  = 0.1;
our $RANDOM = 0;

######
##
## Terminal control
##
######

sub init_term {
  # From Term::Cap docs

  my $termios = POSIX::Termios->new;

  $termios->getattr;
  my $ospeed = $termios->getospeed;

  $TERM = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
  $TERM->Trequire (qw(UP md me));
}

sub move_up {
  my ($lines) = @_;

  print $TERM->Tgoto ('UP', undef, $lines);
}

sub highlight {
  my ($char) = @_;

  return
    ($TERM->Tputs ('md') .
     $char .
     $TERM->Tputs ('me'));
}

######
##
## Puzzle management
##
######

# Read puzzle from file

sub read_puzzle {
  my ($file) = @_;
  my $puzzle = [];

  open FILE, $file
    or return;

  while (<FILE>) {
    chomp;
    push @$puzzle, [split //, $_];
  }

  close FILE;
  return $puzzle;
}

# Find player's initial position

sub starting_point {
  my ($puzzle) = @_;

  for my $row (0..$#{$puzzle}) {
    for my $col (0..$#{$puzzle->[$row]}) {
      if ($puzzle->[$row]->[$col] eq $PLAYER) {
        $puzzle->[$row]->[$col] = $EMPTY;
        return ($row, $col);
      }
    }
  }

  return;
}

# Make sure puzzle has enough targets for all of the free boxes

sub has_enough_targets {
  my ($puzzle) = @_;

  my %count;

  for my $row (0..$#{$puzzle}) {
    for my $col (0..$#{$puzzle->[$row]}) {
      $count{$puzzle->[$row]->[$col]}++;
    }
  }

  return ($count{$TARGET} >= $count{$BOX});
}

# String representation of puzzle's current state

sub puzzle_state {
  my ($puzzle) = @_;

  my $state = join "\n", map { join "", @$_ } @$puzzle;
  return $state;
}

# Check to see if the puzzle is solved

sub puzzle_solved {
  my ($puzzle) = @_;

  for my $row (0..$#{$puzzle}) {
    for my $col (0..$#{$puzzle->[$row]}) {
      return if $puzzle->[$row]->[$col] eq $TARGET;
    }
  }

  return 1;
}

# Display puzzle, possibly including the current number of pushes
# (stack depth) on the first line, then reposition the cursor at the
# top for a redisplay

sub show_puzzle {
  my ($puzzle, $player_row, $player_col, $pushes) = @_;

  for my $row (0..$#{$puzzle}) {
    my $line;

    for my $col (0..$#{$puzzle->[$row]}) {
      $line .=
        (($row == $player_row and $col == $player_col) ?
         $PLAYER :
         $puzzle->[$row]->[$col]);
    }

    # Draw boxes & targets in bold to make them stand out

    $line =~ s|([$BOX$TARGET$FTARGET]+)|highlight ($1)|ge;

    if ($row == 0) {
      $line .= sprintf "  %-10d", $pushes
        if $pushes;
    }

    print "$line\n";
  }

  move_up (scalar @$puzzle);
}

# Move the cursor back down to the bottom of the puzzle, show a
# message and exit

sub final_msg {
  my ($puzzle, $msg, $code) = @_;

  print "\n" x scalar @$puzzle;
  print "\n$msg\n\n";
  exit $code;
}

######
##
## Motion
##
######

# Position state checks

sub is_pushable   { $_[0] eq $BOX   or $_[0] eq $FTARGET }
sub is_occupiable { $_[0] eq $EMPTY or $_[0] eq $TARGET  }

# Make sure we don't leave the puzzle. The playing area should be
# surrounded by walls, but we never actually verify that.

sub out_of_bounds {
  my ($puzzle, $row, $col) = @_;

  return
    ($row < 0 or $row >= $#{$puzzle} or
     $col < 0 or $col >= $#{$puzzle->[$row]});
}

# Get the piece at a certain spot

sub get_piece {
  my ($puzzle, $row, $col) = @_;

  return
    (out_of_bounds ($puzzle, $row, $col) ?
     undef                               :
     $puzzle->[$row]->[$col]);
}

# Given a starting point and a direction, find the next two pieces in
# that direction. Return the row/column index and the current piece in
# each position.

sub move_data {
  my ($puzzle, $row, $col, $move) = @_;

  my ($row1, $col1);
  my ($row2, $col2);

  # If the move is 2 or -2, we're going vertically, otherwise
  # horizontally

  if ($move % 2 == 0) {
    my $nmove = $move / 2;

    $row1 = $row + $nmove;
    $col1 = $col;

    $row2 = $row + ($nmove * 2);
    $col2 = $col;
  } else {
    $row1 = $row;
    $col1 = $col + $move;

    $row2 = $row;
    $col2 = $col + ($move * 2);
  }

  my $piece1 = get_piece ($puzzle, $row1, $col1);
  my $piece2 = get_piece ($puzzle, $row2, $col2);

  return
    ($row1, $col1, $piece1,
     $row2, $col2, $piece2);
}

# Check to see if a certain move would result in a valid box push

sub can_push {
  my ($puzzle, $row, $col, $move) = @_;

  my ($row1, $col1, $piece1,
      $row2, $col2, $piece2) = move_data ($puzzle, $row, $col, $move);

  # The piece must be pushable, and the spot it's going must be
  # occupiable

  return
    (is_pushable   ($piece1) and
     is_occupiable ($piece2));
}

# Check to see if a box is "stuck", meaning that it can never be
# pushed

sub is_stuck {
  my ($puzzle, $row, $col) = @_;

  # If a box can be pushed now, then it's not stuck and we're done. 
  # But if a box is blocked in by other boxes, then it's only stuck if
  # all of those boxes are stuck too. Otherwise a push on one of those
  # might make this one on-stuck.
  #
  # We'll use a standard "flood-fill" algorithm to efficiently find
  # all boxes touching the current box. As soon as we find one that's
  # pushable, we're done.

  my @queue;
  my %seen;

  push @queue, [$row, $col];

  while (@queue) {
    my $next        = shift @queue;
    my ($row, $col) = @$next;

    # Mark the boxes we've already checked so we don't go backwards

    $seen{$row,$col} = $WALL;

    # Go one spot in each direction, and see if the box can be pushed
    # from there

    for my $move ($LEFT, $RIGHT, $UP, $DOWN) {
      my ($row1, $col1) = move_data ($puzzle, $row, $col, $move);
      my $piece1        = $seen{$row1,$col1} || $puzzle->[$row1]->[$col1];

      # To push back on the piece we just left, we'll try the OPPOSITE
      # move of the one we made to get here, which is easily done by
      # negating $move

      return if
        (is_occupiable ($piece1) and
         can_push      ($puzzle, $row1, $col1, -$move));

      push @queue, [$row1, $col1]
        if ($piece1 eq $BOX);
    }
  }

  # We can't push this box or any of its neighbors, so it must be
  # stuck

  return 1;
}

# Check to ensure the puzzle is solvable

sub is_solvable {
  my ($puzzle) = @_;

  # If there are any stuck boxes (see above), the puzzle is unsolvable

  for my $row (0..$#{$puzzle}) {
    for my $col (0..$#{$puzzle->[$row]}) {
      next unless
        ($puzzle->[$row]->[$col] eq $BOX);

      return if
        is_stuck ($puzzle, $row, $col);
    }
  }

  # Note that this doesn't guarantee that the puzzle is solvable --
  # there are still other conditions that can make it unsolvable.
  # Adding more checks will probably make the program faster.

  return 1;
}

# Find all pushes that can be made from the current position

sub find_pushes {
  my ($puzzle, $row, $col) = @_;

  # We're starting out in empty space, and looking for all of the
  # reachable positions from which a box can be pushed. As in
  # is_stuck, we'll use the "flood-fill" algorithm to find all
  # neighboring empty space, and in each position, check all four
  # directions to see if there's a pushable box in that direction.
  #
  # Unlike in is_stuck, we're building up a list of ALL pushes we can
  # make from here, so don't stop until we've searched all reachable
  # empty space.
  #
  # While we're at it, we'll build up a path to each push, which will
  # allow us to present a complete set of moves at the end.
  #
  # Note that neither the set of pushes nor the set of moves is likely
  # to be minimal. The set of moves could be reduced by applying
  # Dijkstra's algorithm on the empty space maps once the exact set of
  # pushes is found.

  my @pushes;
  my @queue;
  my %seen;

  push @queue, [$row, $col];

  while (@queue) {
    my $next               = shift @queue;
    my ($row, $col, @prev) = @$next;

    # Mark the spaces we've already been to so we don't go backwards

    $seen{$row,$col} = $WALL;

    # In each direction, we might find a box we can push, or more
    # empty space we can walk into

    my @moves = ($LEFT, $RIGHT, $UP, $DOWN);
    @moves    = shuffle @moves if $RANDOM;

    for my $move (@moves) {
      # Can we push in this direction?

      push @pushes, [$row, $col, $move, @prev]
        if can_push ($puzzle, $row, $col, $move);

      # Can we walk in this direction?

      my ($row1, $col1) = move_data ($puzzle, $row, $col, $move);
      my $piece1        = $seen{$row1,$col1} || $puzzle->[$row1]->[$col1];

      push @queue, [$row1, $col1, @prev, $move]
        if is_occupiable ($piece1);
    }
  }

  return @pushes;
}

# Try to push a box. If successful, return the new position (and a way
# to undo the push, which we'll need later) -- otherwise return
# nothing.
#
# Note that we assume all moves we're given have already passed the
# can_push test, so we're looking for other conditions that would make
# this push invalid.

sub do_push {
  my ($puzzle, $states, $row, $col, $move) = @_;

  my ($row1, $col1, $piece1,
      $row2, $col2, $piece2) = move_data ($puzzle, $row, $col, $move);

  # Push the box first, and undo it later if something goes wrong

  $puzzle->[$row1]->[$col1] = $piece1 eq $FTARGET ? $TARGET  : $EMPTY;
  $puzzle->[$row2]->[$col2] = $piece2 eq $TARGET  ? $FTARGET : $BOX;

  my $undo = sub {
    $puzzle->[$row1]->[$col1] = $piece1;
    $puzzle->[$row2]->[$col2] = $piece2;
  };

  # Make sure we didn't just make the puzzle unsolveable

  unless (is_solvable ($puzzle)) {
    $undo->();
    return;
  }

  # The puzzle should be in a new state that it hasn't been in before.
  # Otherwise, we might just push one box back and forth forever.

  my $state = puzzle_state ($puzzle);

  if (exists $states->{$state}) {
    $undo->();
    return;
  }

  # Ok, push successful

  return ($row1, $col1, $undo);
}

######
##
## Solver
##
######

# Recursive solver

sub solve_recursive {
  my ($puzzle, $row, $col, $states, $pushes) = @_;

  # Simple brute-force algorithm:
  #
  #   - Find all valid pushes from the current spot
  #   - For each push:
  #       - Do it
  #       - Recurse
  #       - Undo it

  my @available_pushes = find_pushes ($puzzle, $row, $col);

  for my $push (@available_pushes) {
    my ($row, $col, $move, @prev) = @$push;

    my ($new_row, $new_col, $undo) =
      do_push ($puzzle, $states, $row, $col, $move)
        or next;

    push @$pushes, $push;

    # Save the state, to make sure we don't end up back here again

    my $state = puzzle_state ($puzzle);
    $states->{$state} = 1;

    # Check to wee if we're done

    my $solved = puzzle_solved ($puzzle);

    if ($solved or not $QUIET) {
      show_puzzle ($puzzle, $new_row, $new_col, scalar @$pushes);

      return 1      if $solved;
      sleep  $DELAY if $DELAY;
    }

    # Down we go...

    solve_recursive ($puzzle, $new_row, $new_col, $states, $pushes)
      and return 1;

    # Oops, didn't work out

    pop @$pushes;
    $undo->();
  }

  return;
}

# Entry point

sub solve_puzzle {
  my ($puzzle, $row, $col) = @_;

  my $states = {};
  my $pushes = [];

  my $start  = time;
  my $solved = solve_recursive ($puzzle, $row, $col, $states, $pushes);
  my $end    = time;

  return unless $solved;

  return (1, $end - $start, $pushes);
}

# Create a complete list of moves from a list of pushes

sub list_moves {
  my (@pushes) = @_;

  my @moves;

  for my $push (@pushes) {
    my ($row, $col, $move, @prev) = @$push;

    push @moves, map { $MOVE{$_} } @prev;
    push @moves, uc $MOVE{$move};
  }

  return @moves;
}

###############################################################################

my $usage = <<USAGE;
Usage: $0 [-q | -d <delay>] [-r] puzzlefile

  -q          Quick mode -- don't show solutions in progress
  -d <delay>  Sleep for <delay> seconds between frames (0 or decimal ok)
  -r          Move randomly, instead of always left/right/up/down
USAGE

GetOptions
  (
   'q'   => \$QUIET,
   'd=s' => \$DELAY,
   'r'   => \$RANDOM,
  )
  or die $usage;

my $puzzle_file = shift
  or die $usage;

init_term;

my $puzzle =
  read_puzzle ($puzzle_file) or die "Error reading $puzzle_file: $!\n";

is_solvable ($puzzle)        or die "Puzzle started out unsolvable\n";
has_enough_targets ($puzzle) or die "Puzzle doesn't contain enough targets\n";

my ($row, $col) =
  starting_point ($puzzle)   or die "Puzzle contains no starting point\n";

show_puzzle ($puzzle, $row, $col);

my ($solved, $time, $pushes) = solve_puzzle ($puzzle, $row, $col);

if (not $solved) {
  final_msg ($puzzle, "No solution found", 1);
}

my @moves  = list_moves (@$pushes);
my $result = sprintf ("Solved in %d pushes (%d moves), %.2fs\n",
                      scalar @$pushes, scalar @moves, $time);

while (my @line = splice @moves, 0, 70, ()) {
  $result .= "\n";
  $result .= join "", @line;
}

final_msg ($puzzle, $result, 0);