File Coverage

lib/Settlers/Event/Robber.pm

Criterion	Covered	Total	%
statement	69	80	86.2
branch	15	34	44.1
condition	3	9	33.3
subroutine	16	17	94.1
pod	0	11	0.0
total	103	151	68.2

package Settlers::Event::Robber;
$Settlers::Event::Robber::VERSION = '0.07';
use strict;
use warnings;
use POSIX 'ceil';

sub new
{
  my ($class, $args) = @_;

  bless {
    players_to_steal  => [],
    players_to_concede=> [],
    active            => 0,
    location          => set_initial_location($args->{map}),
    moved             => 0,
  }, $class;
}

sub active     { $_[0]->{active} }
sub location   { $_[0]->{location} }

sub activate
{
  my ($self, $players_to_concede) = @_;
  die "robber is already active\n" if $self->active;
  $self->{active} = 1;

  # check which players have more than 7 cards and need to concede
  for (@$players_to_concede)
  {
    next unless $_->resource_total > 7;
    push @{$self->{players_to_concede}}, {player => $_, target_total => ceil($_->resource_total / 2)};
  }
  return $self->{players_to_concede};
}

sub check_players_to_concede
{
  my ($self) = @_;
  my @remaining_players = ();
  for my $pair (@{$self->{players_to_concede}})
  {
    next if $pair->{player}->resource_total <= $pair->{target_total};
    push @remaining_players, $pair;
  }
  $self->{players_to_concede} = \@remaining_players;
  return $self->{players_to_concede};
}

sub deactivate
{
  my $self = shift;
  die "robber is already inactive\n" unless $self->active;
  $self->check_players_to_concede;
  die "Not all players have conceded their resources yet!\n" if @{$self->{players_to_concede}};
  die "robber hasn\'t moved yet!\n"  unless $self->moved;
  $self->{active} = 0;
  $self->{moved} = 0;
}

# deploy to a random desert tile
sub set_initial_location
{
  my $tiles = shift->tiles_by_type_code('D');
  my $tile = $tiles->[ int rand(@$tiles) ];
  die "There are no desert tiles!\n" unless $tile;
  return $tile;
}

sub move
{
  my ($self, $tile,$active_player, $players) = @_;
  $self->check_players_to_concede;

  die "move requires tile & players arguments\n"
    unless $tile && $tile->isa('Settlers::Map::Tile') && $players && ref $players eq 'ARRAY';

  die "Not all players have conceded their resources yet!\n" if @{$self->{players_to_concede}};

  die "the robber can only be moved when active\n" unless $self->{active};

  die "the robber has already moved\n" if $self->{moved};

  die "the robber cannot be moved to the same tile\n"
    if $self->{location}->uuid eq $tile->uuid;

  $self->{location} = $tile;
  $self->{moved} = 1;

  my @players_to_steal = ();

  PLAYER:
  for my $player (@$players)
  {
    next if $player eq $active_player;
    for my $property (@{$player->properties})
    {
      if ($property->location->is_adjacent($tile))
      {
        push @players_to_steal, $player;
        next PLAYER;
      }
    }
  }
  $self->{players_to_steal} = \@players_to_steal;
  return $tile;
}

# check player has an adjacent property to the robber
# return a random resource if they are
sub steal
{
  my ($self, $player) = @_;
  die "the robber can only steal when active\n" unless $self->{active};
  die "the robber hasn\'t moved yet!\n" unless $self->{moved};

  if (grep($_->number == $player->number, @{$self->{players_to_steal}}))
  {
    return $player->resource_lose_random;
  }
  else
  {
    die "$player->{number} has no adjacent properties\n";
  }
}
sub moved { $_[0]->{moved} }

sub can_steal { scalar @{$_[0]->{players_to_steal}} }
1;

__END__