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

Shlomi Fish <mailto:shlomif-ik1l9ssToec+JF/[email protected]> mailed on 28 December 2007
12:31:

| IMPORTANT: Please do not post solutions, hints, or other spoilers
| until at least 60 hours after the date of this message.  Thanks.
|=20
| I was told the "What does this code do?" quizzes were not as good as a
new
| programming task, so here's a more traditional QOTW that I came up
with. In
| this quiz you'll try to solve the following Sokoban (
| http://en.wikipedia.org/wiki/Sokoban ) puzzle using Perl:
|=20
| {{{{{{{{{{{{{{
|   ####
|   #  #
|   #  ####
| ###$.$  #
| #  .@.  #
| #  $.$###
| ####  #
|    #  #
|    ####
| }}}}}}}}}}}}}}


Well past the spoiler line now ...

(I do prefer these tasks to "WDTCD?" quizzes. *And* I=20
had some tuits over the holidays. Anyone else out there?)

I've tried not to be too clever.=20

* Standard breadth-first search, no heuristics

* tree is stored in a hash, as child =3D> parent pairs

* sparse tree (I only record the fastest way to get to a state)

* the text representation of a board state is used=20
  for both move detection and for storing

* subroutine 'move' checks whether the sokoban can
  move to the right, and what the result would be.
  By all rights it should be simple and elegant code.
  Instead, it's a workmanlike hack. Emphasis is on=20
  'works', however.

* subroutine 'moves' finds all possible descendants
  of a given board state by presenting consecutive=20
  rotated board states to sub move

There are gains to be made by taking advantage of the
fourfold rotational symmetry here. But that would be
clever.

Also, this text representation (xsb format) is highly
compressible, and it might be worthwhile to store the
board states that way. This is a small puzzle (25 pos-
itions, 4 boxes - only 25*24*23*22*21/4*3*2*1 =3D 265650=20
board states possible).

I get a solution (77 steps) in slighly over three min-
utes on this box (WinXP, single CPU, 3GHz).=20


##############################################
#!/perl

use strict;
use warnings;
# use Devel::Size qw(total_size);

my $puzzle =3D<<'EOP';
  ####
  #  #
  #  ####
###$.$  #
#  .@.  #
#  $.$###
####  #
   #  #
   ####
EOP
solve($puzzle);


sub move
{
  my $puzzle =3D shift;
  my $pos =3D index($puzzle, '@');
  my $tar0 =3D my $tar1 =3D 0;
 =20
  if ($pos =3D=3D -1)
  {
    $pos =3D index($puzzle, '+');
    $tar0 =3D 1;
  }
 =20
  my $next =3D substr($puzzle,$pos+1,1);
 =20
  if ($next eq ' ')
  {
    substr($puzzle, $pos+1, 1, '@');
    substr($puzzle, $pos,   1, $tar0 ? '.' : ' ');
    return $puzzle;   =20
  }
  elsif ($next eq '.')
  {
    substr($puzzle, $pos+1, 1, '+');
    substr($puzzle, $pos,   1, $tar0 ? '.' : ' ');
    return $puzzle;   =20
  }
  elsif ($next eq '#')
  {
    return undef;
  }
 =20
  # only boxes left
  $tar1 =3D 1 if $next eq '*';
  die "expecting a box (*\$), found '$next' in \n$puzzle\n" unless $next
eq '$' or $tar1;
  $next =3D substr($puzzle,$pos+2,1);
 =20
  if ($next eq ' ')
  {
    substr($puzzle, $pos+2, 1, '$');
    substr($puzzle, $pos+1, 1, $tar1 ? '+' : '@');
    substr($puzzle, $pos,   1, $tar0 ? '.' : ' ');
    return $puzzle;       =20
  }
  elsif ($next eq '.')
  {
    substr($puzzle, $pos+2, 1, '*');
    substr($puzzle, $pos+1, 1, $tar1 ? '+' : '@');
    substr($puzzle, $pos,   1, $tar0 ? '.' : ' ');
    return $puzzle;       =20
  }
  return undef;
}

sub rotate
{
  my $puzzle =3D shift;
  my @lines =3D split /\n/, $puzzle;

  my $maxl =3D 0;
  for (@lines)
  {
    my $l =3D length;
    $maxl =3D $l if $l > $maxl;
  }
 =20
  my @newlines;
  for my $j (0..$#lines)
  {
    my $l =3D length $lines[$j];
    for my $i (0..$maxl-1)
    {
      my $char;
      if ($i >=3D $l)
      {
        $char =3D ' ';
      }
      else
      {
        $char =3D substr($lines[$j],$i,1);
      }
      $newlines[$maxl-$i-1] .=3D $char;
    }
  }
 =20
  my $newpuzzle =3D (join "\n", @newlines) . "\n";
  return $newpuzzle;
}

sub moves
{
  my $puzzle =3D shift;
  my @moves;
 =20
  my $move =3D move($puzzle);
  push @moves, $move if defined $move;
 =20
  my $rot =3D rotate($puzzle);
  $move =3D move($rot);
  push @moves, rotate(rotate(rotate($move))) if defined $move;
 =20
  $rot =3D rotate($rot);
  $move =3D move($rot);
  push @moves, rotate(rotate($move)) if defined $move;
 =20
  $rot =3D rotate($rot);
  $move =3D move($rot);
  push @moves, rotate($move) if defined $move;
 =20
  return @moves;
}

sub is_solved
{
  my $puzzle =3D shift;
 =20
  return 0 if $puzzle =3D~ /\./;
  return 0 if $puzzle =3D~ /\+/;
 =20
  if ($puzzle =3D~ /\$/)
  {
    die "Apparently more boxes than targets in \n$puzzle\n";
  }
 =20
  return 1;
}


sub solve
{
  my $puzzle =3D shift;
  my %adjacency =3D ($puzzle =3D> 'START');
  my @queue =3D ($puzzle);
  my $maxsize =3D 0;
  while (1)
  {
    my $state =3D shift @queue;
    for my $cand (moves($state))
    {
      next if exists $adjacency{$cand};
      $adjacency{$cand} =3D $state;
      if (is_solved($cand))
      {
        print_sol($cand, \%adjacency);
#	my $size =3D total_size(\%adjacency) + total_size(\@queue);
#	print "Tree contains $size bytes.\n";
        return;
      }
      push @queue, $cand;
    }
#    print join "\t", scalar(keys %adjacency), scalar @queue, "\n";
  }
 =20
  die "Unsolvable?"; =20
}

sub print_sol
{
  my $solution =3D shift;
  my $href =3D shift;
 =20
  my @steps;
  while ($solution ne 'START')
  {
    unshift @steps, $solution;
    $solution =3D $href->{$solution};
  }
 =20
  print join "---\n", @steps;
  print "---\n... and it took me only ".(time - $^T)." seconds!";
}


--=20
Jurgen Pletinckx
AlgoNomics NV