File Coverage

lib/Catan/Map.pm

Criterion	Covered	Total	%
statement	152	154	98.7
branch	35	50	70.0
condition	28	60	46.6
subroutine	27	28	96.4
pod	0	9	0.0
total	242	301	80.4

package Catan::Map;
$Catan::Map::VERSION = '0.03';
use strict;
use warnings;
use Catan::Map::Tile;
use Catan::Map::Intersection;
use Catan::Map::Path;
use List::Util 'shuffle';
use Math::HexGrid::Hex 0.03;

my @resource_numbers = (5,2,6,3,8,10,9,12,11,4,8,10,9,4,5,6,3,11);

my %tile_types = (
 D   => 'Catan::Map::Tile::Desert',
 F   => 'Catan::Map::Tile::Fields',
 FO  => 'Catan::Map::Tile::Forest',
 HR  => 'Catan::Map::Tile::Harbor',
 HRB => 'Catan::Map::Tile::HarborBrick',
 HRG => 'Catan::Map::Tile::HarborGrain',
 HRL => 'Catan::Map::Tile::HarborLumber',
 HRO => 'Catan::Map::Tile::HarborOre',
 HRW => 'Catan::Map::Tile::HarborWool',
 H   => 'Catan::Map::Tile::Hills',
 M   => 'Catan::Map::Tile::Mountains',
 P   => 'Catan::Map::Tile::Pastures',
 S   => 'Catan::Map::Tile::Sea',
);
eval "require $_" for values %tile_types;

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

  die "$class new requires a type argument (starter, random or custom)\n"
    unless exists $args->{type};

  # pick map type
  if ($args->{type} eq 'starter')
  {
    $self->{tiles} = _build_tiles($self->_starter);
  }
  elsif ($args->{type} eq 'random')
  {
    $self->{tiles} = _build_tiles($self->_random);
  }
  elsif ($args->{type} eq 'custom')
  {
    die "A custom map requires a map argument; an arrayref defining the map\n"
      unless exists $args->{map};
    $self->{tiles} = _build_tiles($args->{map});
  }
  else
  {
    die "$class->new requires a type argument (starter, random or custom)\n";
  }

  $self->{type} = $args->{type};
  $self->{intersections} = _build_intersections($self->{tiles});
  $self->{paths} = _build_paths($self->{intersections});
  return $self;
}

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

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

sub find_tile
{
  my ($self, $coordinates) = @_;

  die 'find_tile requires a coordinates arrayref of two integers'
    unless $coordinates && ref $coordinates eq 'ARRAY' && @$coordinates == 2;

  my $uuid = "$coordinates->[0],$coordinates->[1]";
  return $self->{tiles}{$uuid} || die "Tile $uuid not found!";
}

sub tiles_by_type_code
{
  my ($self, $type_code) = @_;

  die "tiles_by_type_code requires a type code letter"
    unless $type_code && $type_code =~ qr/^[A-Z]$/;

  my @tiles;
  for my $tile (values %{$self->{tiles}})
  {
    push(@tiles, $tile) if $tile->code eq $type_code;
  }
  return \@tiles;
}

sub tiles_by_resource_number
{
  my ($self, $number) = @_;

  die "tiles_by_resource_number requires a resource number"
    unless defined $number && $number =~ qr/^[0-9]+$/;

  my @tiles;
  for my $tile (values %{$self->{tiles}})
  {
    push(@tiles, $tile) if $tile->number == $number;
  }
  return \@tiles;
}

sub tiles_by_intersection
{
  my ($self, $intersection) = @_;

  die "tiles_by_intersection requires an intersection argument"
    unless $intersection && ref $intersection eq 'Catan::Map::Intersection';

  my @tiles;
  for my $tile (values %{$self->{tiles}})
  {
    push(@tiles, $tile) if $intersection->is_adjacent($tile);
  }
  return \@tiles;
}

sub find_intersection
{
  my ($self, $coordinates) = @_;
  die 'find_intersection requires an arrayref of 3 coordinates pairs'
    unless $coordinates && ref $coordinates eq 'ARRAY' && @$coordinates == 3;

  my @tiles;
  for (@$coordinates)
  {
    push @tiles, $self->find_tile($_);
  }
  my $uuid = Catan::Map::Intersection->new(\@tiles)->uuid;
  return $self->{intersections}{$uuid} || die "Intersection $uuid not found!";
}

sub find_path
{
  my ($self, $coordinates) = @_;
  die 'find_path requires an arrayref of two triples of coordinates pairs'
    unless $coordinates && ref $coordinates eq 'ARRAY' && @$coordinates == 2;

  my @intersections;
  for (@$coordinates)
  {
    push @intersections, $self->find_intersection($_);
  }
  my $uuid = Catan::Map::Path->new(\@intersections)->uuid;
  return $self->{paths}{$uuid} || die "Path $uuid not found!";
}

sub _build_tiles
{
  my ($map_plan) = @_;

  my %tiles = ();

  die 'build_tiles requires a arrayref of key/pairs describing the map'
    unless $map_plan && ref $map_plan eq 'ARRAY';

  for (@$map_plan)
  {
    my ($q, $r, $tile_code, $resource_number) = @$_;

    die 'Error building tiles, invalid resource number'
      unless !defined $resource_number # undef is valid
        || grep $resource_number == $_, @resource_numbers;


    my $tile_class = exists $tile_types{$tile_code}
      ? $tile_types{$tile_code}
      : die 'Error building tiles, invalid tile type';
    my $tile = $tile_class->new($q, $r, $resource_number);
    $tiles{$tile} = $tile;
  }
  return \%tiles;
}

