interface/gtp_examples/twogtp-a

#! /usr/bin/perl -w

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# This program is distributed with GNU Go, a Go program.            #
#                                                                   #
# Write gnugo@gnu.org or see http://www.gnu.org/software/gnugo/     #
# for more information.                                             #
#                                                                   #
# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007    #
# 2008 and 2009 by the Free Software Foundation.                    #
#                                                                   #
# This program is free software; you can redistribute it and/or     #
# modify it under the terms of the GNU General Public License       #
# as published by the Free Software Foundation - version 3,         #
# or (at your option) any later version.                            #
#                                                                   #
# This program is distributed in the hope that it will be           #
# useful, but WITHOUT ANY WARRANTY; without even the implied        #
# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR           #
# PURPOSE.  See the GNU General Public License in file COPYING      #
# for more details.                                                 #
#                                                                   #
# You should have received a copy of the GNU General Public         #
# License along with this program; if not, write to the Free        #
# Software Foundation, Inc., 51 Franklin Street, Fifth Floor,       #
# Boston, MA 02111, USA.                                            #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
#
# Here is a small perlscript twogtp. Its purpose is to run
# two programs against each other. Both must support the Go
# Text Protocol. For example GNU Go 2.7.241 or higher works.
#
# It is easier to implement this program in gtp than gmp.
# The script is almost trivial. It also works with cygwin on
# windows.
#
# Run with:
#
# twogtp --white '<path to program 1> --mode gtp <options>' \
#        --black '<path to program 2> --mode gtp <options>' \
#        [twogtp options]
#
# Possible twogtp options:
#
#   --verbose 1 (to list moves) or --verbose 2 (to draw board)
#   --komi <amount>
#   --handicap <amount>
#   --size <board size>                     (default 19)
#   --games <number of games to play>       (-1 to play forever)
#   --sgffile <filename>
#
#

package TWOGTP_A;

use IPC::Open2;
use Getopt::Long;
use FileHandle;
use strict;
use warnings;
use Carp;

STDOUT->autoflush(1);

#following added globally to allow "use strict" :
my $vertex;
my $first;
my $sgfmove;
my $sgffilename;
my $pidw;
my $pidb;
my $sgffile;
my $handicap_stones;
my $resultw;
my $resultb;
my @vertices;
my $second;
my %game_list;
#end of "use strict" repairs


my $white;
my $black;
my $size = 19;
my $verbose = 0;
my $komi;
my $handicap = 0;
my $games = 1;
my $wanthelp;

my $helpstring = "

Run with:

twogtp --white \'<path to program 1> --mode gtp [program options]\' \\
       --black \'<path to program 2> --mode gtp [program options]\' \\
       [twogtp options]

Possible twogtp options:

  --verbose 1 (to list moves) or --verbose 2 (to draw board)
  --komi <amount>
  --handicap <amount>
  --size <board size>                     (default 19)
  --games <number of games to play>       (-1 to play forever)
  --sgffile <filename>
  --help                                  (show this)

";

GetOptions(
           "white|w=s"              => \$white,
           "black|b=s"              => \$black,
           "verbose|v=i"            => \$verbose,
           "komi|k=f"               => \$komi,
           "handicap|h=i"           => \$handicap,
           "size|boardsize|s=i"     => \$size,
           "sgffile|o=s"            => \$sgffilename,
           "games=i"                => \$games,
           "help"                   => \$wanthelp,
);

if ($wanthelp) {
  print $helpstring;
  exit;
}


if (!$white) {
  $white = '../gnugo.exe --mode gtp --quiet';
  warn "Defaulting white to: $white";
}
if (!$black) {
  $black = '../gnugo.exe --mode gtp --quiet';
  warn "Defaulting black to: $black";
}

die $helpstring unless defined $white and defined $black;

# create FileHandles
#my $black_in;
my $black_in  = new FileHandle;         # stdin of black player
my $black_out = new FileHandle;         # stdout of black player
my $white_in  = new FileHandle;         # stdin of white player
my $white_out = new FileHandle;         # stdout of white player
my $b_gtp_ver;                          # gtp version of black player
my $w_gtp_ver;                          # gtp version of white player

