File Coverage

lib/Catan/Game.pm
Criterion Covered Total %
statement 148 633 23.3
branch 45 400 11.2
condition 4 178 2.2
subroutine 32 69 46.3
pod 0 50 0.0
total 229 1330 17.2


line stmt bran cond sub pod time code
1             package Catan::Game;
2             $Catan::Game::VERSION = '0.02';
3 2     2   35794 use strict;
  2         4  
  2         49  
4 2     2   27 use 5.20.0;
  2         8  
5 2     2   1468 use experimental qw/postderef signatures/;
  2         7897  
  2         13  
6 2     2   409 use warnings;
  2         3  
  2         50  
7 2     2   10 no warnings 'experimental';
  2         4  
  2         64  
8 2     2   880 use Catan::Event::Monopoly;
  2         6  
  2         56  
9 2     2   792 use Catan::Event::RoadBuilding;
  2         6  
  2         60  
10 2     2   857 use Catan::Event::Robber;
  2         7  
  2         64  
11 2     2   840 use Catan::Event::YearOfPlenty;
  2         6  
  2         58  
12 2     2   791 use Catan::Game::Bank;
  2         4  
  2         59  
13 2     2   826 use Catan::Game::Player;
  2         5  
  2         60  
14 2     2   14 use Catan::Game::Trade;
  2         2  
  2         44  
15 2     2   506 use Catan::Map;
  2         4  
  2         66  
16 2     2   1866 use Data::Dumper;
  2         14199  
  2         122  
17 2     2   1312 use Data::UUID;
  2         1431  
  2         139  
18 2     2   1990 use JSON::XS 'encode_json';
  2         11533  
  2         134  
19 2     2   14 use List::Util qw/all/;
  2         4  
  2         19543  
20              
21             #ABSTRACT: a class for managing games of Catan
22              
23             # valid phases
24             our @phases = qw/Setup Deployment Play End/;
25              
26             our %actions = (
27             BC => \&build_city,
28             BD => \&build_dc,
29             BR => \&build_road,
30             BS => \&build_settlement,
31             CH => \&chat,
32             CR => \&concede_resources,
33             DR => \&dice_roll,
34             GO => \&game_over,
35             LA => \&largest_army,
36             LR => \&longest_road,
37             MD => \&map_define,
38             MO => \&monopoly,
39             PA => \&player_add,
40             PD => \&play_dc,
41             PE => \&phase_end,
42             PS => \&phase_start,
43             RA => \&robber_activate,
44             RD => \&robber_deactivate,
45             RE => \&round_end,
46             RM => \&robber_move,
47             RP => \&resource_production,
48             RR => \&robber_rob,
49             RS => \&round_start,
50             TA => \&trade_accept,
51             TB => \&trade_bank,
52             TC => \&trade_cancel,
53             TE => \&turn_end,
54             TO => \&trade_offer,
55             TS => \&turn_start,
56             YP => \&year_of_plenty,
57             );
58              
59 1 50   1 0 1638 sub new ($class, $args = {})
  1 50       4  
  1 50       4  
  1         5  
60 1         2 {
61             my $self = bless {
62             bank => Catan::Game::Bank->new,
63             log => exists $args->{log} && ref $args->{log} eq 'GLOB' ? $args->{log} : undef,
64 1 50 33     10 map => undef,
65             max_players => 4,
66             max_victory_points => 10,
67             monopoly => undef,
68             phase_index => -1,
69             players => [],
70             road_building => undef,
71             round => 0,
72             trades => {},
73             turn_index => -1,
74             year_of_plenty => undef,
75             }, $class;
76              
77             # begin setup phase (and print to log if present)
78 1         7 $self->action('PS', {phase => 'setup'});
79              
80 1         9 return $self;
81             }
82              
83 11 50   11 0 36 sub action ($self, $action_code, $args = {})
  11 50       29  
  11 100       14  
  11         14  
  11         33  
84 11         12 {
85 11         20 my @action_history = ();
86              
87 11 50       36 if (!$action_code)
    100          
88             {
89 0         0 push @action_history, $self->chat({player => 'A', msg => "action requires an action code\n"});
90             }
91             elsif (exists $actions{$action_code})
92             {
93 10         13 my $results = eval { $actions{$action_code}->($self, $args) };
  10         63  
94 10 100       61 push @$results, $self->chat({player => 'A', msg => $@}) if $@;
95 10         32 push @action_history, @$results;
96             }
97             else
98             {
99 1         8 push @action_history, $self->chat({player => 'A', msg => "action type $action_code is unknown\n"});
100             }
101 11         33 $self->_log(\@action_history);
102 11         54 return \@action_history;
103             }
104              
105 0 0   0 0 0 sub build_road ($self, $args)
  0 0       0  
  0         0  
  0         0  
