File Coverage

lib/Catan/Event/Robber.pm

Criterion	Covered	Total	%
statement	67	78	85.9
branch	14	34	41.1
condition	3	9	33.3
subroutine	15	16	93.7
pod	0	10	0.0
total	99	147	67.3

package Catan::Event::Robber;
$Catan::Event::Robber::VERSION = '0.03';
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' 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' unless $self->active;
  $self->check_players_to_concede;
  die 'Not all players have conceded their resources yet!' if @{$self->{players_to_concede}};
  die 'robber hasn\'t moved yet!'  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!' unless $tile;
  return $tile;
}

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

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

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

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

  die 'the robber has already moved' if $self->{moved};

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

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

  my @players_to_steal = ();

  PLAYER:
  for my $player (@$players)
  {
    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;

  # if there are no eligible players to steal from deactivate the robber
  $self->deactivate unless @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' unless $self->{active};
  die 'the robber hasn\'t moved yet!' 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";
  }
}
sub moved { $_[0]->{moved} }
1;

__END__