A* search algorithm: Difference between revisions

=={{header|Perl}}==

<lang perl>#!/usr/bin/perl

use strict; # https://rosettacode.org/wiki/A*_search_algorithm

use warnings;

use List::AllUtils qw( nsort_by );

sub distance

{

my ($r1, $c1, $r2, $c2) = split /[, ]/, "@_";

sqrt( ($r1-$r2)**2 + ($c1-$c2)**2 );

}

my $start = '0,0';

my $finish = '7,7';

my %barrier = map {$_, 100}

split ' ', '2,4 2,5 2,6 3,6 4,6 5,6 5,5 5,4 5,3 5,2 4,2 3,2';

my %values = ( $start, 0 );

my @new = [ $start, 0 ];

my %from;

my $mid;

while( ! exists $values{$finish} and @new )

{

my $pick = (shift @new)->[0];

for my $n ( nsort_by { distance($_, $finish) } # heuristic

grep !/-|8/ && ! exists $values{$_},

glob $pick =~ s/\d+/{@{[$&-1]},$&,@{[$&+1]}}/gr

)

{

$from{$n} = $pick;

$values{$n} = $values{$pick} + ( $barrier{$n} // 1 );

my $new = [ $n, my $dist = $values{$n} ];

my $low = 0; # binary insertion into @new (the priority queue)

my $high = @new;

$new[$mid = $low + $high >> 1][1] <= $dist

? ($low = $mid + 1) : ($high = $mid) while $low < $high;

splice @new, $low, 0, $new; # insert in order

}

}

my $grid = "s.......\n" . ('.' x 8 . "\n") x 7;

substr $grid, /,/ * $` * 9 + $', 1, 'b' for keys %barrier;

my @path = my $pos = $finish; # the walkback to get path

while( $pos ne $start )

{

substr $grid, $pos =~ /,/ ? $` * 9 + $' : die, 1, 'x';

unshift @path, $pos = $from{$pos};

}

print "$grid\nvalue $values{$finish} path @path\n";</lang>

{{out}}

<pre>

s.......

.x......

..x.bbb.

.xb...b.

.xb...b.

.xbbbbb.

..x.....

...xxxxx

value 11 path 0,0 1,1 2,2 3,1 4,1 5,1 6,2 7,3 7,4 7,5 7,6 7,7

</pre>

===Extra Credit===

<lang perl>#!/usr/bin/perl

use strict; # https://rosettacode.org/wiki/A*_search_algorithm

use warnings; # extra credit

use List::AllUtils qw( sum );

my $start = <<END;

087

654

321

END

my $finish = <<END;

123

456

780

END

my @tiles = $finish =~ /[1-9a-z]/g;

my $width = index $start, "\n";

my $gap = qr/.{$width}/s;

my $mod = $width + 1;

my %rc = map {$_, int($_ / $mod) . ',' . ($_ % $mod)} 0 .. length($start) - 2;

my %finishrc = map { $_, [ split /,/, $rc{index $finish, $_} ] } @tiles;

my %found = ( $start, 1 );

my @new = [ $start, heuristic($start) ]; # a priority queue

my %from;

my $mid;

while( ! exists $found{$finish} and @new )

{

my $pick = (shift @new)->[0];

for my $n ( grep ! exists $found{$_},

$pick =~ s/0(\w)/${1}0/r, # up

$pick =~ s/(\w)0/0$1/r, # down

$pick =~ s/0($gap)(\w)/$2${1}0/r, # left

$pick =~ s/(\w)($gap)0/0$2$1/r, # right

)

{

$found{$n} = $from{$n} = $pick;

my $new = [ $n, my $dist = heuristic( $n ) ];

my $low = 0; # binary insertion into @new (the priority queue)

my $high = @new;

$new[$mid = $low + $high >> 1][1] <= $dist

? ($low = $mid + 1) : ($high = $mid) while $low < $high;

splice @new, $low, 0, $new; # insert in order

}

}

#use Data::Dump 'dd'; dd \%found;

my $count = keys %found;

exists $found{$finish} or die "no solution found with $count\n";

my @path = my $pos = $finish; # the walkback to get path

unshift @path, $pos = $from{$pos} while $pos ne $start;

my $steps = @path - 1;

my $states = keys %found;

#print "$_\n" for @path;

my (undef, $w) = split ' ', qx(stty size);

while( @path )

{

my @section = splice @path, 0, int( $w / ($mod + 1) );

while( $section[0] )

{

s/(.*)\n/ print "$1 "; ''/e for @section;

print "\n";

}

print "\n";

}

print "steps: $steps states: $states\n";

sub heuristic

{

my $from = shift;

sum map

{

my ($r1, $c1) = split /,/, $rc{index $from, $_};

my ($r2, $c2) = @{ $finishrc{$_} };

abs($r1 - $r2) + abs($c1 - $c2)

} @tiles;

}</lang>

{{out}}

<pre>

087 807 870 874 874 874 874 874 074 704 740 741 741 741 741 741 041

654 654 654 650 651 651 651 051 851 851 851 850 852 852 852 052 752

321 321 321 321 320 302 032 632 632 632 632 632 630 603 063 863 863

401 410 412 412 412 412 412 012 102 120 123 123

752 752 750 753 753 753 053 453 453 453 450 456

863 863 863 860 806 086 786 786 786 786 786 780

steps: 28 states: 53

</pre>k