File Coverage

lib/Catan/Game/Bank.pm
Criterion Covered Total %
statement 49 62 79.0
branch 8 18 44.4
condition 10 35 28.5
subroutine 11 15 73.3
pod 0 12 0.0
total 78 142 54.9


line stmt bran cond sub pod time code
1             package Catan::Game::Bank;
2             $Catan::Game::Bank::VERSION = '0.03';
3 5     5   57237 use strict;
  5         10  
  5         135  
4 5     5   39 use warnings;
  5         10  
  5         162  
5 5     5   25 use List::Util 'shuffle';
  5         15  
  5         4869  
6              
7             my %resource_table = (
8             B => 'Catan::Resource::Brick',
9             G => 'Catan::Resource::Grain',
10             L => 'Catan::Resource::Lumber',
11             O => 'Catan::Resource::Ore',
12             W => 'Catan::Resource::Wool',
13             );
14             eval "require $_" for values %resource_table;
15              
16 0     0 0 0 sub name { 'The Bank' }
17 780     780 0 3148 sub number { 'bank' }
18 575     575 0 1878 sub resources { $_[0]->{resources} }
19              
20             sub new
21             {
22 3     3 0 31 my ($class, $args) = @_;
23              
24 3         58 return bless {
25             deck => deck_build($args),
26             resources => resource_build($args),
27             }, $class;
28             }
29              
30 28     28 0 106 sub deck { $_[0]->{deck} }
31              
32 0     0 0 0 sub deck_remaining { scalar @{$_->{deck}} }
  0         0  
33              
34             sub deck_build
35             {
36 3     3 0 6 my $args = shift;
37              
38             # NB the 5-6 player game has 1 extra MO, RB, YP. 5 extra KN.
39 3         7 my (@codes);
40 3   33     38 push @codes, ($args->{knight_count} || ('KN') x 14);
41 3   33     26 push @codes, ($args->{vp_count} || ('VP') x 5);
42 3   33     42 push @codes, ($args->{monopoly_count} || ('MO') x 2);
43 3   33     21 push @codes, ($args->{road_building_count} || ('RB') x 2);
44 3   33     23 push @codes, ($args->{year_of_plenty_count}|| ('YP') x 2);
45              
46 3         157 return [shuffle @codes];
47             }
48              
49             sub deck_draw
50             {
51 9     9 0 20 my ($self, $type) = @_;
52 9 50       16 die 'no more development cards left!' unless @{$self->deck};
  9         26  
53              
54             # if the type of card is in the deck use it instead of drawing
55 9 100       25 if ($type)
56             {
57 8         10 my $has_found = undef;
58 8         15 $type = uc $type;
59 8         15 my @deck = ();
60 8         12 for (@{$self->deck})
  8         20  
61             {
62 172 100 100     477 if ($_ ne $type || $has_found)
63             {
64 164         278 push(@deck, $_);
65             }
66             else
67             {
68 8         16 $has_found = 1;
69             }
70             }
71 8 50       61 $self->{deck} = [$type, @deck] if $has_found;
72             }
73 9         26 return shift @{$self->deck};
  9         24  
74             }
75              
76             sub resource_build
77             {
78 3     3 0 7 my $args = shift;
79             # NB the 5-6 player game has 25 of each resource
80 3   50     21 my $count = $args->{resource_count} || 19;
81             return {
82 3         59 B => $count,
83             G => $count,
84             L => $count,
85             O => $count,
86             W => $count,
87             };
88             }
89              
90             sub resource_from_notation
91             {
92 168     168 0 249 my ($self, $resources) = @_;
93 168 50 33     827 die 'resource from notation requires a hashref of resource codes and amounts'
94             unless $resources && ref $resources eq 'HASH';
95              
96 168         253 my @resource_objects = ();
97              
98 168         430 for my $code (keys %$resources)
99             {
100 284         422 my $amount = $resources->{$code};
101 284         603 my $class = $resource_table{ uc $code };
102              
103 284 50       514 die "invalid resource code $_->{code}" unless $class;
104 284         957 push @resource_objects, $class->new($amount);
105             }
106 168         439 return \@resource_objects;
107             }
108              
109             sub resource_by_code
110             {
111 0     0 0   my ($self, $code) = @_;
112             die 'resource by code requires a valid resource code!'
113 0 0 0       unless $code && exists $resource_table{ uc $code };
114              
115 0           return $resource_table{uc $code};
116             }
117              
118             sub resource_concede
119             {
120 0     0 0   my ($self, $player, $details) = @_;
121 0 0 0       die 'resource_concede requires a player and resources hashref'
      0        
      0        
122             unless $player && $player->isa('Catan::Game::Player')
123             && $details && ref $details eq 'HASH';
124              
125 0           my $trade = Catan::Game::Trade->new($self, [$player], { $player->number => $details});
126              
127             # check all amounts are negative as the player is supposed to be CONCEDING resources
128 0           for (@{$trade->resources($player->number)})
  0            
129             {
130 0 0         die 'resource_concede amounts must be negative!' unless $_->amount < 0;
131             }
132 0           return $trade->execute;
133             }
134              
135             1;
136              
137             __END__