#!/usr/bin/env perl
use strict;
use warnings;

# Partly taken from https://www.forbes.com/sites/rogerkay/2011/12/19/generous-tit-for-tat-a-winning-strategy
# And https://medium.com/thinking-is-hard/a-prisoners-dilemma-cheat-sheet-4d85fe289d87
# And http://www.prisoners-dilemma.com/strategies.html

use Game::Theory::TwoPersonMatrix;
use Algorithm::Combinatorics qw/ combinations /;
use List::Util::WeightedChoice qw/ choose_weighted /;

use constant COOP   => 1;
use constant DEFECT => 2;

# Set the number of moves
my $max = shift || 200;

my $players = {
    jesus   => [ \&cooperate, \&cooperate ],
    lucifer => [ \&defect,    \&defect ],
    random  => [ \&random,    \&random ],
    tft     => [ \&cooperate, \&tit_for_tat ],
    atft    => [ \&defect,    \&tit_for_tat ], # "Agressive tit-for-tat"
    rtft    => [ \&defect,    \&rev_tit_for_tat ],
    tftt    => [ \&cooperate, \&tit_for_two_tats ],
    gtft    => [ \&cooperate, \&generous_tit_for_tat ],
    grim    => [ \&cooperate, \&grim ],
    fbf     => [ \&cooperate, \&firm_but_fair ],
    pavlov  => [ \&cooperate, \&pavlov ],
    sm      => [ \&cooperate, \&soft_majority ],
    hm      => [ \&defect,    \&hard_majority ],
};

my $population = [
    ('jesus')   x 2,
    ('lucifer') x 2,
    ('random')  x 2,
    ('tft')     x 2,
    ('rtft')    x 2,
    ('atft')    x 2,
    ('tftt')    x 2,
    ('gtft')    x 2,
    ('grim')    x 2,
    ('fbf')     x 2,
    ('pavlov')  x 2,
    ('sm')      x 2,
];

my %scores;
@scores{ keys %$players } = (0) x keys %$players;

my %wins;
@wins{ keys %$players } = (0) x keys %$players;

# A prisoner's dilemma
my $g = Game::Theory::TwoPersonMatrix->new(
    payoff1 => [ [3, 0], [5, 1] ],
    payoff2 => [ [3, 5], [0, 1] ],
);

# A hawk-dove game
#my $g = Game::Theory::TwoPersonMatrix->new(
#    payoff1 => [ [0, 3], [1, 2] ], # [X, W], [L, T]
#    payoff2 => [ [0, 1], [3, 2] ], # [X, L], [W, T]
#);

my $iter = combinations( $population, 2 );

my $i = 0;

# Play each player against the others
while ( my $pair = $iter->next ) {
    $i++;
#    print "$i: @$pair\n";

    my $player   = $pair->[0];
    my $opponent = $pair->[1];

    my @moves;

    # Set initial strategies
    my %strategy = (
        1 => $players->{$player}[0]->()->{1},
        2 => $players->{$opponent}[0]->()->{2},
    );

    for ( 1 .. $max ) {
        # Each player makes a move
        my ($play) = $g->play(%strategy);

        # The strategies are encoded in the key
        push @moves, ( keys %$play )[0];

        # The payoffs are in the values
        my ($v) = values %$play;

        # Update the score for each player
        $scores{$player}   += $v->[0];
        $scores{$opponent} += $v->[1];

        # Tally the number of times won
        if ( $v->[0] > $v->[1] ) {
            $wins{$player}++;
        }
        elsif ( $v->[1] > $v->[0] ) {
            $wins{$opponent}++;
        }

        # Set next strategies
        %strategy = (
            1 => $players->{$player}[1]->(\@moves)->{1},
            2 => $players->{$opponent}[1]->(\@moves)->{2},
        );
    }
}

print "Wins:\n";
for my $player ( sort { $wins{$b} <=> $wins{$a} } keys %wins ) {
    print "\t$player = $wins{$player}\n";
}

print "Scores:\n";
for my $player ( sort { $scores{$b} <=> $scores{$a} } keys %scores ) {
    print "\t$player = $scores{$player}\n";
}

sub random {
    return {
        1 => { 1 => 0.5, 2 => 0.5 },
        2 => { 1 => 0.5, 2 => 0.5 }
    };
}

sub cooperate {
    # Always cooperate
    return {
        1 => { 1 => 1, 2 => 0 },
        2 => { 1 => 1, 2 => 0 },
    };
}

sub defect {
    # Always defect
    return {
        1 => { 1 => 0, 2 => 1 },
        2 => { 1 => 0, 2 => 1 },
    };
}

sub grim { # https://en.wikipedia.org/wiki/Grim_trigger
    my $moves = shift;

    #    Player1, Player2
    my ( $strat1, $strat2 ) = split /,/, $moves->[-1];

    # Cooperate until defected against, then defect forever
    return {
        1 => {                                                      # Player1
            1 => $strat1 == COOP && $strat2 == COOP ? 1 : 0,        # Cooperate
            2 => $strat1 == DEFECT || $strat2 == DEFECT ? 1 : 0,    # Defect
        },
        2 => {                                                      # Player2
            1 => $strat1 == COOP && $strat2 == COOP ? 1 : 0,        # Cooperate
            2 => $strat1 == DEFECT || $strat2 == DEFECT ? 1 : 0,    # Defect
        },
    }
}

sub tit_for_tat { # https://en.wikipedia.org/wiki/Tit_for_tat
    my $moves = shift;

    my ( $strat1, $strat2 ) = split /,/, $moves->[-1];

    # Do whatever the opponent did the last move
    return {
        1 => {
            1 => $strat2 == COOP ? 1 : 0,
            2 => $strat2 == DEFECT ? 1 : 0,
        },
        2 => {
            1 => $strat1 == COOP ? 1 : 0,
            2 => $strat1 == DEFECT ? 1 : 0,
        },
    }
}