106 0         0 {
107 0         0 my $player_number = $args->{player};
108 0         0 my $location = $args->{path};
109              
110 0 0 0     0 die "deploy road requires player and path arguments!\n"
111             unless $player_number && $location;
112              
113 0 0       0 die "It is not player $player_number\'s turn!\n"
114             unless $self->is_players_turn($player_number);
115              
116 0 0       0 die "You can only build during the Deployment and Play phases\n"
117             unless $self->phase =~ /^(?:Deployment|Play)$/;
118              
119 0 0 0     0 die "Player $player_number has already deployed a road this turn!\n"
120             if $self->player->has_built_road && $self->phase eq 'Deployment';
121              
122             die "Player $player_number hasn't rolled the dice yet"
123             unless $self->phase eq 'Deployment' || $self->player->has_rolled_dice
124 0 0 0     0 || (defined $self->{road_building} && $self->{road_building}->can_build_road);
      0        
      0        
125              
126 0 0       0 die "Player $player_number must move the robber first\n"
127             if $self->robber->active;
128              
129 0 0       0 die "Invalid path\n" unless my $path = $self->map->find_path($location);
130              
131 0         0 for my $player (@{$self->players})
  0         0  
132             {
133             die "That path is occupied\n"
134 0 0       0 if grep($path->is_colliding($_->location), @{$player->roads});
  0         0  
135             }
136              
137             my $free = ($self->phase eq 'Deployment' ||
138 0 0 0     0 (defined $self->{road_building} && $self->{road_building}->can_build_road())) ? 1 : 0;
139 0         0 $self->player->road_build($path, $self->bank, $free);
140              
141 0         0 my @actions = ();
142             push @actions, { BR => { player => $player_number, path => $location }},
143 0         0 @{$self->longest_road};
  0         0  
144 0         0 return \@actions;
145             }
146              
147 0 0   0 0 0 sub longest_road ($self)
  0 0       0  
  0         0  
148 0         0 {
149 0         0 my @actions = ();
150              
151 0         0 my @properties = map { @{$_->properties} } @{$self->players};
  0         0  
  0         0  
  0         0  
152 0         0 my $players_by_road_length = {};
153 0         0 for (@{$self->players})
  0         0  
154             {
155 0         0 my $length = scalar @{$_->max_road_calculate(\@properties)};
  0         0  
156 0         0 push @{ $players_by_road_length->{ $length } }, $_;
  0         0  
157             }
158              
159 0         0 my $have_tested_leading_road;
160 0         0 for my $road_length (sort {$b <=> $a} keys %$players_by_road_length)
  0         0  
161             {
162 0         0 my @players = @{$players_by_road_length->{$road_length}};
  0         0  
163              
164 0         0 for my $player (@players)
165             {
166 0 0 0     0 if ($have_tested_leading_road)
    0 0        
167             {
168 0 0       0 $player->longest_road_toggle if $player->longest_road;
169             }
170             elsif (@players == 1 && $road_length >= 6 && !$player->longest_road)
171             {
172 0         0 $player->longest_road_toggle;
173 0         0 push @actions, { LR => {player => $player->number, length => $road_length}};
174             }
175             }
176 0         0 $have_tested_leading_road = 1;
177             }
178             # check for player victory from longest road
179 0 0       0 if (my $game_over = $self->game_over)
180             {
181 0         0 push @actions, @$game_over;
182             }
183 0         0 return \@actions;
184             }
185              
186 0 0   0 0 0 sub game_over ($self)
  0 0       0  
  0         0  
187 0         0 {
188 0 0       0 if (my $player = $self->player_victory_check)
189             {
190 0         0 return [{ GO => { player => $player->number } }, @{$self->phase_end}];
  0         0  
191             }
192             }
193              
194 0 0   0 0 0 sub build_settlement ($self, $args)
  0 0       0  
  0         0  
  0         0  
195 0         0 {
196 0         0 my $player_number = $args->{player};
197 0         0 my $location = $args->{intersection};
198              
199 0 0       0 die "You can only build during the Deployment and Play phases\n"
200             unless $self->phase =~ /^(?:Deployment|Play)$/;
201              
202 0 0 0     0 die "deploy settlement requires player and intersection arguments!\n"
203             unless $player_number && $location;
204              
205 0 0       0 die "It is not $player_number\'s turn!\n"
206             unless $self->is_players_turn($player_number);
207              
208 0 0 0     0 die "Player $player_number hasn't rolled the dice yet\n"
209             unless $self->phase eq 'Deployment' || $self->player->has_rolled_dice;
210              
211 0 0 0     0 die "Player $player_number has already deployed a settlement this turn!\n"
212             if $self->player->has_built_settlement && $self->phase eq 'Deployment';
213              
214 0 0       0 die "Player $player_number must move the robber first\n"
215             if $self->robber->active;
216              
217 0 0       0 die "Invalid intersection\n" unless my $intersection = $self->map->find_intersection($location);
218              
219 0         0 for my $player (@{$self->players})
  0         0  
220             {
221             die "That intersection is occupied or too close to another property\n"
222             unless 0 == grep(($intersection->is_colliding($_->location)
223 0 0 0     0 || $intersection->is_adjacent($_->location)), @{$player->properties});
  0         0  
224             }
225              
226 0 0       0 my $free = $self->phase eq 'Deployment' ? 1 : 0;
227 0         0 my $settlement = $self->player->settlement_build($intersection, $self->bank, $free);
228 0         0 my @actions = ({ BS => { player => $player_number, intersection => $location } });
229 0         0 $self->player->update_ratios($self->map); # in case they built next to a harbor
230              
231             # special resource production on deploying 2nd settlement
232 0 0 0     0 if ($self->phase eq 'Deployment' && $self->round == 2)
233             {
234 0         0 push @actions, @{$self->resource_production_deployment($settlement->location)};
  0         0  
235             }
236 0         0 push @actions, @{$self->longest_road};
  0         0  
237 0         0 return \@actions;
238             }
239              
240 0 0   0 0 0 sub build_city ($self, $args)
  0 0       0  
  0         0  
  0         0  
