It turns out that we stumbled upon the rules. I have not inscribed the rules on stone because of 2 reasons: firstly, the original rules were not solid either and, secondly, because I respected some monks' already wrote code adhering to some rules. Well the more the merrier. Science is an anarchic enterprise R.Feynmann allegedly said.

This is also why I postponed publishing my solution. Because it uses yet another rule which is not in the original, "no back-movement", which basically de-faces the problem to a new one. I explain below why this rule. So, for what is worth, here is my take primarily aiming to show yet another way of solving these kind of problems.

My approach is stochastic and as such it does not guarantee the one, best solution but some solution which may be acceptable. It is based on genetic algorithms and uses J.J.Merelo-Guervos' Algorithm::Evolutionary. I have used this package before for solving much different problems, e.g. Re: optimization problem and Re^3: Curious about Perl's strengths in 2018 for solving a weights-combination and a set of linear equations problems. It is a very powerful optimisation method and a very good package.

The rules are as originally stated where "silding" does count the number of squares. However, the most important rule is that no back-movement is allowed. The only reason for this is: laziness as I could not be bothered to add the extra complexity of encoding a variable-length route (i.e. variable number of columns not squares) into a genetic algorithm with fixed-length "chromosomes". There are of course ways to do that if I pressed my mind hard enough but why not postpone it for another day - it looks our days will get longer and longer? So, as it is, a route comprises of pivots, one at each column of the grid. Y[0]->Y[1]->Y[2]->Y[numcols-1] etc. and each segment (i.e. Y[1]->Y[2]) is just a line. Sliding applies for a segment. This sort of setting is encoded very easily on a chromosome made of N+1 bits per column. The 1 bit is the sliding flag. The other N bits encode the Y-coordinate of the pivot. Which means that grid height can only be a power of 2. Here is an example route: 1001-0011-0111 meaning: slide to (0,1), no-slide to (1,3), no-slide to (2,7). The beginning and ending squares which are located at the first and last columns of the grid are not encoded in the route.

The genetic algorithm will then re-combine a population of 500 routes (as the bit-strings described above) to search the set of solution and possibly arrive to a good one. Running it on the same grid several times (with different search-seed) will give an indication of how good final solutions are. That's possible because my mid-range computer single-threadedly takes a maximum of 200 seconds for a 1024x1024 grid.

Edit: I forgot to mention that I am using a cache for calculated segments which yields a good speed-up. For example, for the 16x16 case cache usage is read: 232024, write: 6204

bw, bliako

#!/usr/bin/env perl

####################################################################
# demonstrate the use of genetic algorithms in searching a 2D grid
# heavily based on Algorithm::Evolutionary by J. J. Merelo-Guervos
# author: bliako (bliako//at//cpan.org)
# github: https://github.com/hadjiprocopis/genetic-algorithm-search-2d
+-grid
# date: 13/03/2020
# basic usage: $0 --grid-width 32 --grid-height 32
# default usage: just run it with no params for a 16x16 grid (which pr
+ints OK)
####################################################################

use strict;
use warnings;

use Getopt::Long;

use Algorithm::Evolutionary::Experiment;
use Algorithm::Evolutionary::Op::Easy;
use Algorithm::Evolutionary::Op::Bitflip;
use Algorithm::Evolutionary::Op::Crossover;

