File Coverage

blib/lib/Game/DijkstraMap.pm

Criterion	Covered	Total	%
statement	311	316	98.4
branch	124	152	81.5
condition	72	107	67.2
subroutine	31	31	100.0
pod	22	23	95.6
total	560	629	89.0

# -*- 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.05';

use constant SQRT2 => sqrt(2);

with 'MooX::Rebuild';

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 clone {
    my ($self) = @_;
    my $newdm  = $self->rebuild;
    my $dimap  = $self->dimap;
    if ( defined $dimap ) {
        my $map;
        my $cols = $dimap->[0]->$#*;
        for my $r ( 0 .. $dimap->$#* ) {
            for my $c ( 0 .. $cols ) {
                $map->[$r][$c] = $dimap->[$r][$c];
            }
        }
        $newdm->dimap($map);
    }
    return $newdm;
}

sub dimap_with {
    my ( $self, $param ) = @_;
    my $dimap = $self->dimap;
    croak "dimap not set" 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 each_cell {
    my ( $self, $fn ) = @_;
    croak "need a code ref" if !defined $fn or ref $fn ne 'CODE';
    my $dimap = $self->dimap;
    croak "dimap not set" if !defined $dimap;
    my $cols = $dimap->[0]->$#*;
    for my $r ( 0 .. $dimap->$#* ) {
        for my $c ( 0 .. $cols ) {
            $fn->( $dimap, $r, $c, $self );
        }
    }
    return $self;
}

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->bad_cost
        )
    );
    $self->dimap($dimap);
    return $self;
}

sub next {
    my ( $self, $r, $c, $value ) = @_;
    my $dimap = $self->dimap;
    croak "dimap not set" 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 "dimap not set" 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 "dimap not set" 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, $badcost, $adjvals ) = @_;
    $adjvals //= \&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 == $badcost or $value == $mincost;
                my $isneg;
                if ( $value < 0 ) {
                    $isneg = 1;
                    $value = abs $value;
                }
                my $best = $maxcost;
                for my $nv ( $adjvals->( $dimap, $r, $c, $maxrow, $maxcol ) ) {
                    next if $nv == $badcost;
                    $nv   = abs $nv;
                    $best = $nv if $nv < $best;
                    last if $best == $mincost;
                }
                if ( $value >= $best + 2 ) {
                    my $newval = $best + 1;
                    $newval *= -1 if $isneg;
                    $dimap->[$r][$c] = $newval;
                    $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, $badcost ) = @_;
    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 == $badcost or $value == $mincost;
                my $isneg;
                if ( $value < 0 ) {
                    $isneg = 1;
                    $value = abs $value;
                }
                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 ) )
                ) {
                    next if $nr->[0] == $badcost;
                    $nr->[0] = abs $nr->[0];
                    $best    = $nr if $nr->[0] < $best->[0];
                    last if $best->[0] == $mincost;
                }
                if ( $value > $best->[0] + SQRT2 ) {
                    my $newval = $best->[0] + $best->[1];
                    $newval *= -1 if $isneg;
                    $dimap->[$r][$c] = $newval;
                    $stable = 0;
                }
            }
        }
        last if $stable;
    }
    return $iters;
}

sub normalize {
    my ($self) = @_;
    my $dimap = $self->dimap;
    croak "dimap not set" if !defined $dimap;
    $self->_set_iters(
        $self->normfn->(
            $dimap, $self->min_cost, $self->max_cost, $self->bad_cost
        )
    );
    return $self;
}

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 "dimap not set" if !defined $dimap;
    my $maxcost = $self->max_cost;
    my $mincost = $self->min_cost;
    my $badcost = $self->bad_cost;
    my $maxcol  = $dimap->[0]->$#*;
    for my $r ( 0 .. $dimap->$#* ) {

        for my $c ( 0 .. $maxcol ) {
            $dimap->[$r][$c] = $maxcost
              if $dimap->[$r][$c] != $mincost and $dimap->[$r][$c] != $badcost;
        }
    }
    $self->_set_iters(
        $self->normfn->( $dimap, $mincost, $maxcost, $self->bad_cost ) );
    $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 "dimap not set" 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 "dimap not set" 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 "dimap not set" 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__