241 0         0 {
242 0         0 my $player_number = $args->{player};
243 0         0 my $location = $args->{intersection};
244              
245 0 0       0 die "You can only build during the Deployment and Play phases\n"
246             unless $self->phase =~ /^(?:Deployment|Play)$/;
247              
248 0 0 0     0 die "build settlement requires player and intersection arguments!\n"
249             unless $player_number && $location;
250              
251 0 0       0 die "It is not Player $player_number\'s turn!\n"
252             unless $self->is_players_turn($player_number);
253              
254 0 0       0 die "Player $player_number hasn't rolled the dice yet\n"
255             unless $self->player->has_rolled_dice;
256              
257 0 0       0 die "Player $player_number must move the robber first\n"
258             if $self->robber->active;
259              
260 0 0       0 die "Invalid intersection\n" unless my $intersection = $self->map->find_intersection($location);
261              
262 0         0 $self->player->city_build($intersection, $self->bank);
263 0         0 return [{ BC => { player => $player_number, intersection => $location } }];
264             }
265              
266 0 0   0 0 0 sub build_dc ($self, $args)
  0 0       0  
  0         0  
  0         0  
267 0         0 {
268 0         0 my $player_number = $args->{player};
269 0         0 my $type = $args->{type};
270              
271 0 0       0 die "You can only build during the Deployment and Play phases\n"
272             unless $self->phase =~ /^(?:Deployment|Play)$/;
273              
274 0 0       0 die "deploy settlement requires a player argument!\n"
275             unless $player_number;
276              
277 0 0       0 die "It is not $player_number\'s turn!\n"
278             unless $self->player->number == $player_number;
279              
280 0 0       0 die "Player $player_number hasn't rolled the dice yet\n"
281             unless $self->player->has_rolled_dice;
282              
283 0 0       0 die "Player $player_number must move the robber first\n"
284             if $self->robber->active;
285              
286 0         0 my $card = $self->player->development_card_build($self->bank->deck_draw($type), $self->bank);
287 0         0 return [{ BD => { player => $player_number, type => $card->type } }];
288             }
289              
290 0 0   0 0 0 sub play_dc ($self, $args)
  0 0       0  
  0         0  
  0         0  
291 0         0 {
292 0         0 my $player_number = $args->{player};
293 0         0 my $type = $args->{type};
294              
295 0 0 0     0 die "play development card requires player and development card type arguments!\n"
296             unless $player_number && $type;
297              
298 0 0       0 die "You can only play development cards during the Play phase\n"
299             unless $self->phase eq 'Play';
300              
301 0 0       0 die "It is not Player $player_number\'s turn!\n"
302             unless $self->is_players_turn($player_number);
303              
304 0 0       0 die "Player $player_number has already played a development card this turn!\n"
305             if $self->player->has_played_dc;
306              
307 0 0       0 die "Player $player_number must move the robber first\n"
308             if $self->robber->active;
309              
310 0         0 my $card = $self->player->development_card_play($type);
311              
312 0         0 my @actions = ();
313 0         0 push @actions, { PD => { player => $player_number, type => $card->type } };
314              
315 0 0       0 if ($card->type eq 'KN')
    0          
    0          
    0          
316             {
317 0         0 $self->player->add_knight;
318 0         0 push @actions, @{$self->robber_activate({from_7 => undef})},
319 0         0 @{$self->largest_army};
  0         0  
320             }
321             elsif ($card->type eq 'YP')
322             {
323 0         0 $self->{year_of_plenty} = Catan::Event::YearOfPlenty->new;
324             }
325             elsif ($card->type eq 'MO')
326             {
327 0         0 $self->{monopoly} = Catan::Event::Monopoly->new();
328             }
329             elsif ($card->type eq 'RB')
330             {
331 0         0 $self->{road_building} = Catan::Event::RoadBuilding->new($self->player);
332             }
333             else
334             {
335 0         0 die sprintf "Invalid development card type %s\n", $card->type;
336             }
337              
338 0         0 return \@actions;
339             }
340              
341             sub largest_army
342             {
343 0     0 0 0 my $self = shift;
344              
345             # largest army is the player who has played at least 3 knights
346             # and more knights than any other player
347 0         0 my %players_by_knights;
348 0         0 for (@{$self->players})
  0         0  
349             {
350 0         0 push @{$players_by_knights{ $_->knights }}, $_;
  0         0  
351             }
352              
353 0         0 my @actions = ();
354 0         0 my $have_tested_leaders;
355 0         0 for my $knights_played (sort {$b <=> $a} keys %players_by_knights)
  0         0  
356             {
357 0         0 my @players = @{$players_by_knights{$knights_played}};
  0         0  
358              
359 0         0 for my $player (@players)
360             {
361 0 0 0     0 if ($have_tested_leaders)
    0 0        
362             {
363 0 0       0 $player->largest_army->toggle if $player->largest_army;
364             }
365             elsif (@players == 1 && $knights_played >= 3 && !$player->largest_army)
366             {
367 0         0 $player->largest_army_toggle;
368 0         0 push @actions, {LA => {player => $player->number, strength => $knights_played}};
369             }
370             }
371 0         0 $have_tested_leaders = 1;
372             }
373              
374             # check for player victory
375 0 0       0 if (my $game_over = $self->game_over)
376             {
377 0         0 push @actions, @$game_over;
378             }
379 0         0 return \@actions;
380             }
381              
382 0 0   0 0 0 sub monopoly ($self, $args)
  0 0       0  
  0         0  
  0         0  
