File Coverage

blib/lib/Mafia.pm
Criterion Covered Total %
statement 144 235 61.2
branch 31 66 46.9
condition 25 58 43.1
subroutine 34 57 59.6
pod 17 26 65.3
total 251 442 56.7


line stmt bran cond sub pod time code
1             package Mafia;
2              
3 1     1   35362 use 5.010001;
  1         4  
4 1     1   6 use strict;
  1         1  
  1         30  
5 1     1   6 use warnings;
  1         6  
  1         50  
6 1     1   693 use parent qw/Exporter/;
  1         337  
  1         5  
7              
8 1     1   61 use constant;
  1         1  
  1         42  
9 1     1   838 use Storable qw/dclone/;
  1         4194  
  1         227  
10              
11             our $VERSION = '0.001003';
12              
13 5     5 0 1158 sub defconst { constant->import($_ => $_) for @_ }
14              
15             BEGIN {
16             # Roles
17 1     1   4 defconst qw/vanilla goon doctor vigilante roleblocker jailkeeper gunsmith tracker watcher bodyguard rolecop cop sk hider/;
18              
19             # Factions
20 1         3 defconst qw/mafia town/;
21              
22             # Extra traits
23 1         3 defconst qw/miller godfather weak macho bulletproof/;
24              
25             # Messages
26 1         4 defconst qw/MSG_NIGHT MSG_DAY MSG_PLAYERS_ALIVE MSG_DEATH MSG_GUNCHECK MSG_NORESULT MSG_TRACK MSG_WATCH MSG_COP MSG_ROLECOP/;
27              
28             # Action types
29 1         3 defconst qw/ACT_KILL ACT_LYNCH ACT_PROTECT ACT_GUARD ACT_ROLEBLOCK ACT_GUNCHECK ACT_TRACK ACT_WATCH ACT_ROLECOP ACT_COP ACT_TRACK_RESULT ACT_WATCH_RESULT ACT_HIDE/;
30             }
31              
32             use constant +{ ## no critic (Capitalization)
33 1         291 townie => town,
34             ROLE => [vanilla, goon, doctor, vigilante, roleblocker, jailkeeper, gunsmith, tracker, watcher, bodyguard, rolecop, cop, sk, hider],
35             FACTION => [mafia, town],
36             FLAG => [miller, godfather, weak, macho, bulletproof],
37             ACTION_ORDER => [ACT_HIDE, ACT_ROLEBLOCK, ACT_PROTECT, ACT_GUARD, ACT_GUNCHECK, ACT_ROLECOP, ACT_COP, ACT_TRACK, ACT_WATCH, ACT_KILL, ACT_LYNCH, ACT_TRACK_RESULT, ACT_WATCH_RESULT],
38             INVESTIGATIVE_ACTIONS => [ACT_GUNCHECK, ACT_TRACK, ACT_WATCH, ACT_ROLECOP, ACT_COP],
39             GUNROLES => [vigilante, gunsmith],
40 1     1   8 };
  1         1  