##############################
# begin the Grid etc. packages
##############################
{
package Path;
use strict;
use warnings;

use overload
    '""' => 'toString';

sub new {
    my ($class, $grid) = @_;
    my $W = $grid->{'w'};
    my $self = {
        'w' => $W,
        'start' => $grid->{'start'},
        'end' => $grid->{'end'},
        # the first and last part of the path are on the same col as t
+he start/end square of the spec
        # that's ok, it gives extra flexibility.
        'Y' => [ (0)x$W ],
        # however, we need 1 extra slide-bit from the move from last p
+ath square to the end-square of the spec
        # the slide-bit, i.e. if 1 then do not collect score from pass
+ing squares
        'slide' => [ (0)x($W+1) ],
        'score' => undef,
        'distance' => undef,
    };
    bless $self => $class;
    print "Path::new() : called for width ".$self->{'w'}.".\n";
    return $self;
}
sub Y {
    my ($self, $x, $value) = @_;
    $self->{'Y'}->[$x] = $value if defined $value;
    return $self->{'Y'}->[$x];
}
sub slide {
    my ($self, $x, $value) = @_;
    $self->{'slide'}->[$x] = $value if defined $value;
    return $self->{'slide'}->[$x];
}
sub toString {
    my $self = $_[0];
    my $W = $self->{'w'};

    my ($y);
    my $y0 = $self->{'start'}->[1];
    my $x0 = 0;
    my $ret = "[";
    for(my $x=0;$x<$W;$x++){
        $y = $self->{'Y'}->[$x];
        $ret .= 
             ($self->{'slide'}->[$x]==1?'S':'N')
            .":($x0,$y0)->($x,$y)"
            .','
        ;
        $x0 = $x; $y0 = $y;
    }
    return $ret
        . ($self->{'slide'}->[$W]==1?'S':'N')
        . ":($x0,$y0)->(".($W-1).",".$self->{'end'}->[1].")"
        .']'
}
} # end package Path
{
package Cell;
use strict;
use warnings;

use overload
    '""' => 'toString';

our $VISITED_MARKS = {0=>' ', 1=>'+', 2=>'*'};

sub new {
    my ($class, $x, $y, $score) = @_;
    my $self = {
        'x' => $x,
        'y' => $y,
        'score' => $score,
        # zero means we have not visited, 1 means we visited but slidi
+ng (did not collect score)
        # 2 means visited and collected score (no slide)
        'visited' => 0,
    };
    bless $self => $class;
    #print "Cell::new() : called: for ($x, $y).\n";
    return $self;
}
sub visit { $_[0]->{'visited'} = $_[1] }
sub visited { return $_[0]->{'visited'} }
sub visited_mark { return $Cell::VISITED_MARKS->{$_[0]->visited()} }
sub score {
    my $self = $_[0];
    my $m = $_[1];
    if( defined $m ){ $self->{'score'} = $m; }
    return $_[0]->{'score'}
}
sub toString {
    my $self = $_[0];
    # a visited of 0 means we did not visit and no mark is there (mark
+ is ' ')
    # visited of 1 means we visited and collected score, mark is '+'
    # visited of 2 means we visited but sliding (no score collected), 
+mark is '*'
    return
        $self->{'x'}.",".$self->{'y'}
        . '='
        . $self->{'score'}
        . $self->visited_mark()
}
} # end package Cell

