File:The topology of 2x2 games.jpg

use strict;
use List::Util qw(min);
my $unitlength = "0.6cm";

for my $l (1..4)
    {
    open FILE, ">layer$l.tex" or die $!;
    print FILE "\\documentclass{article}\n";
    print FILE "\\pagestyle{empty}\n";
    print FILE "\\addtolength{\\hoffset}{-2cm}\n";
    print FILE "\\begin{document}\n";
    print FILE "\\setlength{\\unitlength}{$unitlength}\n";
    print FILE "\\begin{picture}(27,27)\n";
    print FILE "\\thicklines\n";
    for my $r (1..6){
        for my $c (1..6){
            my $p = get_payoff_matrix($l, $c, $r);
            print FILE generate_diagram_code($p, (($r-2)%6)*4.5, (($c-2)%6)*4.5);
            }
	}
    for my $i (1..6){
	printf FILE "\\put(%.1f,%.1f){\\Large \\textsf{\\textbf{$i}}}\n", 1.5+4.5*(($i-2)%6), -1.6 if $l==1||$l==4;
	printf FILE "\\put(%.1f,%.1f){\\Large \\textsf{\\textbf{$i}}}\n", $l>=3?27:-2, 1.3+4.5*(($i-2)%6);
	}
    printf FILE "\\put(%.1f,%.1f){\\Huge\\textsf{\\textbf{$l}}}\n", $l==3||$l==4?-1:26, $l==2||$l==3?-1.3:25;
    print FILE "\\end{picture}\n\n";
    print FILE "\\end{document}\n";
    close FILE;
    }



sub hat6 { min($_[0], 7-$_[0]) }

sub get_payoff_matrix
	{
	my($l, $c, $r) = @_;
	my $p;
	# $p->[$s1][$s2][$k] is payoff of player $k when first player uses strategy $s1 and second uses $s2

	$p->[1][1][0] = 4;
	$p->[0][1][0] = hat6(($c+1)%6+1);
	$p->[1][0][0] = hat6(($c+3)%6+1);
	$p->[0][0][0] = hat6(($c+5)%6+1);
	$p->[0][0][1] = 4;
	$p->[0][1][1] = hat6(($r+1)%6+1);
	$p->[1][0][1] = hat6(($r+3)%6+1);
	$p->[1][1][1] = hat6(($r+5)%6+1);

	if($l==2 || $l==3){
	    ($p->[0][0][1], $p->[1][0][1]) = ($p->[1][0][1], $p->[0][0][1]);
	    ($p->[0][1][1], $p->[1][1][1]) = ($p->[1][1][1], $p->[0][1][1]);
	    }
	if($l==3 || $l==4){
	    ($p->[0][0][1], $p->[0][1][1]) = ($p->[0][1][1], $p->[0][0][1]);
	    ($p->[1][0][1], $p->[1][1][1]) = ($p->[1][1][1], $p->[1][0][1]);
	    }
	$p->[2] = [$l, $c, $r];
	return $p;
	}


sub print_payoff_matrix
	{
	my $p = shift;
	for my $r (0, 1){
	    for my $c (0,1){
	        print "$p->[$r][$c][0], $p->[$r][$c][1]     ";
	        }
	    print "\n";
	    }
	}


