File Coverage

blib/lib/Games/Roguelike/Mob.pm

Criterion	Covered	Total	%
statement	40	243	16.4
branch	3	118	2.5
condition	1	39	2.5
subroutine	8	25	32.0
pod	17	19	89.4
total	69	444	15.5

use strict;

package Games::Roguelike::Mob;

use Games::Roguelike::Utils qw(:all);
use Games::Roguelike::Console;
use Games::Roguelike::Area;
use Data::Dumper;
use Carp qw(croak confess);

=head1 NAME

Games::Roguelike::Mob - Roguelike mobile object

=head1 SYNOPSIS

 package myMob;
 use base 'Games::Roguelike::Mob';

 $area = Games::Roguelike::Area->new();
 $m = myMob->new($area, sym=>'D', x=>5,y=>6);       # creates a mob at location 5, 6
                                                    # with symbol 'D', inside area $area

 $m->autoex()					    # moves the mob towards the nearest unexplored area
 $m->kbdmove($c)				    # moves the mob according to keystroke '$c' using traditional roguelike semantics

=head1 DESCRIPTION

Mobile object used by drawing routines in Roguelke::Area

=head2 METHODS

=over 4

=item new($area, %options)

Area is an ::Area object, common options are:

 sym=>'@', 		# symbol to use when rendering
 items=>[], 		# array ref of contained items
 hasmem=>1,		# whether the mob uses the "memory" feature
 pov=>-1, 	        # distance the mob can "see" (-1 = infinite, 0 = blind)
 singleminded=>0,	# whether the mob will "wander" when the movetoward function is called

All "unknown" options are saved in the object's hash, with the assumption that they
will be used by the game, for example "->{MaxHp}", etc.

=cut

sub new {
        my $pkg = shift;
        my $area = shift;
	croak("can't create mob without area") unless $area && $area->isa('Games::Roguelike::Area');

        my $self = {};

        $self->{area} = $area;
	$self->{sym}='@';
	$self->{msglog} = [];
	$self->{items} = [];
	$self->{odir} = '';
	$self->{hasmem} = 1;
	$self->{pov} = -1;
	$self->{singleminded} = 0;		# whether it tries to wander around in pursuit of a goal

        while( my ($k, $v) = splice(@_, 0, 2)) {
                $self->{$k} = $v;
        }

        if (!defined($self->{x})) {
                ($self->{x}, $self->{y}) = $area->findrandmap($area->{fsym}, 0, 1);
        }

        bless $self, $pkg;
        $area->addmob($self);
        return $self;
}

=item area([new])

Either returns the current area (no arguments) or set the area (one argument).

If an area is supplied, the old area has "delmob" called on it,and the new area has "addmob" called on it.

=cut

sub area {
        my $self = shift;
        if (@_) {
		$self->{area}->delmob($self);
        	$self->{area} = $_[0];
        	$_[0]->addmob($self);
		if ($self->{area}->{world}) {
			$self->{area}->{world}->area($self->{area});
		}
        }
        return $self->{area};
}

=item x()

=item y()

Returns the location of the mob

=cut

sub x {
	return $_[0]->{x};
}

sub y {
	return $_[0]->{y};
}

=item on()

Returns the map symbol from the current area at the mob's current x, y location.

=cut

sub on {
	my $self = shift;
	return $self->{area}->{map}->[$self->{x}][$self->{y}];
}

=item movetofeature(@ARGS)

Calls the "findfeature" function on the current area with the @ARGS, and, if one is returned, reposition with x/y coordinates to match.

Checkmove/aftermove are not called.

=cut

sub movetofeature {
	my $self = shift;
        my ($cx,$cy) = $self->{area}->findfeature(@_);
	if (defined($cx)) {
        	$self->{x} = $cx;
        	$self->{y} = $cy;
		return 1;
	} else {
		return 0;
	}
}

my %DIAGS = (
	'nw'=>['n','w'],
	'ne'=>['n','e'],
	'sw'=>['s','w'],
	'se'=>['s','e'],
	'n',=>['nw','ne'],
	's',=>['sw','se'],
	'e',=>['ne','ne'],
	'w',=>['sw','nw'],
);

=item movetoward($x, $y, $error)

Moves the mob toward the point specified.   If error is specified, the destination point is "blurred" by the error radius.

=cut