383 0         0 {
384 0         0 my $player_number = $args->{player};
385 0         0 my $code = $args->{resource_code};
386              
387 0 0 0     0 die "Monopoly requires player and resource code arguments!\n"
388             unless $player_number && $code;
389              
390 0 0       0 die "It is not Player $player_number\'s turn!\n"
391             unless $self->is_players_turn($player_number);
392              
393             die "Player $player_number does not have a monopoly!\n"
394 0 0       0 unless defined $self->{monopoly};
395              
396 0 0       0 die "Player $player_number must move the robber first\n"
397             if $self->robber->active;
398              
399 0         0 my $resources = $self->{monopoly}->calculate($player_number, $code, $self->players, $self->bank);
400 0         0 undef $self->{monopoly};
401              
402 0         0 return [{MO => {resources => $resources} }];
403             }
404              
405 0 0   0 0 0 sub year_of_plenty ($self, $args)
  0 0       0  
  0         0  
  0         0  
406 0         0 {
407 0         0 my $player_number = $args->{player};
408 0         0 my $resources = $args->{resources};
409              
410 0 0 0     0 die "Year of Plenty requires player and resource arguments!\n"
      0        
411             unless $player_number && $resources && ref $resources eq 'HASH';
412              
413 0 0       0 die "It is not Player $player_number\'s turn!\n"
414             unless $self->is_players_turn($player_number);
415              
416             die "Player $player_number does not have year of plenty!\n"
417 0 0       0 unless defined $self->{year_of_plenty};
418              
419 0         0 my $trade = Catan::Game::Trade->new($self->bank, $self->players, $resources, 1);
420              
421 0         0 $self->{year_of_plenty}->validate($trade);
422 0         0 $trade->execute;
423 0         0 undef $self->{year_of_plenty};
424              
425 0         0 return [{YP => {resources => $trade->as_hashref} }];
426             }
427              
428 2 50   2 0 7 sub phase_start ($self, $args = {})
  2 50       6  
  2 100       5  
  2         5  
429 2         5 {
430 2 50       14 die "The end phase is the last phase!\n" if $self->{phase_index} == $#phases;
431              
432 2         6 my $new_phase = $phases[ ++$self->{phase_index} ];
433              
434             # reset the round and turns counters
435 2         4 $self->{round} = 0;
436 2         4 $self->{turn_index} = -1;
437              
438 2         8 my @actions = ({PS => {phase => $new_phase}});
439              
440             # deploy the robber, start deployment round 1
441 2 100       8 if ($new_phase eq 'Deployment')
    50          
442             {
443 1         3 push @actions, @{$self->robber_setup}, @{$self->round_start};
  1         4  
  0         0  
444             }
445             elsif ($new_phase eq 'Play')
446             {
447 0         0 push @actions, @{$self->round_start};
  0         0  
448             }
449 1         3 return \@actions;
450             }
451              
452 0 0   0 0 0 sub concede_resources ($self, $args)
  0 0       0  
  0         0  
  0         0  