{
package Grid;
use strict;
use warnings;

use overload
    '""' => 'toString';

sub new {
    my ($class, $w, $h, $start, $end, $maxscore) = @_;
    my $self = {
        'w' => $w,
        'h' => $h,
        'start' => $start,
        'end' => $end,
        'cells' => undef,
        'path' => undef,
        'cache' => {},
        'cache-usage' => {'read' => 0, 'write' => 0},
        'maxscore' => $maxscore // 10
    };
    bless $self => $class;
    print "Grid::new() : called for dims: ($w x $h), start: @{$start},
+ end: @{$end}.\n";
    $self->populate_randomly($self->{'maxscore'});
    return $self;
}
sub populate_randomly {
    # put random scores to each cell for testing purposes
    my ($self, $maxscore) = @_;
    my $x = 0;
    $self->{'cells'} = [];
    $self->{'cache'} = {};
    for(my $i=0;$i<$self->{'w'};$i++){
        my @acol = ();
        for(my $j=0;$j<$self->{'h'};$j++){
            $acol[$j] = Cell->new($i, $j, $maxscore - int(rand(2*$maxs
+core+1)));
        }
        $self->{'cells'}->[$i] = \@acol;
    }
}
sub populate_test_path_randomly {
    # create a chain of cells (a path) with high scores which we will 
+use to test our algorithm
    my $self = $_[0];
    my $pathscore = $_[1] // $self->{'maxscore'}*2;

    my $C = $self->{'cells'};
    my $w = $self->{'w'};
    my $h = $self->{'h'};
    for(my $i=0;$i<$w;$i++){
        $C->[$i]->[int(rand($h))]->score($pathscore);
    }
}
sub calculate_path {
    my ($self, $path, $setpath) = @_;
    #$self->unpath();
    my $C = $self->{'cells'};

    #print "Grid::calculate_path() : called.\n";
    my ($acell, $y, $j, $slide, $A, $B, $ascore, $adistance, $X);

    # create these shortcuts so we don't seek them inside the loop
    my $PW = $path->{'w'};
    my $PY = $path->{'Y'};
    my $PS = $path->{'slide'};
    my $cache = $self->{'cache'};

    # start from the starting square, do not collect score because thi
+s will happen inside the loop
    my $y0 = $self->{'start'}->[1];
    my $score = 0;
    my $distance = 0;
    for(my $x=0;$x<=$PW;$x++){
        $slide = $PS->[$x];
        if( $x==$PW ){
            $y = $self->{'end'}->[1];
            if( $y == $y0 ){ last; }
            $X = $x-1;
        } else { $y = $PY->[$x]; $X = $x; }

        my $segment = join(':', $X, $y0, $y, $slide);
        #print "entering ($x,$y0)->($x->$y) slide=$slide\n";
        if( $setpath==0 && exists $cache->{$segment} ){
            ($ascore, $adistance, $y0) = @{$cache->{$segment}};
            #print "Grid::calculate_path() : using cache for '$segment
+' : $ascore, $adistance, $y0\n";
            $self->{'cache-usage'}->{'read'}++;
            $score += $ascore;
            $distance += $adistance;
        } else {
            _calcpath($X, $y, $y0, $slide, $C, $setpath, \$ascore, \$a
+distance);
            $y0 = $y;
            $cache->{$segment} = [$ascore, $adistance, $y0];
            #print "Grid::calculate_path() : set cache for '$segment' 
+: $ascore, $adistance, $y0\n";
            $self->{'cache-usage'}->{'write'}++;
            $score += $ascore;
            $distance += $adistance;
        }
        #print "ascore=$ascore, total=$score\n";
        #print $self;
    }
    # score of end square is already collected

    $path->{'score'} = $score;
    $path->{'distance'} = $distance;
    return [$distance, $score];
}
sub _calcpath {
    my ($X, $y, $y0, $slide, $C, $setpath, $ascoreref, $adistanceref) 
+= @_;
    my ($A, $B);
    my $DEBUG=0;
    if( $y0 < $y ){ $A = $y0; $B = $y; } else { $A = $y; $B = $y0; }

    # collect the score of the starting square even if we slide but on
+ly the START square
    my $acell = $C->[$X]->[$A];
    $acell->visit(1) if $setpath==1;
    my $ascore = $acell->{'score'};
    print "collecting1 ($X,$A) = ".$acell->{'score'}."\n" if $DEBUG;

    for(my $j=$A+1;$j<$B;$j++){
        $acell = $C->[$X]->[$j];
        if( $slide == 0 ){
            $ascore += $acell->{'score'};
            print "collecting2 ($X,$j) = ".$acell->{'score'}."\n" if $
+DEBUG;
        }# else { print "visiting2 ($X,$j) = ".$acell->{'score'}."\n";
+ }
        # visited of 1 means we visited and collected score, mark is '
++'
        # visited of 2 means we visited but sliding (no score collecte
+d), mark is '*'
        $acell->visit($slide+1) if $setpath==1; # 1 means not collecte
+d score, 2 means score collected
    }
    # collect the score of the end square even if we slide but only th
+e END square
    if( $y0 != $y ){
        $acell = $C->[$X]->[$B];
        print "collecting3 ($X,$B) = ".$acell->{'score'}."\n" if $DEBU
+G;
        $ascore += $acell->{'score'};
        $acell->visit(1) if $setpath==1;
    }
    $$ascoreref = $ascore;
    $$adistanceref = $B-$A+1;
}

