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