453 0         0 {
454 0         0 my $player_number = $args->{player};
455 0         0 my $resources = $args->{resources};
456 0         0 my $player = $self->player_by_number($player_number);
457              
458             die "Concede resources requires player and resource argument for 1 player!\n"
459             unless $player && $resources && ref $resources eq 'HASH'
460             && (1 == keys %$resources)
461             && (exists $resources->{$player_number})
462 0     0   0 && (all { $_ < 0 } values %{$resources->{$player_number}})
  0         0  
463 0 0 0     0 && (1 == grep($player_number == $_->{player}->number, @{$self->robber->check_players_to_concede}));
  0   0     0  
      0        
      0        
      0        
      0        
464              
465 0         0 my @actions = ();
466              
467 0         0 my $trade = Catan::Game::Trade->new($self->bank, $self->players, $resources, 1);
468 0         0 my $summary = $trade->execute;
469              
470 0         0 push @actions, {CR => { player => $player_number, resources => $summary }};
471              
472 0         0 my $msg;
473 0         0 for (@{$self->robber->check_players_to_concede})
  0         0  
474             {
475             $msg .= sprintf "Player %d must concede %d resources. ",
476 0         0 $_->{player}->number, ($_->{player}->resource_total - $_->{target_total});
477             }
478 0 0       0 push(@actions, $self->chat({player => 'A', msg => $msg})) if $msg;
479              
480 0         0 return \@actions;
481             }
482              
483 6 50   6 0 17 sub chat ($self,$args)
  6 50       15  
  6         9  
  6         9  
484 6         7 {
485 6         11 my $player_number = $args->{player};
486 6         10 my $msg = $args->{msg};
487              
488 6 50 33     39 die "Chat requires player and msg arguments\n"
      33        
489             unless ($player_number eq 'A' || $self->is_player_number($player_number)) && $msg;
490              
491 6         30 return { CH => {player => $player_number, msg => $msg} };
492             }
493              
494 1 50   1 0 5 sub robber_setup ($self, $args = {})
  1 50       3  
  1 50       3  
  1         4  
495 1         2 {
496 1         4 $self->{robber} = Catan::Event::Robber->new({map => $self->map});
497 0         0 return [ { RM => $self->robber->location->uuid } ];
498             }
499              
500 0 0   0 0 0 sub robber_activate ($self, $args = {})
  0 0       0  
  0 0       0  
  0         0  
501 0         0 {
502 0         0 my @actions = ({ RA => undef });
503              
504 0 0       0 my $players = $args->{from_7} ? $self->players : [];
505              
506 0         0 my $msg;
507 0         0 for (@{$self->robber->activate($players)})
  0         0  
508             {
509             $msg .= sprintf "Player %d must concede %d resources. ",
510 0         0 $_->{player}->number, ($_->{player}->resource_total - $_->{target_total});
511             }
512 0 0       0 push(@actions, $self->chat({player => 'A', msg => $msg})) if $msg;
513 0         0 return \@actions;
514             }
515              
516 0 0   0 0 0 sub robber_deactivate ($self, $args = {})
  0 0       0  
  0 0       0  
  0         0  
517 0         0 {
518 0         0 $self->robber->deactivate;
519 0         0 return [ { RD => undef } ];
520             }
521              
522             # steal and deactivate
523 0 0   0 0 0 sub robber_rob ($self, $args)
  0 0       0  
  0         0  
  0         0  
524 0         0 {
525 0         0 my $player = $self->player_by_number($args->{player});
526 0         0 my $target_player = $self->player_by_number($args->{target_player});
527 0         0 my $code = $args->{code};
528              
529 0 0 0     0 die "robber steal requires a player and target player arguments\n"
530             unless $player && $target_player;
531              
532 0 0       0 die "It is not $player\'s turn\n" unless $self->is_players_turn($player->number);
533              
534 0   0     0 $code ||= $self->robber->steal($target_player);
535 0         0 my $trade = Catan::Game::Trade->new($self->bank, $self->players, {
536             $target_player->number=> {$code =>-1},
537             $player->number => {$code => 1},
538             });
539 0         0 $trade->execute;
540 0         0 $self->robber->deactivate;
541             return [
542 0         0 { RR => $trade->as_hashref },
543             { RD => undef },
544             ];
545             }
546              
547 0 0   0 0 0 sub robber_move ($self, $args)
  0 0       0  
  0         0  
  0         0  
548 0         0 {
549 0         0 my $player_number = $args->{player};
550 0         0 my $location = $args->{tile};
551              
552 0 0 0     0 die "build settlement requires player and tile arguments!\n"
553             unless $player_number && $location;
554              
555 0 0       0 die "It is not player $player_number\'s turn!"
556             unless $player_number == $self->player->number;
557              
558 0         0 my $tile = $self->map->find_tile($location);
559              
560 0         0 $self->robber->move($tile, $self->players);
561 0         0 my @actions;
562 0         0 push @actions, { RM => { tile => $tile->uuid} };
563              
564             # robber will deactivate if there are no eligible players
565             # to steal from
566 0 0       0 push @actions, { RD => undef } unless $self->robber->active;
567 0         0 return \@actions;
568             }
569              
570 1 50   1 0 5 sub phase_end ($self, $args = {})
  1 50       4  
  1 50       2  
  1         7  
571 1         2 {
572 1         4 return [ { PE => {phase => $self->phase} }, @{$self->phase_start} ];
  1         4  
573             }
574              
575 0 0   0 0 0 sub round_start ($self, $args = {})
  0 0       0  
  0 0       0  
  0         0  
576 0         0 {
577 0         0 return [ { RS => {round => ++$self->{round}} }, @{$self->turn_start} ];
  0         0  
578             }
579              
580 0 0   0 0 0 sub round_end ($self, $args = {})
  0 0       0  
  0 0       0  
  0         0  