sub movetoward {
	my $self = shift;
	my ($x, $y, $err) = @_;
	my ($dx, $dy) = ($x - $self->{x}, $y - $self->{y});

	if ($err > 0) {
		$dx += (randi($err*2+1)- $err);
		$dy += (randi($err*2+1)- $err);
		intify($dx, $dy);
	}

	return 0 if $dx == 0 && $dy == 0;
	my $d;

	if ($dy > 0) {
		$d = 's'
	} elsif ($dy < 0) {
		$d = 'n'
	}

	if ($dx > 0) {
		$d .= 'e'
	} elsif ($dx < 0) {
		$d .= 'w'
	}

	# nonzero means move happened
	my $ok = $self->move($d);
	return $ok if $ok;

	# try moving orthoganally again sometimes... to range farther
	if (($self->{singleminded}==0) && rand(2) > 1 && $self->{odir}) {
                $ok = $self->move($self->{odir});
		$self->{area}->dprint("ortho repeat of $self->{odir}") if $ok;
                return $ok if $ok;
	}

	# try moving diags of move
	my @d;

	if (abs($dy) > abs($dx)) {
		@d = @{$DIAGS{$d}};
	} elsif (abs($dy) < abs($dx)) {
		@d = ($DIAGS{$d}->[1],$DIAGS{$d}->[0]);
	} else {
		@d = randsort(@{$DIAGS{$d}});
	}

	for (@d) {
		$ok = $self->move($_);
		$self->{odir} = '' if $ok;
		return $ok if $ok;
	}

	return 0 if $self->{singleminded} > 1;

	# try moving orthoganally to the way you want to go
	for (randsort(orthogs($d))) {
                $ok = $self->move($_);
		$self->{area}->dprint("moved orthog $_") if $ok;
		$self->{odir} = $_ if $ok;
                return $ok if $ok;
	}

	return 0;
}

my %ORTHOGS = (
	'n'=>['e','w','ne','nw'],
	's'=>['e','w','se','sw'],
	'e'=>['n','s','ne','se'],
	'w'=>['n','s','nw','sw'],
	'ne'=>['nw','se'],
	'nw'=>['ne','sw'],
	'se'=>['ne','sw'],
	'sw'=>['nw','se'],
);

sub orthogs {
	my ($d) = @_;
	return @{$ORTHOGS{$d}};
}

=item kbdmove($c[, $testonly])

Moves the mob in direction '$c': 'h' is LEFT, 'l' is RIGHT, etc.

The testonly flag is passed to the "move" function.

=cut

sub kbdmove {
	my $self = shift;
	my ($c, $testonly) = @_;
        if ($c eq '.') {
                return $self->move('.', $testonly);
        }
        if ($c eq 'h' || $c eq 'LEFT') {
                return $self->move('w', $testonly);
        }
        if ($c eq 'l' || $c eq 'RIGHT') {
                return $self->move('e', $testonly);
        }
        if ($c eq 'j' || $c eq 'DOWN') {
                return $self->move('s', $testonly);
        }
        if ($c eq 'k' || $c eq 'UP') {
                return $self->move('n', $testonly);
        }
        if ($c eq 'y') {
                return $self->move('nw', $testonly);
        }
        if ($c eq 'b') {
                return $self->move('sw', $testonly);
        }
        if ($c eq 'u') {
                return $self->move('ne', $testonly);
        }
        if ($c eq 'n') {
                return $self->move('se', $testonly);
        }
	return 0;
}

=item safetomove()

Returns true if it's safe to continue autoexploring.

Default behavior is to return false if any mobs are in view.

=cut

sub safetomove {
        my $self = shift;
        my $area = $self->{area};
        for my $m (@{$area->{mobs}}) {
                next if $m eq $self;
                if ($area->checkpov($self, $m->{x}, $m->{y})) {
                	return 0;
                }
        }
	return 1;
}

=item autoex ([bool only1])

Find closest unexplored square and move towards it until it's no longer unexplored.

If world is specified, this loops and draws the map.   Otherwise, it moves only 1 step.

=cut

