#!/usr/bin/perl -w
use strict;
use warnings;
use Data::Dumper;				# for debugging
use Time::HiRes qw (time);		# for profiling

my @solution = ();				# the solution as moves
my @solpics  = ();				# the solution as "pictures"
my %poslist  = ();				# list of all positions that have been reached already - to prevent loops

my $MAXMOVES  = 36;				# upper limit for the number of moves (btw: the first move is move #0!)

my $LINES   =  8;
my $COLUMNS =  8;
my $EXIT    = 34;
my $MAXCHAR;					# highest "name" of the blocks
my %blocksize;					# the size of each block
my %blockdir;					# the orientation of all blocks (h or v)

my $pos = "********\n".			# The playfield
          "*..EEE.*\n".			#  * "A" needs to be moved out
          "*....C.*\n".			#  * all other blocks are numbered from B...Z - with no gaps in the names
          "*AA.BC..\n".			#  * all blocks need to be 2 or 3 boxes long
          "*...BDF*\n".			#  * free positions are marked with "." (including the exit)
          "*...BDF*\n".			#  * the borders are marked with "*"
          "*....D.*\n".			#  * the exit is hardcoded (position 34, see above)
		  "********\n";
	
setpos();
init(); 						# init the meta-data of the field

my $movecount = 0;				# count the number of steps
my $starttime = time();			# for profiling

my $result    = solve ($pos);	# recursively solve the puzzle 

my $endtime   = time();

if ($result == 1)				
{
	print ($pos,"can be solved with the following  ",scalar(@solution), " moves: ", join(" ",@solution), "\n\n");
	for (my $i = 0; $i < scalar(@solution); $i++) { print $solution[$i],"\n",$solpics[$i]; }
	print ($pos,"can be solved with the following  ",scalar(@solution), " moves: ", join(" ",@solution), "\n\n");

}
else
{
	print ($pos,"cannot be solved in ",$MAXMOVES+1," moves\n");
}

print "$movecount steps have been executed to find that solution\n";
print $endtime-$starttime," seconds have been needed.\n";

exit 0;		

#Debuging
#print( Data::Dumper->Dumpxs( [ \ %blocksize ], [ qw{ *blocksize } ] ));	
#print( Data::Dumper->Dumpxs( [ \ %blockdir  ], [ qw{ *blockdir  } ] ));	

  
#============================== recursive solution ==========================================================================================		  
sub solve
{
	my $pos = $_[0];

	return 1	if (substr($pos, $EXIT, 1) eq "A");		# a solution has been found :-)  Horray!
#	return 0	if (scalar(@solution) > $MAXMOVES) ; 	# too many steps                                  <--- comment this in (###1###)

	
	my @moves = getMoves($pos);
	return 0    if (scalar(@moves) == 0) ;				# no moves => not finished

#	print $pos, join(",",@moves), " [$movecount steps][",scalar(keys(%poslist))," positions checked][",scalar(@solution)," steps in current solution]\n";
	
	foreach my $m (@moves)
	{
		$movecount++;										# increase the count of moves ...
		my $newpos = move ($pos, $m);						# do the next move 
		next if (exists($poslist{$newpos}));				# that position was already there .. skip it to prevent going in loops

		push (@solution, $m);								# store the new move
		push (@solpics,  $newpos);
		$poslist{$pos} = 1;
		
		my $res = solve ($newpos);							# evaluate the new position
		return $res  if ($res == 1);						# return if a soultion has been found
		
		pop (@solution);									# no solution has been found with this move	
		pop (@solpics);										# => remove it and try the next one
#		delete $poslist{$pos};                              #                                            <--- comment this in (###1###)
	}
	return 0;											# we didn't find anything...
}		  
	