sub generate_diagram_code
	{
	my($p, $X, $Y) = @_;
        my $dcircle = 0.35;
        my $rcircle = 0.25;
        my $rdots   = 0.12;
        my $distdots= 0.2;

        my @points;
        for my $i (0, 1){
            for my $j (0, 1){
                my $isnash   = ($p->[$i][$j][0] > $p->[1-$i][$j][0]) && ($p->[$i][$j][1] > $p->[$i][1-$j][1]);
                my $isminmax = min($p->[$i][0][0], $p->[$i][1][0]) > min($p->[1-$i][0][0], $p->[1-$i][1][0]) &&
                               min($p->[0][$j][1], $p->[1][$j][1]) > min($p->[0][1-$j][1], $p->[1][1-$j][1]);
                push @points, [$p->[$i][$j][0]-1, $p->[$i][$j][1]-1, $isnash, $isminmax];
                }
            }

        my $out;

        #----- draw coordinate lines -----
        my($xa, $ya);
        foreach (@points){
            $xa = $_->[0] if $_->[1]==0;
            $ya = $_->[1] if $_->[0]==0;
            }
        $out .= sprintf("\\put(%.5g,%.5g){\\line(1,0){%.5g}}\n", $X, $Y, $xa-$rcircle) if $xa>0;
        $out .= sprintf("\\put(%.5g,%.5g){\\line(0,1){%.5g}}\n", $X, $Y, $ya-$rcircle) if $ya>0;
        $out .= sprintf("\\put(%.5g,%.5g){\\line(1,0){%.5g}}\n", $X+$xa+$rcircle, $Y, 3-$xa) if $xa<3;
        $out .= sprintf("\\put(%.5g,%.5g){\\line(0,1){%.5g}}\n", $X, $Y+$ya+$rcircle, 3-$ya) if $ya<3;


        #----- draw circles representing players' payoffs -----
        foreach (@points){
            my $star = $_->[2] ? "" : "*";
            $out .= sprintf("\\put(%.5g,%.5g){\\circle$star\{$dcircle}}\n", $X+$_->[0], $Y+$_->[1]);
            # draw minmax cross
            if($_->[3]){
        	$out .= sprintf("\\put(%.5g,%.5g){\\line(0,1){$rcircle}}\n",  $X+$_->[0], $Y+$_->[1]+$rcircle);
        	$out .= sprintf("\\put(%.5g,%.5g){\\line(0,-1){$rcircle}}\n", $X+$_->[0], $Y+$_->[1]-$rcircle);
        	$out .= sprintf("\\put(%.5g,%.5g){\\line(1,0){$rcircle}}\n",  $X+$_->[0]+$rcircle, $Y+$_->[1]);
        	$out .= sprintf("\\put(%.5g,%.5g){\\line(-1,0){$rcircle}}\n", $X+$_->[0]-$rcircle, $Y+$_->[1]);
        	}
            }

        #----- draw lines representing inducement correspondence -----
        foreach my $player (0, 1){
            # color
            foreach my $i (0, 1){
                my $p1 = $player? $p->[0][$i] : $p->[$i][0];
                my $p2 = $player? $p->[1][$i] : $p->[$i][1];
                # slope
                my $sx = $p2->[0] - $p1->[0];
                my $sy = $p2->[1] - $p1->[1];
                for my $k (2, 3){
                    if($sx%$k==0 && $sy%$k==0){
                        $sx /= $k;
                        $sy /= $k;
                        }
                    }
                # starting point
                my $x1 = $X + $p1->[0]-1 + $rcircle * $sx/sqrt($sx**2+$sy**2);
                my $y1 = $Y + $p1->[1]-1 + $rcircle * $sy/sqrt($sx**2+$sy**2);
                # length
                my $l = ($sx==0) ? abs($p2->[1] - $p1->[1]) - 2*$rcircle
              		         : abs($p2->[0] - $p1->[0]) - 2*$rcircle*abs($sx)/sqrt($sx**2+$sy**2);
                # draw the line!
                if($player){
                    $out .= sprintf("\\put(%.5g,%.5g){\\line(%d,%d){%.5f}}\n", $x1, $y1, $sx, $sy, $l);
                    }
                else{
                    my $L = sqrt(($p2->[0]-$p1->[0])**2 + ($p2->[1]-$p1->[1])**2) - 2*$rcircle - 2/3*$distdots;
                    my $ndots = int($L / $distdots);
                    my $dx = $L/$ndots * $sx/sqrt($sx**2+$sy**2);
                    my $dy = $L/$ndots * $sy/sqrt($sx**2+$sy**2);
                    $out .= sprintf("\\multiput(%.5g,%.5g)(%.5g,%.5g){%d}{\\circle*{$rdots}}\n", $x1+$dx/3, $y1+$dy/3, $dx, $dy, $ndots+1);
                    }
                }
            # un-color
            }

        my $name = get_common_name(@{$p->[2]});
        if($name){
            my $l = length($name);
            $out .= sprintf("\\put(%.5g,%.5g){\\scriptsize %s}\n", $X+1.5-$l*0.1, $Y-0.6, $name);
            }
        $out .= sprintf("\\put(%.5g,%.5g){\\scriptsize %s}\n", $X+3.2, $Y+0.1, join("", @{$p->[2]}));
        }

