File Coverage

lib/Games/PMM/Arena.pm

Criterion	Covered	Total	%
statement	112	112	100.0
branch	39	40	97.5
condition	14	15	93.3
subroutine	25	25	100.0
pod	14	22	63.6
total	204	214	95.3

package Games::PMM::Arena;

use strict;

sub new
{
	bless
	{
		x_limit     =>  9,
		y_limit     =>  9,
		coordinates => [],
		monsters    => {},
	}, shift;
}

sub coordinates
{
	my $self = shift;
	return $self->{coordinates};
}

sub monsters
{
	my $self = shift;
	$self->{monsters};
}

sub x_limit
{
	my $self = shift;
	$self->{x_limit};
}

sub y_limit
{
	my $self = shift;
	$self->{y_limit};
}

sub add_monster
{
	my ($self, $monster, %coordinates) = @_;

	$self->set_position( monster => $monster, %coordinates );
}

sub set_position
{
	my ($self, %args) = @_;

	my $coords   = $self->coordinates();
	my $monsters = $self->monsters();

	return unless $self->validate_position( %args );

	$coords->[ $args{x} ][ $args{y} ]   = $args{monster};
	$monsters->{ $args{monster}->id() } = [ $args{x}, $args{y} ];
}

sub validate_position
{
	my ($self, %args) = @_;
	my $coords        = $self->coordinates();

	return unless $self->within_bounds( %args );

	return if defined $coords->[ $args{x} ][ $args{y} ];
	return 1;
}

sub within_bounds
{
	my ($self, %args) = @_;
	my $coords        = $self->coordinates();

	return if $args{x} > $self->x_limit() or $args{y} > $self->y_limit();
	return if $args{x} < 0                or $args{y} < 0;

	return 1;
}

sub delete_position
{
	my ($self, %args) = @_;
	my $coords        = $self->coordinates();
	my $monsters      = $self->monsters();
	my $monster       = $coords->[ $args{ x } ][ $args{ y } ];

	$coords->[ $args{ x } ][ $args{ y } ] = undef;
	return unless $monster;
	delete $monsters->{ $monster->id() };
}

sub get_position
{
	my ($self, $monster) = @_;
	my $id               = $monster->id();
	my $monsters         = $self->monsters();

	return unless exists $monsters->{ $id };

	my ($x, $y)          = @{ $monsters->{ $id } };
	return { x => $x, y => $y };
}

sub update_position
{
	my ($self, $monster, %args)   = @_;
	my $old_pos                   = $self->get_position( $monster );

	return unless $self->validate_position( %args );

	$self->delete_position( monster => $monster, %$old_pos );
	$self->set_position(    monster => $monster,  %args );
}

sub get_monster
{
	my ($self, %args) = @_;
	my $coords        = $self->coordinates();

	return unless $self->within_bounds( %args );

	return $coords->[ $args{x} ][ $args{y} ];
}

for my $method
(
	{ name => 'forward', modifier => +1 },
	{ name => 'reverse', modifier => -1 },
)
{
	no strict 'refs';

	*{ $method->{name} } = sub
	{
		my ($self, $monster) = @_;

		my $pos        = $self->get_position( $monster );
		my $direction  = $monster->direction( $method->{modifier} );
		$pos->{x}     += $direction->{x};
		$pos->{y}     += $direction->{y};

		return unless $self->validate_position( %$pos );

		$self->update_position( $monster, %$pos );
	};
}

sub is_wall
{
	my ($self, %args) = @_;

	return 1 if $args{x} < 0 or $args{x} > $self->x_limit();
	return 1 if $args{y} < 0 or $args{y} > $self->y_limit();
	return;
}

sub get_distance
{
	my ($self, $pos, %to) = @_;

	my ($small_x, $big_x) = $self->minmax( $to{x}, $pos->{x} );
	my ($small_y, $big_y) = $self->minmax( $to{y}, $pos->{y} );

	return $big_x - $small_x + $big_y - $small_y;
}

sub minmax
{
	my ($self, $val1, $val2) = @_;
	return $val1 < $val2 ? ( $val1, $val2 ) : ( $val2, $val1 );
}

sub scan
{
	my ($self, $monster) = @_;
	my $id               = $monster->id();
	my $pos              = $self->get_position( $monster );

	my @seen;
	while ( my ($monster_id, $data) = each %{ $self->monsters() })
	{
		next if $monster_id == $id;
		my ($x, $y)          = @$data;
		my $distance         = $self->get_distance( $pos, x => $x, y => $y );

		next unless $self->can_see( $monster, $pos,
			distance => $distance,
			x        => $x,
			y        => $y
		);

		push @seen,
		{
			id       => $monster_id,
			x        => $x,
			y        => $y,
			distance => $distance,
		};
	}

	return @seen;
}

my %facings =
(
	north => sub {
		my ($self, $pos) = @_;

		return
		{
			from => $pos->{x},
			to   => $self->x_limit(),
			perp => 'y',
			axis => 'x',
		};
	},
	south => sub {
		my ($self, $pos) = @_;
		return
		{
			from => 0,
			to   => $pos->{x},
			perp => 'y',
			axis => 'x',
		};
	},
	east  => sub {
		my ($self, $pos) = @_;

		return
		{
			from => $pos->{y},
			to   => $self->y_limit(),
			perp => 'x',
			axis => 'y',
		}
	},
	west  => sub {
		my ($self, $pos) = @_;
		return
		{
			from => 0,
			to   => $pos->{y},
			perp => 'x',
			axis => 'y',
		}
	},
);

sub can_see
{
	my ($self, $monster, $pos, %args) = @_;
	my $look                          = $facings{ $monster->facing() };
	my $limits                        = $self->$look( $pos );
	my $axis                          = $limits->{axis};
	my $perp_axis                     = $limits->{perp};

	# can see adjacent monsters, but not behind
	return ! $self->behind( $monster, $pos, %args ) if $args{distance} == 1;

	# cannot see non-adjacent monsters on perpendicular axis
	return if $args{$perp_axis} == $pos->{$perp_axis};

	# can see all monsters from current position to boundary along facing axis
	return 1 if $args{$axis} >= $limits->{from} and
				$args{$axis} <= $limits->{to};

	return;
}

my %check_behind =
(
	north => { axis => 'y', mod => -1 },
	south => { axis => 'y', mod => +1 },
	east  => { axis => 'x', mod => -1 },
	west  => { axis => 'x', mod => +1 },
);

sub behind
{
	my ($self, $monster, $pos, %args) = @_;
	my $check                         = $check_behind{ $monster->facing };

	return $pos->{$check->{axis}} + $check->{mod} == $args{$check->{axis}};
}

sub move_monster
{
	my ($self, $monster, %coords) = @_;
	my $position                  = $self->get_position( $monster );

	$position->{x} += $coords{x};
	$position->{y} += $coords{y};

	$self->update_position( $monster,
		x       => $position->{x},
		y       => $position->{y},
	);
}

sub attack
{
	my ($self, $monster) = @_;
	my $victim                   = $self->get_victim( $monster );
	return unless $victim;
	$victim->damage();
}

sub get_victim
{
	my ($self, $monster) = @_;
	my @nearby           = grep { $_->{distance} == 1 } $self->scan( $monster );

	return unless @nearby;
	return $self->get_monster( map { $_ => $nearby[0]->{$_} } qw( x y ) );
}

1;
__END__