Game-DijkstraMap-1.02004075500017500001750000000000001342071557000140355ustar00jmatesjmatesGame-DijkstraMap-1.02/lib004075500017500001750000000000001342071556100146035ustar00jmatesjmatesGame-DijkstraMap-1.02/lib/Game004075500017500001750000000000001342071556100154545ustar00jmatesjmatesGame-DijkstraMap-1.02/lib/Game/DijkstraMap.pm010064400017500001750000000712251342071514500203040ustar00jmatesjmates# -*- Perl -*-
#
# Dijkstra Map path finding. run perldoc(1) on this file for additional
# documentation
package Game::DijkstraMap;
use 5.24.0;
use warnings;
use Carp qw(croak);
use List::Util 1.26 qw(shuffle sum0);
use Moo;
use namespace::clean;
use Scalar::Util qw(looks_like_number);
our $VERSION = '1.02';
use constant SQRT2 => sqrt(2);
has bad_cost => ( is => 'rw', default => sub { -2147483648 } );
has min_cost => ( is => 'rw', default => sub { 0 } );
has max_cost => ( is => 'rw', default => sub { 2147483647 } );
has costfn => (
is => 'rw',
default => sub {
return sub {
my ( $self, $c ) = @_;
if ( $c eq '#' ) { return $self->bad_cost }
if ( $c eq 'x' ) { return $self->min_cost }
return $self->max_cost;
};
}
);
has dimap => ( is => 'rw' );
has iters => ( is => 'rwp', default => sub { 0 } );
has next_m => ( is => 'rw', default => sub { 'next' } );
has normfn => ( is => 'rw', default => sub { \&norm_4way } );
sub BUILD {
my ( $self, $param ) = @_;
croak "cannot have both map and str2map arguments"
if exists $param->{'map'} and exists $param->{'str2map'};
$self->map( $param->{'map'} )
if exists $param->{'map'};
$self->map( $self->str2map( $param->{'str2map'} ) )
if exists $param->{'str2map'};
}
sub adjacent_values {
my ( $dimap, $r, $c, $maxrow, $maxcol ) = @_;
my @values;
for my $i ( -1, 1 ) {
my $x = $c + $i;
push @values, $dimap->[$r][$x] if $x >= 0 and $x <= $maxcol;
for my $j ( -1 .. 1 ) {
$x = $r + $i;
my $y = $c + $j;
push @values, $dimap->[$x][$y]
if $x >= 0
and $x <= $maxrow
and $y >= 0
and $y <= $maxcol;
}
}
return @values;
}
sub adjacent_values_diag {
my ( $dimap, $r, $c, $maxrow, $maxcol ) = @_;
my @values;
push @values, $dimap->[ $r - 1 ][ $c - 1 ] if $r > 0 and $c > 0;
push @values, $dimap->[ $r - 1 ][ $c + 1 ] if $r > 0 and $c < $maxcol;
push @values, $dimap->[ $r + 1 ][ $c - 1 ] if $r < $maxrow and $c > 0;
push @values, $dimap->[ $r + 1 ][ $c + 1 ] if $r < $maxrow and $c < $maxcol;
return @values;
}
sub adjacent_values_sq {
my ( $dimap, $r, $c, $maxrow, $maxcol ) = @_;
my @values;
push @values, $dimap->[$r][ $c - 1 ] if $c > 0;
push @values, $dimap->[$r][ $c + 1 ] if $c < $maxcol;
push @values, $dimap->[ $r - 1 ][$c] if $r > 0;
push @values, $dimap->[ $r + 1 ][$c] if $r < $maxrow;
return @values;
}
sub dimap_with {
my ( $self, $param ) = @_;
my $dimap = $self->dimap;
croak "cannot make new dimap from unset map" if !defined $dimap;
my $new_dimap;
my $badcost = $self->bad_cost;
my $cols = $dimap->[0]->$#*;
for my $r ( 0 .. $dimap->$#* ) {
COL: for my $c ( 0 .. $cols ) {
my $value = $dimap->[$r][$c];
if ( $value == $badcost ) {
$new_dimap->[$r][$c] = $badcost;
next COL;
}
$value *= $param->{my_weight} // 1;
my @here = map $_->values( [ $r, $c ] )->[0], $param->{objs}->@*;
for my $h ( 0 .. $#here ) {
if ( $here[$h] == $badcost ) {
$new_dimap->[$r][$c] = $badcost;
next COL;
}
$value += $here[$h] * ( $param->{weights}->[$h] // 0 );
}
$new_dimap->[$r][$c] = $value;
}
}
return $new_dimap;
}
sub map {
my ( $self, $map ) = @_;
my $dimap = [];
croak "no valid map supplied"
if !defined $map
or ref $map ne 'ARRAY'
or !defined $map->[0]
or ref $map->[0] ne 'ARRAY';
my $cols = $map->[0]->@*;
for my $r ( 0 .. $map->$#* ) {
croak "unexpected column count at row $r" if $map->[$r]->@* != $cols;
for my $c ( 0 .. $cols - 1 ) {
$dimap->[$r][$c] = $self->costfn->( $self, $map->[$r][$c] );
}
}
$self->_set_iters(
$self->normfn->( $dimap, $self->min_cost, $self->max_cost ) );
$self->dimap($dimap);
return $self;
}
sub next {
my ( $self, $r, $c, $value ) = @_;
my $dimap = $self->dimap;
croak "cannot pathfind on unset map" if !defined $dimap;
my $maxrow = $dimap->$#*;
my $maxcol = $dimap->[0]->$#*;
croak "row $r out of bounds" if $r > $maxrow or $r < 0;
croak "col $c out of bounds" if $c > $maxcol or $c < 0;
my @adj;
$value //= $dimap->[$r][$c];
return \@adj if $value <= $self->min_cost;
for my $i ( -1, 1 ) {
my $x = $c + $i;
push @adj, [ [ $r, $x ], $dimap->[$r][$x] ] if $x >= 0 and $x <= $maxcol;
for my $j ( -1 .. 1 ) {
$x = $r + $i;
my $y = $c + $j;
push @adj, [ [ $x, $y ], $dimap->[$x][$y] ]
if $x >= 0
and $x <= $maxrow
and $y >= 0
and $y <= $maxcol;
}
}
my $badcost = $self->bad_cost;
return [ grep { $_->[1] < $value and $_->[1] != $badcost } @adj ];
}
sub next_best {
my ( $self, $r, $c ) = @_;
my $method = $self->next_m;
my @ret =
sort { $a->[1] <=> $b->[1] } shuffle $self->$method( $r, $c )->@*;
return $ret[0]->[0];
}
# next() but only in square directions or "orthogonal" (but diagonals
# are orthogonal to one another) or in the "cardinal directions" (NSEW)
# but that term also seems unsatisfactory. "4-way" is also used for this
# with the assumption of cardinal directions
sub next_sq {
my ( $self, $r, $c, $value ) = @_;
my $dimap = $self->dimap;
croak "cannot pathfind on unset map" if !defined $dimap;
my $maxrow = $dimap->$#*;
my $maxcol = $dimap->[0]->$#*;
croak "row $r out of bounds" if $r > $maxrow or $r < 0;
croak "col $c out of bounds" if $c > $maxcol or $c < 0;
my @adj;
$value //= $dimap->[$r][$c];
return \@adj if $value <= $self->min_cost;
if ( $c > 0 ) {
push @adj, [ [ $r, $c - 1 ], $dimap->[$r][ $c - 1 ] ];
}
if ( $c < $maxcol ) {
push @adj, [ [ $r, $c + 1 ], $dimap->[$r][ $c + 1 ] ];
}
if ( $r > 0 ) {
push @adj, [ [ $r - 1, $c ], $dimap->[ $r - 1 ][$c] ];
}
if ( $r < $maxrow ) {
push @adj, [ [ $r + 1, $c ], $dimap->[ $r + 1 ][$c] ];
}
my $badcost = $self->bad_cost;
return [ grep { $_->[1] < $value and $_->[1] != $badcost } @adj ];
}
sub next_with {
my ( $self, $r, $c, $param ) = @_;
my $dimap = $self->dimap;
croak "cannot pathfind on unset map" if !defined $dimap;
my $badcost = $self->bad_cost;
my $curcost = $dimap->[$r][$c];
return undef if $curcost <= $self->min_cost;
$curcost *= $param->{my_weight} // 1;
my @here = map $_->values( [ $r, $c ] )->[0], $param->{objs}->@*;
for my $h ( 0 .. $#here ) {
# this may cause problems if something is standing on a cell
# they can no longer move into but where it is still legal for
# them to leave that cell
return undef if $here[$h] == $badcost;
$curcost += $here[$h] * ( $param->{weights}->[$h] // 0 );
}
my $method = $self->next_m;
my $coords = $self->$method( $r, $c, $self->max_cost );
return undef unless $coords->@*;
my @costs = map $_->values( map $_->[0], $coords->@* ), $param->{objs}->@*;
my @ret;
COORD: for my $p ( 0 .. $coords->$#* ) {
my @weights;
for my $k ( 0 .. $#costs ) {
next COORD if $costs[$k][$p] == $badcost;
push @weights, $costs[$k][$p] * ( $param->{weights}->[$k] // 0 );
}
my $newcost = sum0 $coords->[$p][1] * ( $param->{my_weight} // 1 ), @weights;
push @ret, [ $coords->[$p][0], $newcost ] if $newcost < $curcost;
}
return undef unless @ret;
@ret = sort { $a->[1] <=> $b->[1] } shuffle @ret;
return $ret[0]->[0];
}
# 4-way "square" normalization as seen in the Brogue article (was called
# normalize_costs and used to be a method). one could possibly also
# normalize only in the diagonal directions...
sub norm_4way {
my ( $dimap, $mincost, $maxcost, $avfn ) = @_;
$avfn //= \&adjacent_values_sq;
my $iters = 0;
my $maxrow = $dimap->$#*;
my $maxcol = $dimap->[0]->$#*;
my $stable;
while (1) {
$stable = 1;
$iters++;
for my $r ( 0 .. $maxrow ) {
for my $c ( 0 .. $maxcol ) {
my $value = $dimap->[$r][$c];
next if $value <= $mincost;
my $best = $maxcost;
for my $nv ( $avfn->( $dimap, $r, $c, $maxrow, $maxcol ) ) {
$best = $nv if $nv < $best and $nv >= $mincost;
last if $best == $mincost;
}
if ( $value >= $best + 2 ) {
$dimap->[$r][$c] = $best + 1;
$stable = 0;
}
}
}
last if $stable;
}
return $iters;
}
# 8-way normalization could either be done with small integers where
# diagonals cost the same as square motion (this is non-Euclidean though
# traditional in roguelikes) ...
sub norm_8way {
push @_, \&adjacent_values;
&norm_4way; # perldoc perlsub explains this calling form
}
# ... or one could instead use floating point values to better
# approximate diagonals costing sqrt(2) but this is more complicated,
# which is perhaps why many roguelikes use 4-way or non-Euclidean 8-way
sub norm_8way_euclid {
my ( $dimap, $mincost, $maxcost ) = @_;
my $iters = 0;
my $maxrow = $dimap->$#*;
my $maxcol = $dimap->[0]->$#*;
my $stable;
while (1) {
$stable = 1;
$iters++;
for my $r ( 0 .. $maxrow ) {
for my $c ( 0 .. $maxcol ) {
my $value = $dimap->[$r][$c];
next if $value <= $mincost;
my $best = [ $maxcost, 0 ];
for my $nr (
map( [ $_, 1 ], adjacent_values_sq( $dimap, $r, $c, $maxrow, $maxcol ) ),
map( [ $_, SQRT2 ], adjacent_values_diag( $dimap, $r, $c, $maxrow, $maxcol ) )
) {
$best = $nr if $nr->[0] < $best->[0] and $nr->[0] >= $mincost;
last if $best->[0] == $mincost;
}
if ( $value > $best->[0] + SQRT2 ) {
$dimap->[$r][$c] = $best->[0] + $best->[1];
$stable = 0;
}
}
}
last if $stable;
}
return $iters;
}
sub path_best {
my ( $self, $r, $c, $method ) = @_;
my @path;
while ( my $next = $self->next_best( $r, $c, $method ) ) {
push @path, $next;
( $r, $c ) = @$next;
}
return \@path;
}
sub recalc {
my ($self) = @_;
my $dimap = $self->dimap;
croak "cannot recalc unset map" if !defined $dimap;
my $maxcost = $self->max_cost;
my $mincost = $self->min_cost;
my $maxcol = $dimap->[0]->$#*;
for my $r ( 0 .. $dimap->$#* ) {
for my $c ( 0 .. $maxcol ) {
$dimap->[$r][$c] = $maxcost if $dimap->[$r][$c] > $mincost;
}
}
$self->_set_iters( $self->normfn->( $dimap, $mincost, $maxcost ) );
$self->dimap($dimap);
return $self;
}
sub str2map {
my ( $self_or_class, $str, $lf ) = @_;
croak "no string given" if !defined $str;
$lf //= $/;
my @map;
for my $line ( split $lf, $str ) {
push @map, [ split //, $line ];
}
return \@map;
}
sub to_tsv {
my ( $self, $ref ) = @_;
if ( !defined $ref ) {
$ref = $self->dimap;
croak "cannot use an unset map" if !defined $ref;
}
my $s = '';
my $cols = $ref->[0]->$#*;
for my $r ( 0 .. $ref->$#* ) {
my $d = "\t";
for my $c ( 0 .. $cols ) {
$s .= $ref->[$r][$c] . $d;
$d = '' if $c == $cols - 1;
}
$s .= $/;
}
return $s;
}
sub unconnected {
my ($self) = @_;
my $dimap = $self->dimap;
croak "nothing unconnected on unset map" if !defined $dimap;
my @points;
my $maxcost = $self->max_cost;
my $maxcol = $dimap->[0]->$#*;
for my $r ( 0 .. $dimap->$#* ) {
for my $c ( 0 .. $maxcol ) {
push @points, [ $r, $c ] if $dimap->[$r][$c] == $maxcost;
}
}
return \@points;
}
sub update {
my $self = shift;
my $dimap = $self->dimap;
croak "cannot update unset map" if !defined $dimap;
my $maxrow = $dimap->$#*;
my $maxcol = $dimap->[0]->$#*;
for my $ref (@_) {
my ( $r, $c ) = ( $ref->[0], $ref->[1] );
croak "row $r out of bounds" if $r > $maxrow or $r < 0;
croak "col $c out of bounds" if $c > $maxcol or $c < 0;
croak "value must be a number" unless looks_like_number $ref->[2];
$dimap->[$r][$c] = int $ref->[2];
}
$self->dimap($dimap);
return $self;
}
sub values {
my $self = shift;
my $dimap = $self->dimap;
croak "cannot get values from unset map" if !defined $dimap;
my @values;
my $maxrow = $dimap->$#*;
my $maxcol = $dimap->[0]->$#*;
for my $point (@_) {
my ( $r, $c ) = ( $point->[0], $point->[1] );
croak "row $r out of bounds" if $r > $maxrow or $r < 0;
croak "col $c out of bounds" if $c > $maxcol or $c < 0;
push @values, $dimap->[$r][$c];
}
return \@values;
}
1;
__END__
=head1 NAME
Game::DijkstraMap - a numeric grid of weights plus some related functions
=head1 SYNOPSIS
use Game::DijkstraMap;
my $dm = Game::DijkstraMap->new;
# x is where the player is (the goal) and the rest are
# considered as walls or floor tiles (see the costfn)
my $level = Game::DijkstraMap->str2map(<<'EOM');
#########
#.h.....#
#.#####'#
#.#.###x#
#########
EOM
# setup the dijkstra map
$dm->map($level);
# or, the above can be condensed down to
use Game::DijkstraMap;
my $dm = Game::DijkstraMap->new( str2map => <<'EOM' );
...
EOM
# path finding is now possible
$dm->next( 1, 2 ); # [[1,3], 6]
$dm->next( 1, 6 ); # [[1,7], 2], [[2,7], 1]
$dm->next_sq( 1, 6 ); # [[1,7], 2]
$dm->next_best( 1, 6 ); # 2,7
$dm->path_best( 1, 1 );
$dm->next_m('next_sq');
$dm->next_best( 1, 6 ); # 1,7
$dm->path_best( 1, 1 );
# change the open door ' to a closed one
$dm->update( [ 2, 7, -1 ] );
$dm->recalc;
$dm->next( 1, 7 ); # nowhere better to move to
$dm->unconnected; # [[3,3]]
# custom costfn example -- search in the walls
$dm = Game::DijkstraMap->new(
costfn => sub {
my ( $self, $c ) = @_;
if ( $c eq '#' ) { return $self->max_cost }
return $self->bad_cost;
}
);
=head1 DESCRIPTION
This module implements code described by "The Incredible Power of
Dijkstra Maps" article. Such maps have various uses in roguelikes or
other games. This implementation may not be fast but should allow quick
prototyping of map-building and path-finding exercises.
L
The L section describes what this module does in
more detail.
=head1 CONSTRUCTOR
The B method accepts the L in the usual L
fashion. Additionally I