File Coverage

blib/lib/Game/LevelMap.pm

Criterion	Covered	Total	%
statement	77	77	100.0
branch	14	14	100.0
condition	18	20	90.0
subroutine	13	13	100.0
pod	6	7	85.7
total	128	131	97.7

# -*- Perl -*-
#
# a small level map implementation that uses characters (or strings
# consisting of escape sequences or combining characters, or objects
# that ideally stringify themselves properly) in an array of arrays
# representing a level map as might be used in a game

package Game::LevelMap;

use 5.24.0;
use warnings;
use Carp qw(croak);
use Moo;
use namespace::clean;

our $VERSION = '0.02';

has level => (
    is      => 'rw',
    default => sub { [ [] ] },
    isa     => sub {
        my ($lm) = @_;
        croak "LevelMap must be an AoA"
          if !defined $lm
          or ref $lm ne 'ARRAY'
          or ref $lm->[0] ne 'ARRAY';
        my $cols = $lm->[0]->$#*;
        for my $row ( 1 .. $lm->$#* ) {
            if ( $cols != $lm->[$row]->$#* ) {
                croak 'unequal column length at row index ' . $row;
            }
        }
    },
    trigger => sub {
        my ( $self, $lm ) = @_;
        $self->_set_rows( $lm->$#* );
        $self->_set_cols( $lm->[0]->$#* );
    }
);
has rows => ( is => 'rwp' );
has cols => ( is => 'rwp' );

sub BUILD {
    my ( $self, $args ) = @_;
    croak "level and from_string both may not be set"
      if exists $args->{level} and exists $args->{from_string};
    $self->from_string( $args->{from_string} ) if exists $args->{from_string};
}

sub clone {
    my ($self) = @_;
    my $lm = $self->level;
    my @map;
    for my $rown ( 0 .. $lm->$#* ) {
        for my $coln ( 0 .. $lm->$#* ) {
            $map[$rown][$coln] = $lm->[$rown][$coln];
        }
    }
    return __PACKAGE__->new( level => \@map );
}

sub from_string {
    my ( $self, $s ) = @_;
    my @map;
    my $cols;
    for my $row ( split $/, $s ) {
        push @map, [ split '', $row ];
        my $newcols = $map[-1]->$#*;
        if ( defined $cols ) {
            if ( $cols != $newcols ) {
                croak 'unequal column length at row index ' . $#map;
            }
        } else {
            $cols = $newcols;
        }
    }
    $self->level( \@map );
    return $self;
}

# TODO this might buffer and only print what differs across successive
# calls (for less bandwidth over an SSH connection)
sub to_panel {
    my $self = shift;
    my ( $col, $row, $width, $height, $x, $y ) = map int, @_[ 0 .. 5 ];
    my $oobfn    = $_[6] // sub { return ' ' };
    my $lm       = $self->level;
    my $map_cols = $lm->$#*;
    my $map_rows = $lm->[0]->$#*;
    croak "x must be within the level map" if $x < 0 or $x > $map_cols;
    croak "y must be within the level map" if $y < 0 or $y > $map_rows;
    my $scol = $x - int( $width / 2 );
    my $srow = $y - int( $height / 2 );
    my $s    = '';

    for my $r ( $srow .. $srow + $height - 1 ) {
        $s .= "\e[" . $row++ . ';' . $col . 'H';
        for my $c ( $scol .. $scol + $width - 1 ) {
            if ( $c < 0 or $c > $map_cols or $r < 0 or $r > $map_rows ) {
                $s .= $oobfn->( $lm, $c, $r, $map_cols, $map_rows );
            } else {
                $s .= $lm->[$r][$c];
            }
        }
    }
    print $s;
    return $self;
}

sub to_string {
    my ($self) = @_;
    my $lm     = $self->level;
    my $s      = '';
    for my $rowref ( $lm->@* ) { $s .= join( '', $rowref->@* ) . $/ }
    return $s;
}

sub to_terminal {
    my $self = shift;
    my ( $col, $row ) = map int, @_;
    my $lm = $self->level;
    my $s  = '';
    for my $rowref ( $lm->@* ) {
        $s .= "\e[" . $row++ . ';' . $col . 'H' . join( '', $rowref->@* );
    }
    print $s;
    return $self;
}

sub update_terminal {
    my $self = $_[0];
    my ( $col, $row ) = map int, @_[ 1 .. 2 ];
    my $lm = $self->level;
    my $s  = '';
    for my $point ( @_[ 3 .. $#_ ] ) {
        $s .= "\e["
          . ( $row + $point->[1] ) . ';'
          . ( $col + $point->[0] ) . 'H'
          . $lm->[ $point->[1] ][ $point->[0] ];
    }
    print $s;
    return $self;
}

1;
__END__