sub _build_intersections
{
  my $map = shift;

  die '_building_intersections requires a hashref of 37 tiles'
    unless $map && ref $map eq 'HASH' && keys %$map == 37;

  my %intersections;
  my $centre_tile = $map->{"0,0"};

  die '_building_intersections requires a map with a centre tile'
    unless $centre_tile;

  for my $k (keys %$map)
  {
    my $tile1 = $map->{$k};

    for my $d (0..5)
    {
      my $tile2 = $map->{ $tile1->tile_neighbor_uuid($d) };
      my $tile3 = $map->{ $tile1->tile_neighbor_uuid($d + 1) };

      # avoid creating intersections that don't exist in map
      next unless $tile2 && $tile3;

      my $i  = Catan::Map::Intersection->new([$tile1, $tile2, $tile3]);
      $intersections{$i->uuid} = $i;
    }
  }
  return \%intersections;
}

sub _build_paths
{
  my $intersections = shift;

  die '_building_paths requires a hashref of 54 intersections'
    unless $intersections && ref $intersections eq 'HASH'
      && keys %$intersections == 54;

  my %paths;

  for my $i (keys %$intersections)
  {
    for my $j (keys %$intersections)
    {
      my $i1 = $intersections->{$i};
      my $i2 = $intersections->{$j};

      # skip colliding and non-adjacent
      next if $i1 eq $i2 || !$i1->is_adjacent($i2);
      my $p = Catan::Map::Path->new([$i1, $i2]);
      $paths{$p->uuid} = $p;
    }
  }
  return \%paths;
}

sub _starter
{
  return [
    [0,-3,"HR",undef],
    [1,-3,"S",undef],
    [2,-3,"HRW",undef],
    [3,-3,"S",undef],
    [3,-2,"HR",undef],
    [3,-1,"S",undef],
    [3,0,"HRG",undef],
    [2,1,"S",undef],
    [1,2,"HRB",undef],
    [0,3,"S",undef],
    [-1,3,"HRL",undef],
    [-2,3,"S",undef],
    [-3,3,"HR",undef],
    [-3,2,"S",undef],
    [-3,1,"HR",undef],
    [-3,0,"S",undef],
    [-2,-1,"HRO",undef],
    [-1,-2,"S",undef],
    [0,-2,"FO",11],
    [1,-2,"P",12],
    [2,-2,"F",9],
    [2,-1,"P",10],
    [2,0,"F",8],
    [1,1,"M",3],
    [0,2,"FO",6],
    [-1,2,"F",2],
    [-2,2,"M",5],
    [-2,1,"H",8],
    [-2,0,"D",undef],
    [-1,-1,"H",4],
    [0,-1,"M",6],
    [1,-1,"H",5],
    [1,0,"FO",4],
    [0,1,"P",9],
    [-1,1,"P",10],
    [-1,0,"FO",3],
    [0,0,"F",11]
  ];
}

sub _random
{
  # only the land tiles are random
  my @land_types = shuffle qw/H H H D F F F F FO FO FO FO P P P P M M M/;

  # make a local copy so we can mutate it
  my @local_resource_numbers = @resource_numbers;

  my $type       = shift @land_types;
  my $number     = $type eq 'D' ? undef : pop @local_resource_numbers;
  my @land_tiles = ([0, 0, $type, $number]);

  while (scalar @land_types)
  {
    my $i = 0;
    my @new_tiles = ();
    for my $tile (@land_tiles)
    {
      my $hex = Math::HexGrid::Hex->new($tile->[0], $tile->[1]);

      for my $direction (map { $_ + (2*$hex->hex_length) - $i } reverse 5..10)
      {
        my $neighbor = $hex->hex_neighbor($direction);

        # skip neighbors we already have
        next if grep($neighbor->{q} == $_->[0] && $neighbor->{r} == $_->[1],
          @land_tiles, @new_tiles);

        my $type = shift @land_types;
        # pop the number as we're working inside out instead of outside in
        my $number = $type eq 'D' ? undef : pop @local_resource_numbers;
        push @new_tiles, [$neighbor->{q}, $neighbor->{r}, $type, $number];
      }
      $i++;
    }
    push @land_tiles, @new_tiles;
  }

  my @tiles = (
    [0,-3,"HR",undef],
    [1,-3,"S",undef],
    [2,-3,"HRW",undef],
    [3,-3,"S",undef],
    [3,-2,"HR",undef],
    [3,-1,"S",undef],
    [3,0,"HRG",undef],
    [2,1,"S",undef],
    [1,2,"HRB",undef],
    [0,3,"S",undef],
    [-1,3,"HRL",undef],
    [-2,3,"S",undef],
    [-3,3,"HR",undef],
    [-3,2,"S",undef],
    [-3,1,"HR",undef],
    [-3,0,"S",undef],
    [-2,-1,"HRO",undef],
    [-1,-2,"S",undef],
  );
  push @tiles, @land_tiles;
  return \@tiles;
}
1;

__END__