sub generous_tit_for_tat {
    my $moves = shift;

    my ( $strat1, $strat2 ) = split /,/, $moves->[-1];

    my $defect1 = $strat2 == DEFECT && choose_weighted( [ 1, 0 ], [ 9, 1 ] );
    my $defect2 = $strat1 == DEFECT && choose_weighted( [ 1, 0 ], [ 9, 1 ] );

    # Tit-for-tat except 10% cooperate when defected against
    return {
        1 => {
            1 => !$defect1 ? 1 : 0,
            2 => $defect1 ? 1 : 0,
        },
        2 => {
            1 => !$defect2 ? 1 : 0,
            2 => $defect2 ? 1 : 0,
        },
    }
}

sub rev_tit_for_tat {
    my $moves = shift;

    my ( $strat1, $strat2 ) = split /,/, $moves->[-1];

    # Do the opposite of whatever the opponent did the last move
    return {
        1 => {
            1 => $strat2 == DEFECT ? 1 : 0,
            2 => $strat2 == COOP ? 1 : 0,
        },
        2 => {
            1 => $strat1 == DEFECT ? 1 : 0,
            2 => $strat1 == COOP ? 1 : 0,
        },
    }
}

sub tit_for_two_tats { # https://en.wikipedia.org/wiki/Tit_for_tat#Tit_for_two_tats
    my $moves = shift;

    return cooperate() if @$moves == 1;

    my ( $strat11, $strat12 ) = split /,/, $moves->[-1];
    my ( $strat21, $strat22 ) = split /,/, $moves->[-2];

    # Defect if the opponent has defected twice in a row
    return {
        1 => {
            1 => !( $strat12 == DEFECT && $strat22 == DEFECT ) ? 1 : 0,
            2 => $strat12 == DEFECT && $strat22 == DEFECT ? 1 : 0,
        },
        2 => {
            1 => !( $strat11 == DEFECT && $strat21 == DEFECT ) ? 1 : 0,
            2 => $strat11 == DEFECT && $strat21 == DEFECT ? 1 : 0,
        },
    }
}

sub firm_but_fair {
    my $moves = shift;

    my ( $strat1, $strat2 ) = split /,/, $moves->[-1];

    # Cooperate except after receiving a sucker's payoff
    return {
        1 => {
            1 => !( $strat1 == COOP && $strat2 == DEFECT ) ? 1 : 0,
            2 => $strat1 == COOP && $strat2 == DEFECT ? 1 : 0,
        },
        2 => {
            1 => !( $strat1 == DEFECT && $strat2 == COOP ) ? 1 : 0,
            2 => $strat1 == DEFECT && $strat2 == COOP ? 1 : 0,
        },
    }
}

sub pavlov {
    my $moves = shift;

    my ( $strat1, $strat2 ) = split /,/, $moves->[-1];

    # If a reward or temptation payoff is received last round then repeat choice, otherwise opposite
    return {
        1 => {
            1 => ( $strat1 == COOP && $strat2 == COOP ) || ( $strat1 == DEFECT && $strat2 == DEFECT ) ? 1 : 0,
            2 => ( $strat1 == DEFECT && $strat2 == COOP ) || ( $strat1 == COOP && $strat2 == DEFECT ) ? 1 : 0,
        },
        2 => {
            1 => ( $strat1 == COOP && $strat2 == COOP ) || ( $strat1 == DEFECT && $strat2 == DEFECT ) ? 1 : 0,
            2 => ( $strat1 == COOP && $strat2 == DEFECT ) || ( $strat1 == DEFECT && $strat2 == COOP ) ? 1 : 0,
        },
    }
}

sub soft_majority {
    my $moves = shift;

    my %strat;

    for my $move ( @$moves ) {
        my ( $one, $two ) = split /,/, $move;

        $strat{1}{coop}   += $one == COOP ? 1 : 0;
        $strat{1}{defect} += $one == DEFECT ? 1 : 0;
        $strat{2}{coop}   += $two == COOP ? 1 : 0;
        $strat{2}{defect} += $two == DEFECT ? 1 : 0;
    }

    my $defect1 = $strat{2}{coop} < $strat{2}{defect};
    my $defect2 = $strat{1}{coop} < $strat{1}{defect};

    # Defect if the number of opponent defections is greater than their cooperations
    return {
        1 => {
            1 => !$defect1 ? 1 : 0,
            2 => $defect1 ? 1 : 0,
        },
        2 => {
            1 => !$defect2 ? 1 : 0,
            2 => $defect2 ? 1 : 0,
        },
    }
}

sub hard_majority {
    my $moves = shift;

    my %strat;

    for my $move ( @$moves ) {
        my ( $one, $two ) = split /,/, $move;

        $strat{1}{coop}   += $one == COOP ? 1 : 0;
        $strat{1}{defect} += $one == DEFECT ? 1 : 0;
        $strat{2}{coop}   += $two == COOP ? 1 : 0;
        $strat{2}{defect} += $two == DEFECT ? 1 : 0;
    }

    my $defect1 = $strat{2}{coop} <= $strat{2}{defect};
    my $defect2 = $strat{1}{coop} <= $strat{1}{defect};

    # Defect if the number of opponent defections is greater than or equal to their cooperations
    return {
        1 => {
            1 => !$defect1 ? 1 : 0,
            2 => $defect1 ? 1 : 0,
        },
        2 => {
            1 => !$defect2 ? 1 : 0,
            2 => $defect2 ? 1 : 0,
        },
    }
}