while ($games > 0) {
    $pidb = open2($black_out, $black_in, $black);
    print "black pid: $pidb\n" if $verbose;
    $pidw = open2($white_out, $white_in, $white);
    print "white pid: $pidw\n" if $verbose;

    $sgffile = rename_sgffile($games, $sgffilename) if defined $sgffilename;

    if ((defined $sgffilename) && !open(SGFFILEHANDLE, ">$sgffile")) {
        printf("can't open $sgffile\n");
        undef($sgffilename);
    }

    if (!defined $komi) {
        if ($handicap eq 0) {
            $komi = 5.5;
        }
        else {
            $komi = 0.5;
        }
    }

    print $black_in  "protocol_version\n";
    $b_gtp_ver = eat_gtp_ver($black_out);
    print $black_in  "boardsize $size\n";
    eat_no_response($black_out);
    print $black_in  "clear_board\n";
    eat_no_response($black_out);
    print $black_in  "komi $komi\n";
    eat_no_response($black_out);

    print $white_in  "protocol_version\n";
    $w_gtp_ver = eat_gtp_ver($white_out);
    print $white_in  "boardsize $size\n";
    eat_no_response($white_out);
    print $white_in  "clear_board\n";
    eat_no_response($white_out);
    print $white_in  "komi $komi\n";
    eat_no_response($white_out);

    print SGFFILEHANDLE "(;GM[1]FF[4]RU[Japanese]SZ[$size]HA[$handicap]KM[$komi]"
        if defined $sgffilename;

    my $pass = 0;
    my ($move, $toplay);

    if ($handicap < 2) {
        $toplay = 'B';
    }
    else {
        $toplay = 'W';
        print $black_in "fixed_handicap $handicap\n";
        $handicap_stones = eat_handicap($black_out);
        if (defined $sgffilename) {
            print SGFFILEHANDLE $handicap_stones;
        }
        print $white_in "fixed_handicap $handicap\n";
        $handicap_stones = eat_handicap($white_out);
    }
    while ($pass < 2) {
        if ($toplay eq 'B') {
            if ($b_gtp_ver eq 1) {
                print $black_in "genmove_black\n";
            } else {
                print $black_in "genmove black\n";
            }
            $move = eat_move($black_out);
            $sgfmove = standard_to_sgf($move);
            print SGFFILEHANDLE ";B[$sgfmove]\n" if defined $sgffilename;
            print "Black plays $move\n" if $verbose;
            if ($move =~ /PASS/i) {
                $pass++;
            } else {
                $pass = 0;
            }
            if ($w_gtp_ver eq 1) {
                print $white_in "black $move\n";
            } else {
                print $white_in "play black $move\n";
            }
            eat_no_response($white_out);
            if ($verbose > 1) {
                print $white_in "showboard\n";
                if ($w_gtp_ver eq 2) {
                    eat_showboard($white_out);
                } else {
                    eat_no_response($white_out);
                }
            }
            $toplay = 'W';
        } else {
            if ($w_gtp_ver eq 1) {
                print $white_in "genmove_white\n";
            } else {
                print $white_in "genmove white\n";
            }
            $move = eat_move($white_out);
            $sgfmove = standard_to_sgf($move);
            print SGFFILEHANDLE ";W[$sgfmove]\n" if defined $sgffilename;
            print "White plays $move\n" if $verbose;
            if ($move =~ /PASS/i) {
                $pass++;
            } else {
                $pass = 0;
            }
            if ($b_gtp_ver eq 1) {
                print $black_in "white $move\n";
            } else {
                print $black_in "play white $move\n";
            }
            eat_no_response($black_out);
            if ($verbose > 1) {
                print $black_in "showboard\n";
                if ($b_gtp_ver eq 2) {
                    eat_showboard($black_out);
                } else {
                    eat_no_response($black_out);
                }
            }
            $toplay = 'B';
        }
    }
    print $white_in "final_score\n";
    $resultw = eat_score($white_out);
    print "Result according to W: $resultw\n";
    print $black_in "final_score\n";
    $resultb = eat_score($black_out);
    print "Result according to B: $resultb\n";
    print $white_in "quit\n";
    print $black_in "quit\n";
    if (defined $sgffilename) {
        print "sgf file: $sgffile\n";
        print SGFFILEHANDLE ")";
        close SGFFILEHANDLE;
        $game_list{$sgffile} = $resultw . "|" . $resultb
    }
    $games-- if $games > 0;
    close $black_in;
    close $black_out;
    close $white_in;
    close $white_out;
    waitpid $pidb, 0;
    waitpid $pidw, 0;
    print "games remaining: $games\n";
}

if (defined $sgffilename) {
  my $index_out  = new FileHandle;
  open ($index_out, "> " . index_name($sgffilename));
  print $index_out
"<HTML><HEAD><TITLE>game results</TITLE></HEAD>
<BODY><H3>Game Results</H3>
<H4>White: ".html_encode($white)."</H4>
<H4>Black: ".html_encode($black)."</H4>
<TABLE border=1>
 <TR>
  <TD>SGF file</TD>
  <TD>Result</TD>
 </TR>
";
 foreach (sort by_result keys(%game_list)) {
    print $index_out "<TR><TD><A href=\"$_\">$_</A></TD>" .
                "<TD>".html_encode(game_result($_))."</TD></TR>\n";
  }
  print $index_out "</TABLE></BODY></HTML>\n";
}

