File Coverage

blib/lib/Game/Theory/TwoPersonMatrix.pm
Criterion Covered Total %
statement 244 244 100.0
branch 45 48 93.7
condition 24 33 72.7
subroutine 26 26 100.0
pod 12 12 100.0
total 351 363 96.6


line stmt bran cond sub pod time code
1             package Game::Theory::TwoPersonMatrix;
2             our $AUTHORITY = 'cpan:GENE';
3              
4             # ABSTRACT: Analyze a 2 person matrix game
5              
6 1     1   728 use strict;
  1         2  
  1         22  
7 1     1   5 use warnings;
  1         2  
  1         35  
8              
9             our $VERSION = '0.2204';
10              
11 1     1   5 use Carp;
  1         1  
  1         51  
12 1     1   405 use Algorithm::Combinatorics qw( permutations );
  1         2987  
  1         57  
13 1     1   382 use Array::Transpose;
  1         328  
  1         46  
14 1     1   465 use List::MoreUtils qw( all zip );
  1         9946  
  1         6  
15 1     1   945 use List::Util qw( max min sum0 );
  1         2  
  1         97  
16 1     1   378 use List::Util::WeightedChoice qw( choose_weighted );
  1         10627  
  1         2309  
17              
18              
19              
20             sub new {
21 38     38 1 561 my $class = shift;
22 38         102 my %args = @_;
23             my $self = {
24             1 => $args{1},
25             2 => $args{2},
26             payoff => $args{payoff},
27             payoff1 => $args{payoff1},
28             payoff2 => $args{payoff2},
29 38         127 };
30 38         61 bless $self, $class;
31 38         137 return $self;
32             }
33              
34              
35             sub expected_payoff
36             {
37 13     13 1 1753 my ($self) = @_;
38              
39 13         21 my $expected_payoff;
40              
41             # For each strategy of player 1...
42 13         16 for my $i ( sort keys %{ $self->{1} } )
  13         59  
43             {
44             # For each strategy of player 2...
45 29         38 for my $j ( sort keys %{ $self->{2} } )
  29         62  
46             {
47 76 100 66     147 if ( $self->{payoff1} && $self->{payoff2} )
48             {
49 8         26 $expected_payoff->[0] += $self->{1}{$i} * $self->{2}{$j} * $self->{payoff1}[$i - 1][$j - 1];
50 8         22 $expected_payoff->[1] += $self->{1}{$i} * $self->{2}{$j} * $self->{payoff2}[$i - 1][$j - 1];
51             }
52             else {
53             # Expected value is the sum of the probabilities of each payoff
54 68         188 $expected_payoff += $self->{1}{$i} * $self->{2}{$j} * $self->{payoff}[$i - 1][$j - 1];
55             }
56             }
57             }
58              
59 13         77 return $expected_payoff;
60             }
61              
62              
63             sub s_expected_payoff
64             {
65 4     4 1 1291 my ($self) = @_;
66              
67 4         7 my $expected_payoff;
68              
69             # For each strategy of player 1...
70 4         6 for my $i ( sort keys %{ $self->{1} } )
  4         21  
71             {
72             # For each strategy of player 2...
73 8         13 for my $j ( sort keys %{ $self->{2} } )
  8         15  
74             {
75 16 100 66     46 if ( $self->{payoff1} && $self->{payoff2} )
76             {
77 8         27 $expected_payoff->[0] .= " + $self->{1}{$i} * $self->{2}{$j} * $self->{payoff1}[$i - 1][$j - 1]";
78 8         23 $expected_payoff->[1] .= " + $self->{1}{$i} * $self->{2}{$j} * $self->{payoff2}[$i - 1][$j - 1]";
79             }
80             else {
81             # Expected value is the sum of the probabilities of each payoff
82 8         24 $expected_payoff .= " + $self->{1}{$i} * $self->{2}{$j} * $self->{payoff}[$i - 1][$j - 1]";
83             }
84             }
85             }
86              
87             my $deplus = sub
88             {
89 6     6   9 my ($string) = @_;
90 6         31 $string =~ s/^ \+ (.+)$/$1/;
91 6         12 return $string;
92 4         17 };
93              
94 4 100 66     15 if ( $self->{payoff1} && $self->{payoff2} )
95             {
96 2         5 $expected_payoff->[0] = $deplus->($expected_payoff->[0]);
97 2         6 $expected_payoff->[1] = $deplus->($expected_payoff->[1]);
98             }
99             else {
100 2         4 $expected_payoff = $deplus->($expected_payoff);
101             }
102              
103 4         27 return $expected_payoff;
104             }
105              
106              
107             sub counter_strategy
108             {
109 3     3 1 1101 my ( $self, $player ) = @_;
110              
111 3         9 my $counter_strategy = [];
112 3         5 my %seen;
113              
114 3 100       10 my $opponent = $player == 1 ? 2 : 1;
115              
116 3         6 my @keys = 1 .. keys %{ $self->{$player} };
  3         12  
117 3         9 my @pure = ( 1, (0) x ( @keys - 1 ) );
118              
119 3         14 my $i = permutations( \@pure );
120              
121 3         149 while ( my $strategies = $i->next )
122             {
123 10 100       137 next if $seen{"@$strategies"}++;
124              
125             my $g = Game::Theory::TwoPersonMatrix->new(
126             $player => { zip @keys, @$strategies },
127             $opponent => $self->{$opponent},
128 7   66     62 payoff => $self->{payoff} || $self->{"payoff$player"},
129             );
130              
131 7         19 push @$counter_strategy, $g->expected_payoff();
132             }
133              
134 3         41 return $counter_strategy;
135             }
136              
137              
138             sub saddlepoint
139             {
140 5     5 1 2573 my ($self) = @_;
141              
142 5         9 my $saddlepoint;
143              
144 5         6 my $rsize = @{ $self->{payoff} } - 1;
  5         10  
145 5         7 my $csize = @{ $self->{payoff}[0] } - 1;
  5         10  
146              
147 5         12 for my $row ( 0 .. $rsize )
148             {
149             # Get the minimum value of the current row
150 14         18 my $min = min @{ $self->{payoff}[$row] };
  14         34  
151              
152             # Inspect each column given the row
153 14         20 for my $col ( 0 .. $csize )
154             {
155             # Get the payoff
156 36         44 my $val = $self->{payoff}[$row][$col];
157              
158             # Is the payoff also the row minimum?
159 36 100       67 if ( $val == $min )
160             {
161             # Gather the column values for each row
162 16         20 my @col;
163 16         26 for my $r ( 0 .. $rsize )
164             {
165 50         75 push @col, $self->{payoff}[$r][$col];
166             }
167             # Get the maximum value of the columns
168 16         25 my $max = max @col;
169              
170             # Is the payoff also the column maximum?
171 16 100       35 if ( $val == $max )
172             {
173 5         19 $saddlepoint->{"$row,$col"} = $val;
174             }
175             }
176             }
177             }
178              
179 5         24 return $saddlepoint;
180             }
181              
182              
183             sub oddments
184             {
185 1     1 1 2 my ($self) = @_;
186              
187 1         2 my $rsize = @{ $self->{payoff}[0] };
  1         12  
188 1         3 my $csize = @{ $self->{payoff} };
  1         2  
189 1 50 33     8 carp 'Payoff matrix must be 2x2' unless $rsize == 2 && $csize == 2;
190              
191 1         2 my ( $player, $opponent );
192              
193 1         3 my $A = $self->{payoff}[0][0];
194 1         2 my $B = $self->{payoff}[0][1];
195 1         2 my $C = $self->{payoff}[1][0];
196 1         2 my $D = $self->{payoff}[1][1];
197              
198 1         2 my ( $x, $y );
199 1         3 $x = abs( $D - $C );
200 1         2 $y = abs( $A - $B );
201 1         3 my $i = $x / ( $x + $y );
202 1         2 my $j = $y / ( $x + $y );
203 1         2 $player = [ $i, $j ];
204              
205 1         2 $x = abs( $D - $B );
206 1         1 $y = abs( $A - $C );
207 1         9 $i = $x / ( $x + $y );
208 1         2 $j = $y / ( $x + $y );
209 1         3 $opponent = [ $i, $j ];
210              
211 1         7 return [ $player, $opponent ];
212             }
213              
214              
215             sub row_reduce
216             {
217 2     2 1 391 my ($self) = @_;
218              
219 2         5 my @spliced;
220              
221 2         2 my $rsize = @{ $self->{payoff} } - 1;
  2         6  
222 2         2 my $csize = @{ $self->{payoff}[0] } - 1;
  2         5  
223              
224 2         7 for my $row ( 0 .. $rsize )
225             {
226             #warn "R:$row = @{ $self->{payoff}[$row] }\n";
227 7         10 for my $r ( 0 .. $rsize )
228             {
229 25 100       41 next if $r == $row;
230             #warn "\tN:$r = @{ $self->{payoff}[$r] }\n";
231 18         21 my @cmp;
232 18         24 for my $x ( 0 .. $csize )
233             {
234 54 100       95 push @cmp, ( $self->{payoff}[$row][$x] <= $self->{payoff}[$r][$x] ? 1 : 0 );
235             }
236             #warn "\t\tC:@cmp\n";
237 18 100   30   48 if ( all { $_ == 1 } @cmp )
  30         61  
238             {
239 3         7 push @spliced, $row;
240             }
241             }
242             }
243              
244 2         8 $self->_reduce_game( $self->{payoff}, \@spliced, 1 );
245              
246 2         65 return $self->{payoff};
247             }
248              
249              
250             sub col_reduce
251             {
252 3     3 1 285 my ($self) = @_;
253              
254 3         4 my @spliced;
255              
256 3         11 my $transposed = transpose( $self->{payoff} );
257              
258 3         90 my $rsize = @$transposed - 1;
259 3         4 my $csize = @{ $transposed->[0] } - 1;
  3         6  
260              
261 3         5 for my $row ( 0 .. $rsize )
262             {
263             #warn "R:$row = @{ $transposed->[$row] }\n";
264 10         33 for my $r ( 0 .. $rsize )
265             {
266 34 100       92 next if $r == $row;
267             #warn "\tN:$r = @{ $transposed->[$r] }\n";
268 24         27 my @cmp;
269 24         34 for my $x ( 0 .. $csize )
270             {
271 72 100       137 push @cmp, ( $transposed->[$row][$x] >= $transposed->[$r][$x] ? 1 : 0 );
272             }
273             #warn "\t\tC:@cmp\n";
274 24 100   42   61 if ( all { $_ == 1 } @cmp )
  42         77  
275             {
276 3         7 push @spliced, $row;
277             }
278             }
279             }
280              
281 3         8 $self->_reduce_game( $transposed, \@spliced, 2 );
282              
283 3         7 $self->{payoff} = transpose( $transposed );
284              
285 3         84 return $self->{payoff};
286             }
287              
288             sub _reduce_game
289             {
290 5     5   9 my ( $self, $payoff, $spliced, $player ) = @_;
291              
292 5         7 my $seen = 0;
293 5         10 for my $row ( @$spliced )
294             {
295 6         7 $row -= $seen++;
296             # Reduce the payoff column
297 6         10 splice @$payoff, $row, 1;
298             # Eliminate the strategy of the opponent
299 6 50       25 delete $self->{$player}{$row + 1} if exists $self->{$player}{$row + 1};
300             }
301             }
302              
303              
304             sub mm_tally
305             {
306 2     2 1 594 my ($self) = @_;
307              
308 2         4 my $mm_tally;
309              
310 2 100 66     11 if ( $self->{payoff1} && $self->{payoff2} )
311             {
312             # Find maximum of row minimums for the player
313 1         4 $mm_tally = $self->_tally_max( $mm_tally, 1, $self->{payoff1} );
314              
315             # Find minimum of column maximums for the opponent
316 1         2 my @m = ();
317 1         3 my %s = ();
318              
319 1         3 my $transposed = transpose( $self->{payoff2} );
320              
321 1         24 for my $row ( 0 .. @$transposed - 1 )
322             {
323 2         3 $s{$row} = min @{ $transposed->[$row] };
  2         5  
324 2         5 push @m, $s{$row};
325             }
326              
327 1         4 $mm_tally->{2}{value} = max @m;
328              
329 1         4 for my $row ( sort keys %s )
330             {
331 2 100       3 push @{ $mm_tally->{2}{strategy} }, ( $s{$row} == $mm_tally->{2}{value} ? 1 : 0 );
  2         17  
332             }
333             }
334             else
335             {
336             # Find maximum of row minimums
337 1         5 $mm_tally = $self->_tally_max( $mm_tally, 1, $self->{payoff} );
338              
339             # Find minimum of column maximums
340 1         2 my @m = ();
341 1         2 my %s = ();
342              
343 1         4 my $transposed = transpose( $self->{payoff} );
344              
345 1         33 for my $row ( 0 .. @$transposed - 1 )
346             {
347 4         11 $s{$row} = max @{ $transposed->[$row] };
  4         9  
348 4         8 push @m, $s{$row};
349             }
350              
351 1         4 $mm_tally->{2}{value} = min @m;
352              
353 1         5 for my $row ( sort keys %s )
354             {
355 4 100       6 push @{ $mm_tally->{2}{strategy} }, ( $s{$row} == $mm_tally->{2}{value} ? 1 : 0 );
  4         11  
356             }
357             }
358              
359 2         27 return $mm_tally;
360             }
361              
362             sub _tally_max
363             {
364 2     2   5 my ( $self, $mm_tally, $player, $payoff ) = @_;
365              
366 2         3 my @m;
367             my %s;
368              
369             # Find maximum of row minimums
370 2         6 for my $row ( 0 .. @$payoff - 1 )
371             {
372 5         8 $s{$row} = min @{ $payoff->[$row] };
  5         15  
373 5         9 push @m, $s{$row};
374             }
375              
376 2         9 $mm_tally->{$player}{value} = max @m;
377              
378 2         8 for my $row ( sort keys %s )
379             {
380 5 100       16 push @{ $mm_tally->{$player}{strategy} }, ( $s{$row} == $mm_tally->{$player}{value} ? 1 : 0 );
  5         17  
381             }
382              
383 2         6 return $mm_tally;
384             }
385              
386              
387             sub pareto_optimal
388             {
389 4     4 1 279 my ($self) = @_;
390              
391 4         5 my $pareto_optimal;
392              
393 4         5 my $rsize = @{ $self->{payoff1} } - 1;
  4         8  
394 4         5 my $csize = @{ $self->{payoff1}[0] } - 1;
  4         31  
395              
396             # Compare each row & column with every other
397 4         10 for my $row ( 0 .. $rsize )
398             {
399 8         11 for my $col ( 0 .. $csize )
400             {
401             #warn "RC:$row,$col = ($self->{payoff1}[$row][$col],$self->{payoff2}[$row][$col])\n";
402              
403             # Find all pairs to compare against
404 16         21 my %seen;
405 16         19 for my $r ( 0 .. $rsize )
406             {
407 32         39 for my $c ( 0 .. $csize )
408             {
409 64 100 100     228 next if ( $r == $row && $c == $col ) || $seen{"$r,$c"}++;
      66        
410              
411 48         69 my $p = $self->{payoff1}[$row][$col];
412 48         66 my $q = $self->{payoff2}[$row][$col];
413             #warn "\trc:$r,$c = ($self->{payoff1}[$r][$c],$self->{payoff2}[$r][$c])\n";
414              
415 48 100 100     137 if ( $p >= $self->{payoff1}[$r][$c] && $q >= $self->{payoff2}[$r][$c] )
416             {
417             #warn "\t\t$row,$col > $r,$c at ($p,$q)\n";
418             # XXX We exploit the unique key feature of perl hashes
419 8         26 $pareto_optimal->{ "$row,$col" } = [ $p, $q ];
420             }
421             }
422             }
423             }
424             }
425              
426 4         21 return $pareto_optimal;
427             }
428              
429              
430             sub nash
431             {
432 7     7 1 2029 my ($self) = @_;
433              
434 7         12 my $nash;
435              
436 7         7 my $rsize = @{ $self->{payoff1} } - 1;
  7         14  
437 7         9 my $csize = @{ $self->{payoff1}[0] } - 1;
  7         13  
438              
439             # Find all row & column max pairs
440 7         15 for my $row ( 0 .. $rsize )
441             {
442 15         20 my $rmax = max @{ $self->{payoff2}[$row] };
  15         31  
443              
444 15         23 for my $col ( 0 .. $csize )
445             {
446             #warn "RC:$row,$col = ($self->{payoff1}[$row][$col],$self->{payoff2}[$row][$col])\n";
447              
448 36         44 my @col;
449 36         46 for my $r ( 0 .. $rsize )
450             {
451 84         123 push @col, $self->{payoff1}[$r][$col];
452             }
453 36         56 my $cmax = max @col;
454              
455 36         43 my $p = $self->{payoff1}[$row][$col];
456 36         47 my $q = $self->{payoff2}[$row][$col];
457              
458 36 100 100     87 if ( $p == $cmax && $q == $rmax )
459             {
460             #warn "\t$p == $cmax && $q == $rmax\n";
461 10         35 $nash->{"$row,$col"} = [ $p, $q ];
462             }
463             }
464             }
465              
466 7         35 return $nash;
467             }
468              
469              
470             sub play
471             {
472 4     4 1 585 my ( $self, %strategies ) = @_;
473              
474 4         6 my $play;
475              
476             # Allow for alternate strategies
477 4         14 $self->{$_} = $strategies{$_} for keys %strategies;
478              
479 4         17 my $rplay = $self->_player_move(1);
480 4         215 my $cplay = $self->_player_move(2);
481              
482             $play->{ "$rplay,$cplay" } = exists $self->{payoff} && $self->{payoff}
483             ? $self->{payoff}[$rplay - 1][$cplay - 1]
484 4 100 66     165 : [ $self->{payoff1}[$rplay - 1][$cplay - 1], $self->{payoff2}[$rplay - 1][$cplay - 1] ];
485              
486 4         22 return $play;
487             }
488              
489             sub _player_move {
490 8     8   13 my ( $self, $player ) = @_;
491              
492 8         14 my $keys = [ sort keys %{ $self->{$player} } ];
  8         30  
493 8         16 my $weights = [ map { $self->{$player}{$_} } @$keys ];
  16         30  
494              
495             # Handle the [0, 0, ...] edge case
496 8 50       28 $weights = [ (1) x @$weights ] if 0 == sum0 @$weights;
497              
498 8         22 return choose_weighted( $keys, $weights );
499             }
500              
501             1;
502              
503             __END__