File Coverage

lib/Catan/Game/Player.pm

Criterion	Covered	Total	%
statement	231	252	91.6
branch	48	70	68.5
condition	18	33	54.5
subroutine	55	60	91.6
pod	0	42	0.0
total	352	457	77.0

package Catan::Game::Player;
$Catan::Game::Player::VERSION = '0.03';
use strict;
use warnings;
use Catan::Asset::Road;
use Catan::Asset::Settlement;
use Catan::Asset::City;
use Catan::Asset::DevelopmentCard;
use Games::Dice;
use List::Util qw/sum/;

use overload
  '""' => 'name',
  fallback => 1;

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

  bless {
    actions_this_turn=> [],
    action_history => [],
    number       => $args->{number},
    # all resources start at zero!
    resources    => {B => 0, G => 0, L => 0, O => 0, W => 0},
    ratios       => {B => 4, G => 4, L => 4, O => 4, W => 4},
    roads        => [],
    settlements  => [],
    cities       => [],
    cards        => [],
    points       => 0,
    knights      => 0,
    longest_road => 0,
    largest_army => 0,
    max_road     => 0,
  }, $class;
}

sub resource_lose_random
{
  my $self = shift;
  for (keys %{$self->{resources}})
  {
    return $_ if $self->{resources}{$_} > 0;
  }
  die "$self does not have any resources to lose\n";
}

sub resource_total
{
  my $self = shift;
  return sum values %{$self->resources};
}

sub summary
{
  my $self = shift;
  return {
    victory_points => $self->victory_points_count,
    resources      => $self->resources,
    assets         => {
      settlements     => scalar @{$self->settlements},
      cities          => scalar @{$self->cities},
      cards           => scalar @{$self->{cards}},
      roads           => scalar @{$self->roads},
      max_road_length => $self->max_road_length,
      longest_road    => $self->longest_road,
    },
    military => {
      knights_played => $self->{knights},
      largest_army   => $self->largest_army,
    },
    actions_this_turn  => join ', ', @{$_[0]->actions},
  };
}

sub buy_asset
{
  my ($self, $bank, $class) = @_;
  my %costs = ();
  for (@{$class->cost})
  {
    $costs{$_->code} = $_->amount;
  }
  my $trade = Catan::Game::Trade->new($bank, [$self], { $self->number => \%costs }, 1);
  $trade->execute;
}

sub road_build
{
  my ($self, $location, $bank, $free) = @_;

  die "$self has reached the maximum road limit\n"
    unless @{$self->roads} < 15;

  die "$self does not have an adjacent property to build a road there\n"
    unless $self->has_connecting_property($location) || $self->has_connecting_road($location);

  die "$self must build a road next to their second property during deployment\n"
    if @{$self->settlements} == 2 && !$location->is_adjacent($self->settlements->[1]->location)
      && @{$self->roads} == 1;

  $self->buy_asset($bank, 'Catan::Asset::Road') unless ($free);
  my $road = Catan::Asset::Road->new($location);
  push @{$self->roads}, $road;
  push @{$self->{actions_this_turn}}, 'BR';
  return $road;
}

sub has_connecting_road
{
  my ($self, $location) = @_;
  return grep($_->location->is_adjacent($location), @{$self->roads});
}

sub has_connecting_property
{
  my ($self, $location) = @_;
  return grep($location->is_adjacent($_->location), @{$self->properties});
}

sub settlement_build
{
  my ($self, $location, $bank, $free) = @_;

  die "$self has reached the maximum settlement limit\n"
    unless @{$self->settlements} < 5;

  die "$self does not have an adjacent road to build a property\n"
    unless $free || $self->has_connecting_road($location);

  $self->buy_asset($bank, 'Catan::Asset::Settlement') unless ($free);
  my $settlement = Catan::Asset::Settlement->new($location);
  push @{$self->{settlements}}, $settlement;
  $self->action_add('BS');
  return $settlement;
}

sub city_build
{
  my ($self, $intersection, $bank) = @_;
  $self->buy_asset($bank, 'Catan::Asset::City');

  die "$self has reached the maximum city limit\n"
    unless @{$self->cities} < 4;

  # remove old settlement
  my ($city, @settlements);
  for (@{$self->settlements})
  {
    if ($_->location->is_colliding($intersection))
    {
      $city = Catan::Asset::City->new($intersection);
      undef $_;
    }
    else
    {
      push(@settlements, $_);
    }
  }
  if ($city)
  {
    push @{$self->{cities}}, $city;
  $self->action_add('BC');
    $self->{settlements} = \@settlements;
    return $city;
  }
  die "$self has no eligible settlements!\n";
}

sub development_card_build
{
  my ($self, $type, $bank) = @_;
  $self->buy_asset($bank, 'Catan::Asset::DevelopmentCard');
  my $card = Catan::Asset::DevelopmentCard->new($type);
  $self->victory_points_add if $type eq 'VP';
  push @{$self->{cards}}, $card;
  $self->action_add('BD');
  return $card;
}

sub development_card_play
{
  my ($self, $type) = @_;
  die "development_card_play requires a type argument\n" unless $type;

  die "$self has already played a development card this turn\n"
    if $self->has_played_dc;

  die "Victory Point cards cannot be played - they are automatically added to a player's VP total\n"
    if $type eq 'VP';

  # remove card
  my ($card, @cards);
  for (@{$self->{cards}})
  {
    if ($_->type eq $type && !$card)
    {
      $card =  $_;
    }
    else
    {
      push(@cards, $_);
    }
  }
  die "$self does not have that development card!\n" unless $card;
  $self->{cards} = \@cards;
  $self->action_add('PD');
  return $card;
}

