Rosetta Code

Sokoban: Difference between revisions

Page Discussion

Sokoban (view source)

Revision as of 02:56, 28 November 2013

4,050 bytes added ,  10 years ago
→‎{{header|Perl}}: Totally rewrote the perl solution.
(→‎{{header|Perl}}: Totally rewrote the perl solution.)
Line 1,564:
<pre>luULLulDDurrrddlULrruLLrrUruLLLulD</pre>
=={{header|Perl}}==
This performs asimultaneous breadth first searchsearches, whichstarting *ought*from tothe produceinitial an optimalstate
and various possible final states, and meeting somewhere in the middle.
solution. There is a bug in the code, though, so that on this example,
 
it produces a solution of length 36 instead of length 34. Corrections welcome!
On my laptop, which has a slow cpu and little memory, it can solve the basic puzzle
in about a second, and a slightly harder one in about 50 seconds.
 
A slightly more basic version of this code, doing a single breadth first search,
took twenty seconds for the basic puzzle, and was unable to solve the slightly harder
one before I lost patience with it (about half an hour).
 
The meet-in-the-middle search uses massively less memory, but obviously more lines
of code. Due to the way I alternate between forward and rearward computation, it's
possible for the solution to be at most one step longer than the optimal one... but it
would still be a valid solution. I could fix it, but at the cost of speed and memory.
 
<lang Perl>#!perl
use strict;
use warnings qw(FATAL all);
my $@initial = split /\n/, <<'LEVEL';
#############
# # #
# $$$$$$$ @#
#....... #
#############
 
#######
# #
Line 1,579 ⟶ 1,597:
#.# @#
#######
 
LEVEL
=for
space is an empty square
Line 1,590 ⟶ 1,608:
=cut
 
my $cols = 1+index $initial, "\n" or die;
 
