| 1 | #! /usr/bin/perl -w |
| 2 | |
| 3 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
| 4 | # This program is distributed with GNU Go, a Go program. # |
| 5 | # # |
| 6 | # Write gnugo@gnu.org or see http://www.gnu.org/software/gnugo/ # |
| 7 | # for more information. # |
| 8 | # # |
| 9 | # Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 # |
| 10 | # 2008 and 2009 by the Free Software Foundation. # |
| 11 | # # |
| 12 | # This program is free software; you can redistribute it and/or # |
| 13 | # modify it under the terms of the GNU General Public License # |
| 14 | # as published by the Free Software Foundation - version 3, # |
| 15 | # or (at your option) any later version. # |
| 16 | # # |
| 17 | # This program is distributed in the hope that it will be # |
| 18 | # useful, but WITHOUT ANY WARRANTY; without even the implied # |
| 19 | # warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # |
| 20 | # PURPOSE. See the GNU General Public License in file COPYING # |
| 21 | # for more details. # |
| 22 | # # |
| 23 | # You should have received a copy of the GNU General Public # |
| 24 | # License along with this program; if not, write to the Free # |
| 25 | # Software Foundation, Inc., 51 Franklin Street, Fifth Floor, # |
| 26 | # Boston, MA 02111, USA. # |
| 27 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
| 28 | # |
| 29 | # Here is a small perlscript twogtp. Its purpose is to run |
| 30 | # two programs against each other. Both must support the Go |
| 31 | # Text Protocol. For example GNU Go 2.7.241 or higher works. |
| 32 | # |
| 33 | # It is easier to implement this program in gtp than gmp. |
| 34 | # The script is almost trivial. It also works with cygwin on |
| 35 | # windows. |
| 36 | # |
| 37 | # Run with: |
| 38 | # |
| 39 | # twogtp --white '<path to program 1> --mode gtp <options>' \ |
| 40 | # --black '<path to program 2> --mode gtp <options>' \ |
| 41 | # [twogtp options] |
| 42 | # |
| 43 | # Possible twogtp options: |
| 44 | # |
| 45 | # --verbose 1 (to list moves) or --verbose 2 (to draw board) |
| 46 | # --komi <amount> |
| 47 | # --handicap <amount> |
| 48 | # --size <board size> (default 19) |
| 49 | # --games <number of games to play> (-1 to play forever) |
| 50 | # --sgffile <filename> |
| 51 | # |
| 52 | # |
| 53 | |
| 54 | package TWOGTP_A; |
| 55 | |
| 56 | use IPC::Open2; |
| 57 | use Getopt::Long; |
| 58 | use FileHandle; |
| 59 | use strict; |
| 60 | use warnings; |
| 61 | use Carp; |
| 62 | |
| 63 | STDOUT->autoflush(1); |
| 64 | |
| 65 | #following added globally to allow "use strict" : |
| 66 | my $vertex; |
| 67 | my $first; |
| 68 | my $sgfmove; |
| 69 | my $sgffilename; |
| 70 | my $pidw; |
| 71 | my $pidb; |
| 72 | my $sgffile; |
| 73 | my $handicap_stones; |
| 74 | my $resultw; |
| 75 | my $resultb; |
| 76 | my @vertices; |
| 77 | my $second; |
| 78 | my %game_list; |
| 79 | #end of "use strict" repairs |
| 80 | |
| 81 | |
| 82 | my $white; |
| 83 | my $black; |
| 84 | my $size = 19; |
| 85 | my $verbose = 0; |
| 86 | my $komi; |
| 87 | my $handicap = 0; |
| 88 | my $games = 1; |
| 89 | my $wanthelp; |
| 90 | |
| 91 | my $helpstring = " |
| 92 | |
| 93 | Run with: |
| 94 | |
| 95 | twogtp --white \'<path to program 1> --mode gtp [program options]\' \\ |
| 96 | --black \'<path to program 2> --mode gtp [program options]\' \\ |
| 97 | [twogtp options] |
| 98 | |
| 99 | Possible twogtp options: |
| 100 | |
| 101 | --verbose 1 (to list moves) or --verbose 2 (to draw board) |
| 102 | --komi <amount> |
| 103 | --handicap <amount> |
| 104 | --size <board size> (default 19) |
| 105 | --games <number of games to play> (-1 to play forever) |
| 106 | --sgffile <filename> |
| 107 | --help (show this) |
| 108 | |
| 109 | "; |
| 110 | |
| 111 | GetOptions( |
| 112 | "white|w=s" => \$white, |
| 113 | "black|b=s" => \$black, |
| 114 | "verbose|v=i" => \$verbose, |
| 115 | "komi|k=f" => \$komi, |
| 116 | "handicap|h=i" => \$handicap, |
| 117 | "size|boardsize|s=i" => \$size, |
| 118 | "sgffile|o=s" => \$sgffilename, |
| 119 | "games=i" => \$games, |
| 120 | "help" => \$wanthelp, |
| 121 | ); |
| 122 | |
| 123 | if ($wanthelp) { |
| 124 | print $helpstring; |
| 125 | exit; |
| 126 | } |
| 127 | |
| 128 | |
| 129 | if (!$white) { |
| 130 | $white = '../gnugo.exe --mode gtp --quiet'; |
| 131 | warn "Defaulting white to: $white"; |
| 132 | } |
| 133 | if (!$black) { |
| 134 | $black = '../gnugo.exe --mode gtp --quiet'; |
| 135 | warn "Defaulting black to: $black"; |
| 136 | } |
| 137 | |
| 138 | die $helpstring unless defined $white and defined $black; |
| 139 | |
| 140 | # create FileHandles |
| 141 | #my $black_in; |
| 142 | my $black_in = new FileHandle; # stdin of black player |
| 143 | my $black_out = new FileHandle; # stdout of black player |
| 144 | my $white_in = new FileHandle; # stdin of white player |
| 145 | my $white_out = new FileHandle; # stdout of white player |
| 146 | my $b_gtp_ver; # gtp version of black player |
| 147 | my $w_gtp_ver; # gtp version of white player |
| 148 | |
| 149 | while ($games > 0) { |
| 150 | $pidb = open2($black_out, $black_in, $black); |
| 151 | print "black pid: $pidb\n" if $verbose; |
| 152 | $pidw = open2($white_out, $white_in, $white); |
| 153 | print "white pid: $pidw\n" if $verbose; |
| 154 | |
| 155 | $sgffile = rename_sgffile($games, $sgffilename) if defined $sgffilename; |
| 156 | |
| 157 | if ((defined $sgffilename) && !open(SGFFILEHANDLE, ">$sgffile")) { |
| 158 | printf("can't open $sgffile\n"); |
| 159 | undef($sgffilename); |
| 160 | } |
| 161 | |
| 162 | if (!defined $komi) { |
| 163 | if ($handicap eq 0) { |
| 164 | $komi = 5.5; |
| 165 | } |
| 166 | else { |
| 167 | $komi = 0.5; |
| 168 | } |
| 169 | } |
| 170 | |
| 171 | print $black_in "protocol_version\n"; |
| 172 | $b_gtp_ver = eat_gtp_ver($black_out); |
| 173 | print $black_in "boardsize $size\n"; |
| 174 | eat_no_response($black_out); |
| 175 | print $black_in "clear_board\n"; |
| 176 | eat_no_response($black_out); |
| 177 | print $black_in "komi $komi\n"; |
| 178 | eat_no_response($black_out); |
| 179 | |
| 180 | print $white_in "protocol_version\n"; |
| 181 | $w_gtp_ver = eat_gtp_ver($white_out); |
| 182 | print $white_in "boardsize $size\n"; |
| 183 | eat_no_response($white_out); |
| 184 | print $white_in "clear_board\n"; |
| 185 | eat_no_response($white_out); |
| 186 | print $white_in "komi $komi\n"; |
| 187 | eat_no_response($white_out); |
| 188 | |
| 189 | print SGFFILEHANDLE "(;GM[1]FF[4]RU[Japanese]SZ[$size]HA[$handicap]KM[$komi]" |
| 190 | if defined $sgffilename; |
| 191 | |
| 192 | my $pass = 0; |
| 193 | my ($move, $toplay); |
| 194 | |
| 195 | if ($handicap < 2) { |
| 196 | $toplay = 'B'; |
| 197 | } |
| 198 | else { |
| 199 | $toplay = 'W'; |
| 200 | print $black_in "fixed_handicap $handicap\n"; |
| 201 | $handicap_stones = eat_handicap($black_out); |
| 202 | if (defined $sgffilename) { |
| 203 | print SGFFILEHANDLE $handicap_stones; |
| 204 | } |
| 205 | print $white_in "fixed_handicap $handicap\n"; |
| 206 | $handicap_stones = eat_handicap($white_out); |
| 207 | } |
| 208 | while ($pass < 2) { |
| 209 | if ($toplay eq 'B') { |
| 210 | if ($b_gtp_ver eq 1) { |
| 211 | print $black_in "genmove_black\n"; |
| 212 | } else { |
| 213 | print $black_in "genmove black\n"; |
| 214 | } |
| 215 | $move = eat_move($black_out); |
| 216 | $sgfmove = standard_to_sgf($move); |
| 217 | print SGFFILEHANDLE ";B[$sgfmove]\n" if defined $sgffilename; |
| 218 | print "Black plays $move\n" if $verbose; |
| 219 | if ($move =~ /PASS/i) { |
| 220 | $pass++; |
| 221 | } else { |
| 222 | $pass = 0; |
| 223 | } |
| 224 | if ($w_gtp_ver eq 1) { |
| 225 | print $white_in "black $move\n"; |
| 226 | } else { |
| 227 | print $white_in "play black $move\n"; |
| 228 | } |
| 229 | eat_no_response($white_out); |
| 230 | if ($verbose > 1) { |
| 231 | print $white_in "showboard\n"; |
| 232 | if ($w_gtp_ver eq 2) { |
| 233 | eat_showboard($white_out); |
| 234 | } else { |
| 235 | eat_no_response($white_out); |
| 236 | } |
| 237 | } |
| 238 | $toplay = 'W'; |
| 239 | } else { |
| 240 | if ($w_gtp_ver eq 1) { |
| 241 | print $white_in "genmove_white\n"; |
| 242 | } else { |
| 243 | print $white_in "genmove white\n"; |
| 244 | } |
| 245 | $move = eat_move($white_out); |
| 246 | $sgfmove = standard_to_sgf($move); |
| 247 | print SGFFILEHANDLE ";W[$sgfmove]\n" if defined $sgffilename; |
| 248 | print "White plays $move\n" if $verbose; |
| 249 | if ($move =~ /PASS/i) { |
| 250 | $pass++; |
| 251 | } else { |
| 252 | $pass = 0; |
| 253 | } |
| 254 | if ($b_gtp_ver eq 1) { |
| 255 | print $black_in "white $move\n"; |
| 256 | } else { |
| 257 | print $black_in "play white $move\n"; |
| 258 | } |
| 259 | eat_no_response($black_out); |
| 260 | if ($verbose > 1) { |
| 261 | print $black_in "showboard\n"; |
| 262 | if ($b_gtp_ver eq 2) { |
| 263 | eat_showboard($black_out); |
| 264 | } else { |
| 265 | eat_no_response($black_out); |
| 266 | } |
| 267 | } |
| 268 | $toplay = 'B'; |
| 269 | } |
| 270 | } |
| 271 | print $white_in "final_score\n"; |
| 272 | $resultw = eat_score($white_out); |
| 273 | print "Result according to W: $resultw\n"; |
| 274 | print $black_in "final_score\n"; |
| 275 | $resultb = eat_score($black_out); |
| 276 | print "Result according to B: $resultb\n"; |
| 277 | print $white_in "quit\n"; |
| 278 | print $black_in "quit\n"; |
| 279 | if (defined $sgffilename) { |
| 280 | print "sgf file: $sgffile\n"; |
| 281 | print SGFFILEHANDLE ")"; |
| 282 | close SGFFILEHANDLE; |
| 283 | $game_list{$sgffile} = $resultw . "|" . $resultb |
| 284 | } |
| 285 | $games-- if $games > 0; |
| 286 | close $black_in; |
| 287 | close $black_out; |
| 288 | close $white_in; |
| 289 | close $white_out; |
| 290 | waitpid $pidb, 0; |
| 291 | waitpid $pidw, 0; |
| 292 | print "games remaining: $games\n"; |
| 293 | } |
| 294 | |
| 295 | if (defined $sgffilename) { |
| 296 | my $index_out = new FileHandle; |
| 297 | open ($index_out, "> " . index_name($sgffilename)); |
| 298 | print $index_out |
| 299 | "<HTML><HEAD><TITLE>game results</TITLE></HEAD> |
| 300 | <BODY><H3>Game Results</H3> |
| 301 | <H4>White: ".html_encode($white)."</H4> |
| 302 | <H4>Black: ".html_encode($black)."</H4> |
| 303 | <TABLE border=1> |
| 304 | <TR> |
| 305 | <TD>SGF file</TD> |
| 306 | <TD>Result</TD> |
| 307 | </TR> |
| 308 | "; |
| 309 | foreach (sort by_result keys(%game_list)) { |
| 310 | print $index_out "<TR><TD><A href=\"$_\">$_</A></TD>" . |
| 311 | "<TD>".html_encode(game_result($_))."</TD></TR>\n"; |
| 312 | } |
| 313 | print $index_out "</TABLE></BODY></HTML>\n"; |
| 314 | } |
| 315 | |
| 316 | sub game_result { |
| 317 | $_ = shift; |
| 318 | $_ = $game_list{$_}; |
| 319 | #i.e.: B+13.5 (upper bound: -13.5, lower: -13.5)|B+13.5 (upper bound: -13.5, lower: -13.5) |
| 320 | #Make sure that all 4 values are the same. I've not seen them different yet. |
| 321 | #If they are ever different, need to improve the HTML output (now just -999) - |
| 322 | # an explanation of the score mismatch problem would be appropriate. |
| 323 | $_ =~ /^.*upper bound..([0-9+.\-]*)..lower..\1.\|.*upper bound..\1..lower..\1./; |
| 324 | if (defined($1)) { |
| 325 | return $1; |
| 326 | } else { |
| 327 | return -999; |
| 328 | } |
| 329 | } |
| 330 | |
| 331 | sub by_result { |
| 332 | game_result($a) <=> game_result($b) || $a cmp $b; |
| 333 | } |
| 334 | |
| 335 | sub html_encode { |
| 336 | #print shift; |
| 337 | my $r = shift; |
| 338 | $r =~ s/&/&/g; |
| 339 | $r =~ s/</</g; |
| 340 | $r =~ s/>/>/g; |
| 341 | return $r; |
| 342 | } |
| 343 | |
| 344 | |
| 345 | |
| 346 | sub eat_no_response { |
| 347 | my $h = shift; |
| 348 | |
| 349 | # ignore empty lines |
| 350 | my $line = ""; |
| 351 | while ($line eq "") { |
| 352 | chop($line = <$h>) or die "No response!"; |
| 353 | $line =~ s/(\s|\n)*$//smg; |
| 354 | } |
| 355 | } |
| 356 | |
| 357 | sub eat_move { |
| 358 | my $h = shift; |
| 359 | # ignore empty lines |
| 360 | my $line = ""; |
| 361 | while ($line eq "") { |
| 362 | if (!defined($line = <$h>)) { |
| 363 | print SGFFILEHANDLE ")"; |
| 364 | close SGFFILEHANDLE; |
| 365 | die "Engine crashed!\n"; |
| 366 | } |
| 367 | $line =~ s/(\s|\n)*$//smg; |
| 368 | } |
| 369 | my ($equals, $move) = split(' ', $line, 2); |
| 370 | $line = <$h>; |
| 371 | defined($move) or confess "no move found: line was: '$line'"; |
| 372 | return $move; |
| 373 | } |
| 374 | |
| 375 | sub eat_handicap { |
| 376 | my $h = shift; |
| 377 | my $sgf_handicap = "AB"; |
| 378 | # ignore empty lines, die if process is gone |
| 379 | my $line = ""; |
| 380 | while ($line eq "") { |
| 381 | chop($line = <$h>) or die "No response!"; |
| 382 | } |
| 383 | @vertices = split(" ", $line); |
| 384 | foreach $vertex (@vertices) { |
| 385 | if (!($vertex eq "=")) { |
| 386 | $vertex = standard_to_sgf($vertex); |
| 387 | $sgf_handicap = "$sgf_handicap\[$vertex\]"; |
| 388 | } |
| 389 | } |
| 390 | return "$sgf_handicap;"; |
| 391 | } |
| 392 | |
| 393 | sub eat_score { |
| 394 | my $h = shift; |
| 395 | # ignore empty lines, die if process is gone |
| 396 | my $line = ""; |
| 397 | while ($line eq "") { |
| 398 | chop($line = <$h>) or die "No response!"; |
| 399 | $line =~ s/^\s*//msg; |
| 400 | $line =~ s/\s*$//msg; |
| 401 | } |
| 402 | $line =~ s/\s*$//; |
| 403 | my ($equals, $result) = split(' ', $line, 2); |
| 404 | $line = <$h>; |
| 405 | return $result; |
| 406 | } |
| 407 | |
| 408 | sub eat_gtp_ver { |
| 409 | my $h = shift; |
| 410 | my $line = ""; |
| 411 | |
| 412 | while ($line eq "") { |
| 413 | chop($line = <$h>) or die "No response!"; |
| 414 | $line =~ s/^\s*//msg; |
| 415 | $line =~ s/\s*$//msg; |
| 416 | } |
| 417 | $line =~ s/\s*$//; |
| 418 | my ($equals, $result) = split(' ', $line, 2); |
| 419 | $line = <$h>; |
| 420 | return $result; |
| 421 | } |
| 422 | |
| 423 | sub eat_showboard { |
| 424 | my $h = shift; |
| 425 | my $line = ""; |
| 426 | |
| 427 | while ($line eq "") { |
| 428 | chop($line = <$h>) or die "No response!"; |
| 429 | $line =~ s/^\s*//msg; |
| 430 | $line =~ s/\s*$//msg; |
| 431 | } |
| 432 | $line =~ s/\s*$//; |
| 433 | my ($equals, $result) = split(' ', $line, 2); |
| 434 | |
| 435 | while (!($line =~ /^\s*$/)) { |
| 436 | $result .= $line; |
| 437 | $line = <$h>; |
| 438 | } |
| 439 | print STDERR $result; |
| 440 | } |
| 441 | |
| 442 | sub standard_to_sgf { |
| 443 | for (@_) { confess "Yikes!" if !defined($_); } |
| 444 | for (@_) { tr/A-Z/a-z/ }; |
| 445 | $_ = shift(@_); |
| 446 | /([a-z])([0-9]+)/; |
| 447 | return "tt" if $_ eq "pass"; |
| 448 | |
| 449 | $first = ord $1; |
| 450 | if ($first > 104) { |
| 451 | $first = $first - 1; |
| 452 | } |
| 453 | $first = chr($first); |
| 454 | $second = chr($size+1-$2+96); |
| 455 | return "$first$second"; |
| 456 | } |
| 457 | |
| 458 | sub rename_sgffile { |
| 459 | my $nogames = int shift(@_); |
| 460 | $_ = shift(@_); |
| 461 | s/\.sgf$//; |
| 462 | # Annoying to loose _001 on game #1 in multi-game set. |
| 463 | # Could record as an additional parameter. |
| 464 | # return "$_.sgf" if ($nogames == 1); |
| 465 | return sprintf("$_" . "_%03d.sgf", $nogames); |
| 466 | } |
| 467 | |
| 468 | sub index_name { |
| 469 | $_ = shift; |
| 470 | s/\.sgf$//; |
| 471 | return $_ . "_index.html"; |
| 472 | } |