Unsolved problem + boredom =

#!/usr/bin/perl

# 15 puzzle solver

use strict;
use warnings;

my $start = <<END; # initial layout, 0 for empty cell
14 15  1  2
12  7  6 10
13  3 11  9
 8  4  5  0
END

my @squarestomove = solve( split ' ', $start );

while( @squarestomove > 10 )
  {
  print "steps: @{[ splice @squarestomove, 0, 10 ]}\n";
  }
print "steps: @squarestomove\n";

exit;

sub solve # internally runs in letters, not numbers, for regex purpose
+s
  {
  my (%numbers2letters, %letters2numbers);
  @numbers2letters{ 0..15 } = (' ', 'a'..'o');
  %letters2numbers = reverse %numbers2letters;
  my $board = join '', @numbers2letters{@_};
  $board =~ s/....\K(?=.)/\n/g;
  my $win   = "abcd\nefgh\nijkl\nmno ";
  my $moves = '';

  for my $n (1..18) # place first, then first two, first three, etc.
    {
    (my $path, $board) = solvepart($board, substr $win, 0, $n );
    print "path: $path\n\n$board\n\n";
    $moves .= $path;
    }

  #print "\nmoves: $moves\n";
  1 while $moves =~ s/(.)\1//g; # remove dups
  print "\nmoves: $moves\n\n";

  return @letters2numbers{ split //, $moves};
  }

sub solvepart
  {
  my ($have, $want) = @_;
  my @stack = $have;
  my %seen;
  my $delta = length $have =~ s/\n.*//sr;
  my $count = 0;

  while( $_ = shift @stack )
    {
    $count++;
    if( $count > 1e7 ) # loop protection, may need to be larger
      {
      my $size = keys %seen;
      die "died with $size seen\n";
      }
    my ($path, $board) = /(.*),(.*)/s ? ($1, $2 ) : ('', $_);
    #print "$board\n\n";
    if( $want eq substr $board, 0, length $want)
      {
      return $path, $board;
      }
    elsif( $seen{$board}++ )
      {
      }
    else
      {
      my $new = $board;
      if( $new =~ s/(\w) / $1/ ) # right
        {
        $seen{$new} or push @stack, "$path$1,$new";
        }
      $new = $board;
      if( $new =~ s/ (\w)/$1 / ) # left
        {
        $seen{$new} or push @stack, "$path$1,$new";
        }
      $new = $board;
      if( $new =~ s/(\w)(.{$delta}) / $2$1/s ) # down
        {
        $seen{$new} or push @stack, "$path$1,$new";
        }
      $new = $board;
      if( $new =~ s/ (.{$delta})(\w)/$2$1 /s ) # up
        {
        $seen{$new} or push @stack, "$path$2,$new";
        }
      }
    }
  die "no solution for $_";
  }
[download]

It's just a simple breadth first search looking to position the 1 first, then 1 & 2, then 1 & 2 & 3, etc. Trying to do the whole thing at once was too big for my machine (and maybe any machine :).

There are still some debug prints left on, and some near infinite loop detection code.

Internally I use letters to simplify (and speed up?) the regex for finding moves.

---

---

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

• How do I compose an effective node title?
• How do I post a question effectively?
• Markup in the Monastery

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		&
	<		&lt;
	>		&gt;
	[		&#91;
	]		&#93;

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.