581 0         0 {
582 0         0 $_->actions_clear for (@{$self->players});
  0         0  
583              
584             # 2 round limit on deployment phase
585 0 0 0     0 if ($self->phase eq 'Deployment' && $self->round == 2)
586             {
587 0         0 return [ { RE => {round => $self->round}}, @{$self->phase_end} ];
  0         0  
588             }
589 0         0 return [ { RE => {round => $self->round}}, @{$self->round_start} ];
  0         0  
590             }
591              
592 0 0   0 0 0 sub turn_start ($self, $args = {})
  0 0       0  
  0 0       0  
  0         0  
593 0         0 {
594 0 0       0 die "cannot start turn during setup\n" if $self->phase eq 'Setup';
595              
596 0 0 0     0 if ($self->turn == 0)
    0 0        
    0 0        
    0 0        
597             {
598 0         0 $self->{turn_index}++;
599             }
600             # if its the last players turn in deployment
601             # & they haven't deployed 2 settlements
602             # it's their turn again
603             elsif ($self->phase eq 'Deployment'
604 0         0 && $self->turn == @{$self->players}
605 0         0 && @{$self->player->settlements} == 1)
606             {
607 0         0 $self->{turn_index} = $self->{turn_index};
608             }
609             # if its deployment and the current player
610             # has deployed 2 settlements
611             # switch to the previous player
612             elsif ($self->phase eq 'Deployment'
613 0         0 && @{$self->player->settlements} == 2)
614             {
615 0         0 $self->{turn_index}--;
616             }
617             elsif ($self->phase eq 'Play'
618 0         0 && $self->{turn_index} + 1 == @{$self->players})
619             {
620 0         0 $self->{turn_index} = 0;
621             }
622             else
623             {
624 0         0 $self->{turn_index}++;
625             }
626              
627 0         0 my @actions = ({ TS => {player => $self->player->number}});
628 0         0 return \@actions;
629             }
630              
631 0 0   0 0 0 sub turn_end ($self, $args = {})
  0 0       0  
  0 0       0  
  0         0  
632 0         0 {
633 0         0 my $player_number = $args->{player};
634              
635 0 0       0 die "It is not Player $player_number\'s turn!\n"
636             unless $self->is_players_turn($player_number);
637              
638 0 0 0     0 die "Player $player_number hasn't rolled the dice yet\n"
639             unless $self->phase eq 'Deployment' || $self->player->has_rolled_dice;
640              
641 0 0 0     0 die "Player has not built a road and a settlement\n"
      0        
642             if $self->phase eq 'Deployment'
643             && !($self->player->has_built_road && $self->player->has_built_settlement);
644              
645 0         0 my @actions = ();
646              
647 0 0       0 if ($self->robber->active)
648             {
649 0         0 $self->robber->deactivate;
650 0         0 push @actions, { RD => undef };
651             }
652              
653             # clear outstanding events, open trades
654 0         0 $self->trades_clear;
655 0         0 undef $self->{monopoly};
656 0         0 undef $self->{road_building};
657 0         0 undef $self->{year_of_plenty};
658              
659 0         0 push @actions, { TE => {player => $self->player->number }};
660              
661             # if it's the last players turn
662             # or its development phase & the current player has two properties
663             # and it's player #1
664 0 0 0     0 if (($self->turn == @{$self->players}
  0   0     0  
      0        
      0        
      0        
      0        
      0        
665             && $self->phase eq 'Play')
666             || ($self->phase eq 'Deployment'
667 0         0 && @{$self->player->properties} == 2
668             && $self->turn == 1)
669             || ($self->phase eq 'Deployment'
670 0         0 && @{$self->player->properties} == 1
671 0         0 && $self->turn == @{$self->players}))
672             {
673 0         0 push @actions, @{$self->round_end};
  0         0  
674             }
675             # else move to the next player
676             else
677             {
678 0         0 push @actions, @{$self->turn_start};
  0         0  
679             }
680 0         0 return \@actions;
681             }
682              
683 0 0   0 0 0 sub player_victory_check ($self, $args = {})
  0 0       0  
  0 0       0  
  0         0  
684 0         0 {
685             my @players_by_vps = sort {
686 0         0 $b->victory_points_count <=> $a->victory_points_count } @{$self->players};
  0         0  
  0         0  
687              
688 0 0       0 return $players_by_vps[0] if $players_by_vps[0]->victory_points_count >= 10;
689             }
690              
691 5 50   5 0 14 sub player_add ($self, $args = {})
  5 50       12  
  5 50       7  
  5         12  
692 5         6 {
693 5 50       16 die "cannot add player outside of setup phase\n" unless $self->phase eq 'Setup';
694             die "cannot add player as max players has been reached\n"
695 5 100       10 unless $self->{max_players} > @{$self->players};
  5         13  
696              
697 4         53 my $number = @{$self->players} + 1;
  4         10  
698 4         29 my $player = Catan::Game::Player->new({number => "$number"});
699 4         10 push @{$self->players}, $player;
  4         9  
700 4         14 return [{PA => {player => $player->number} }];
701             }
702              
703 0 0   0 0 0 sub dice_roll ($self, $args)
  0 0       0  
  0         0  
  0         0  