sub unpath {
    my $self = $_[0];
    my $C = $self->{'cells'};
    my $w = $self->{'w'};
    my $h = $self->{'h'};
    my ($i, $j);
    for($i=0;$i<$w;$i++){
        for($j=0;$j<$h;$j++){
            $C->[$i]->[$j]->visit(0);
        }
    }
}
sub toString {
    my $self = $_[0];
    my $ret = "";

    my $C = $self->{'cells'};
    my $w = $self->{'w'};
    my $h = $self->{'h'};

    my ($i, $j, $acell);
    $ret .= sprintf("%4s|", ""); for($i=0;$i<$w;$i++){ $ret .= sprintf
+("%4s|", "$i"); } $ret .= "\n";
    for($i=0;$i<($w+1);$i++){ for($j=0;$j<5;$j++){ $ret .= "-" } } $re
+t .= "\n";
    for($j=0;$j<$h;$j++){
        $ret .= sprintf("%4s|", $j);
        for($i=0;$i<$w;$i++){
            $acell = $C->[$i]->[$j];
            $ret .= sprintf("%s%3s|", $acell->visited_mark(), "".$C->[
+$i]->[$j]->score())
        }
        $ret .= "\n";
    }
    $ret .= "cache usage: read: ".$self->{'cache-usage'}->{'read'}.", 
+write: ".$self->{'cache-usage'}->{'write'}."\n";
    return $ret
}
} # end package Grid
#############################
# end the Grid etc. packages
#############################

########################
# begin the main program
########################

# grid size
my $W = 16;
my $H = 16; # <<< Height must be multiple of 2
my $seed_create = 123; # seed to create a test path, fix it so that al
+l the same
my $seed_search = time; # seed for searching with GA, can fix it with 
+options or leave it dangling
my $Y0 = -1;
my $YN = -1;
# search for those maximum iterations or when fitness changes less by 
+the amount specified
my $MAXITERS=100;
my $BREAK_WHEN_FITNESS_DOES_NOT_CHANGE = 10E-03;
my $STOPEARLY = 1;
if( ! Getopt::Long::GetOptions(
    "grid-width|w=i" => \$W,
    "grid-height|h=i" => \$H,
    "seed-create=i" => \$seed_create,
    "seed-search=i" => \$seed_search,
    "start-at-y=i" => \$Y0,
    "end-at-y=i" => \$YN,
    "max-iters=i" => \$MAXITERS,
    "stop-early!" => \$STOPEARLY,
    "help|h" => sub {
        print "Usage : $0 [--grid-width W] [--grid-height H] [--seed-c
+reate S] [--seed-search S] [--start-at-y Y] [--end-at-y Y] [--max-ite
+rs M] [--(no-)stop-early]\n";
        exit(0);
    },
) ){ die "error in command line arguments.\n"; }

my $bits_per_height_gene = int(log($H)/log(2));
die "Grid height must be a power of 2 but it was $H != 2^${bits_per_he
+ight_gene}" unless 2**(int(log($H)/log(2))) == $H;

# Y coord of the starting and ending squares
$Y0 = int($H/2) unless $Y0 >= 0; 
$YN = int($H/4) unless $YN >= 0;

if( ! $STOPEARLY ){ $BREAK_WHEN_FITNESS_DOES_NOT_CHANGE = -1 }

# score in each square ranges between +- MAXSCORE
my $MAXSCORE=10;

print "$0 : creating the grid and a test-path (seed $seed_create) ...\
+n";

srand($seed_create);
# nothing to change below
my $tstarted = time;
my $G = Grid->new($W, $H, [0,$Y0], [$W-1, $YN], $MAXSCORE);
$G->populate_test_path_randomly($MAXSCORE*2+1);
my $myPath = Path->new($G);

print "$0 : searching (seed $seed_search) ...\n";
srand($seed_search);

###### make genetic
# our chromosome consists of bits
# the first bit is whether we slide from start square (which is fixed 
+and not part of the chromosome)
# to the next square, call it B
# the second bit is whether we slide from B to next square, C
# the next N bits represent the y-coordinate of the B square
# the max y-coordinate is $H, so N = log_2($H)
# this continues up to the last square of the path
# then we have one extra bit representing the slide from last square o
+f path to our
# ending square (which is not part of the path)
# So the path consists of $W-1 y-coordinates plus their slide-bit (of 
+each)
# plus 2 extra slide-bits
my $chromosomeSizeInBits = $W*(1 + $bits_per_height_gene) + 1;

print "$0 : number of bits in the chromosome: $chromosomeSizeInBits\n"
+;

