Anonymous user
A* search algorithm: Difference between revisions
→{{header|Phix}}
Alextretyak (talk | contribs) (Added 11l) |
|||
Line 3,025:
(1 1 1 1 1 1 1 1 1 1)
</pre>
=={{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
=={{header|Phix}}==
| |||