File Coverage

lib/Settlers/Map.pm

Criterion	Covered	Total	%
statement	168	170	98.8
branch	37	54	68.5
condition	31	66	46.9
subroutine	30	31	96.7
pod	0	12	0.0
total	266	333	79.8

package Settlers::Map;
$Settlers::Map::VERSION = '0.07';
use strict;
use warnings;
use Settlers::Map::Tile;
use Settlers::Map::Intersection;
use Settlers::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   => 'Settlers::Map::Tile::Desert',
 F   => 'Settlers::Map::Tile::Fields',
 FO  => 'Settlers::Map::Tile::Forest',
 H   => 'Settlers::Map::Tile::Hills',
 M   => 'Settlers::Map::Tile::Mountains',
 P   => 'Settlers::Map::Tile::Pastures',
 S   => 'Settlers::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->{schema} = $self->_starter;
    $self->{tiles} = _build_tiles($self->{schema}{tiles});
  }
  elsif ($args->{type} eq 'random')
  {
    $self->{schema} = $self->_random;
    $self->{tiles} = _build_tiles($self->{schema}{tiles});
  }
  elsif ($args->{type} eq 'custom')
  {
    die "A custom map requires a schema containing the tiles and harbor data (see https://github.com/dnmfarrell/Settlers-Game-Notation)\n"
      unless exists $args->{schema}{tiles} && exists $args->{schema}{harbors};
    $self->{schema} = $args->{schema};
    $self->{tiles} = _build_tiles($args->{schema}{tiles});
  }
  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});
  $self->{harbors} = $self->build_harbors($self->{schema}{harbors});
  return $self;
}

sub schema  { $_[0]->{schema} }
sub harbors { $_[0]->{harbors} }
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 'Settlers::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 = Settlers::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 = Settlers::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  = Settlers::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 = Settlers::Map::Path->new([$i1, $i2]);
      $paths{$p->uuid} = $p;
    }
  }
  return \%paths;
}

my %harbor_types = (
  HR  => 'Generic Harbor',
  HRB => 'Brick Harbor',
  HRG => 'Grain Harbor',
  HRL => 'Lumber Harbor',
  HRO => 'Ore Harbor',
  HRW => 'Wool Harbor',
);

sub build_harbors
{
  my ($self, $harbors) = @_;
  die 'build_harbors requires an arrayref of arrays of paths and harbor types'
    unless $harbors && ref $harbors eq 'ARRAY';

  my @harbors  = ();
  for my $pair (@$harbors)
  {
    my ($coordinates, $code) = @$pair;
    my $path = $self->find_path($coordinates);
    die "invalid harbor code!\n" unless exists $harbor_types{$code};
    push @harbors, { code => $code, location => $path };
  }
  return \@harbors;
}

sub _starter
{
  return {
    tiles => [
      [0,-3,"S",undef],
      [1,-3,"S",undef],
      [2,-3,"S",undef],
      [3,-3,"S",undef],
      [3,-2,"S",undef],
      [3,-1,"S",undef],
      [3,0,"S",undef],
      [2,1,"S",undef],
      [1,2,"S",undef],
      [0,3,"S",undef],
      [-1,3,"S",undef],
      [-2,3,"S",undef],
      [-3,3,"S",undef],
      [-3,2,"S",undef],
      [-3,1,"S",undef],
      [-3,0,"S",undef],
      [-2,-1,"S",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]
    ],
    harbors => [
      [ [[[0,-3],[0,-2],[-1,-2]],  [[1,-3],[0,-2],[0,-3]]],   "HR"],
      [ [[[2,-3],[1,-2],[1,-3]],   [[2,-3],[2,-2],[1,-2]]],   "HRW"],
      [ [[[3,-2],[2,-1],[2,-2]],   [[3,-2],[3,-1],[2,-1]]],   "HR"],
      [ [[[3,-1],[3,0],[2,0]],     [[3,0],[2,1],[2,0]]],      "HR"],
      [ [[[2,1],[1,2],[1,1]],      [[1,1],[1,2],[0,2]]],      "HRB"],
      [ [[[0,2],[-1,3],[-1,2]],    [[-1,2],[-1,3],[-2,3]]],   "HRL"],
      [ [[[-2,2],[-2,3],[-3,3]],   [[-2,2],[-3,3],[-3,2]]],  "HR"],
      [ [[[-2,1],[-3,2],[-3,1]],   [[-2,0],[-2,1],[-3,1]]],   "HRG"],
      [ [[[-1,-1],[-2,0],[-2,-1]], [[-1,-2],[-1,-1],[-2,-1]]],"HRO"]
    ]
  };
}

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,"S",undef],
    [1,-3,"S",undef],
    [2,-3,"S",undef],
    [3,-3,"S",undef],
    [3,-2,"S",undef],
    [3,-1,"S",undef],
    [3,0,"S",undef],
    [2,1,"S",undef],
    [1,2,"S",undef],
    [0,3,"S",undef],
    [-1,3,"S",undef],
    [-2,3,"S",undef],
    [-3,3,"S",undef],
    [-3,2,"S",undef],
    [-3,1,"S",undef],
    [-3,0,"S",undef],
    [-2,-1,"S",undef],
    [-1,-2,"S",undef],
  );
  push @tiles, @land_tiles;

  my @harbors = (
      [ [[[0,-3],[0,-2],[-1,-2]],  [[1,-3],[0,-2],[0,-3]]],   "HR"],
      [ [[[2,-3],[1,-2],[1,-3]],   [[2,-3],[2,-2],[1,-2]]],   "HRW"],
      [ [[[3,-2],[2,-1],[2,-2]],   [[3,-2],[3,-1],[2,-1]]],   "HR"],
      [ [[[3,-1],[3,0],[2,0]],     [[3,0],[2,1],[2,0]]],      "HR"],
      [ [[[2,1],[1,2],[1,1]],      [[1,1],[1,2],[0,2]]],      "HRB"],
      [ [[[0,2],[-1,3],[-1,2]],    [[-1,2],[-1,3],[-2,3]]],   "HRL"],
      [ [[[-2,2],[-2,3],[-3,3]],   [[-2,2],[-3,3],[-3,2]]],  "HR"],
      [ [[[-2,1],[-3,2],[-3,1]],   [[-2,0],[-2,1],[-3,1]]],   "HRG"],
      [ [[[-1,-1],[-2,0],[-2,-1]], [[-1,-2],[-1,-1],[-2,-1]]],"HRO"]
    );
  return { tiles => \@tiles, harbors => \@harbors };
}
1;

__END__