sub get_common_name {
    my($l, $c, $r) = @_;
    my %common_names = (
	111 => "Prisoner's Dilemma",
	112 => "Called Bluff",
	114 => "Cuban Missile Crisis",
	116 => "Total Conflict",
	121 => "Called Bluff",
	122 => "Chicken",
	123 => "Asym. BoS",
	124 => "Skewed BoS",
	126 => "Bully",
	132 => "Asym. BoS",
	133 => "BoS",
	134 => "BoS",
	135 => "Protector 1",
	136 => "Protector 3",
	141 => "Cuban Missile Crisis",
	142 => "Skewed BoS",
	143 => "BoS",
	144 => "Hero",
	145 => "Protector 2",
	146 => "Protector 4",
	152 => "Type game",
	153 => "Protector 1",
	154 => "Protector 2",
	155 => "Anti-Chicken",
	161 => "Total Conflict",
	162 => "Bully",
	163 => "Protector 3",
	164 => "Protector 4",
	166 => "Anti-Prisoner's Dilemma",
	211 => "Ideological Hegemony I",
	212 => "Hegemonic Stability",
	213 => "Samson and Delilah",
	216 => "Blackmailer A",
	221 => "Alibi",
	222 => "Cycle",
	223 => "Inspector-Evader",
	224 => "Cuban Missile Crisis",
	225 => "Big Bully",
	226 => "Hamlet and Claudius",
	231 => "Alibi",
	232 => "Cycle",
	233 => "Cycle",
	234 => "Total Conflict",
	235 => "Cycle",
	241 => "Alibi",
	242 => "Cycle",
	243 => "Cycle",
	244 => "Pursuit of the Israelites",
	252 => "Type game",
	261 => "Ideological Hegemony 2",
	262 => "Vietnam Bombing",
	265 => "Cuban Missile Crisis",
	266 => "Blackmailer B",
	311 => "No Conflict",
	316 => "Pure Common-interest",
	322 => "Stag Hunt",
	323 => "Asym. Coordination",
	324 => "Asym. Coordination",
	325 => "Pure Common-interest",
	332 => "Asym. Coordination",
	333 => "Coordination",
	334 => "Pure Coordination",
	342 => "Asym. Coordination",
	343 => "Pure Coordination",
	344 => "Coordination",
	352 => "Pure Common-interest",
	361 => "Pure Common-interest",
	366 => "Harmony",
	412 => "Alibi",
	413 => "Alibi",
	414 => "Alibi",
	416 => "Ideological Hegemony 2",
	421 => "Hegemonic Stability",
	422 => "Cycle",
	423 => "Cycle",
	424 => "Cycle",
	426 => "Vietnam",
	431 => "Samson and Delilah",
	432 => "Inspector-Evader",
	433 => "Cycle",
	434 => "Cycle",
	442 => "Cuban Missile Crisis",
	443 => "Total Conflict",
	444 => "Pursuit of the Israelites",
	452 => "Big Bully",
	453 => "Cycle",
	456 => "Cuban Missile Crisis",
	461 => "Blackmailer A",
	462 => "Hamlet and Claudius",
	466 => "Ideological Hegemony 1",
	);
    return $common_names{"$l$c$r"};
    }