AI-Pathfinding-AStar-Rectangle
view release on metacpan or search on metacpan
Benchmark/perl-vs-xs.pl view on Meta::CPAN
for my $y (0 .. WIDTH_Y - 1 )
{
$m->set_passability($x, $y, $map[$x][$y]) ;
}
}
my ( $x_start, $y_start ) = ( WIDTH_X >> 1, WIDTH_Y >> 1 );
my ( $x_end, $y_end ) = ( 0, 0 );
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;
Benchmark/perl-vs-xs.pl view on Meta::CPAN
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 )
{
for my $y (0 .. WIDTH_Y - 1 )
{
$g[$x][$y] = 0;
$r[$x][$y] = 0;
Benchmark/perl-vs-xs.pl view on Meta::CPAN
{
# 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;
my $inc1 = $dy << 1;
my $inc2 = ($dy - $dx) << 1;
if ( $x1 > $x2)
{
Benchmark/perl-vs-xs.pl view on Meta::CPAN
$y++;
$d += $inc2;
};
$obstacle+=!$map[$x][$y];
$pixel += 5;
};
return ( $obstacle << 3 ) + $pixel;
}
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 " ##"
}
examples/snake_labirint.pl view on Meta::CPAN
#~ use constant WIDTH_Y => 10;
use constant WIDTH_X => 64;
use constant WIDTH_Y => 32;
my $m = AI::Pathfinding::AStar::Rectangle->new({ width => WIDTH_X, height => WIDTH_Y });
use strict;
use warnings;
no warnings 'once';
#~ $m->foreach_xy_set( sub { $a < 12 && 1<$b && $b <9 } );
#~ $m->draw_path( 5, 5, '1666666888' );
#~ exit;
my @from = (0,0);
my @to = (WIDTH_X >> 1, WIDTH_Y >> 1);
my @map;
{
# Generate map
for my $x (0 .. WIDTH_X - 1 )
{
examples/snake_labirint.pl view on Meta::CPAN
$map[$_][WIDTH_Y - 5] = 0 for 5 .. WIDTH_X - 10;
$map[$_][10] = 0 for 10 .. WIDTH_X - 10;
$map[WIDTH_X - 10][$_] = 0 for 10 .. WIDTH_Y - 5;
$map[10][$_] = 0 for 10 .. WIDTH_Y - 10;
$map[$_][WIDTH_Y - 10] = 0 for 10 .. WIDTH_X - 15;
$map[WIDTH_X - 15][$_] = 0 for 15 .. WIDTH_Y - 10;
$map[$_][15] = 0 for 15 .. WIDTH_X - 15;
}
# copy map to map object
$m->foreach_xy_set( sub { $map[$a][$b] });
my ($path) = $m->astar(@to, @from);
sub swap(\@\@){
@_[0,1] = @_[1,0];;
}
#swap(@to, @from);
$m->draw_path(@to, $path);
lib/AI/Pathfinding/AStar/Rectangle.pm view on Meta::CPAN
our @EXPORT = qw(
);
our $VERSION = '0.23';
require XSLoader;
XSLoader::load('AI::Pathfinding::AStar::Rectangle', $VERSION);
# Preloaded methods go here.
sub foreach_xy{
my $self = shift;
my $sub = shift;
no strict 'refs';
local *a= *{ caller() . '::a' };
local *b= *{ caller() . '::b' };
local ($a, $b );
local $_;
for $a ( $self->start_x .. $self->last_x ){
for $b ( $self->start_y .. $self->last_y ){
$_ = $self->get_passability( $a, $b );
&$sub();
}
};
}
sub foreach_xy_set{
my $self = shift;
my $sub = shift;
no strict 'refs';
local *a= *{ caller() . '::a' };
local *b= *{ caller() . '::b' };
local ($a, $b );
local $_;
for $a ( $self->start_x .. $self->last_x ){
for $b ( $self->start_y .. $self->last_y ){
$_ = $self->get_passability( $a, $b );
$self->set_passability( $a, $b, (scalar &$sub()) );
};
};
}
sub create_map($){
unshift @_, __PACKAGE__;
goto &new;
}
1 for ($a, $b); #suppress warnings
sub set_passability_string{
my $self = shift;
my $passability = shift;
die "Bad passabilitity param for set_passability_string" unless $self->width * $self->height == length( $passability );
$self->foreach_xy_set( sub { substr $passability, 0, 1, '' } );
}
sub get_passability_string{
my $self = shift;
my $buf = '';
$self->foreach_xy( sub { $buf.= chr( $_)} );
return $buf;
}
sub draw_path{
my $map = shift;
my ($x, $y) = splice @_, 0, 2;
my $path = shift;
my @map;
$map->foreach_xy( sub {$map[$a][$b]= $_} );
# draw path
my %vect = (
# x y
1 => [-1, 1, ],
2 => [ 0, 1, '.|'],
3 => [ 1, 1, '|\\'],
4 => [-1, 0, '|<'],
6 => [ 1, 0, '|>'],
7 => [-1,-1, '|\\'],
lib/AI/Pathfinding/AStar/Rectangle.pm view on Meta::CPAN
Set coordinates of left-bootom point
=item last_x(), last_y()
Get coords for right-upper point
=item foreach_xy( BLOCK )
Call BLOCK for every point on map.
$map->foreach_xy( sub { $A[$a][$b] = $_ })
($a, $b, $_) (x, y, passability)
=item foreach_xy_set( sub { $A[$a][$b] });
set passability for every point at map.
BLOCK must return passability for point ($a, $b);
$a and $b must be global var not declared as my, our,
=item is_path_valid( start_x, start_y, path)
Check if path is valid path, all points from ( start_x, start_y ) to path end is passable
In list context return ( end_x, end_y, weigth, true or false )
lib/AI/Pathfinding/AStar/Rectangle.pm view on Meta::CPAN
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
# 00010203040506070809101112131415
# |#|#|#|#|#|#|#|#|#|#|#|#|#|#|#0
# |#|#|#|#|#|#|#|#|#|#|#|#|#|#|#1
# |_|_|_|_|_|_|_|_|_|_|_|_|#|#|#2
# |_|_|_|_|_|_|_|_|_|_|_|_|#|#|#3
PERL_MAGIC_overload|5.007002||p
PERL_MAGIC_pos|5.007002||p
PERL_MAGIC_qr|5.007002||p
PERL_MAGIC_regdata|5.007002||p
PERL_MAGIC_regdatum|5.007002||p
PERL_MAGIC_regex_global|5.007002||p
PERL_MAGIC_shared_scalar|5.007003||p
PERL_MAGIC_shared|5.007003||p
PERL_MAGIC_sigelem|5.007002||p
PERL_MAGIC_sig|5.007002||p
PERL_MAGIC_substr|5.007002||p
PERL_MAGIC_sv|5.007002||p
PERL_MAGIC_taint|5.007002||p
PERL_MAGIC_tiedelem|5.007002||p
PERL_MAGIC_tiedscalar|5.007002||p
PERL_MAGIC_tied|5.007002||p
PERL_MAGIC_utf8|5.008001||p
PERL_MAGIC_uvar_elem|5.007003||p
PERL_MAGIC_uvar|5.007002||p
PERL_MAGIC_vec|5.007002||p
PERL_MAGIC_vstring|5.008001||p
PERL_UNUSED_DECL|5.007002||p
PERL_UNUSED_VAR|5.007002||p
PERL_UQUAD_MAX|5.004000||p
PERL_UQUAD_MIN|5.004000||p
PERL_USE_GCC_BRACE_GROUPS|5.009004||p
PERL_USHORT_MAX|5.004000||p
PERL_USHORT_MIN|5.004000||p
PERL_VERSION|5.006000||p
PL_DBsignal|5.005000||p
PL_DBsingle|||pn
PL_DBsub|||pn
PL_DBtrace|||pn
PL_Sv|5.005000||p
PL_bufend|5.011000||p
PL_bufptr|5.011000||p
PL_compiling|5.004050||p
PL_copline|5.011000||p
PL_curcop|5.004050||p
PL_curstash|5.004050||p
PL_debstash|5.004050||p
PL_defgv|5.004050||p
ck_require|||
ck_return|||
ck_rfun|||
ck_rvconst|||
ck_sassign|||
ck_select|||
ck_shift|||
ck_sort|||
ck_spair|||
ck_split|||
ck_subr|||
ck_substr|||
ck_svconst|||
ck_trunc|||
ck_unpack|||
ckwarn_d||5.009003|
ckwarn||5.009003|
cl_and|||n
cl_anything|||n
cl_init_zero|||n
cl_init|||n
cl_is_anything|||n
dofindlabel|||
doform|||
doing_taint||5.008001|n
dooneliner|||
doopen_pm|||
doparseform|||
dopoptoeval|||
dopoptogiven|||
dopoptolabel|||
dopoptoloop|||
dopoptosub_at|||
dopoptowhen|||
doref||5.009003|
dounwind|||
dowantarray|||
dump_all||5.006000|
dump_eval||5.006000|
dump_exec_pos|||
dump_fds|||
dump_form||5.006000|
dump_indent||5.006000|v
dump_mstats|||
dump_packsubs||5.006000|
dump_sub||5.006000|
dump_sv_child|||
dump_trie_interim_list|||
dump_trie_interim_table|||
dump_trie|||
dump_vindent||5.006000|
dumpuntil|||
dup_attrlist|||
emulate_cop_io|||
eval_pv|5.006000||p
eval_sv|5.006000||p
expect_number|||
fbm_compile||5.005000|
fbm_instr||5.005000|
feature_is_enabled|||
fetch_cop_label||5.011000|
filter_add|||
filter_del|||
filter_gets|||
filter_read|||
find_and_forget_pmops|||
find_array_subscript|||
find_beginning|||
find_byclass|||
find_hash_subscript|||
find_in_my_stash|||
find_runcv||5.008001|
find_rundefsvoffset||5.009002|
find_script|||
find_uninit_var|||
first_symbol|||n
fold_constants|||
forbid_setid|||
force_ident|||
force_list|||
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
get_db_sub|||
get_debug_opts|||
get_hash_seed|||
get_hv|5.006000||p
get_isa_hash|||
get_mstats|||
get_no_modify|||
get_num|||
get_op_descs||5.005000|
get_op_names||5.005000|
get_opargs|||
isPRINT|5.004000||p
isPSXSPC|5.006001||p
isPUNCT|5.006000||p
isSPACE|||
isUPPER|||
isXDIGIT|5.006000||p
is_an_int|||
is_gv_magical_sv|||
is_handle_constructor|||n
is_list_assignment|||
is_lvalue_sub||5.007001|
is_uni_alnum_lc||5.006000|
is_uni_alnumc_lc||5.006000|
is_uni_alnumc||5.006000|
is_uni_alnum||5.006000|
is_uni_alpha_lc||5.006000|
is_uni_alpha||5.006000|
is_uni_ascii_lc||5.006000|
is_uni_ascii||5.006000|
is_uni_cntrl_lc||5.006000|
is_uni_cntrl||5.006000|
magic_dump||5.006000|
magic_existspack|||
magic_freearylen_p|||
magic_freeovrld|||
magic_getarylen|||
magic_getdefelem|||
magic_getnkeys|||
magic_getpack|||
magic_getpos|||
magic_getsig|||
magic_getsubstr|||
magic_gettaint|||
magic_getuvar|||
magic_getvec|||
magic_get|||
magic_killbackrefs|||
magic_len|||
magic_methcall|||
magic_methpack|||
magic_nextpack|||
magic_regdata_cnt|||
magic_setdefelem|||
magic_setenv|||
magic_sethint|||
magic_setisa|||
magic_setmglob|||
magic_setnkeys|||
magic_setpack|||
magic_setpos|||
magic_setregexp|||
magic_setsig|||
magic_setsubstr|||
magic_settaint|||
magic_setutf8|||
magic_setuvar|||
magic_setvec|||
magic_set|||
magic_sizepack|||
magic_wipepack|||
make_matcher|||
make_trie_failtable|||
make_trie|||
scan_const|||
scan_formline|||
scan_heredoc|||
scan_hex|||
scan_ident|||
scan_inputsymbol|||
scan_num||5.007001|
scan_oct|||
scan_pat|||
scan_str|||
scan_subst|||
scan_trans|||
scan_version||5.009001|
scan_vstring||5.009005|
scan_word|||
scope|||
screaminstr||5.005000|
search_const|||
seed||5.008001|
sequence_num|||
sequence_tail|||
share_hek||5.004000|
si_dup|||
sighandler|||n
simplify_sort|||
skipspace0|||
skipspace1|||
skipspace2|||
skipspace|||
softref2xv|||
sortcv_stacked|||
sortcv_xsub|||
sortcv|||
sortsv_flags||5.009003|
sortsv||5.007003|
space_join_names_mortal|||
ss_dup|||
stack_grow|||
start_force|||
start_glob|||
start_subparse||5.004000|
stashpv_hvname_match||5.011000|
stdize_locale|||
store_cop_label|||
strEQ|||
strGE|||
strGT|||
strLE|||
strLT|||
strNE|||
str_to_version||5.006000|
strip_return|||
strnEQ|||
strnNE|||
study_chunk|||
sub_crush_depth|||
sublex_done|||
sublex_push|||
sublex_start|||
sv_2bool|||
sv_2cv|||
sv_2io|||
sv_2iuv_common|||
sv_2iuv_non_preserve|||
sv_2iv_flags||5.009001|
sv_2iv|||
sv_2mortal|||
sv_2num|||
sv_2nv|||
sys_init||5.010000|n
sys_intern_clear|||
sys_intern_dup|||
sys_intern_init|||
sys_term||5.010000|n
taint_env|||
taint_proper|||
tmps_grow||5.006000|
toLOWER|||
toUPPER|||
to_byte_substr|||
to_uni_fold||5.007003|
to_uni_lower_lc||5.006000|
to_uni_lower||5.007003|
to_uni_title_lc||5.006000|
to_uni_title||5.007003|
to_uni_upper_lc||5.006000|
to_uni_upper||5.007003|
to_utf8_case||5.007003|
to_utf8_fold||5.007003|
to_utf8_lower||5.007003|
to_utf8_substr|||
to_utf8_title||5.007003|
to_utf8_upper||5.007003|
token_free|||
token_getmad|||
tokenize_use|||
tokeq|||
tokereport|||
too_few_arguments|||
too_many_arguments|||
uiv_2buf|||n
warn|||v
watch|||
whichsig|||
write_no_mem|||
write_to_stderr|||
xmldump_all|||
xmldump_attr|||
xmldump_eval|||
xmldump_form|||
xmldump_indent|||v
xmldump_packsubs|||
xmldump_sub|||
xmldump_vindent|||
yyerror|||
yylex|||
yyparse|||
yywarn|||
);
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
}
exit 0;
}
# Scan for possible replacement candidates
my(%replace, %need, %hints, %warnings, %depends);
my $replace = 0;
my($hint, $define, $function);
sub find_api
{
my $code = shift;
$code =~ s{
/ (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
| "[^"\\]*(?:\\.[^"\\]*)*"
| '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
grep { exists $API{$_} } $code =~ /(\w+)/mg;
}
while (<DATA>) {
else {
my @new = grep { -f } glob $_
or warn "'$_' does not exist.\n";
push @files, grep { !$seen{$_}++ } @new;
}
}
}
else {
eval {
require File::Find;
File::Find::find(sub {
$File::Find::name =~ /($srcext)$/i
and push @files, $File::Find::name;
}, '.');
};
if ($@) {
@files = map { glob "*$_" } @srcext;
}
}
if (!@ARGV || $opt{filter}) {
else {
info("Looks good");
}
}
close PATCH if $patch_opened;
exit 0;
sub try_use { eval "use @_;"; return $@ eq '' }
sub mydiff
{
local *F = shift;
my($file, $str) = @_;
my $diff;
if (exists $opt{diff}) {
$diff = run_diff($opt{diff}, $file, $str);
}
if (!defined $diff and try_use('Text::Diff')) {
}
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";
unlink $tmp;
}
else {
error("Cannot open '$tmp' for writing: $!");
}
return undef;
}
sub rec_depend
{
my($func, $seen) = @_;
return () unless exists $depends{$func};
$seen = {%{$seen||{}}};
return () if $seen->{$func}++;
my %s;
grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
}
sub parse_version
{
my $ver = shift;
if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
return ($1, $2, $3);
}
elsif ($ver !~ /^\d+\.[\d_]+$/) {
die "cannot parse version '$ver'\n";
}
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "cannot parse version '$ver'\n";
}
}
return ($r, $v, $s);
}
sub format_version
{
my $ver = shift;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
$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;
}
sub strip
{
my $self = do { local(@ARGV,$/)=($0); <> };
my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
$copy =~ s/^(?=\S+)/ /gms;
$self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
$self =~ s/^SKIP.*(?=^__DATA__)/SKIP
if (\@ARGV && \$ARGV[0] eq '--unstrip') {
eval { require Devel::PPPort };
\$@ and die "Cannot require Devel::PPPort, please install.\\n";
if (eval \$Devel::PPPort::VERSION < $VERSION) {
/* Replace: 1 */
# define PL_ppaddr ppaddr
# define PL_no_modify no_modify
/* Replace: 0 */
#endif
#if (PERL_BCDVERSION <= 0x5004005)
/* Replace: 1 */
# define PL_DBsignal DBsignal
# define PL_DBsingle DBsingle
# define PL_DBsub DBsub
# define PL_DBtrace DBtrace
# define PL_Sv Sv
# define PL_bufend bufend
# define PL_bufptr bufptr
# define PL_compiling compiling
# define PL_copline copline
# define PL_curcop curcop
# define PL_curstash curstash
# define PL_debstash debstash
# define PL_defgv defgv
imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
sv = va_arg(*args, SV*);
}
}
{
const line_t ocopline = PL_copline;
COP * const ocurcop = PL_curcop;
const int oexpect = PL_expect;
#if (PERL_BCDVERSION >= 0x5004000)
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
#else
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
modname, imop);
#endif
PL_expect = oexpect;
PL_copline = ocopline;
PL_curcop = ocurcop;
}
}
#endif
#endif
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = D_PPP_PL_copline;
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash)
PL_curstash = PL_curcop->cop_stash = stash;
newSUB(
#if (PERL_BCDVERSION < 0x5003022)
start_subparse(),
#elif (PERL_BCDVERSION == 0x5003022)
start_subparse(0),
#else /* 5.003_23 onwards */
start_subparse(FALSE, 0),
#endif
newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
);
PL_hints = oldhints;
PL_curcop->cop_stash = old_cop_stash;
PL_curstash = old_curstash;
#endif
#ifndef PERL_MAGIC_vec
# define PERL_MAGIC_vec 'v'
#endif
#ifndef PERL_MAGIC_utf8
# define PERL_MAGIC_utf8 'w'
#endif
#ifndef PERL_MAGIC_substr
# define PERL_MAGIC_substr 'x'
#endif
#ifndef PERL_MAGIC_defelem
# define PERL_MAGIC_defelem 'y'
#endif
#ifndef PERL_MAGIC_glob
# define PERL_MAGIC_glob '*'
#endif
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_8 = UV_MAX / 8;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
for (; len-- && *s; s++) {
/* gcc 2.95 optimiser not smart enough to figure that this subtraction
out front allows slicker code. */
int digit = *s - '0';
if (digit >= 0 && digit <= 7) {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
*/
redo:
if (!overflowed) {
if (value <= max_div_8) {
value = (value << 3) | digit;
t/01-simple.t view on Meta::CPAN
is(ref create_map({width=>1, height=>1}), $T);
is($a->width, 12, 'width');
is($a->height, 15, 'height');
is($a->start_x, 0, 'start_x of new map eq 0');
is($a->start_y, 0, 'start_y of new map eq 0');
is($a->last_x, 11, 'last_x of new map eq 0');
is($a->last_y, 14, 'last_y of new map eq 0');
my $s='';
$a->foreach_xy( sub {$s.=$_} );
is($s, ('0' x (12*15)));
$a->set_start_xy(40, 50 );
is($a->start_x, 40, 'start_x of map eq 40');
is($a->start_y, 50, 'start_y of map eq 50');
is($a->last_x, 40+11, 'last_x of map eq 51');
is($a->last_y, 50+14, 'last_y of map eq 64');
$s='';
$a->foreach_xy( sub {$s.=$_} );
is($s, ('0' x (12*15)));
$a->set_start_xy( -40, -50 );
is($a->start_x, -40, 'start_x of map eq -40');
is($a->start_y, -50, 'start_y of map eq -50');
is($a->last_x, -40+11, 'last_x of map eq -29');
is($a->last_y, -50+14, 'last_y of map eq -36');
$a->start_x(0);
is($a->start_x, 0, "set start x");
$a->start_y(0);
is($a->start_y, 0, "set start y");
# 10 + 8
my $s_1='';
$a->foreach_xy_set( sub { 1;} );
$a->foreach_xy( sub {$s_1.=$_} );
is($s_1, ('1' x (12*15)), "all 111");
#########################
# 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/02-passability.t view on Meta::CPAN
my $accum;
$accum = '';
for my $x(-2..14){
for my $y (-2..17){
$accum.= $m->get_passability($x,$y);
}
}
is($accum, ( '0' x (12*15)), "all 0");
$m->foreach_xy_set( sub { $a + 2 ;});
$accum = '';
$m->foreach_xy( sub {$accum.= 1 if ($a + 2) == $_;});
is($accum, ( '1' x (12*15)), "all 1 ");
$m->foreach_xy_set( sub { $b + 2 ;});
$accum = '';
$m->foreach_xy( sub {$accum.= 1 if ($b + 2) == $_;});
is($accum, ( '1' x (12*15)), "all 1 ");
$m->set_start_xy(-2, 2);
$m->foreach_xy_set( sub { $a + 2 ;});
$accum = '';
$m->foreach_xy( sub {$accum.= 1 if ($a + 2) == $_;});
is($accum, ( '1' x (12*15)), "all 1 ");
$m->foreach_xy_set( sub { $b + 2 ;});
$accum = '';
$m->foreach_xy( sub {$accum.= 1 if ($b + 2) == $_;});
is($accum, ( '1' x (12*15)), "all 1 ");
$m->set_start_xy(0,0);
my $count = 0;
$count = 0;
for my $x (0..11){
for my $y (0..14){
t/05-foreach.t view on Meta::CPAN
eval "use $T";
}
{
my $m = $T->new( { width => 5, height => 5 } );
$a = "TODO_a";
$b = "TODO_b";
$_ = "TODO__";
my $ok = 1;
$m->foreach_xy( sub {$ok &&= defined $a && defined $b && defined $_ && $_ == 0; } );
is( $ok, 1, "foreach on empty");
is( $a, "TODO_a", '$a remain value' );
is( $b, "TODO_b", '$b remain value' );
is( $_, "TODO__", '$_ remain value' );
$ok = 1;
$m->foreach_xy_set( sub { $ok &&= defined $a && defined $b && defined $_ && $_ == 0 ; $a %2 } );
is( $ok, 1 , '$a, $b, $_ defined and right');
is( $a, "TODO_a", '$a remain value' );
is( $b, "TODO_b", '$b remain value' );
is( $_, "TODO__", '$_ remain value' );
$ok = 1;
$m->foreach_xy( sub {$ok &&= defined $a && defined $b && defined $_ && $_ == $a %2 ; } );
is( $ok, 1, "foreach on even \$a");
is( $m->get_passability( 0,0 ), 0, "(0,0)");
is( $m->get_passability( 0,1 ), 0, "(0,1)");
is( $m->get_passability( 1,0 ), 1, "(1,0)");
is( $m->get_passability( 1,1 ), 1, "(1,1)");
my $q = $m->clone();
$ok = 1;
$q->foreach_xy( sub {$ok &&= defined $a && defined $b && defined $_ && $_ == $a %2 ; } );
is( $ok, 1, "foreach on cloned");
ok( $q != $m , "clone is different" );
is( $q->width, $m->width, "clone width");
is( $q->height, $m->height, "clone height");
is( $q->start_x, $m->start_x, "clone start_x");
is( $q->start_y, $m->start_y, "clone start_y");
is( $q->last_x, $m->last_x, "clone last_x");
is( $q->last_y, $m->last_y, "clone last_y");
$q = $m->clone_rect( 1, 1, 2, 3);
$ok = 1;
$q->foreach_xy( sub {$ok &&= defined $a && defined $b && defined $_ && $_ == $a %2 ; } );
is($ok, 1, "foreach on rect clone" );
ok( $q != $m, "rect clone is different" );
is( $q->width, 2, "clone width");
is( $q->height, 3, "clone height");
is( $q->start_x, 1, "clone start_x");
is( $q->start_y, 1, "clone start_y");
is( $q->last_x, 2, "clone last_x");
is( $q->last_y, 3, "clone last_y");
( run in 0.666 second using v1.01-cache-2.11-cpan-88abd93f124 )