sub action_history { $_[0]->{action_history} }
sub actions_taken  { $_[0]->{actions_this_turn} }
sub action_add     { push @{$_[0]->{actions_this_turn}}, $_[1] }

sub actions_clear
{
  my $self = shift;
  push @{$self->{action_history}}, $self->actions_taken;
  $self->{actions_this_turn} = [];
}

sub victory_points_add  { ++$_[0]->{points} }

sub victory_points_count
{
  my $self = shift;
  return $self->{points}  # vp cards played
    + ($self->{longest_road} ? 2 : 0)
    + ($self->{largest_army} ? 2 : 0)
    + @{$self->{settlements}}
    + (@{$self->{cities}} * 2);
}

sub largest_army_toggle
{
  my $self = shift;
  $self->{largest_army} = $self->{largest_army} ? 0 : 1;
}

sub longest_road_toggle
{
  my $self = shift;
  $self->{longest_road} = $self->{longest_road} ? 0 : 1;
}

sub max_road_calculate
{
  my ($self, $all_properties) = @_;

  my %intersections;

  for (@{$self->roads})
  {
    push @{$intersections{$_->location->start->uuid}}, $_;
    push @{$intersections{$_->location->end->uuid}}, $_;
  }

  # delete intersections occupied by enemy properties
  # as they break roads
  for my $prop (@$all_properties)
  {
    # skip player's own properties
    next if grep($prop->location->is_colliding($_->location), @{$self->properties});
    delete $intersections{$prop->location->uuid};
  }

  my @paths;
  for my $k (keys %intersections)
  {
    for my $r (@{$intersections{$k}})
    {
      push @paths, @{backtrack([[{uuid =>$k, road => $r}]], \%intersections)};
    }
  }
  my @sorted_paths = sort { @$b <=> @$a } @paths, [];
  my $max_road = shift @sorted_paths;
  $self->{max_road_length} = scalar @$max_road;
  return $max_road;
}

sub max_road_length { $_[0]->{max_road_length} }

sub backtrack
{
  my ($paths, $intersections) = @_;

  die 'backtrack requires an arrayref and a hashref as arguments'
    unless $paths && ref $paths eq 'ARRAY' && @$paths
      && $intersections && ref $intersections eq 'HASH' && keys %$intersections;

  my @new_paths = ();

  for my $path (@$paths)
  {
    my $uuid = $path->[-1]{uuid};
    my $road = $path->[-1]{road};

    for my $connecting_road (@{ $intersections->{$uuid} })
    {
      next if scalar grep($connecting_road->location->is_colliding($_->{road}->location), @$path);

      my $next_uuid;

      if ($connecting_road->location->start eq $uuid)
      {
        $next_uuid =  $connecting_road->location->end->uuid;
      }
      elsif ($connecting_road->location->end eq $uuid)
      {
        $next_uuid = $connecting_road->location->start->uuid;
      }

      if ($next_uuid)
      {
        # make a copy of the path
        my @new_path = @$path;
        push @new_path, {uuid => $next_uuid, road => $connecting_road};
        push @new_paths, \@new_path;
      }
    }
  }
  if (@new_paths)
  {
    return backtrack(\@new_paths, $intersections);
  }
  return $paths;
}

# players with generic and specific harbors get better trading ratios with the bank
sub update_ratios
{
  my ($self, $map) = @_;
  my @tiles = map(@{$map->tiles_by_intersection($_->location)}, @{$self->properties});
  my %ratios = %{$self->ratios};

  for (@tiles)
  {
    if ($_->code eq 'HR')
    {
      while (my ($k, $v) = each %ratios)
      {
        $ratios{$k} = 3 if $v == 4;
      }
    }
    elsif ($_->code eq 'HRB')
    {
      $ratios{B} = 2;
    }
    elsif ($_->code eq 'HRG')
    {
      $ratios{G} = 2;
    }
    elsif ($_->code eq 'HRL')
    {
      $ratios{L} = 2;
    }
    elsif ($_->code eq 'HRO')
    {
      $ratios{O} = 2;
    }
    elsif ($_->code eq 'HRW')
    {
      $ratios{W} = 2;
    }
  }
  $self->{ratios} = \%ratios;
}

sub roll_dice
{
  my ($self, $result) = @_;
  $self->action_add('RD');
  return ($result || Games::Dice::roll('2d6'));
}

sub number          { $_[0]->{number} }
sub properties      { [ @{$_[0]->{settlements}}, @{$_[0]->{cities}} ] }
sub roads           { $_[0]->{roads} }
sub settlements     { $_[0]->{settlements} }
sub cities          { $_[0]->{cities} }
sub resources       { $_[0]->{resources} }
sub has_rolled_dice { grep $_ eq 'RD', @{$_[0]->actions_taken} }
sub has_built_road  { grep $_ eq 'BR', @{$_[0]->actions_taken} }
sub has_built_settlement { grep $_ eq 'BS', @{$_[0]->actions_taken} }
sub has_built_city  { grep $_ eq 'BC', @{$_[0]->actions_taken} }
sub has_played_dc   { grep $_ eq 'PD', @{$_[0]->actions_taken} }
sub add_knight      { ++$_[0]->{knights} }
sub knights         { $_[0]->{knights} }
sub longest_road    { $_[0]->{longest_road} }
sub largest_army    { $_[0]->{largest_army} }
sub name            { "Player $_[0]->{number}" }
sub ratios          { $_[0]->{ratios} }
1;

__END__