41              
42             my %ROLE_HASH = map { $_ => 1 } @{ROLE()};
43             my %FACTION_HASH = map { $_ => 1 } @{FACTION()};
44             my %FLAG_HASH = map { $_ => 1 } @{FLAG()};
45             my %INVESTIGATIVE_ACTIONS_HASH = map { $_ => 1 } @{INVESTIGATIVE_ACTIONS()};
46             my %GUNROLES_HASH = map { $_ => 1 } @{GUNROLES()};
47              
48             our @EXPORT = do {
49 1     1   6 no strict 'refs'; ## no critic (ProhibitNoStrict)
  1         1  
  1         3389  
50             grep { $_ !~ [qw/import/] and exists &$_ } keys %{__PACKAGE__ . '::'};
51             };
52              
53             ################################################## Helper subs
54              
55             sub import {
56 6     6   1389 strict->import;
57 6         1504 goto &Exporter::import;
58             }
59              
60             my (%players, %tplayers, @actions);
61             my $daycnt = 0;
62             my $nightcnt = 0;
63             my $isday = 0;
64             my $first = 1;
65              
66             sub clean{
67 5     5 0 5015 %players = ();
68 5         15 %tplayers = ();
69 5         8 @actions = ();
70 5         6 $daycnt = 0;
71 5         5 $nightcnt = 0;
72 5         5 $isday = 0;
73 5         6 $first = 1;
74             }
75              
76             sub uniq {
77 0     0 0 0 my %hash = map { $_ => 1 } @_;
  0         0  
78 0         0 keys %hash
79             }
80              
81             sub phase {
82 17 100   17 0 43 return "Day $daycnt" if $isday;
83 6 50       14 return "Night $nightcnt" unless $isday;
84             }
85              
86             sub rolename { ## no critic (RequireArgUnpacking)
87 17     17 0 11 my %player = %{$players{$_[0]}};
  17         36  
88 17         22 my ($faction, $role) = ($player{faction}, $player{role});
89 17 100 66     85 if (defined $faction && $faction eq town && $role eq vanilla) {
      100        
90 8         6 undef $faction;
91 8         6 $role = 'Vanilla Townie';
92             }
93 17         19 my @tokens = ();
94 17 100       25 push @tokens, ucfirst $faction if $faction;
95 17         16 for my $flag (@{FLAG()}) {
  17         17  
96 85 50       102 push @tokens, ucfirst $flag if $player{$flag}
97             }
98 17 50 66     46 push @tokens, ucfirst $role unless $role eq goon && $player{godfather};
99 17         40 "@tokens"
100             }
101              
102             sub msg {
103 67     67 0 98 my ($type, @args) = @_;
104             my %msg_lut = (
105             MSG_NIGHT => sub {
106 11     11   11 my ($night) = @args;
107 11 50       19 say '' unless $first;
108 11         9 $first = 0;
109 11         118 say "It is Night $night";
110             },
111              
112             MSG_DAY => sub {
113 11     11   14 my ($day) = @args;
114 11 100       18 say '' unless $first;
115 11         9 $first = 0;
116 11         164 say "It is Day $day";
117             },
118              
119             MSG_PLAYERS_ALIVE => sub {
120 22     22   56 @args = sort @args;
121 22         320 say 'Players alive: ', join ', ', @args
122             },
123              
124             MSG_DEATH => sub {
125 17     17   25 my %args = @args;
126 17         21 my ($who, $reason) = @args{'target', 'reason'};
127 17         16 my $phase = phase;
128 17         23 my $rolename = rolename $who;
129 17         222 say "$who ($rolename) — $reason $phase";
130             },
131              
132             MSG_GUNCHECK => sub {
133 0     0   0 my %args = @args;
134 0         0 my ($gunsmith, $who, $hasgun) = @args{'source', 'target', 'result'};
135 0 0       0 say "$gunsmith: $who has a gun" if $hasgun;
136 0 0       0 say "$gunsmith: $who does not have a gun" unless $hasgun;
137             },
138              
139             MSG_NORESULT => sub {
140 0     0   0 my %args = @args;
141 0         0 my ($who) = $args{'source'};
142 0         0 say "$who: No result"
143             },
144              
145             MSG_TRACK => sub {
146 0     0   0 my %args = @args;
147 0         0 my ($tracker, $who, $result) = @args{'source', 'target', 'result'};
148 0         0 my @result = @{$result};
  0         0  
149 0         0 local $, = ', ';
150 0 0       0 say "$tracker: $who did not visit anyone" unless scalar @result;
151 0 0       0 say "$tracker: $who visited: @result" if scalar @result;
152             },
153              
154             MSG_WATCH => sub {
155 0     0   0 my %args = @args;
156 0         0 my ($watcher, $who, $result) = @args{'source', 'target', 'result'};
157 0         0 my @result = @{$result};
  0         0  
158 0         0 local $, = ', ';
159 0 0       0 say "$watcher: $who was not visited by anyone" unless scalar @result;
160 0 0       0 say "$watcher: $who was visited by: @result" if scalar @result;
161             },
162              
163             MSG_ROLECOP => sub {
164 0     0   0 my %args = @args;
165 0         0 my ($rolecop, $who, $role) = @args{'source', 'target', 'result'};
166 0         0 say "$rolecop: $who\'s role is: $role"
167             },
168              
169             MSG_COP => sub {
170 6     6   14 my %args = @args;
171 6         8 my ($cop, $who, $ismafia) = @args{'source', 'target', 'result'};
172 6 50       8 say "$cop: $who is mafia" if $ismafia;
173 6 50       143 say "$cop: $who is not mafia" unless $ismafia;
174             },
175 67         688 );
176              
177 67         92 $msg_lut{$type}->();
178             }
179              
180             sub putaction {
181 24     24 0 43 my ($delay, $type, %args) = @_;
182 24   50     79 $actions[$delay]->{$type} //= [];
183 24 0 33     93 if (exists $args{target} && exists $args{source} && $players{$args{target}}{faction} eq mafia && $players{$args{source}}{weak}) {
      66        
      33        
184 0         0 putaction($delay, ACT_KILL, target => $args{source}, reason => 'targeted scum');
185             }
186 24         14 push @{$actions[$delay]->{$type}}, \%args
  24         84  
187             }
188              
189             sub doaction { ## no critic (ProhibitExcessComplexity)
190 24     24 0 25 my ($type, $args) = @_;
191 24         46 my %args = %$args;
192 24         23 my $source = $args{source};
193 24         22 my $target = $args{target};
194 24 100 66     61 if (defined $source && defined $target) {
195             # Watcher and tracker variables
196 13   50     36 $tplayers{$source}{targets} //= [];
197 13         11 push @{$tplayers{$source}{targets}}, $target;
  13         18  
198 13   100     34 $tplayers{$target}{sources} //= [];
199 13         6 push @{$tplayers{$target}{sources}}, $source;
  13         15  
200              
201             # Copy this action to everybody hiding behind $target
202 13 50       24 if (exists $tplayers{$target}{hiders}) {
203 0         0 for my $target (@{$tplayers{$target}{hiders}}) {
  0         0  
204 0         0 my %new_args = %args;
205 0         0 $new_args{target} = $target;
206 0         0 $new_args{hidepierce} = 1;
207 0         0 doaction($type, \%new_args);
208             }
209             }
210              
211             # Check if the action should be blocked
212 13   66     25 my $strongkill = $type eq ACT_KILL && $args{strong};
213 13         11 my $roleblocked = $tplayers{$source}{roleblocked};
214 13         11 my $hidden = $tplayers{$target}{hidden};
215 13         11 my $hidepierce = $args{hidepierce};
216 13 50 33     51 if ($source && (( $roleblocked && !$strongkill ) || ($hidden && !$hidepierce) )) {
      33        
217 0 0       0 msg MSG_NORESULT, %args if $INVESTIGATIVE_ACTIONS_HASH{$type};
218             return
219 0         0 }
220             }
221              
222             my %act_lut = (
223             ACT_KILL => sub {
224 6 50 33 6   13 break if $tplayers{$target}{bulletproof} && defined $source;
225 6 50 33     13 if ($tplayers{$target}{guard_count} && defined $source) {
226 0         0 $tplayers{$target}{guard_count}--;
227             # Copy this action to the first guard
228 0         0 $args{target} = shift @{$tplayers{$target}{guards}};
  0         0  
229 0         0 @_ = ($type, %args);
230 0         0 goto &doaction;
231             }
232 6 50 33     7 if ($tplayers{$target}{protection} && !$args{strong}) {
233 0         0 $tplayers{$target}{protection}--;
234             break
235 0         0 }
236 6         12 msg MSG_DEATH, %args;
237 6         76 delete $players{$target}
238             },
239              
240             ACT_LYNCH => sub {
241 11 50   11   18 if ($tplayers{$target}{guard_count}) {
242 0         0 $tplayers{$target}{guard_count}--;
243 0         0 $args{target} = shift @{$tplayers{$target}{guards}};
  0         0  
244 0         0 $target=$args{target};
245             }
246 11 50       16 if ($tplayers{$target}{protection}) {
247 0         0 $tplayers{$target}{protection}--;
248             break
249 0         0 }
250 11         15 msg MSG_DEATH, %args, reason => 'lynched';
251 11         161 delete $players{$target}
252             },
253              
254             ACT_PROTECT => sub {
255 1   50 1   5 my $count = $args{count} // 1;
256             $tplayers{$target}{protection} += $count unless $tplayers{$target}{macho}
257 1 50       15 },
258              
259             ACT_ROLEBLOCK => sub {
260 0     0   0 $tplayers{$target}{roleblocked} = 1
261             },
262              
263             ACT_GUNCHECK => sub {
264 0     0   0 my $role = $players{$target}{role};
265 0   0     0 my $hasgun = $GUNROLES_HASH{$role} || ($players{$target}{faction} eq mafia && $role ne doctor);
266 0         0 msg MSG_GUNCHECK, %args, result => $hasgun
267             },
268              
269             ACT_TRACK_RESULT => sub {
270 0   0 0   0 msg MSG_TRACK, %args, result => [ uniq @{$tplayers{$target}{targets} // []} ];
  0         0  
271             },
272              
273             ACT_WATCH_RESULT => sub {
274 0   0 0   0 msg MSG_WATCH, %args, result => [ uniq @{$tplayers{$target}{sources} // []} ];
  0         0  
275             },
276              
277             ACT_GUARD => sub {
278 0     0   0 $tplayers{$target}{guard_count}++;
279 0   0     0 $tplayers{$target}{guards} //= [];
280 0         0 push @{$tplayers{$target}{guards}}, $source;
  0         0  
281             },
282              
283             ACT_ROLECOP => sub {
284 0     0   0 my $result = $players{$target}{role};
285 0 0       0 $result = vanilla if $result eq goon;
286 0         0 msg MSG_ROLECOP, %args, result => ucfirst $result
287             },
288              
289             ACT_COP => sub {
290 6     6   9 my $result = $players{$target}{faction} eq mafia;
291 6 50       8 $result = 1 if $players{$target}{miller};
292 6 50       9 $result = 0 if $players{$target}{godfather};
293 6         8 msg MSG_COP, %args, result => $result
294             },
295              
296             ACT_HIDE => sub {
297 0     0   0 $tplayers{$source}{hidden} = 1;
298 0   0     0 $tplayers{$target}{hiders} //= [];
299 0         0 push @{$tplayers{$target}{hiders}}, $source
  0         0  
300             },
301 24         256 );
302              
303 24         37 $act_lut{$type}->();
304             }
305              
306             sub process_phase_change {
307 22     22 0 15 %tplayers = %{dclone \%players};
  22         730  
308 22         43 my $actions = shift @actions;
309 22         17 for my $type (@{ACTION_ORDER()}) {
  22         29  
310 286         170 doaction $type, $_ for @{$actions->{$type}}
  286         383  
311             }
312             }
313              
314             ################################################## User subs
315              
316             sub player {
317 35     35 1 78 my ($name, @args) = @_;
318 35         19 my %player;
319 35         35 for my $trait (@args) {
320 70 100       93 $player{role} = $trait if $ROLE_HASH{$trait};
321 70 100       99 $player{faction} = $trait if $FACTION_HASH{$trait};
322 70 50       101 $player{$trait} = 1 if $FLAG_HASH{$trait};
323             }
324              
325 35         63 $players{$name} = \%player;
326             }
327              
328             sub day {
329 11     11 1 26 process_phase_change;
330 11         9 $isday = 1;
331 11         21 msg MSG_DAY, ++$daycnt;
332 11         23 msg MSG_PLAYERS_ALIVE, keys %players;
333             }
334              
335             sub night {
336 11     11 1 26 process_phase_change;
337 11         10 $isday = 0;
338 11         15 msg MSG_NIGHT, ++$nightcnt;
339 11         20 msg MSG_PLAYERS_ALIVE, keys %players;
340             }
341              
342             sub lynch {
343 11     11 1 31 my ($who) = @_;
344 11         15 putaction 0, ACT_LYNCH, target => $who;
345             }
346              
347             sub factionkill {
348 6     6 1 18 my ($killer, $who, $reason, @args) = @_;
349 6         8 putaction 0, ACT_KILL, target => $who, source => $killer, reason => $reason, @args;
350             }
351              
352             sub protect {
353 1     1 1 3 my ($doctor, $who) = @_;
354 1         4 putaction 0, ACT_PROTECT, target => $who, source => $doctor;
355             }
356              
357             sub vig {
358 0     0 1 0 my ($vig, $who, $reason, @args) = @_;
359 0         0 putaction 0, ACT_KILL, target => $who, source => $vig, reason => $reason, @args;
360             }
361              
362             sub roleblock {
363 0     0 1 0 my ($roleblocker, $who) = @_;
364 0         0 putaction 0, ACT_ROLEBLOCK, target => $who, source => $roleblocker;
365             }
366              
367             sub jailkeep {
368 0     0 1 0 my ($jailkeeper, $who) = @_;
369 0         0 putaction 0, ACT_ROLEBLOCK, target => $who, source => $jailkeeper;
370 0         0 putaction 0, ACT_PROTECT, target => $who, source => $jailkeeper, count => 1000;
371             }
372              
373             sub guncheck {
374 0     0 1 0 my ($gunsmith, $who) = @_;
375 0         0 putaction 0, ACT_GUNCHECK, target => $who, source => $gunsmith;
376             }
377              
378             sub track {
379 0     0 1 0 my ($tracker, $who) = @_;
380 0         0 putaction 0, ACT_TRACK, target => $who, source => $tracker;
381 0         0 putaction 0, ACT_TRACK_RESULT, target => $who, source => $tracker;
382             }
383              
384             sub watch {
385 0     0 1 0 my ($watcher, $who) = @_;
386 0         0 putaction 0, ACT_WATCH, target => $who, source => $watcher;
387 0         0 putaction 0, ACT_WATCH_RESULT, target => $who, source => $watcher;
388             }
389              
390             sub guard {
391 0     0 1 0 my ($guard, $who) = @_;
392 0         0 putaction 0, ACT_GUARD, target => $who, source => $guard;
393             }
394              
395             sub rolecopcheck {
396 0     0 1 0 my ($rolecop, $who) = @_;
397 0         0 putaction 0, ACT_ROLECOP, target => $who, source => $rolecop;
398             }
399              
400             sub copcheck {
401 6     6 1 14 my ($cop, $who) = @_;
402 6         8 putaction 0, ACT_COP, target => $who, source => $cop;
403             }
404              
405             sub skill {
406 0     0 1   my ($sk, $who, $reason, @args) = @_;
407 0           putaction 0, ACT_KILL, target => $who, source => $sk, reason => $reason, @args;
408             }
409              
410             sub hide {
411 0     0 1   my ($hider, $who) = @_;
412 0           putaction 0, ACT_HIDE, target => $who, source => $hider;
413             }
414              
415             1;
416             __END__