sub game_result {
  $_ = shift;
  $_ = $game_list{$_};
  #i.e.:  B+13.5 (upper bound: -13.5, lower: -13.5)|B+13.5 (upper bound: -13.5, lower: -13.5)
  #Make sure that all 4 values are the same.  I've not seen them different yet.
  #If they are ever different, need to improve the HTML output (now just -999) -
  # an explanation of the score mismatch problem would be appropriate.
  $_ =~ /^.*upper bound..([0-9+.\-]*)..lower..\1.\|.*upper bound..\1..lower..\1./;
  if (defined($1)) {
    return $1;
  } else {
    return -999;
  }
}

sub by_result {
  game_result($a) <=> game_result($b) || $a cmp $b;
}

sub html_encode {
  #print shift;
  my $r = shift;
  $r =~ s/&/&amp;/g;
  $r =~ s/</&lt;/g;
  $r =~ s/>/&gt;/g;
  return $r;
}


sub eat_no_response {
    my $h = shift;

# ignore empty lines
    my $line = "";
    while ($line eq "") {
        chop($line = <$h>) or die "No response!";
        $line =~ s/(\s|\n)*$//smg;
    }
}

sub eat_move {
    my $h = shift;
# ignore empty lines
    my $line = "";
    while ($line eq "") {
        if (!defined($line = <$h>)) {
            print SGFFILEHANDLE ")";
            close SGFFILEHANDLE;
            die "Engine crashed!\n";
        }
        $line =~ s/(\s|\n)*$//smg;
    }
    my ($equals, $move) = split(' ', $line, 2);
    $line = <$h>;
    defined($move) or confess "no move found: line was: '$line'";
    return $move;
}

sub eat_handicap {
    my $h = shift;
    my $sgf_handicap = "AB";
# ignore empty lines, die if process is gone
    my $line = "";
    while ($line eq "") {
        chop($line = <$h>) or die "No response!";
    }
    @vertices = split(" ", $line);
    foreach $vertex (@vertices) {
        if (!($vertex eq "=")) {
            $vertex = standard_to_sgf($vertex);
            $sgf_handicap = "$sgf_handicap\[$vertex\]";
        }
    }
    return "$sgf_handicap;";
}

sub eat_score {
    my $h = shift;
# ignore empty lines, die if process is gone
    my $line = "";
    while ($line eq "") {
        chop($line = <$h>) or die "No response!";
        $line =~ s/^\s*//msg;
        $line =~ s/\s*$//msg;
    }
    $line =~ s/\s*$//;
    my ($equals, $result) = split(' ', $line, 2);
    $line = <$h>;
    return $result;
}

sub eat_gtp_ver {
    my $h = shift;
    my $line = "";

    while ($line eq "") {
        chop($line = <$h>) or die "No response!";
        $line =~ s/^\s*//msg;
        $line =~ s/\s*$//msg;
    }
    $line =~ s/\s*$//;
    my ($equals, $result) = split(' ', $line, 2);
    $line = <$h>;
    return $result;
}

sub eat_showboard {
    my $h = shift;
    my $line = "";

    while ($line eq "") {
        chop($line = <$h>) or die "No response!";
        $line =~ s/^\s*//msg;
        $line =~ s/\s*$//msg;
    }
    $line =~ s/\s*$//;
    my ($equals, $result) = split(' ', $line, 2);

    while (!($line =~ /^\s*$/)) {
        $result .= $line;
        $line = <$h>;
    }
    print STDERR $result;
}

sub standard_to_sgf {
    for (@_) { confess "Yikes!" if !defined($_); }
    for (@_) { tr/A-Z/a-z/ };
    $_ = shift(@_);
    /([a-z])([0-9]+)/;
    return "tt" if $_ eq "pass";

    $first = ord $1;
    if ($first > 104) {
        $first = $first - 1;
    }
    $first = chr($first);
    $second = chr($size+1-$2+96);
    return "$first$second";
}

sub rename_sgffile {
    my $nogames = int shift(@_);
    $_ = shift(@_);
    s/\.sgf$//;
    # Annoying to loose _001 on game #1 in multi-game set.
    # Could record as an additional parameter.
    # return "$_.sgf" if ($nogames == 1);
    return sprintf("$_" . "_%03d.sgf", $nogames);
}

sub index_name {
  $_ = shift;
  s/\.sgf$//;
  return $_ . "_index.html";
}