• the grid is stored in a string - so setting a start-position and printing it out is easy
• the algorithm I used is simple:
  • compile a list of all possible moves
  • perform each move
  • skip the move if the resulting position was already encountered (to prevent loops)
  • abort if a solution has been found
  • try to solve the resulting position (recursively)
• The moves are also stored as a string (Block:Direction:# of steps) to be human-readable

Some advice I'd like to ask of you

• I know the puzzle contained at the end of the listing has a solution of less than 40 moves; however the solution returned by the program is 2526 steps
  • I could "optimize" the result by combining subsequent moves of the same block (e.g. A left 1 + A left 1 = A left 2) - but that brings me nowhere near to 40
  • I tried to implement a limit for the recursion-depth (comment in the lines marked with ###1###) - but then the algorithm runs for ages (the 2526-step-solution takes 1,4 sec)
  • How would you propose to change the algorithm to come to a short solution fast?!
• I'm not happy with the conversions between string and array to move the blocks (in sub move()) - is there any better way?
• What else would you change to improve the program?

#!/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 be
+en reached already - to prevent loops

my $MAXMOVES  = 36;                # upper limit for the number of mov
+es (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 b
+oxes long
          "*...BDF*\n".            #  * free positions are marked with
+ "." (including the exit)
          "*...BDF*\n".            #  * the borders are marked with "*
+"
          "*....D.*\n".            #  * the exit is hardcoded (positio
+n 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 solutio
+n has been found :-)  Horray!
#    return 0    if (scalar(@solution) > $MAXMOVES) ;     # too many s
+teps                                  <--- 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 curren
+t solution]\n";
    
    foreach my $m (@moves)
    {
        $movecount++;                                        # increas
+e the count of moves ...
        my $newpos = move ($pos, $m);                        # do the 
+next move 
        next if (exists($poslist{$newpos}));                # that pos
+ition was already there .. skip it to prevent going in loops

        push (@solution, $m);                                # store t
+he new move
        push (@solpics,  $newpos);
        $poslist{$pos} = 1;
        
        my $res = solve ($newpos);                            # evalua
+te the new position
        return $res  if ($res == 1);                        # return i
+f a soultion has been found
        
        pop (@solution);                                    # no solut
+ion has been found with this move    
        pop (@solpics);                                        # => re
+move it and try the next one
#        delete $poslist{$pos};                              #        
+                                    <--- comment this in (###1###)
    }
    return 0;                                            # we didn't f
+ind 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-$nu
+m] = $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+$nu
+m] = $ch; }    # write new position
    }
    elsif ($dir eq "U") {
        for (my $i = 0; $i < $blocksize{$ch}; $i++)  {    $s[$p+$i*($C
+OLUMNS+1)]      = "."; }      # delete old string
        for (my $i = 0; $i < $blocksize{$ch}; $i++)  {    $s[$p+($i-$n
+um)*($COLUMNS+1)] = $ch; }    # write new position
    }
    elsif ($dir eq "D") {
        for (my $i = 0; $i < $blocksize{$ch}; $i++)  {    $s[$p+$i*($C
+OLUMNS+1)]      = "."; }      # delete old string
        for (my $i = 0; $i < $blocksize{$ch}; $i++)  {    $s[$p+($i+$n
+um)*($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 impli
+cit localization of foreach-loop
        last if (index ($pos, $i) != -1); 
    }

    foreach my $ch ("A"..$MAXCHAR)                    # determine orie
+ntation 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 p
+osition
          "*BBB.CC*\n".
          "*..DEEF*\n".
          "*AAD..F.\n".
          "*H.MMLG*\n".
          "*HJJKLG*\n".
          "*IIIK.G*\n".
          "********\n";
}
[download]