My kids came home with little puzzles from a party -- you know the ones -- there's a picture on a series of 15 tiles in a 4 x 4 square with one empty space. You slide around the tiles to scramble or solve the puzzle. The trouble is, it doesn't take much to scramble even these small puzzles beyond solving easily. I said, "This is a job for Super-Perl." Here's the result. (Perl 4 warning...)

# perl script to solve a sliding tile puzzle
# I'm doing 4 x 4 but same should work for other sizes if
# there's enough memory -- you need to change sub kids to
# return possible moves for your size

# Solution is _0123456789abcde which represents
#  _ 0 1 2
#  3 4 5 6
#  7 8 9 a
#  b c d e
# in this configuration 0 or 3 can swap with _

# actually tiles can be named how you like, but _ is the gap

# you put in the desired configuration in $target
# (or visa-versa)

$solution='_0123456789abcde';
#$target='015234_6789abcde';

srand(time); for(0..50) { rand();}
$target=&rnd(40,$solution) unless $target;  # random for testing
print "Target is $target\n";

(%s)=($solution,''); # %s is kids/grandkids... of solution
(%t)=($target,'');   # %t is kids/grandkids... of target
@ws=($solution);     # workque for solution
@wt=($target);       # workque for target
$level=1;

while(1) {
 print "$level \r"; $level++;
 for $a (@ws) {      # for each in workque
  for(&kids($a)) {   # find kids
   next if defined($s{$_});    # skip if already done
   push(@ws2,$_);    # add to workque
   $s{$_}=$a;        # add to history & associate with parent
   &done($_) if defined($t{$_});  # check if we found a solution
  }
 }
 for $a (@wt) {
  for(&kids($a)) {
   next if defined($t{$_});
   push(@wt2,$_);
   $t{$_}=$a;
   &done($_) if defined($s{$_});
  }
 }
 @ws=@ws2; undef @ws2; # move new workque to old and clear for next ti
+me
 @wt=@wt2; undef @wt2;
}

sub kids {
 # return a list of all possible moves from this configuration
 local($_,@r);
 $_=$_[0]; push(@r,$_) if !/^...(_|..._)/ && s/(.)_/_$1/;
 $_=$_[0]; push(@r,$_) if !/^..(_|..._)/ && s/_(.)/$1_/;
 $_=$_[0]; push(@r,$_) if s/(.)(...)_/_$2$1/;
 $_=$_[0]; push(@r,$_) if s/_(...)(.)/$2$1_/;
 return @r;
}

sub done {
 # we're done -- print result
 @r=@_;
 print "$level: done $_[0]\n";

 # backwards from solution
 for($a=$s{$_[0]}; defined($s{$a}); $a=$s{$a}) { push(@r,$a);}

 # forward from target
 for($a=$t{$_[0]}; defined($t{$a}); $a=$t{$a}) { unshift(@r,$a);}

 # dump results
 print join("\n",@r),"\n";
 exit;
}

# execute $_[0] random moves on $_[1]
sub rnd { $_[0] < 1? $_[1]: &rnd($_[0]-1, &r(&kids($_[1]))); }

# return a random element from the list
sub r { $_[($#_+1) * rand()];}

[download]
Enjoy

john

Replies are listed 'Best First'.
fixed bugs and added Manhattan Distance algorithm
by jhanna (Scribe) on May 17, 2001 at 01:07 UTC
    Ok... So the first post actually didn't work. Kids had a serious bug... And truth be told, many puzzles would take forever to solve. So here's one that actually works.

    # perl script to solve a sliding tile puzzle
# I'm doing 4 x 4 but same should work for other sizes if
# there's enough memory -- you need to change sub kids to
# return possible moves for your size

# Solution is _0123456789abcde which represents
#  _ 0 1 2
#  3 4 5 6
#  7 8 9 a
#  b c d e
# in this configuration 0 or 3 can swap with _

# actually tiles can be named how you like, but _ is the gap

# you put in the desired configuration in $target
# (or visa-versa)

$solution='_0123456789abcde';
#$target='015234_6789abcde';
$target = shift(@ARGV);

srand(time); for(0..50) { rand();}
$target=&rnd(30,$solution) unless $target;  # random for testing
print STDERR "Target is $target\n";

(%t)=($target,'');   # %t is kids/grandkids... of target
@wt=($target);       # workque for target
$level=1;

$stime=time;

$l=70;               # I messed around with this to optimize speed / d
+epth

while(@wt) {
 # give a bit of feedback
 print STDERR "$level \r" unless $level & 127; $level++;
 if( ($a=shift(@wt)) ) {     # next item for workque
  for(&kids($a)) {           # for each of the possible moves from her
+e
   next if defined($t{$_});  # if we've been here before, skip it
   push(@wt,$_);             # add this position to the workque
   $t{$_}=$a;                # remember this configuration & its paren
+t
   $md{$_}=&md($_,$solution); # log the distance for this point to the
+ solution
   &done($_) if $_ eq $solution;
  }
 }
 # once in a while we want to reorder the workque by their distances
 if($level % $l == 1) {
  @wt=(sort bymd @wt)[0 .. 2*$l];
 }
}
print "\nNo solution found.\n";

sub kids {
 # return a list of all possible moves from this configuration
 local($_,@r,$i);
 $i=index($_[0],'_') % 4;
 $_=$_[0]; push(@r,$_) if $i!=0 && s/(.)_/_$1/;
 $_=$_[0]; push(@r,$_) if $i!=3 && s/_(.)/$1_/;
 $_=$_[0]; push(@r,$_) if s/(.)(...)_/_$2$1/;
 $_=$_[0]; push(@r,$_) if s/_(...)(.)/$2$1_/;
 return @r;
}

sub done {
 # we're done -- print result
 @r=@_;
 print STDERR time - $stime," seconds $level tries: done $_[0]\n";

  # forward from target
 for($a=$t{$_[0]}; defined($t{$a}); $a=$t{$a}) { unshift(@r,$a);}

 # dump results
 for(@r) { s/(....)/$1 /g; print "$_\n";}
 exit;
}

# execute $_[0] random moves on $_[1]
sub rnd { $_[0] < 1? $_[1]: &rnd($_[0]-1, &r(&kids($_[1]))); }

# return a random element from the list
sub r { $_[($#_+1) * rand()];}

# return manhattan distance of a to b
sub md { local($a,$b,$r)=@_;
 for(0 .. 15) {
  $i=index($b,substr($a,$_,1))-$_;
  $i=-$i if $i < 0;
  $r+=$i % 4 + int($i/4);
 }
 $r;
}

sub bymd { $md{$a} <=> $md{$b}; }

    [download]
    enjoy!
[reply]
[d/l]

Back to Cool Uses for Perl