704 0         0 {
705 0         0 my $player_number = $args->{player};
706              
707 0 0       0 die "It is not Player $player_number\'s turn\n"
708             unless $self->is_players_turn($player_number);
709              
710 0         0 my $dice_roll = $self->player->roll_dice($args->{result});
711 0         0 my @actions = ({ DR => {player => $self->player->number, result => $dice_roll} });
712              
713             # trigger robber action
714 0 0       0 if ($dice_roll == 7)
715             {
716 0         0 push @actions, @{$self->robber_activate({from_7 => 1})};
  0         0  
717             }
718             else
719             {
720 0         0 push @actions, @{$self->resource_production({resource_number => $dice_roll})};
  0         0  
721             }
722 0         0 return \@actions;
723             }
724              
725 0 0   0 0 0 sub resource_production ($self, $args)
  0 0       0  
  0         0  
  0         0  
726 0         0 {
727 0         0 my %resources = ();
728 0         0 my $tiles = $self->map->tiles_by_resource_number($args->{resource_number});
729              
730 0         0 for my $tile (@$tiles)
731             {
732             # the robber prevents resource production
733 0 0       0 next if $self->robber->location->uuid eq $tile->uuid;
734              
735 0         0 for my $player (@{$self->players})
  0         0  
736             {
737 0         0 for my $property (@{$player->properties})
  0         0  
738             {
739 0 0       0 if ($property->location->is_adjacent($tile))
740             {
741             # update the player and bank resource amounts
742 0 0       0 my $amount = $property->isa('Catan::Asset::Settlement') ? 1 : 2;
743 0 0       0 next unless my $resource = $tile->yields($amount);
744 0         0 $resources{$player->number}{$resource->code} += $amount;
745             }
746             }
747             }
748             }
749 0         0 for my $player (@{$self->players})
  0         0  
750             {
751 0 0       0 if (exists $resources{$player->number})
752             {
753             my $trade = Catan::Game::Trade->new(
754 0         0 $self->bank, $self->players, {$player->number => $resources{$player->number}}, 1);
755 0         0 my $results = $trade->execute;
756 0         0 for (keys %{$results->{$self->bank->number}})
  0         0  
757             {
758 0         0 $resources{$self->bank->number}{$_} += $results->{$self->bank->number}{$_};
759             }
760             }
761             }
762 0         0 return [{ RP => {resources => \%resources} }];
763             }
764              
765             # during deployment each player collects adjacent resources for their 2nd property
766 0 0   0 0 0 sub resource_production_deployment ($self, $intersection)
  0 0       0  
  0         0  
  0         0  
767 0         0 {
768 0         0 my %resources = ();
769              
770 0         0 for my $tile (@{$self->map->tiles_by_intersection($intersection)})
  0         0  
771             {
772             # update the player and bank resource amounts
773 0         0 my $resource = $tile->yields(1);
774             # sea tiles don't give out!
775 0 0       0 next unless $resource;
776              
777 0         0 $resources{$self->player->number}{$resource->code} += 1;
778             }
779 0         0 my $trade = Catan::Game::Trade->new($self->bank, $self->players, \%resources, 1);
780 0         0 $trade->execute;
781 0         0 return [{ RP => {resources => \%resources} }];
782             }
783              
784 0 0   0 0 0 sub trade_offer ($self, $args)
  0 0       0  
  0         0  
  0         0  
785 0         0 {
786 0         0 my $offering_player = $args->{player};
787 0         0 my $details = $args->{resources};
788 0   0     0 my $uuid = $args->{uuid} || Data::UUID->new->create_str;
789              
790 0 0       0 die "Offer is not for current player!\n"
791             unless grep($self->player->number == $_, keys %$details);
792              
793 0 0       0 die "Offer does not include offering player!\n"
794             unless grep($offering_player == $_, keys %$details);
795              
796 0 0       0 die "Player $offering_player hasn't rolled the dice yet\n"
797             unless $self->player->has_rolled_dice;
798              
799 0 0       0 die "UUID $uuid is not unique!\n" if exists $self->trades->{$uuid};
800              
801 0         0 my $trade = Catan::Game::Trade->new($self->bank, $self->players, $details);
802 0         0 my $trade_offer = {
803             trade => $trade,
804             uuid => $uuid,
805             player => $offering_player,
806             };
807 0         0 $self->trade_add($trade_offer);
808 0         0 return [{TO => { player => $offering_player, uuid => $uuid, resources => $details}}];
809             }
810              
811 0 0   0 0 0 sub trade_bank ($self, $args)
  0 0       0  
  0         0  
  0         0  