my %dirs = (u => -$cols, d => +length($cols, l => -1, r => +1initial[0]);
my $initial = join '', @initial;
my $size = length($initial);
die unless $size == $cols * @initial;
 
sub WALL() { 1 }
my %walk = ('@ ',' @', '+ ', '.@', '@.' => ' +');
sub PLAYER() { 2 }
$_ = [split //, $_] for values %walk;
sub BOX() { 4 }
sub GOAL() { 8 }
 
my %wallinput = ('@#', 1, '+#', 1);
' ' => 0, '#' => WALL, '@' => PLAYER, '$' => BOX,
'.' => GOAL, '+' => PLAYER|GOAL, '*' => BOX|GOAL,
);
my %output = reverse(%input);
 
sub packed_initial {
my %push;
for my $andthenret = ('';
vec( $ret, $_, 4 ) = $input{substr $initial, $_, 1}
['$ ', '@$'], ['$.', '@*'], # push box from space, to space or goal
for( 0 .. $size-1 );
['* ', '+$'], ['*.', '+*'], # push box from goal, to space or goal
$ret;
) {
my ($from, $to) = @$andthen;
$push{'@'.$from} = [' ', split //, $to];
$push{'+'.$from} = ['.', split //, $to];
}
 
sub printable_board {
my @fifo = (["", $initial]);
my %seen = ($initialboard => 1)shift;
my @c = @output{map vec($board, $_, 4), 0 .. $size-1};
my $ret = '';
while( my @row = splice @c, 0, $cols ) {
$ret .= join '', @row, "\n";
}
$ret;
}
 
my $packed = packed_initial();
while( @fifo ) {
my ($moves, $level) = @{$fifo[0]};
last if -1 == index $level, '$';
shift @fifo;
 
my @udlr = qw(u d l r);
$level =~ /([@+])/ or die "No player!\n";
my @locUDLR = $-[0]qw(U D L R);
my $tiles@deltas = (-$cols, +$cols, -1, +1);
 
my %fseen;
for my $d (keys %dirs) {
INIT_FORWARD: {
splice @loc, 1;
$initial =~ /(\@|\+)/ or die;
substr $tiles, 1, 99, '';
use vars qw(@ftodo @fnext);
@ftodo = (["", $packed, $-[0]]);
$fseen{$packed} = '';
}
 
my %rseen;
push @loc, $loc[-1] + $dirs{$d};
INIT_REVERSE: {
$tiles .= substr $level, $loc[-1], 1;
my $goal = $packed;
vec($goal, $ftodo[0][2], 4) -= PLAYER;
my @u = grep { my $t = vec($goal, $_, 4); $t & GOAL and not $t & BOX } 0 .. $size-1;
my @b = grep { my $t = vec($goal, $_, 4); $t & BOX and not $t & GOAL } 0 .. $size-1;
die unless @u == @b;
vec($goal, $_, 4) += BOX for @u;
vec($goal, $_, 4) -= BOX for @b;
use vars qw(@rtodo @rnext);
FINAL_PLACE: for my $player (0 .. $size-1) {
next if vec($goal, $player, 4);
FIND_GOAL: {
vec($goal, $player + $_, 4) & GOAL and last FIND_GOAL for @deltas;
next FINAL_PLACE;
}
my $a_goal = $goal;
vec($a_goal, $player, 4) += PLAYER;
push @rtodo, ["", $a_goal, $player ];
$rseen{$a_goal} = '';
#print printable_board($a_goal);
}
}
 
my $movelen = -1;
if( my $walk = $walk{ $tiles } ) {
my ($solution);
MAIN: while( @ftodo and @rtodo ) {
 
FORWARD: {
my ($moves, $level, $player) = @{pop @ftodo};
die unless vec($level, $player, 4) & PLAYER;
 
for my $dir_num (0 .. 3) {
my $delta = $deltas[$dir_num];
my @loc = map $player + $delta * $_, 0 .. 2;
my @val = map vec($level, $_, 4), @loc;
 
next if $val[1] & WALL or ($val[1] & BOX and $val[2] & (BOX|WALL));
my $new = $level;
substr vec($new, $loc[$_0], 1,4) $walk->[$_] for 0 ..= 1PLAYER;
vec($new, $loc[1], 4) += PLAYER;
my $nmoves;
if( $val[1] & BOX ) {
vec($new, $loc[1], 4) -= BOX;
vec($new, $loc[2], 4) += BOX;
$nmoves = $moves . $UDLR[$dir_num];
} else {
$nmoves = $moves . $udlr[$dir_num];
}
next if exists $fseen{$new};
$fseen{$new} = $nmoves;
 
push @fnext, [ $nmoves, $new, $loc[1] ];
 
next ifexists $seenrseen{$new}++ or next;
#print(($val[1] & BOX) ? "Push $UDLR[$dir_num]\n" : "Fwalk $udlr[$dir_num]\n");
push @fifo, [ $moves . $d, $new ];
$solution = $new;
next;
last MAIN;
}
 
nextlast FORWARD if $wall{$tiles}@ftodo;
use vars qw(*ftodo *fnext);
(*ftodo, *fnext) = (\@fnext, \@ftodo);
} # end FORWARD
BACKWARD: {
my ($moves, $level, $player) = @{pop @rtodo};
die "<$level>" unless vec($level, $player, 4) & PLAYER;
 
for my $dir_num (0 .. 3) {
push @loc, $loc[-1] + $dirs{$d};
my $tilesdelta .= substr $level, deltas[$loc[-1dir_num], 1;
# look behind and in front of the player.
my @loc = map $player + $delta * $_, -1 .. 1;
my @val = map vec($level, $_, 4), @loc;
 
# unlike the forward solution, we cannot push boxes
my $push = $push{ $tiles } or next;
next if $val[0] & (WALL|BOX);
my $new = $level;
vec($new, $loc[0], 4) += PLAYER;
vec($new, $loc[1], 4) -= PLAYER;
# unlike the forward solution, if we have a box behind us
# we can *either* pull it or not. This means there are
# two "successors" to this board.
if( $val[2] & BOX ) {
my $pull = $new;
vec($pull, $loc[2], 4) -= BOX;
vec($pull, $loc[1], 4) += BOX;
goto RWALK if exists $rseen{$pull};
my $pmoves = $UDLR[$dir_num] . $moves;
$rseen{$pull} = $pmoves;
push @rnext, [$pmoves, $pull, $loc[0]];
goto RWALK unless exists $fseen{$pull};
print "Doing pull\n";
$solution = $pull;
last MAIN;
}
RWALK:
next if exists $rseen{$new}; # next direction.
my $wmoves = $udlr[$dir_num] . $moves;
$rseen{$new} = $wmoves;
push @rnext, [$wmoves, $new, $loc[0]];
next unless exists $fseen{$new};
print "Rwalk\n";
$solution = $new;
last MAIN;
}
 
mylast $newBACKWARD =if $level@rtodo;
use vars qw(*rtodo *rnext);
substr $new, $loc[$_], 1, $push->[$_] for 0 .. 2;
(*rtodo, *rnext) = (\@rnext, \@rtodo);
 
} # end BACKWARD
next if $seen{$new}++;
push @fifo, [ $moves . uc($d), $new ];
}
}
 
if( @fifo$solution ) {
my $fmoves = $fseen{$solution};
my $rmoves = $rseen{$solution};
print "Solution found!\n";
print "MovesTime: ", (time() - $fifo[0][0]^T), " seconds\n";
print "Move LengthMoves: ",length($fifo[0][0]),fmoves "$rmoves\n";
print "FinalMove BoardLength: \n", length($fifo[0][1]fmoves . $rmoves), "\n";
print "Middle Board: \n", printable_board($solution);
} else {
print "No solution found!\n";
Line 1,664 ⟶ 1,786:
{{out}}
<pre>Solution found!
Time: 51 seconds
Moves: luULrddlULUlDrrruLLrrUruLLLulDrDDrdL
Moves: lldlllllllluurDldRRRRRRRRuulD rdLLLLLLrrrrrurrrdLLLLLLLrrrruulDulDulDulDLLulD
Move Length: 36
Move Length: 76
Final Board:
Middle Board:
#######
#############
# #
# # #
#* # $$$$$@ #
#* .......$ $ #
#############
#*@ #
#*# #
#######
</pre>
On this particular puzzle, the branch factor for the different search directions
were clearly quite different, as the forward search only did 29 moves, while the
reverse search did 47 moves.
 
Although my code doesn't print out the actual final board, it would be easy enough
to compute from the move list.
 
=={{header|PicoLisp}}==
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/183241"