sub autoex {
        my $self = shift;
	my ($world) = @_;

        # flood fill find unexplored area
        my $area = $self->{area};
        my ($x1, $y1) = ($self->{x}, $self->{y});
        my $f;

        my @f;
        push @f, [$x1, $y1, []];
        my @bread;
        my ($cx, $cy) = ($x1, $y1);
        my $minlen = 1000000;

	if (!$self->safetomove()) {
		return 0;
	}

	if (!$world && $self->{autopath} && @{$self->{autopath}}) {
		my $moved = $self->move(shift(@{$self->{autopath}}));
		if ($self->{memory}->{$self->{area}->{name}}->[$self->{autocx}][$self->{autocy}]) {
			$self->{autopath} = undef;
		}
		return $moved;
	}

	my $path;		# path to take
        while (@f) {
                my $c = shift @f;	# breadth first
                for (my $d=0;$d<8;++$d) {
                        next unless $self->{memory}->{$self->{area}->{name}}->[$c->[0]][$c->[1]];	# has to be "moving from" a place we have seen

                        my $tx = $DD[$d]->[0]+$c->[0];
                        my $ty = $DD[$d]->[1]+$c->[1];
			my $p = [@{$c->[2]}, $DIRS[$d]];

                        # not off edge
                        next if $tx < 0 || $ty < 0;
                        next if $tx >= $area->{w} || $ty >= $area->{h};

                        next if $bread[$tx][$ty];
                        $bread[$tx][$ty]='.';     #been there in this algorithm

			my $seen = $self->{memory}->{$self->{area}->{name}}->[$tx][$ty];

                        if (!$seen) {	# not explored already;
                          $path = $p;
                          $cx = $tx;
                          $cy = $ty;
			  @f = ();
			  last;
			}

                        # not thru void
                        next if !defined($area->{map}->[$tx][$ty]);
                        next if $area->{map}->[$tx][$ty] eq '';

                        # not thru wall
                        next if index($area->{nomove}, $area->{map}->[$tx][$ty]) >= 0;

	                push @f, [$tx, $ty, $p];    #add to list of places can get to;
                }
        }

	if ($path) {
		if (!$world) {
			my $moved = $self->move(shift(@{$path}));
                        if (!($self->{memory}->{$self->{area}->{name}}->[$cx][$cy])) {
                        	$self->{autopath} = $path;
                        	$self->{autocx} = $cx;
                        	$self->{autocy} = $cy;
                        }
			return $moved;
		} else {
			my $con = $world->{con};
			my $stm=1;
			for (@$path) {
				my $bc = $con->nbgetch();
				if ($bc eq 'q' || $bc eq 'ESC') {
					$stm = 0;
					last;
				}
				my $moved = $self->move($_);
				$stm = $self->safetomove();
				last if !$stm;
				# explored the one we were looking for...remove this to reduce recusion at the expense of wasted moves
				if (($self->{memory}->{$self->{area}->{name}}->[$cx][$cy])) {
					last;
				}
			}
			if (!$stm) {
				return 1;
			} else {
				$world->drawmap();
				$self->autoex(@_);
			}
		}
	}
}


=item move (direction[, testonly])

Uses checkmove to see whether the direction is ok.  If it returns > 0, then moves the mob,
changing its x,y position, and saving the move in "lastmove".

Aftermove is then called if the return value of checkmove was nonzero.

=item lastmove

Returns the direction parameter passed to "move" that resulted in a successful move.

=cut

sub move {
	my $self = shift;
	my ($d, $testonly) = @_;			# news direction
	my $nx = $self->{x} + $DD{$d}->[0];
	my $ny = $self->{y} + $DD{$d}->[1];
	my $r;
	$r = $self->checkmove($nx, $ny, scalar $self->{area}->mobat($nx, $ny), $testonly);
	# less than eq zero means remain still (but move may have occurred)
	if (!$testonly) {
	  if ($r > 0) {
		$self->{area}->dprint("moved $d");
		$self->{x} = $nx;
		$self->{y} = $ny;
		$self->{lastmove} = $d;
	        $self->aftermove($d);
	  } elsif ($r < 0) {
	        $self->aftermove(undef);
	  }
	}
	return $r;
}

sub getmovexy {
        my $self = shift;
        my ($d, $flag) = @_;                    # news direction
        my $nx = $self->{x} + $DD{$d}->[0];
        my $ny = $self->{y} + $DD{$d}->[1];
	return ($nx, $ny);
}

sub lastmove {
	return $_[0]->{lastmove};
}

=item aftermove (direction)

Called after the mob moved with the direction it moved.

If the mob attacks or otherwise moves "nowhere" it is called with 'undef' as the direction.

=cut

sub aftermove {
}

=item checkmove (new-x, new-y, othermob (at location x/y), testonly)

Called before the mob moves with the direction it will move if allowed.

Return value 0 		= no move occurs
Return value 1 		= move occurs
Return value -1 	= attack/move occured, but keep in the same place

=cut

sub checkmove {
	my $self = shift;
	my ($x, $y, $othermob, $testonly) = @_;
	return 0 unless $self->{area}->{map}->[$x][$y] eq $self->{area}->{fsym};
	return 0 unless !$othermob;
	return 1;
}

=item additem (item)

Adds item to inventory.  Override this to add pack full messages, etc.

Return value 0 		= can't add, too full
Return value 1 		= add ok
Return value -1 	= move occured, but not added

=cut

sub additem {
	my $self = shift;
	my $item = shift;
	# i'm never full
	return $item->setcont($self);
}

=item delitem (item)

Removes item from the mob.

=cut

sub delitem {
        my $self = shift;
        my $ob = shift;
	confess("not a mob") unless $self->isa('Games::Roguelike::Mob');
	$self->{area}->dprint("h1");
        my $i = 0;
        for (@{$self->{items}}) {
		if ($_ == $ob) {
                	splice @{$self->{items}}, $i, 1;
			return $_;;
		}
                ++$i;
        }
	return undef;
}

=item dropitem (item)

Removes item, changes it's coordinates, and then tries to put it in the "area".

Returns the result of the "additem" from the area object (which may be a failure).

=cut

sub dropitem {
        my $self = shift;
        my $item = shift;
	$item->{x} = $self->{x};
	$item->{y} = $self->{y};
        $self->{area}->additem($item);
	return 1;
}

=back

=head1 AUTHOR

Erik Aronesty C

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L or the included LICENSE file.

=cut

1;