812 0         0 {
813 0         0 my $player_number = $args->{player};
814 0         0 my $details = $args->{resources};
815              
816 0 0 0     0 die "Offer is not for current player!\n"
817             unless grep($self->player->number == $_, keys %$details)
818             && $player_number == $self->player->number;
819              
820 0         0 my $trade = Catan::Game::Trade->new($self->bank, $self->players, $details);
821 0         0 my $resources = $trade->execute;
822 0         0 return [{TB => {resources => $resources} }];
823             }
824              
825 0 0   0 0 0 sub trade_add ($self, $trade)
  0 0       0  
  0         0  
  0         0  
826 0         0 {
827 0         0 $self->{trades}{$trade->{uuid}} = $trade;
828             }
829              
830 0 0   0 0 0 sub trades_clear ($self)
  0 0       0  
  0         0  
831 0         0 {
832 0         0 $self->{trades} = {};
833             }
834              
835 0     0 0 0 sub trades { $_[0]->{trades} }
836              
837 0 0   0 0 0 sub trade_accept ($self, $args)
  0 0       0  
  0         0  
  0         0  
838 0         0 {
839 0         0 my $player_number = $args->{player};
840 0   0     0 my $uuid = $args->{uuid} || '';
841              
842             die "Player $player_number does not have an active trade with uuid: $uuid\n"
843             unless $player_number
844             && $uuid && exists $self->trades->{$uuid}
845             && $self->trades->{$uuid}{player} != $player_number
846 0 0 0     0 && $self->trades->{$uuid}{trade}->resources($player_number);
      0        
      0        
      0        
847              
848 0         0 my @actions = ();
849 0         0 push @actions, { TA => {player => $player_number, uuid => $uuid} };
850 0         0 my $trade = $self->trades->{$uuid}{trade};
851 0         0 my $details = $trade->execute;
852 0         0 push @actions, { TR => { resources => $details }};
853 0         0 delete $self->trades->{$uuid};
854 0         0 return \@actions;
855             }
856              
857 0 0   0 0 0 sub trade_cancel ($self, $args)
  0 0       0  
  0         0  
  0         0  
858 0         0 {
859 0         0 my $player_number = $args->{player};
860 0   0     0 my $uuid = $args->{uuid} || '';
861              
862             die "Player $player_number does not have an active trade with uuid: $uuid\n"
863             unless $player_number
864             && $uuid && exists $self->trades->{$uuid}
865             && $self->trades->{$uuid}{player} == $player_number
866 0 0 0     0 && $self->trades->{$uuid}{trade}->resources($player_number);
      0        
      0        
      0        
867              
868 0         0 delete $self->trades->{$uuid};
869 0         0 return [{TC => {player => $player_number, uuid => $uuid}}];
870             }
871              
872 1 50   1 0 12 sub starter_map ($self)
  1 50       4  
  1         2  
873 1         2 {
874 1         5 $self->action('MD', Catan::Map->_starter);
875             }
876              
877 1 50   1 0 5 sub random_map ($self)
  1 50       4  
  1         3  
878 1         1 {
879 1         10 $self->action('MD', Catan::Map->_random);
880             }
881              
882 3 50   3 0 9 sub map_define ($self, $map)
  3 50       11  
  3         4  
  3         4  
883 3         4 {
884 3 50       9 die "map can only be defined during setup phase\n" unless $self->phase eq 'Setup';
885 3         17 $self->{map} = Catan::Map->new({type => 'custom', map => $map});
886 0         0 return [{MD => $map}];
887             }
888              
889 1     1 0 167 sub robber { $_[0]->{robber} }
890 13     13 0 39 sub players{ $_[0]->{players} }
891 0     0 0 0 sub player { $_[0]->{players}[$_[0]->{turn_index}] }
892 0     0 0 0 sub bank { $_[0]->{bank} }
893 1     1 0 13 sub map { $_[0]->{map} }
894 9     9 0 35 sub phase { $phases[$_[0]->{phase_index}] }
895 0     0 0 0 sub round { $_[0]->{round} }
896 0     0 0 0 sub turn { $_[0]->{turn_index} + 1 }
897              
898 0 0   0 0 0 sub player_by_number ($self, $number)
  0 0       0  
  0         0  
  0         0  
899 0         0 {
900 0 0       0 die "player_by_number requires a number argument!\n" unless $number;
901 0         0 my @player = grep ($number == $_->number, @{$self->players});
  0         0  
902 0 0       0 die "No players with nnumber $number found!\n" unless @player;
903 0         0 return $player[0];
904             }
905              
906 0 0   0 0 0 sub is_players_turn ($self, $number)
  0 0       0  
  0         0  
  0         0  
907 0         0 {
908 0 0       0 die "is_players_turn requires a number argument!\n" unless $number;
909 0         0 return $self->player->number == $number;
910             }
911              
912             sub _log
913             {
914 11     11   21 my ($self, $msgs) = @_;
915 11 50 33     54 die "log requires an arrayref of msgs\n" unless $msgs && ref $msgs eq 'ARRAY';
916 11 50       32 return unless my $fh = $self->{log};
917 11         119 say $fh encode_json($_) for @$msgs;
918             }
919              
920             1;
921              
922             __END__