AI-Pathfinding-AStar-Rectangle
view release on metacpan or search on metacpan
Benchmark/perl-vs-xs.pl view on Meta::CPAN
my $t0 = [gettimeofday];
my $path;
my $r = timethese( -1, {Perl=>sub { astar( $x_start, $y_start, $x_end, $y_end ) },
XS=>sub {$m->astar($x_start, $y_start, $x_end, $y_end);}});
cmpthese($r);
die;
for (0..99) {
$path = &astar( $x_start, $y_start, $x_end, $y_end );
}
print "Elapsed: ".tv_interval ( $t0 )."\n";
print "Path length: ".length($path)."\n";
# start end points
$map[ $x_start ][ $y_start ] = 3;
$map[ $x_end ][ $y_end ] = 4;
# draw path
my %vect = (
# x y
1 => [-1, 1, '|/'],
2 => [ 0, 1, '.|'],
3 => [ 1, 1, '|\\'],
4 => [-1, 0, '|<'],
Benchmark/perl-vs-xs.pl view on Meta::CPAN
my ( $x, $y ) = ( $x_start, $y_start );
for ( split //, $path )
{
$map[$x][$y] = '|o';
$x += $vect{$_}->[0];
$y += $vect{$_}->[1];
$map[$x][$y] = '|o';
}
printf "%02d", $_ for 0 .. WIDTH_X - 1;
print "\n";
for my $y ( 0 .. WIDTH_Y - 1 )
{
for my $x ( 0 .. WIDTH_X - 1 )
{
print $map[$x][$y] eq
'1' ? "|_" : (
$map[$x][$y] eq '0' ? "|#" : (
$map[$x][$y] eq '3' ? "|S" : (
$map[$x][$y] eq '4' ? "|E" : $map[$x][$y] ) ) );
}
print "$y\n";
}
sub astar
{
my ( $xs, $ys, $xe, $ye ) = @_;
my %close;
my ( %open, @g, @h, @r, @open_idx );
for my $x (0 .. WIDTH_X - 1 )
{
Benchmark/perl-vs-xs.pl view on Meta::CPAN
( abs( $xn - $xe ) + abs( $yn - $ye ) ) * 7;
$r[$xn][$yn] = [$x,$y];
push @open_idx, [$xn, $yn, \$g[$xn][$yn], \$h[$xn][$yn]];
}
# deb($x, $y, $xn, $yn, \@g);
}
@open_idx = sort { ${$a->[2]} + ${$a->[3]} <=> ${$b->[2]} + ${$b->[3]} } @open_idx;
( $x, $y ) = @{ shift @open_idx };
$it++;
}
# print "Iterations: $it: $oindx\n";
my $path = "";
my %idx2path =
(
"0.-1" => 8, #|.
"1.-1" => 9, #/.
"1.0" => 6, #.-
"1.1" => 3, #`\
"0.1" => 2, #`|
"-1.1" => 1, #
"-1.0" => 4,
"-1.-1" => 7
);
while ( $x != $xs || $y != $ys )
{
# print "$x:$y\n";
my ($xp, $yp) = @{$r[$x][$y]};
$path = $idx2path{($x-$xp).".".($y-$yp)}.$path;
( $x, $y ) = ( $xp, $yp);
}
# print "Path: $path\n";
return $path;
}
sub calc_obstacle
{
my ( $x1, $y1, $x2, $y2 ) = @_;
my ( $x, $y, $Xend, $obstacle, $pixel);
my $dx = abs($x2 - $x1);
my $dy = abs($y2 - $y1);
my $d = ( $dy << 1 ) - $dx;
Benchmark/perl-vs-xs.pl view on Meta::CPAN
sub deb
{
my ( $x, $y, $xn, $yn, $g) = @_;
for my $j ( 0 .. WIDTH_Y - 1 )
{
for my $i ( 0 .. WIDTH_X - 1 )
{
if ( !$map[$i][$j] )
{
print " ##"
}
else
{
if ( $x == $i && $y == $j)
{
print "c";
}
elsif ( $xn == $i && $yn == $j )
{
print "n";
}
else
{
print " ";
}
printf "%02d", $g->[$i]->[$j]
}
}
print "\n";
}
<>;
}
Rectangle.xs view on Meta::CPAN
offset+= moves[ *position - '0'];
if (! newmap->map[offset] ){
XPUSHs(&PL_sv_no);
goto last_op;
}
weigth+= path_weigths[ *position - '0' ];
++position;
}
// fprintf( stderr, "ok");
gimme = GIMME_V;
if (gimme == G_ARRAY){
int x,y;
int norm;
norm = offset ;
x = norm % ( newmap->width + 2) + newmap->start_x - 1;
y = norm / ( newmap->width + 2) + newmap->start_y - 1;
mXPUSHi(x);
mXPUSHi(y);
lib/AI/Pathfinding/AStar/Rectangle.pm view on Meta::CPAN
2 => [ 0, 1, '.|'],
3 => [ 1, 1, '|\\'],
4 => [-1, 0, '|<'],
6 => [ 1, 0, '|>'],
7 => [-1,-1, '|\\'],
8 => [ 0,-1, '\'|'],
9 => [ 1,-1, '|/']
);
my @path = split //, $path;
print "Steps: ".scalar(@path)."\n";
for ( @path )
{
$map[$x][$y] = '|o';
$x += $vect{$_}->[0];
$y -= $vect{$_}->[1];
$map[$x][$y] = '|o';
}
printf "%02d", $_ for 0 .. $map->last_x;
print "\n";
for my $y ( 0 .. $map->last_y - 1 )
{
for my $x ( 0 .. $map->last_x - 1 )
{
print $map[$x][$y] eq
'1' ? "|_" : (
$map[$x][$y] eq '0' ? "|#" : (
$map[$x][$y] eq '3' ? "|S" : (
$map[$x][$y] eq '4' ? "|E" : $map[$x][$y] ) ) );
}
print "$y\n";
}
}
1;
__END__
=head1 NAME
AI::Pathfinding::AStar::Rectangle - AStar algorithm on rectangle map
lib/AI/Pathfinding/AStar/Rectangle.pm view on Meta::CPAN
# $map = AI::Pathfinding::AStar::Rectangle->new({{height=>10, width=>10});
for my $x ($map->start_x..$map->last_x){
for my $y ($map->start_y..$map->last_y){
$map->set_passability($x, $y, $A[$x][$y]) # 1 - Can pass througth , 0 - Can't pass
}
}
my $path = $map->astar( $from_x, $from_y, $to_x, $to_y);
print $path, "\n"; # print path in presentation of "12346789" like keys at keyboard
=head1 DESCRIPTION
AI::Pathfinding::AStar::Rectangle provide abstraction for Rectangle map with AStar algoritm
=head1 OBJECT METHODS
=over 4
lib/AI/Pathfinding/AStar/Rectangle.pm view on Meta::CPAN
In list context return ( end_x, end_y, weigth, true or false )
=item path_goto( start_x, start_y, path)
In list context return
( end_x, end_y, weigth )
weight is sum of <diagonal (1379)> * 14 + <short path> * 10
=item draw_path( start_x, start_y, path)
print path to STDOUT
#!/usr/bin/perl
#
my $m = AI::Pathfinding::AStar::Rectangle->new({ width => 16, height => 8 });
$m->foreach_xy_set( sub { $a < 12 && 1<$b && $b <9 } );
$m->draw_path( 5, 5, '1666666888' );
Result:
# Steps: 10
=head2 --copy=I<suffix>
If this option is given, a copy of each file will be saved with
the given suffix that contains the suggested changes. This does
not require any external programs. Note that this does not
automagially add a dot between the original filename and the
suffix. If you want the dot, you have to include it in the option
argument.
If neither C<--patch> or C<--copy> are given, the default is to
simply print the diffs for each file. This requires either
C<Text::Diff> or a C<diff> program to be installed.
=head2 --diff=I<program>
Manually set the diff program and options to use. The default
is to use C<Text::Diff>, when installed, and output unified
context diffs.
=head2 --compat-version=I<version>
=head2 --cplusplus
Usually, F<ppport.h> will detect C++ style comments and
replace them with C style comments for portability reasons.
Using this option instructs F<ppport.h> to leave C++
comments untouched.
=head2 --quiet
Be quiet. Don't print anything except fatal errors.
=head2 --nodiag
Don't output any diagnostic messages. Only portability
alerts will be printed.
=head2 --nohints
Don't output any hints. Hints often contain useful portability
notes. Warnings will still be displayed.
=head2 --nochanges
Don't suggest any changes. Only give diagnostic output and hints
unless these are also deactivated.
-----------------------------------------------------------------------------------------
PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL
PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL
eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
grok_number() NEED_grok_number NEED_grok_number_GLOBAL
grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
load_module() NEED_load_module NEED_load_module_GLOBAL
my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL
my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL
my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL
my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL
newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL
newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL
newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL
pv_display() NEED_pv_display NEED_pv_display_GLOBAL
pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL
pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL
list-provided list-unsupported api-info=s
)) or usage();
};
if ($@ and grep /^-/, @ARGV) {
usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
die "Getopt::Long not found. Please don't use any options.\n";
}
if ($opt{version}) {
print "This is $0 $VERSION.\n";
exit 0;
}
usage() if $opt{help};
strip() if $opt{strip};
if (exists $opt{'compat-version'}) {
my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
if ($@) {
die "Invalid version number format: '$opt{'compat-version'}'\n";
}
die "Only Perl 5 is supported\n" if $r != 5;
die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
$opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
}
else {
$opt{'compat-version'} = 5;
}
my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
? ( $1 => {
($2 ? ( base => $2 ) : ()),
($3 ? ( todo => $3 ) : ()),
(index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
do_msgrcv|||
do_msgsnd|||
do_oddball|||
do_op_dump||5.006000|
do_op_xmldump|||
do_open9||5.006000|
do_openn||5.007001|
do_open||5.004000|
do_pmop_dump||5.006000|
do_pmop_xmldump|||
do_print|||
do_readline|||
do_seek|||
do_semop|||
do_shmio|||
do_smartmatch|||
do_spawn_nowait|||
do_spawn|||
do_sprintf|||
do_sv_dump||5.006000|
do_sysseek|||
do_tell|||
do_trans_complex_utf8|||
do_trans_complex|||
do_trans_count_utf8|||
do_trans_count|||
do_trans_simple_utf8|||
do_trans_simple|||
do_trans|||
forbid_setid|||
force_ident|||
force_list|||
force_next|||
force_version|||
force_word|||
forget_pmop|||
form_nocontext|||vn
form||5.004000|v
fp_dup|||
fprintf_nocontext|||vn
free_global_struct|||
free_tied_hv_pool|||
free_tmps|||
gen_constant_list|||
get_arena|||
get_aux_mg|||
get_av|5.006000||p
get_context||5.006000|n
get_cvn_flags||5.009005|
get_cv|5.006000||p
is_uni_cntrl_lc||5.006000|
is_uni_cntrl||5.006000|
is_uni_digit_lc||5.006000|
is_uni_digit||5.006000|
is_uni_graph_lc||5.006000|
is_uni_graph||5.006000|
is_uni_idfirst_lc||5.006000|
is_uni_idfirst||5.006000|
is_uni_lower_lc||5.006000|
is_uni_lower||5.006000|
is_uni_print_lc||5.006000|
is_uni_print||5.006000|
is_uni_punct_lc||5.006000|
is_uni_punct||5.006000|
is_uni_space_lc||5.006000|
is_uni_space||5.006000|
is_uni_upper_lc||5.006000|
is_uni_upper||5.006000|
is_uni_xdigit_lc||5.006000|
is_uni_xdigit||5.006000|
is_utf8_alnumc||5.006000|
is_utf8_alnum||5.006000|
is_utf8_char_slow|||n
is_utf8_char||5.006000|
is_utf8_cntrl||5.006000|
is_utf8_common|||
is_utf8_digit||5.006000|
is_utf8_graph||5.006000|
is_utf8_idcont||5.008000|
is_utf8_idfirst||5.006000|
is_utf8_lower||5.006000|
is_utf8_mark||5.006000|
is_utf8_print||5.006000|
is_utf8_punct||5.006000|
is_utf8_space||5.006000|
is_utf8_string_loclen||5.009003|
is_utf8_string_loc||5.008001|
is_utf8_string||5.006001|
is_utf8_upper||5.006000|
is_utf8_xdigit||5.006000|
isa_lookup|||
items|||n
ix|||n
my_letohl|||n
my_letohs|||n
my_lstat|||
my_memcmp||5.004000|n
my_memset|||n
my_ntohl|||
my_pclose||5.004000|
my_popen_list||5.007001|
my_popen||5.004000|
my_setenv|||
my_snprintf|5.009004||pvn
my_socketpair||5.007003|n
my_sprintf|5.009003||pvn
my_stat|||
my_strftime||5.007002|
my_strlcat|5.009004||pn
my_strlcpy|5.009004||pn
my_swabn|||n
my_swap|||
my_unexec|||
my_vsnprintf||5.009004|n
need_utf8|||n
newANONATTRSUB||5.006000|
newANONHASH|||
newANONLIST|||
newANONSUB|||
newASSIGNOP|||
newATTRSUB||5.006000|
newAVREF|||
newAV|||
newBINOP|||
pmop_xmldump|||
pmruntime|||
pmtrans|||
pop_scope|||
pregcomp||5.009005|
pregexec|||
pregfree2||5.011000|
pregfree|||
prepend_elem|||
prepend_madprops|||
printbuf|||
printf_nocontext|||vn
process_special_blocks|||
ptr_table_clear||5.009005|
ptr_table_fetch||5.009005|
ptr_table_find|||n
ptr_table_free||5.009005|
ptr_table_new||5.009005|
ptr_table_split||5.009005|
ptr_table_store||5.009005|
push_scope|||
put_byte|||
yyerror|||
yylex|||
yyparse|||
yywarn|||
);
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{todo};
print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for possible replacement candidates
my(%replace, %need, %hints, %warnings, %depends);
my $replace = 0;
my($hint, $define, $function);
my %s;
$_ = [sort grep !$s{$_}++, @$_];
}
if (exists $opt{'api-info'}) {
my $f;
my $count = 0;
my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $f =~ /$match/;
print "\n=== $f ===\n\n";
my $info = 0;
if ($API{$f}{base} || $API{$f}{todo}) {
my $base = format_version($API{$f}{base} || $API{$f}{todo});
print "Supported at least starting from perl-$base.\n";
$info++;
}
if ($API{$f}{provided}) {
my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
print "Support by $ppport provided back to perl-$todo.\n";
print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
print "\n$hints{$f}" if exists $hints{$f};
print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
$info++;
}
print "No portability information available.\n" unless $info;
$count++;
}
$count or print "Found no API matching '$opt{'api-info'}'.";
print "\n";
exit 0;
}
if (exists $opt{'list-provided'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{provided};
my @flags;
push @flags, 'explicit' if exists $need{$f};
push @flags, 'depend' if exists $depends{$f};
push @flags, 'hint' if exists $hints{$f};
push @flags, 'warning' if exists $warnings{$f};
my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
print "$f$flags\n";
}
exit 0;
}
my @files;
my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
my $srcext = join '|', map { quotemeta $_ } @srcext;
if (@ARGV) {
my %seen;
}
else {
diag("Uses $func");
}
}
$warnings += hint($func);
}
unless ($opt{quiet}) {
for $func (sort keys %{$file{uses_todo}}) {
print "*** WARNING: Uses $func, which may not be portable below perl ",
format_version($API{$func}{todo}), ", even with '$ppport'\n";
$warnings++;
}
}
for $func (sort keys %{$file{needed_static}}) {
my $message = '';
if (not exists $file{uses}{$func}) {
$message = "No need to define NEED_$func if $func is never used";
}
if ($file{changes}) {
if (exists $opt{copy}) {
my $newfile = "$filename$opt{copy}";
if (-e $newfile) {
error("'$newfile' already exists, refusing to write copy of '$filename'");
}
else {
local *F;
if (open F, ">$newfile") {
info("Writing copy of '$filename' with changes to '$newfile'");
print F $c;
close F;
}
else {
error("Cannot open '$newfile' for writing: $!");
}
}
}
elsif (exists $opt{patch} || $opt{changes}) {
if (exists $opt{patch}) {
unless ($patch_opened) {
if (!defined $diff) {
$diff = run_diff('diff', $file, $str);
}
if (!defined $diff) {
error("Cannot generate a diff. Please install Text::Diff or use --copy.");
return;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
my $tmp = 'dppptemp';
my $suf = 'aaa';
my $diff = '';
local *F;
while (-e "$tmp.$suf") { $suf++ }
$tmp = "$tmp.$suf";
if (open F, ">$tmp") {
print F $str;
close F;
if (open F, "$prog $file $tmp |") {
while (<F>) {
s/\Q$tmp\E/$file.patched/;
$diff .= $_;
}
close F;
unlink $tmp;
return $diff;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "invalid version '$ver'\n";
}
$s /= 10;
$ver = sprintf "%d.%03d", $r, $v;
$s > 0 and $ver .= sprintf "_%02d", $s;
return $ver;
}
return sprintf "%d.%d.%d", $r, $v, $s;
}
sub info
{
$opt{quiet} and return;
print @_, "\n";
}
sub diag
{
$opt{quiet} and return;
$opt{diag} and print @_, "\n";
}
sub warning
{
$opt{quiet} and return;
print "*** ", @_, "\n";
}
sub error
{
print "*** ERROR: ", @_, "\n";
}
my %given_hints;
my %given_warnings;
sub hint
{
$opt{quiet} and return;
my $func = shift;
my $rv = 0;
if (exists $warnings{$func} && !$given_warnings{$func}++) {
my $warn = $warnings{$func};
$warn =~ s!^!*** !mg;
print "*** WARNING: $func\n", $warn;
$rv++;
}
if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
my $hint = $hints{$func};
$hint =~ s/^/ /mg;
print " --- hint for $func ---\n", $hint;
}
$rv;
}
sub usage
{
my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
my %M = ( 'I' => '*' );
$usage =~ s/^\s*perl\s+\S+/$^X $0/;
$usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
print <<ENDUSAGE;
Usage: $usage
See perldoc $0 for details.
ENDUSAGE
exit 2;
}
eval { require Devel::PPPort };
\$@ and die "Cannot require Devel::PPPort, please install.\\n";
if (eval \$Devel::PPPort::VERSION < $VERSION) {
die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
. "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
. "Please install a newer version, or --unstrip will not work.\\n";
}
Devel::PPPort::WriteFile(\$0);
exit 0;
}
print <<END;
Sorry, but this is a stripped version of \$0.
To be able to use its original script and doc functionality,
please try to regenerate this file using:
\$^X \$0 --unstrip
END
/ms;
/ (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
| ( "[^"\\]*(?:\\.[^"\\]*)*"
| '[^'\\]*(?:\\.[^'\\]*)*' )
| ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
$c =~ s!\s+$!!mg;
$c =~ s!^$LF!!mg;
$c =~ s!^\s*#\s*!#!mg;
$c =~ s!^\s+!!mg;
open OUT, ">$0" or die "cannot strip $0: $!\n";
print OUT "$pl$c\n";
exit 0;
}
__DATA__
*/
#ifndef _P_P_PORTABILITY_H_
#define _P_P_PORTABILITY_H_
#ifndef isCNTRL
# define isCNTRL(c) iscntrl(c)
#endif
#ifndef isGRAPH
# define isGRAPH(c) isgraph(c)
#endif
#ifndef isPRINT
# define isPRINT(c) isprint(c)
#endif
#ifndef isPUNCT
# define isPUNCT(c) ispunct(c)
#endif
#ifndef isXDIGIT
# define isXDIGIT(c) isxdigit(c)
#endif
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#if !defined(my_snprintf)
#if defined(NEED_my_snprintf)
static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
static
#else
extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
#endif
#define my_snprintf DPPP_(my_my_snprintf)
#define Perl_my_snprintf DPPP_(my_my_snprintf)
#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL)
int
DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...)
{
dTHX;
int retval;
va_list ap;
va_start(ap, format);
#ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
#else
retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
if (retval < 0 || (len > 0 && (Size_t)retval >= len))
Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
return retval;
}
#endif
#endif
#if !defined(my_sprintf)
#if defined(NEED_my_sprintf)
static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
static
#else
extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
#endif
#define my_sprintf DPPP_(my_my_sprintf)
#define Perl_my_sprintf DPPP_(my_my_sprintf)
#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL)
int
DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...)
{
va_list args;
va_start(args, pat);
vsprintf(buffer, pat, args);
va_end(args);
return strlen(buffer);
}
#endif
#endif
#ifdef NO_XSLOCKS
# ifdef dJMPENV
# define dXCPT dJMPENV; int rEtV = 0
for (; pv < end && (!max || wrote < max) ; pv += readsize) {
const UV u =
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
isuni ? utf8_to_uvchr((U8*)pv, &readsize) :
#endif
(U8)*pv;
const U8 c = (U8)u & 0xFF;
if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
chsize = my_snprintf(octbuf, sizeof octbuf,
"%"UVxf, u);
else
chsize = my_snprintf(octbuf, sizeof octbuf,
"%cx{%"UVxf"}", esc, u);
} else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
chsize = 1;
} else {
if (c == dq || c == esc || !isPRINT(c)) {
chsize = 2;
switch (c) {
case '\\' : /* fallthrough */
case '%' : if (c == esc)
octbuf[1] = esc;
case '\v' : octbuf[1] = 'v'; break;
case '\t' : octbuf[1] = 't'; break;
case '\r' : octbuf[1] = 'r'; break;
case '\n' : octbuf[1] = 'n'; break;
case '\f' : octbuf[1] = 'f'; break;
case '"' : if (dq == '"')
octbuf[1] = '"';
else
chsize = 1;
break;
default: chsize = my_snprintf(octbuf, sizeof octbuf,
pv < end && isDIGIT((U8)*(pv+readsize))
? "%c%03o" : "%c%o", esc, c);
}
} else {
chsize = 1;
}
}
if (max && wrote + chsize > max) {
break;
} else if (chsize > 1) {
sv_catpvn(dsv, octbuf, chsize);
wrote += chsize;
} else {
char tmp[2];
my_snprintf(tmp, sizeof tmp, "%c", c);
sv_catpvn(dsv, tmp, 1);
wrote++;
}
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
break;
}
if (escaped != NULL)
*escaped= pv - str;
return SvPVX(dsv);
}
t/00-AI-Pathfinding-AStar-Rectangle.t view on Meta::CPAN
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl AI-Pathfinding-AStar-Rectangle.t'
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More tests => 1;
BEGIN { use_ok('AI::Pathfinding::AStar::Rectangle') };
#########################
# Insert your test code below, the Test::More module is use()ed here so read
# its man page ( perldoc Test::More ) for help writing this test script.
t/01-simple.t view on Meta::CPAN
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl Map-XS.t'
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More tests => 10+9+2+1;
1 for $Test::More::TODO;
our $T = 'AI::Pathfinding::AStar::Rectangle';
BEGIN{
eval "use ExtUtils::testlib;" unless grep { m/::testlib/ } keys %INC;
print "not ok $@" if $@;
$T = 'AI::Pathfinding::AStar::Rectangle';
eval "use $T qw(create_map);";
die "Can't load $T: $@." if $@;
}
use AI::Pathfinding::AStar::Rectangle qw(create_map);
my $a= $T->new({ width => 12, height => 15 });
ok($a);
is(ref ($a), $T);
is(ref create_map({width=>1, height=>1}), $T);
t/02-passability.t view on Meta::CPAN
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl Map-XS.t'
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More 'no_plan';
use strict;
use warnings;
1 for $Test::More::TODO;
my $T;
BEGIN{
eval "use ExtUtils::testlib;" unless grep { m/::testlib/ } keys %INC;
print "not ok $@" if $@;
$T = 'AI::Pathfinding::AStar::Rectangle';
eval "use $T qw(create_map);";
die "Can't load $T: $@." if $@;
}
my $m= $T->new({ width => 12, height => 15 });
my $accum;
$accum = '';
for my $x(-2..14){
t/03-path-valid.t view on Meta::CPAN
BEGIN{
$T = "AI::Pathfinding::AStar::Rectangle";
eval "use ExtUtils::testlib;" unless grep { m/testlib/ } keys %INC;
eval "use $T";
}
my $m = $T->new({ width => 5, height => 5 });
for my $d ("0".."9"){
is_deeply([$m->is_path_valid(0,0,$d)], ['']);
#print Dumper([$m->is_path_valid(0,0,$d)], ['']);
};
$m->set_start_xy(2,5);
for my $x (2..6){
for my $y(5..9){
$m->set_passability($x,$y, 1);
}
}
t/04-astar.t view on Meta::CPAN
$T = "AI::Pathfinding::AStar::Rectangle";
eval "use ExtUtils::testlib;" unless grep { m/testlib/ } keys %INC;
eval "use $T";
}
{
my $m = $T->new( { width => 5, height => 5 } );
for my $d ( "0" .. "9" ) {
# is_deeply([$m->validate_path(0,0,$d)], ['']);
# print Dumper([$m->validate_path(0,0,$d)], ['']);
}
$m->set_start_xy( 2, 5 );
for my $x ( 2 .. 6 ) {
for my $y ( 5 .. 9 ) {
$m->set_passability( $x, $y, 1 );
}
}
is_deeply( [ $m->astar( 2, 5, 2, 5 ) ], [ '', 1 ], "empty path" );
is_deeply( [ $m->astar( 2, 5, 2, 6 ) ], [ '2', 1 ], " path= 8" );
is_deeply( [ $m->astar( 2, 5, 3, 5 ) ], [ '6', 1 ], " path= 6" );
is_deeply( [ $m->astar( 2, 5, 3, 6 ) ], [ '3', 1 ], " path= 9" );
for ( split "", 14789 ) {
my ( $x, $y ) = $m->path_goto( 2, 5, $_ );
is_deeply( [ $m->astar( 2, 5, $x, $y ) ], [""], "no path" );
}
for ( split "", 12346789 ) {
my ( $x, $y ) = $m->path_goto( 3, 6, $_ );
print join " ", 3, 6, $x, $y, $_,"\n";
is_deeply( [ $m->astar( 3, 6, $x, $y ) ], [ $_, 1 ], "curry" );
}
for ( split "", 12346789 ) {
my ( $x, $y , $metric, $res) = $m->is_path_valid( 4, 7, $_ x 2 );
is_deeply(
[ $m->astar( 4, 7, $x, $y ) ],
[ $_ x 2, 1 ],
"curry 2"
);
}
t/07-dastar.t view on Meta::CPAN
is_deeply( [ $m->dastar( 2, 5, 2, 6 ) ], [ '', 1 ], " path= 8" );
is_deeply( [ $m->dastar( 2, 5, 3, 5 ) ], [ '', 1 ], " path= 6" );
is_deeply( [ $m->dastar( 2, 5, 3, 6 ) ], [ '3', 1 ], " path= 9" );
for ( split "", 14789 ) {
my ( $x, $y ) = $m->path_goto( 2, 5, $_ );
is_deeply( [ $m->dastar( 2, 5, $x, $y ) ], [""], "no path" );
}
for ( split "", 12346789 ) {
my ( $x, $y ) = $m->path_goto( 3, 6, $_ );
#print join " ", 3, 6, $x, $y, $_,"\n";
is_deeply( [ $m->dastar( 3, 6, $x, $y ) ], [ $_%2 ? $_ : '', 1 ], "curry" );
}
for ( split "", 1379 ) {
my ( $x, $y , $metric, $res) = $m->is_path_valid( 4, 7, $_ x 2 );
is_deeply(
[ $m->dastar( 4, 7, $x, $y ) ],
[ $_ x 2, 1 ],
"curry 2"
);
}
( run in 0.549 second using v1.01-cache-2.11-cpan-de7293f3b23 )