sub calculate_path_fitness {
    my $individual = $_[0];
    my $chromosome = $individual->Chrom();
    chromosome2genes($chromosome, $myPath); # fills $directions and $Y
    my ($distance, $score) = @{ $G->calculate_path($myPath, 0) };
    return $score / $distance;
}
sub set_path_to_grid {
    my $individual = $_[0];
    my $chromosome = $individual->Chrom();
    chromosome2genes($chromosome, $myPath); # fills $directions and $Y
    my ($distance, $score) = @{ $G->calculate_path($myPath, 1) };
    return $score / $distance;
}

sub chromosome2genes {
    # convert a chromosome which consists of genes which consist of bi
+ts(alleles)
    # into a set of numbers to be applied to our problem.
    # that is: 1bit for slide, and as many bits required for the y-coo
+rdinate of the target square
    # plus 1bit for the ending slide

    # chromosome bit string containing all genes as 10101    
    my ($achromosome, $apath) = @_;
    #print "chromosome2genes() : $achromosome\n";
    my $x = 0;
    while( $achromosome =~ /([01])([01]{$bits_per_height_gene})/g ){
        # it means we move to Y with this slide-bit
        $apath->{'slide'}->[$x] = $1;
        $apath->{'Y'}->[$x] = bin2dec($2);
        $x++;
    }
    # now we have one extra slide-bit left at the end for moving to th
+e target square given by the spec
    $achromosome =~ /([01])$/;
    $apath->{'slide'}->[$x] = $1;
}
sub bin2dec {
    # MSB is the last one, e.g. 011 = 6
    my $in = $_[0];
    my $g = 0;
    my $j = 1;
    map { $g += $_*$j; $j*=2; } split(//, $in);
    return $g;
}

my $m = Algorithm::Evolutionary::Op::Bitflip->new(3); # flip this numb
+er of bits randomly
my $c = Algorithm::Evolutionary::Op::Crossover->new(2, 4); # crossover
+ with 2 points
my $ez = new Algorithm::Evolutionary::Op::Easy \&calculate_path_fitnes
+s, 0.8, [$m,$c];
#my $ez = new Algorithm::Evolutionary::Op::CanonicalGA \&fitness, 0.8,
+ [$m,$c];
my $popSize = 500; # population size, each individual in this pop has 
+a chromosome which consists of 2 genes
my $chromosomeType = 'BitString'; # the chromosome is a sequence of bi
+ts as a string
my $e = new Algorithm::Evolutionary::Experiment $popSize, $chromosomeT
+ype, $chromosomeSizeInBits, $ez;

my $populationRef;
my $previous_fitness = 0;
my $current_fitness = 0;
my ($best_solution, $best_fitness);
my $iter = 0;
my $stale=0;
while( (++$iter<$MAXITERS) && ($stale<10) ){
    # create a new generation of solutions, this is one iteration in t
+he genetic algorithm:
    $populationRef = $e->go();
    # the first in the population of solutions is the best for this ge
+neration:
    $best_solution = $populationRef->[0];
    $best_fitness = $best_solution->Fitness();
    print "$iter / $MAXITERS) : fitness: ($previous_fitness -> $curren
+t_fitness ->) $best_fitness\n";
    if( ($BREAK_WHEN_FITNESS_DOES_NOT_CHANGE>0) && (($current_fitness 
+- $previous_fitness) < $BREAK_WHEN_FITNESS_DOES_NOT_CHANGE) ){ $stale
+++ } else { $stale = 0; }
    $previous_fitness = $current_fitness;
    $current_fitness = $best_fitness;
}
set_path_to_grid($best_solution);
print "Best solution at iteration $iter:\n$G\n";
print "$myPath\n";
print "score=".$myPath->{'score'}.", distance=".$myPath->{'distance'}.
+", fitness=$current_fitness, iteration=$iter/$MAXITERS\n";
print "time taken: ".(time-$tstarted)." seconds.\n";
print "$0 : done.\n";

[download]

In reply to Re: Code challenge: Route planning on a 2D grid by bliako
in thread Code challenge: Route planning on a 2D grid by bliako

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • 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! —
  • 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:
    & &amp;
    < &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.