Commit | Line | Data |
---|---|---|
7eeb782e AT |
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 | } |