#============================== get a list of all valid moves ==========================================================================================		  
sub getMoves
{
	my $pos = $_[0];
	my @moves = ();
	
	foreach my $ch  ('A' .. $MAXCHAR)
	{
		my $p = index($pos, $ch);		# left + top corner
		my $s = $blocksize{$ch};		# size 
		my $d = $blockdir {$ch};		# direction
	
		if ($d eq "h")					# horizontal handling
		{
			my $i = 1;
			while(1)
			{
				last unless (substr($pos, $p-$i, 1) eq ".");		# look left for free elements
				push (@moves, "$ch:L:$i");
				$i++;
			}
			$i = 1;
			while(1)
			{
				last unless (substr($pos, $p+$s+$i-1, 1) eq ".");		# look right for free elements
				push (@moves, "$ch:R:$i");
				$i++;
			}
		}
		else							# vertical handling
		{
			my $i = 1;
			while(1)
			{
				last unless (substr($pos, $p-$i*($COLUMNS+1), 1) eq ".");		# look up for free elements
				push (@moves, "$ch:U:$i");
				$i++;
			}
			$i = 1;
			while(1)
			{
				last unless (substr($pos, $p+($s+$i-1)*($COLUMNS+1), 1) eq ".");	# look down for free elements
				push (@moves, "$ch:D:$i");
				$i++;
			}
		}
	}
	return @moves;	
}	
		  
#============================== move a block ==========================================================================================		  
sub move
{
	my $oldpos = $_[0];
	my $m      = $_[1];
	
	$m =~ /(.):(.):(\d)/;
	
	my $ch  = $1;
	my $dir = $2;
	my $num = $3;
	
	my $newpos;
	my @s = split (//, $oldpos);
	my $p = index($oldpos, $ch);
	if ($dir eq "L") {
		for (my $i = 0; $i < $blocksize{$ch}; $i++)  {	$s[$p+$i]      = "."; }    # delete old string
		for (my $i = 0; $i < $blocksize{$ch}; $i++)  {	$s[$p+$i-$num] = $ch; }    # write new position
	}
	elsif ($dir eq "R") {
		for (my $i = 0; $i < $blocksize{$ch}; $i++)  {	$s[$p+$i]      = "."; }    # delete old string
		for (my $i = 0; $i < $blocksize{$ch}; $i++)  {	$s[$p+$i+$num] = $ch; }    # write new position
	}
	elsif ($dir eq "U") {
		for (my $i = 0; $i < $blocksize{$ch}; $i++)  {	$s[$p+$i*($COLUMNS+1)]      = "."; }      # delete old string
		for (my $i = 0; $i < $blocksize{$ch}; $i++)  {	$s[$p+($i-$num)*($COLUMNS+1)] = $ch; }    # write new position
	}
	elsif ($dir eq "D") {
		for (my $i = 0; $i < $blocksize{$ch}; $i++)  {	$s[$p+$i*($COLUMNS+1)]      = "."; }      # delete old string
		for (my $i = 0; $i < $blocksize{$ch}; $i++)  {	$s[$p+($i+$num)*($COLUMNS+1)] = $ch; }    # write new position
	}
	$newpos = join("",@s);
	
	return $newpos;
}	  
		  
#============================== init the main fields ========================================================================================
sub init
{
	foreach my $i (reverse("A" .. "Z"))  
	{ 
		$MAXCHAR = $i;								# overcome implicit localization of foreach-loop
		last if (index ($pos, $i) != -1); 
	}

	foreach my $ch ("A"..$MAXCHAR)					# determine orientation and size of the blocks
	{
		my $p = index ($pos, $ch);
		if (substr($pos, $p+1, 1) eq $ch)  	
		{ 
			my $i = 1;
			while (substr($pos, $p+$i, 1) eq $ch) { $i++; }
			$blocksize{$ch} = $i;
			$blockdir{$ch}  = "h"; 
		}
		else								
		{ 
			my $i = 1;
			while (substr($pos, $p+$i*($COLUMNS+1), 1) eq $ch) { $i++; }
			$blocksize{$ch} = $i;
			$blockdir{$ch} = "v"; 
		}
	}
}

	  
#============================== another starting position ==========================================================================================		  
sub setpos
{
	$pos ="********\n".				# A more complicated starting position
          "*BBB.CC*\n".
          "*..DEEF*\n".
          "*AAD..F.\n".
          "*H.MMLG*\n".
          "*HJJKLG*\n".
          "*IIIK.G*\n".
		  "********\n";
}