#!/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 purposes
  {
  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 $_";
  }