| 1 | #!/usr/bin/perl |
| 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 | # and 2008 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 perlscript regress.pl. Its purpose is to run |
| 30 | # the regression tests that are currently implemented with |
| 31 | # shells and awk scripts. |
| 32 | # |
| 33 | # Run with: |
| 34 | # |
| 35 | # regress.pl --help |
| 36 | # |
| 37 | |
| 38 | package REGRESS; |
| 39 | |
| 40 | use IPC::Open3; |
| 41 | use IO::Handle; |
| 42 | use Getopt::Long; |
| 43 | use FileHandle; |
| 44 | |
| 45 | use FindBin; |
| 46 | |
| 47 | use strict; |
| 48 | use warnings; |
| 49 | |
| 50 | use Carp; |
| 51 | |
| 52 | STDOUT->autoflush(1); |
| 53 | |
| 54 | my $helpstring = " |
| 55 | |
| 56 | Run with: |
| 57 | |
| 58 | regress.pl --goprog \'<path to program> --mode gtp [program options]\' \\ |
| 59 | --testfile \'<path to gtp test file>\' \\ |
| 60 | --all_batches Ignores --testfile, gets test files from Makefile.in |
| 61 | --numbers \'regexp of test numbers the next test after which won\'t be run\' |
| 62 | [options] |
| 63 | |
| 64 | Possible options: |
| 65 | |
| 66 | --verbose 0 (very quiet) --verbose 1 (to list moves) or --verbose 2 (to draw board) |
| 67 | [FIXME: verbose levels not well defined.] |
| 68 | --html 0 (to not generate html) or --html 1 (default - generate html file w/ results) |
| 69 | |
| 70 | "; |
| 71 | |
| 72 | |
| 73 | my %categories = |
| 74 | ("JOSEKI_DATABASE", "", |
| 75 | "JOSEKI_PATTERN", "", |
| 76 | "FUSEKI_CONCEPT", "", |
| 77 | "DYNAMIC_CONNECTION", "Dynamic Connection Reading", |
| 78 | "TACTICAL_READING", "", |
| 79 | "OWL_TUNING", "", |
| 80 | "PATTERN_TUNING", "", |
| 81 | "CONNECTION_TUNING", "", |
| 82 | "MOVE_VALUATION", "", |
| 83 | "ATARI_ATARI", "", |
| 84 | "SEMEAI_MODULE", "", |
| 85 | "KO_READING", "" |
| 86 | ); |
| 87 | |
| 88 | my $trace_output=""; |
| 89 | my $cur_passed; |
| 90 | my $result; |
| 91 | my $correct_re; |
| 92 | my $bang; |
| 93 | my $top_moves; |
| 94 | my $handicap_stones; |
| 95 | my $sgfmove; |
| 96 | my $vertex; |
| 97 | my @vertices; |
| 98 | my $first; |
| 99 | my $second; |
| 100 | my $resultb; |
| 101 | my $resultw; |
| 102 | my $scriptfile; |
| 103 | my $pidt; |
| 104 | my $pidg; |
| 105 | my $testdir; |
| 106 | my $goprog; |
| 107 | my $verbose = 1; |
| 108 | my $old_whole_gtp = ""; |
| 109 | my $html_whole_gtp = ""; |
| 110 | my $testfile; |
| 111 | my $num; |
| 112 | my $filepos; |
| 113 | my $goprog_in ; # stdin of computer player |
| 114 | my $goprog_out; # stdout of computer player |
| 115 | my $goprog_err; # stderr of computer player |
| 116 | my $passes; |
| 117 | my $unexpected_pass; |
| 118 | my $failures; |
| 119 | my $unexpected_fail; |
| 120 | my $numbers = ""; |
| 121 | my $boardsize = 19; #current boardsize |
| 122 | my $testfile_out; |
| 123 | my $all_batches; |
| 124 | my $make_images; |
| 125 | my $cputime; |
| 126 | my $generate_sgf = 1; |
| 127 | |
| 128 | my $goprog_name = "unknown"; |
| 129 | my $goprog_version = "0"; |
| 130 | my $goprog_timestamp = 0; |
| 131 | |
| 132 | my $do_topmove = 0; |
| 133 | my $one_gg_process = 0; |
| 134 | |
| 135 | my @failed_links; |
| 136 | my @FAILED_links; |
| 137 | |
| 138 | my @counters = qw/connection_node owl_node reading_node trymove/; |
| 139 | |
| 140 | my %counters; |
| 141 | |
| 142 | my $next_cmd = ""; |
| 143 | my $prev_cmd = ""; |
| 144 | my $problem_set; |
| 145 | my $wantshelp; |
| 146 | |
| 147 | GetOptions( |
| 148 | "goprog|g=s" => \$goprog, |
| 149 | "verbose|v=i" => \$verbose, |
| 150 | "numbers|n=s" => \$numbers, |
| 151 | "all_batches|all-batches|a=i" => \$all_batches, |
| 152 | "make_images|m=i" => \$make_images, |
| 153 | "problemset|ps|p=s" => \$problem_set, |
| 154 | "help" => \$wantshelp, |
| 155 | "sgf|sgf|s=i" => \$generate_sgf, |
| 156 | ); |
| 157 | |
| 158 | if ($make_images) { |
| 159 | make_images(); |
| 160 | exit; |
| 161 | } |
| 162 | |
| 163 | my $s = (lc ($^O) eq 'mswin32') ? '\\' : '/'; |
| 164 | if (!$goprog) { |
| 165 | $goprog = "..${s}interface${s}gnugo"; |
| 166 | } |
| 167 | |
| 168 | if ($goprog !~ / /) { |
| 169 | $goprog .= " --mode gtp --quiet -t -w -d0x101840 --showtime"; |
| 170 | } |
| 171 | |
| 172 | die $helpstring unless defined $goprog; |
| 173 | |
| 174 | if ($wantshelp) { |
| 175 | print $helpstring; |
| 176 | exit; |
| 177 | } |
| 178 | |
| 179 | |
| 180 | |
| 181 | if (!-e "html") { |
| 182 | mkdir "html"; |
| 183 | } |
| 184 | |
| 185 | |
| 186 | # if $numbers matches the current test number, then read it to mean: |
| 187 | # "inhibit all gtp commands AFTER the matching number, until the next |
| 188 | # numbered test, then resume." |
| 189 | if ($numbers) { |
| 190 | $numbers = "^($numbers)\$"; |
| 191 | } |
| 192 | |
| 193 | use File::stat; |
| 194 | |
| 195 | |
| 196 | # create FileHandles |
| 197 | $goprog_in = new FileHandle; # stdin of computer player |
| 198 | $goprog_out = new FileHandle; # stdout of computer player |
| 199 | $goprog_err = new FileHandle; # stdout of computer player |
| 200 | print "Go program: $goprog\n" if $verbose > 1; |
| 201 | $pidg = open3($goprog_in, $goprog_out, $goprog_err, $goprog) |
| 202 | or die "Couldn't launch GNU Go: $!"; |
| 203 | print "goprog pid: $pidg\n" if $verbose > 1; |
| 204 | my ($goprog_exe) = split (" ", $goprog); |
| 205 | -e $goprog_exe |
| 206 | or ($goprog_exe = "$goprog_exe.exe") && -e $goprog_exe |
| 207 | or die "Couldn't locate go program: $goprog_exe"; |
| 208 | $goprog_timestamp = (stat $goprog_exe)->mtime; |
| 209 | |
| 210 | go_command("name"); |
| 211 | $_ = <$goprog_out>; |
| 212 | if (/^=\s*(.*)/) { |
| 213 | ($goprog_name = $1) =~ s/\s*$//; |
| 214 | } |
| 215 | <$goprog_out>; |
| 216 | go_command("version"); |
| 217 | $_ = <$goprog_out>; |
| 218 | if (/^=\s*(.*)/) { |
| 219 | ($goprog_version = $1) =~ s/\s*$//; |
| 220 | } |
| 221 | <$goprog_out>; |
| 222 | |
| 223 | print "Name: " . $goprog_name ." ". $goprog_version . "\n" if $verbose > 1; |
| 224 | |
| 225 | if ($one_gg_process) { |
| 226 | go_command("quit"); |
| 227 | print "waiting\n" if $verbose > 2; |
| 228 | waitpid $pidg, 0; |
| 229 | print "done waiting\n" if $verbose > 2; |
| 230 | } |
| 231 | |
| 232 | |
| 233 | if ($problem_set) { |
| 234 | open(F, $problem_set) or confess "can't open problem set: $problem_set"; |
| 235 | my %filehash; |
| 236 | while (<F>) { |
| 237 | next if ($_ =~ /^\s*(#.*)?$/); |
| 238 | last if ($_ =~ /DONE|STOP/); |
| 239 | my ($filename, $probnum) = $_ =~ /^([^:]*):(\d+)/; |
| 240 | if (!defined $filename) { |
| 241 | warn "Unexpected line: $_"; |
| 242 | last; |
| 243 | } |
| 244 | $filename =~ s/(\.tst)$//; |
| 245 | push @{$filehash{$filename}}, $probnum; |
| 246 | } |
| 247 | close F; |
| 248 | open(F, $problem_set) or confess "can't open problem set: $problem_set"; |
| 249 | while (<F>) { |
| 250 | next if ($_ =~ /^\s*(#.*)?$/); |
| 251 | my ($filename, $probnum) = $_ =~ /^(.*):(\d+)/; |
| 252 | last unless defined $filename; |
| 253 | $filename =~ s/(\.tst)$//; |
| 254 | if (exists ($filehash{$filename}) ){ |
| 255 | regress_file ("$filename.tst", @{$filehash{$filename}}); |
| 256 | delete $filehash{$filename}; |
| 257 | } |
| 258 | } |
| 259 | close F; |
| 260 | |
| 261 | |
| 262 | } else { |
| 263 | if ($all_batches) { |
| 264 | @ARGV = allTargets(); |
| 265 | } |
| 266 | my $curtstfile = ""; |
| 267 | my $file_count = 0; |
| 268 | while ($file_count <= $#ARGV) { |
| 269 | $curtstfile = $ARGV[$file_count]; |
| 270 | #unlink "html/index.html"; |
| 271 | unlink "html/$curtstfile/index.html"; |
| 272 | print "regressing file $ARGV[$file_count]\n" if $verbose > 1; |
| 273 | unlink "html/$curtstfile/index.html"; |
| 274 | regress_file ($ARGV[$file_count]); |
| 275 | $file_count++; |
| 276 | @failed_links = @FAILED_links = (); |
| 277 | }; |
| 278 | } |
| 279 | |
| 280 | if (!$one_gg_process) { |
| 281 | go_command("quit"); |
| 282 | print "waiting\n" if $verbose > 1; |
| 283 | waitpid $pidg, 0; |
| 284 | print "done waiting\n" if $verbose > 1; |
| 285 | } |
| 286 | |
| 287 | #readline(*STDIN); |
| 288 | |
| 289 | exit; |
| 290 | |
| 291 | |
| 292 | my $g_curtestfile; |
| 293 | |
| 294 | sub regress_chunk { |
| 295 | my @lines = @_; |
| 296 | } |
| 297 | |
| 298 | sub regress_file { |
| 299 | $testfile = shift; |
| 300 | my @problist = sort {$a<=>$b} @_; |
| 301 | if ($verbose) { |
| 302 | print "$testfile"; |
| 303 | print ": ", join (" ", @problist), "\n" if @problist; |
| 304 | print "\n"; |
| 305 | } |
| 306 | ($g_curtestfile) = $testfile =~ /(.*)\.tst$/ or confess "Unparsable test file: $testfile"; |
| 307 | |
| 308 | -e "html" or mkdir "html" or die "Couldn't create html"; |
| 309 | -e "html/$testfile" or mkdir "html/$testfile" or die "Couldn't create html/$testfile"; |
| 310 | |
| 311 | my $childpid; |
| 312 | |
| 313 | unless ($one_gg_process) { |
| 314 | $goprog_in = new FileHandle; # stdin of computer player |
| 315 | $goprog_out = new FileHandle; # stdout of computer player |
| 316 | $goprog_err = new FileHandle; # stderr of computer player |
| 317 | $pidg = open3($goprog_in, $goprog_out, $goprog_err, $goprog); |
| 318 | print "goprog pid: $pidg\n" if $verbose > 1; |
| 319 | unless ($childpid = fork) { |
| 320 | #Child. |
| 321 | chdir "html/$testfile" ; |
| 322 | open (TRACER, ">tracer.ttt"); |
| 323 | while (defined(my $t = <$goprog_err>)) { |
| 324 | last if $t =~ /^ALL DONE/; |
| 325 | print TRACER $t; |
| 326 | print "ERR: $t" if $verbose > 2; |
| 327 | if ($t =~ /^\s*FINISHED PROBLEM:\s*$/ or |
| 328 | $t =~ /^\s*SKIPPED PROBLEM:\s*$/) { |
| 329 | my $num = <$goprog_err>; |
| 330 | print TRACER $num; |
| 331 | $num += 0; |
| 332 | close TRACER or die "Couldn't close temp trace file"; |
| 333 | print "closed trace file\n" if $verbose > 2; |
| 334 | if ($t =~ /^\s*FINISHED PROBLEM:\s*$/) { |
| 335 | rename "tracer.ttt", "$num.trace" |
| 336 | or die "Couldn't rename tracer: $testfile, $num"; |
| 337 | } |
| 338 | open (TRACER, ">tracer.ttt"); |
| 339 | } |
| 340 | } |
| 341 | close TRACER; |
| 342 | exit; |
| 343 | } |
| 344 | } |
| 345 | |
| 346 | foreach (@counters) { |
| 347 | go_command("reset_${_}_counter"); |
| 348 | eat(); |
| 349 | } |
| 350 | |
| 351 | #main bit. |
| 352 | $pidt = open ($testfile_out,"<$testfile") or confess "Can't open $testfile"; |
| 353 | print "testfile pid: $pidt\n" if $verbose > 1; |
| 354 | |
| 355 | my $negate; |
| 356 | my $ignore; |
| 357 | my $fail; |
| 358 | $passes=0; |
| 359 | $unexpected_pass=0; |
| 360 | $failures=0; |
| 361 | $unexpected_fail=0; |
| 362 | $result = ""; |
| 363 | $next_cmd = ""; |
| 364 | $num = 0; |
| 365 | $filepos = 0; |
| 366 | go_command("cputime"); |
| 367 | $cputime = <$goprog_out>; |
| 368 | print "cputime: $cputime\n" if $verbose > 1; |
| 369 | ($cputime) = ($cputime =~ /((\d|\.)+)/); |
| 370 | <$goprog_out>; |
| 371 | |
| 372 | my $skipping; |
| 373 | while (defined($next_cmd)) |
| 374 | { |
| 375 | $filepos++; |
| 376 | my $force_read = 1; |
| 377 | while ($force_read) { |
| 378 | $prev_cmd = $next_cmd; |
| 379 | $next_cmd = <$testfile_out>; |
| 380 | $force_read = 0; |
| 381 | if (defined($next_cmd)) { |
| 382 | chop($next_cmd); |
| 383 | print "NEXT_CMD: '$next_cmd'\n" if ($verbose > 1); |
| 384 | if (($next_cmd =~ /^\s*#\?\s+\[(\!*)(.*)\]\s*(\*)*(\&)*\s*$/)) { |
| 385 | $bang = $1; |
| 386 | if ($1) { $negate = 1} else {$negate = 0}; |
| 387 | $correct_re = $2; |
| 388 | if ($3) { $fail = 1} else { $fail = 0}; |
| 389 | if ($4) {$ignore = 1} else {$ignore = 0}; |
| 390 | |
| 391 | $skipping = (@problist && |
| 392 | eval {foreach my $i (@problist) { return 0 if $i == $num} return 1;} ); |
| 393 | |
| 394 | if ($skipping) { |
| 395 | go_command("echo_err SKIPPED PROBLEM:\n"); |
| 396 | } else { |
| 397 | go_command("echo_err FINISHED PROBLEM:\n"); |
| 398 | } |
| 399 | eat(); #ignore output! |
| 400 | go_command("echo_err $num\n"); |
| 401 | eat(); #ignore output! |
| 402 | |
| 403 | if ($skipping) { |
| 404 | print "$g_curtestfile:$num skipped.\n" if $verbose > 1; |
| 405 | tally_result ($num, "skipped", " ", " "); |
| 406 | } else { |
| 407 | print "TST:$negate - $correct_re - $fail - $ignore\n" if $verbose>1; |
| 408 | if (!$ignore) { |
| 409 | my $match_result = $result =~ /^$correct_re$/ ; |
| 410 | if ($negate) { |
| 411 | $match_result = ! $match_result; |
| 412 | } |
| 413 | if ($match_result) { |
| 414 | if ($fail) { |
| 415 | tally_result ($num,"PASSED","$bang$correct_re","$result"); |
| 416 | } else { |
| 417 | tally_result ($num,"passed","$bang$correct_re","$result"); |
| 418 | } |
| 419 | } else { |
| 420 | if (!$fail) { |
| 421 | tally_result ($num,"FAILED","$bang$correct_re","$result"); |
| 422 | } else { |
| 423 | tally_result ($num,"failed","$bang$correct_re","$result"); |
| 424 | } |
| 425 | } |
| 426 | } |
| 427 | } |
| 428 | $old_whole_gtp = $html_whole_gtp; |
| 429 | $html_whole_gtp = ""; |
| 430 | } else { |
| 431 | if (!($next_cmd =~ /^\s*$/)) { |
| 432 | $html_whole_gtp .= " " . html_encode($next_cmd) . "<BR>\n"; |
| 433 | } |
| 434 | } |
| 435 | $next_cmd =~ s/^\s*$//; $next_cmd =~ s/^#.*$//; |
| 436 | $force_read = $next_cmd eq "" |
| 437 | } |
| 438 | } |
| 439 | if (defined($next_cmd)) { |
| 440 | my ($this_number) = $next_cmd =~ /^([0-9]+)/; |
| 441 | $skipping = (defined($this_number) && |
| 442 | (@problist && |
| 443 | eval {foreach my $i (@problist) {return 0 if $i == $this_number} return 1;} )); |
| 444 | if ($skipping) { |
| 445 | #print "SKIPPING: $next_cmd ($this_number)\n"; |
| 446 | } else { |
| 447 | #print "NOT SKIPPING: $next_cmd\n"; |
| 448 | $top_moves = ""; |
| 449 | if ($do_topmove) { |
| 450 | if ($next_cmd =~ /reg_genmove\s+([blackwhite])+/) { |
| 451 | $next_cmd =~ s/reg_genmove\s+([blackwhite]+)/top_moves_$1/; |
| 452 | $top_moves = 1; |
| 453 | } |
| 454 | } |
| 455 | if (defined($this_number) |
| 456 | && $next_cmd =~ /attack|defend/ |
| 457 | && $generate_sgf) { |
| 458 | go_command("start_sgftrace"); |
| 459 | eat(); #ignore output |
| 460 | } |
| 461 | go_command($next_cmd); |
| 462 | if ($top_moves) { |
| 463 | $top_moves = eat_one(); |
| 464 | if ($top_moves) { |
| 465 | ($result, $_) = split(/ /, $top_moves, 2); |
| 466 | } else { |
| 467 | $result = "PASS"; |
| 468 | $top_moves = ""; |
| 469 | } |
| 470 | print "TopMoves:$top_moves\n" if $verbose > 1; |
| 471 | } else { |
| 472 | $result = eat_one(); |
| 473 | if (!defined($result)) {$result="";} |
| 474 | } |
| 475 | print "RES: $result\n" if $verbose > 1; |
| 476 | if (defined($this_number) && $next_cmd =~ /attack|defend/) { |
| 477 | if ($generate_sgf) { |
| 478 | go_command("finish_sgftrace html$s$testfile$s$this_number.sgf"); |
| 479 | eat(); #ignore output |
| 480 | } else { |
| 481 | unlink "html$s$testfile$s$this_number.sgf"; |
| 482 | } |
| 483 | } |
| 484 | } |
| 485 | if (defined $this_number) {$num = $this_number;} |
| 486 | } |
| 487 | } |
| 488 | |
| 489 | my $pass_string; |
| 490 | my $fail_string; |
| 491 | if ($unexpected_pass == 1) { |
| 492 | $pass_string = "pass"; |
| 493 | } else { |
| 494 | $pass_string = "passes"; |
| 495 | } |
| 496 | if ($unexpected_fail == 1) { |
| 497 | $fail_string = "failure"; |
| 498 | } else { |
| 499 | $fail_string = "failures"; |
| 500 | } |
| 501 | |
| 502 | print "Summary: $passes/" . ($passes + $failures) . |
| 503 | " passes. $unexpected_pass unexpected $pass_string, " |
| 504 | . "$unexpected_fail unexpected $fail_string\n"; |
| 505 | |
| 506 | unless ($one_gg_process) { |
| 507 | go_command("echo_err ALL DONE"); |
| 508 | print "waiting on child\n" if $verbose > 1; |
| 509 | waitpid $childpid, 0; |
| 510 | print "done waiting on child\n" if $verbose > 1; |
| 511 | go_command("quit"); |
| 512 | print "waiting\n" if $verbose > 1; |
| 513 | waitpid $pidg, 0; |
| 514 | print "done waiting\n" if $verbose > 1; |
| 515 | } |
| 516 | } |
| 517 | |
| 518 | sub tally_result { |
| 519 | (my $number, my $status, my $correct, my $incorrect) = @_; |
| 520 | my $showboard = $status ne "skipped"; |
| 521 | $passes++ if $status eq "passed"; |
| 522 | $unexpected_pass++ if $status eq "PASSED"; |
| 523 | $failures++ if $status eq "failed"; |
| 524 | $unexpected_fail++ if $status eq "FAILED"; |
| 525 | |
| 526 | if (($verbose and $status ne "skipped") or |
| 527 | (!$verbose and ($status eq "PASSED" or $status eq "FAILED")) ) { |
| 528 | print "$g_curtestfile:$number: $status: correct: $correct answer: $incorrect\n"; |
| 529 | } |
| 530 | |
| 531 | $cur_passed = ($status =~ /pass/i); |
| 532 | if ($showboard) { |
| 533 | mkdir ("html/$testfile");# die quietly - probably already exists. |
| 534 | my $brd = new FileHandle; |
| 535 | open ($brd, "> html/$testfile/$num.xml") || die "ERROR: couldn't crate xml board: $!\n"; |
| 536 | my $brdout = eat_board(); |
| 537 | print $brd "<GOPROB filepos=$filepos number=$num file=\"$testfile\" status=\"$status\">\n"; |
| 538 | print $brd qq@<ENGINE version="$goprog_version" name="goprog_name" timestamp="goprog_timestamp">\n@; |
| 539 | print $brd "<CORRECT>$correct</CORRECT>\n"; |
| 540 | print $brd "<ANSWER>$incorrect</ANSWER>\n"; |
| 541 | if ($html_whole_gtp !~ /^\s*loadsgf/m) { |
| 542 | $old_whole_gtp .= $html_whole_gtp; |
| 543 | $html_whole_gtp = $old_whole_gtp; |
| 544 | } |
| 545 | print $brd "<GTP_ALL>\n$html_whole_gtp\n</GTP_ALL>"; |
| 546 | foreach my $listval ("DESCRIPTION", "CATEGORY", "SEVERITY") { |
| 547 | my $astxt; |
| 548 | $html_whole_gtp =~ /$listval=(.*?)<BR>/; |
| 549 | if (defined($1)) {$astxt = $1;} else {$astxt = "";}; |
| 550 | print $brd "<$listval>$astxt</$listval>\n"; |
| 551 | } |
| 552 | print $brd "<COUNTERS "; |
| 553 | foreach (@counters) { |
| 554 | go_command("get_${_}_counter"); |
| 555 | my $counts = eat_one(); |
| 556 | defined($counts) or confess "Missing count"; |
| 557 | defined($counters{$_}) or confess "Missing counter"; |
| 558 | my $countdelta = $counts - $counters{$_}; |
| 559 | $counters{$_} = $counts; |
| 560 | print $brd qq@\n $_="$countdelta"@; |
| 561 | } |
| 562 | print $brd ">\n"; |
| 563 | |
| 564 | |
| 565 | go_command("cputime"); |
| 566 | my $new_cputime = <$goprog_out>; |
| 567 | ($new_cputime) = ($new_cputime =~ /((\d|\.)+)/); |
| 568 | print "cputime: ".$new_cputime."\n" if $verbose > 1; |
| 569 | <$goprog_out>; |
| 570 | print $brd "<TIME wall=0.0 CPU=" . sprintf("%.5f", $new_cputime - $cputime) . ">\n"; |
| 571 | $cputime = $new_cputime; |
| 572 | |
| 573 | print $brd "<GTP_COMMAND>$prev_cmd</GTP_COMMAND>\n"; |
| 574 | print $brd $brdout; |
| 575 | |
| 576 | print $brd "<TRACE_OUTPUT>$trace_output</TRACE_OUTPUT>\n"; |
| 577 | $trace_output= ""; |
| 578 | |
| 579 | print $brd "</GOPROB>\n"; |
| 580 | close $brd; |
| 581 | } |
| 582 | } |
| 583 | |
| 584 | sub html_encode { |
| 585 | my $r = shift; |
| 586 | $r =~ s/&/&/g; |
| 587 | $r =~ s/</</g; |
| 588 | $r =~ s/>/>/g; |
| 589 | return $r; |
| 590 | } |
| 591 | |
| 592 | |
| 593 | sub eat_board { |
| 594 | go_command("query_boardsize"); |
| 595 | my $line = eat(); |
| 596 | (undef, $boardsize) = split(' ', $line, 2); |
| 597 | $boardsize = $boardsize + 0; |
| 598 | my $linesleft = $boardsize + 2; |
| 599 | |
| 600 | my $xboard = ""; |
| 601 | |
| 602 | my $cur_point = 0; |
| 603 | my $cur_color = 0; |
| 604 | my $cur_matcher_status = 0; |
| 605 | my $cur_dragon_status=0; |
| 606 | my $cur_owl_status=0; |
| 607 | my $cur_color_letter=0; |
| 608 | my %dragons; |
| 609 | my $white_letter = chr(ord('z')+1); |
| 610 | my $black_letter = chr(ord('A')-1); |
| 611 | my $iline = 1; |
| 612 | my $no_dragon_data = 0; |
| 613 | my %stones; |
| 614 | |
| 615 | if ($prev_cmd =~ /reg_genmove/) { |
| 616 | #FIXME: There may be other commands that won't require dragon_data |
| 617 | #to be regenerated. Better might be to provide a way to query the |
| 618 | #engine whether dragon_data is currently available w/out regenerating. |
| 619 | go_command("dragon_data\n"); |
| 620 | while ($iline) { |
| 621 | $iline = $_ = <$goprog_out>; |
| 622 | if ($iline =~ /^\?(.*)/) { |
| 623 | $no_dragon_data = $1; |
| 624 | $iline = $_ = <$goprog_out>; |
| 625 | last; |
| 626 | } |
| 627 | $iline =~ s/\s*$//mg; |
| 628 | if ($iline =~ /^=?\s*([A-Z][0-9][0-9]?):\s*$/ || !$iline) { |
| 629 | if ($cur_point) { |
| 630 | if ($cur_color eq "white") { |
| 631 | $_ = $white_letter = chr(ord($white_letter)-1); |
| 632 | $cur_color_letter = "O"; |
| 633 | } elsif ($cur_color eq "black" || die "invalid color $cur_color") { |
| 634 | $_ = $black_letter = chr(ord($black_letter)+1); |
| 635 | $cur_color_letter = "X"; |
| 636 | } |
| 637 | $dragons{$cur_point} = $_ . ";status=" . $cur_dragon_status . |
| 638 | ";owl_status=" . $cur_owl_status . |
| 639 | ";color_letter=" . $cur_color_letter. |
| 640 | ";"; |
| 641 | $cur_color = 0; |
| 642 | $cur_matcher_status = 0; |
| 643 | $cur_dragon_status=0; |
| 644 | $cur_owl_status=0; |
| 645 | $cur_color_letter=0; |
| 646 | } |
| 647 | $cur_point = $1; |
| 648 | } elsif ($iline =~ /^color:?\s+([blackwhite]*)\s*$/) { |
| 649 | $cur_color = $1; |
| 650 | } elsif ($iline =~ /^matcher_status:?\s+(\S*)\s*$/) { |
| 651 | $cur_matcher_status = $1; |
| 652 | } elsif ($iline =~ /^status:?\s+(\S*)\s*$/) { |
| 653 | $cur_dragon_status = $1; |
| 654 | } elsif ($iline =~ /^owl_status:?\s+(\S*)\s*$/) { |
| 655 | $cur_owl_status = $1; |
| 656 | } else { |
| 657 | #we ignore lots of dragon data! |
| 658 | } |
| 659 | } |
| 660 | } else { |
| 661 | $no_dragon_data=1; |
| 662 | foreach $cur_color ("white", "black") { |
| 663 | $iline = 1; |
| 664 | go_command("worm_stones $cur_color"); |
| 665 | if ($cur_color eq "white") { |
| 666 | $cur_color_letter = "O"; |
| 667 | } elsif ($cur_color eq "black" || die "invalid color $cur_color") { |
| 668 | $cur_color_letter = "X"; |
| 669 | } |
| 670 | while ($iline) { |
| 671 | $iline = <$goprog_out>; |
| 672 | my $splitline = $iline; |
| 673 | $splitline =~ s/^[=]\s*//; |
| 674 | $splitline =~ s/\s*$//mg; |
| 675 | foreach (split (/\s+/,$splitline)) { |
| 676 | $stones{$_} =";color_letter=" . $cur_color_letter. |
| 677 | ";"; |
| 678 | } |
| 679 | $iline =~ s/\s*$//mg; |
| 680 | } |
| 681 | } |
| 682 | } |
| 683 | |
| 684 | if ($prev_cmd =~ /^[0-9]*\s*reg_genmove/) { |
| 685 | if (! ($next_cmd =~ /^#\?\s*\[(!)?\(?(.*)\)?\]\*?\s*$/)) { |
| 686 | print "BAD TEST: $next_cmd\n"; |
| 687 | } |
| 688 | #$1 and $2 are just $bang and $correct_re, right? |
| 689 | #print "Genmove test:\n"; |
| 690 | #print " $1;$2\n"; |
| 691 | foreach (split(/\|/,$2)) { |
| 692 | if ($1) { |
| 693 | $stones{$_} .= ";known_wrong;"; |
| 694 | } else { |
| 695 | $stones{$_} .= ";known_right;"; |
| 696 | } |
| 697 | } |
| 698 | if ($cur_passed) { |
| 699 | $stones{$result} .= ";try_right;"; |
| 700 | } else { |
| 701 | $stones{$result} .= ";try_wrong;"; |
| 702 | } |
| 703 | } else { |
| 704 | # Experimental - should work for reg_genmove too! |
| 705 | if (! ($next_cmd =~ /^#\?\s*\[(!)?\(?(.*)\)?\]\*?\s*$/)) { |
| 706 | print "BAD TEST: $next_cmd\n"; |
| 707 | } #see commend on this regex above. |
| 708 | my $known = $2; |
| 709 | #Here, look for something that looks like a move! |
| 710 | while ($known =~ s/([A-Z]\d\d?)//) { |
| 711 | if ($bang) { |
| 712 | $stones{$1} .= ";known_wrong;"; |
| 713 | } else { |
| 714 | $stones{$1} .= ";known_right;"; |
| 715 | } |
| 716 | } |
| 717 | my $try = $result; |
| 718 | while ($try =~ s/([A-Z]\d\d?)//) { |
| 719 | if ($cur_passed) { |
| 720 | $stones{$1} .= ";try_right;"; |
| 721 | } else { |
| 722 | $stones{$1} .= ";try_wrong;"; |
| 723 | } |
| 724 | } |
| 725 | } |
| 726 | |
| 727 | { |
| 728 | my $pc = $prev_cmd; |
| 729 | while ($pc =~ s/([A-Z]\d\d?)//) { |
| 730 | $stones{$1} .= ";question;"; |
| 731 | } |
| 732 | } |
| 733 | |
| 734 | |
| 735 | |
| 736 | unless ($no_dragon_data) { |
| 737 | #FIXME: This data is available via the strings line from dragon_data. |
| 738 | go_command("dragon_stones"); |
| 739 | $iline = 1; |
| 740 | while ($iline) { |
| 741 | $iline = <$goprog_out>; |
| 742 | $iline =~ s/\s*$//mg; |
| 743 | $iline =~ s/^=?\s*//; |
| 744 | $iline = " " . $iline . " "; |
| 745 | foreach (keys(%dragons)) { |
| 746 | my $k = $_; |
| 747 | my $label = $dragons{$k}; |
| 748 | if ($iline =~ (" ".$k." ")) { |
| 749 | $iline =~ s/^\s*//; |
| 750 | $iline =~ s/\s*$//; |
| 751 | foreach (split(/ /,$iline)) { |
| 752 | $stones{$_} = $label; |
| 753 | } |
| 754 | } |
| 755 | } |
| 756 | $iline =~ s/\s*//mg; |
| 757 | } |
| 758 | } |
| 759 | |
| 760 | my %tmarr; |
| 761 | if ($prev_cmd =~ /.*reg_genmove\s+([whiteblack]+)/) { |
| 762 | go_command ("top_moves"); |
| 763 | my $top_moves = <$goprog_out>; |
| 764 | <$goprog_out>; |
| 765 | if ($top_moves) { |
| 766 | $top_moves =~ s/^=\s*//; |
| 767 | $top_moves =~ s/\s*$//mg; |
| 768 | print "TOP_MOVES:'$top_moves'\n" if $verbose > 1; |
| 769 | if ($top_moves =~ /^\s*(.*)\s*/) { #i.e. always! |
| 770 | my $t = $1; |
| 771 | %tmarr = split(/\s+/,$t); |
| 772 | foreach my $k (keys(%tmarr)) { |
| 773 | $stones{$k} .= ";move_value=$tmarr{$k};"; |
| 774 | } |
| 775 | } |
| 776 | } |
| 777 | } |
| 778 | |
| 779 | my $j; |
| 780 | my $i; |
| 781 | |
| 782 | for ($j = $boardsize; $j > 0; $j--) { |
| 783 | my $jA = $j; |
| 784 | if ($j <= 9) { |
| 785 | $jA .= " "; |
| 786 | } |
| 787 | for ($i = 1; $i <= $boardsize; $i++) { |
| 788 | my $iA = ord('A') + $i - 1; |
| 789 | if ($iA >= ord('I')) { $iA++; } |
| 790 | $iA = chr($iA); |
| 791 | my $point = ""; |
| 792 | if ($stones{$iA.$j}) { |
| 793 | $point .= qq/ coord="$iA$j"\n/; |
| 794 | my $status = $stones{$iA.$j}; |
| 795 | if ($status =~ /(.).*;owl_status=([^;]*);/) { |
| 796 | $point .= qq/ owl_status="$2"\n/; |
| 797 | } |
| 798 | if ($status =~ /(.).*;status=([^;]*);/) { |
| 799 | $point .= qq/ dragon_letter="$1"\n/; |
| 800 | $point .= qq/ dragon_status="$2"\n/; |
| 801 | } |
| 802 | if ($status =~ /;color_letter=([^;]*);/) { |
| 803 | $point .= qq/ stone="/ . (($1 eq 'X') ? 'black' : 'white') . qq/"\n/; |
| 804 | } |
| 805 | if ($status =~ /;move_value=([^;]*);/) { |
| 806 | $point .= qq/ move_value="$1"\n/; |
| 807 | } |
| 808 | $point .= qq/ known="wrong"\n/ if ($status =~ /;known_wrong;/); |
| 809 | $point .= qq/ known="right"\n/ if ($status =~ /;known_right;/); |
| 810 | $point .= qq/ try="right"\n/ if ($status =~ /;try_right;/); |
| 811 | $point .= qq/ try="wrong"\n/ if ($status =~ /;try_wrong;/); |
| 812 | |
| 813 | $point .= qq/ question="1"\n/ if ($status =~/;question;/); |
| 814 | } |
| 815 | if ($point) { |
| 816 | $xboard .= " <POINT\n" . $point . " ></POINT>\n"; |
| 817 | } |
| 818 | } |
| 819 | } |
| 820 | |
| 821 | return "<BOARD size=$boardsize>\n" . $xboard . "</BOARD>\n"; |
| 822 | } |
| 823 | |
| 824 | |
| 825 | sub eat() { |
| 826 | # ignore empty lines |
| 827 | my $line = ""; |
| 828 | while ($line eq "") { |
| 829 | chop($line = <$goprog_out>) or confess "No response!"; |
| 830 | $line =~ s/\s*$//smg; |
| 831 | } |
| 832 | <$goprog_out>; |
| 833 | return $line; |
| 834 | } |
| 835 | |
| 836 | |
| 837 | sub eat_one { |
| 838 | my ($equals, $move) = split(' ', eat(), 2); |
| 839 | return $move; |
| 840 | } |
| 841 | |
| 842 | sub go_command { |
| 843 | my $cmd = shift; |
| 844 | print $goprog_in "$cmd\n"; |
| 845 | print "CMD:$cmd\n" if $verbose > 1; |
| 846 | foreach (@counters) { |
| 847 | if ($cmd =~ /reset_${_}_counter/) { |
| 848 | $counters{$_} = 0; |
| 849 | } |
| 850 | } |
| 851 | } |
| 852 | |
| 853 | |
| 854 | my %images; |
| 855 | sub extract_images { |
| 856 | my $line = shift; |
| 857 | #i.e.: <TD><IMG HEIGHT=25 WIDTH=25 SRC="../images/B25x43_green.png"></TD> |
| 858 | if ($line =~ /SRC=.*images.(.*)\"><.TD>.*/) { |
| 859 | if ($verbose) { |
| 860 | print " found: $1\n" unless ($images{$1}); |
| 861 | } |
| 862 | $images{$1} = 1; |
| 863 | } |
| 864 | } |
| 865 | |
| 866 | our $curdir; |
| 867 | our $curfile; |
| 868 | our $CURDIR; |
| 869 | sub extract_image_dir { |
| 870 | local $curdir = shift; |
| 871 | local $CURDIR; |
| 872 | opendir $CURDIR, $curdir; |
| 873 | while (local $curfile = readdir $CURDIR) { |
| 874 | $_ = "$curdir/$curfile"; |
| 875 | #print -d."\n"; |
| 876 | #print "X:".($curfile=~/^\.+$/)."\n"; |
| 877 | if ((-d ) && !($curfile=~/^\.{1,2}$/)) { |
| 878 | print "diving into: $curdir/$curfile\n" if $verbose>2; |
| 879 | extract_image_dir ("$curdir/$curfile"); |
| 880 | } elsif (($curfile =~ /\.html$/) && ($curdir =~ /d2/)) { |
| 881 | print "processing: $curdir/$curfile\n" if $verbose; |
| 882 | open IMGFILE, "<$curdir/$curfile" or die "Couldn't open: $curdir/$curfile" ; |
| 883 | while (<IMGFILE>) { |
| 884 | extract_images($_); |
| 885 | } |
| 886 | close IMGFILE; |
| 887 | } else { |
| 888 | #print "no match: $curdir/$curfile\n" if $verbose; |
| 889 | } |
| 890 | } |
| 891 | closedir CURDIR; |
| 892 | } |
| 893 | |
| 894 | |
| 895 | sub make_images { |
| 896 | print "Starting processing\n" if $verbose; |
| 897 | extract_image_dir (".") ; |
| 898 | print "Processed files, generated ".((scalar keys(%images))/2) |
| 899 | ." unique images:\n" if $verbose; |
| 900 | foreach (keys(%images)) { |
| 901 | parseFileName($_); |
| 902 | } |
| 903 | print "Done.\n" if $verbose; |
| 904 | } |
| 905 | |
| 906 | |
| 907 | sub allTargets { |
| 908 | open (MAKEFILE, "< Makefile.in"); |
| 909 | my @targets = ""; |
| 910 | while (<MAKEFILE>) { |
| 911 | if (s/^all_batches://) { |
| 912 | @targets = split; |
| 913 | last; |
| 914 | } |
| 915 | } |
| 916 | my $target_reg = "^" . join ("|", @targets) . ":" ; |
| 917 | close MAKEFILE; |
| 918 | |
| 919 | open (MAKEFILE, "< Makefile.in"); |
| 920 | my @files; |
| 921 | while (<MAKEFILE>) { |
| 922 | if ($_ =~ $target_reg) { |
| 923 | chop($_ = <MAKEFILE>); |
| 924 | while ($_) { |
| 925 | push @files, $_ =~ /\s+(\w+\.tst)/; |
| 926 | chop if defined($_ = <MAKEFILE>); |
| 927 | } |
| 928 | } |
| 929 | } |
| 930 | close MAKEFILE; |
| 931 | |
| 932 | return @files; |
| 933 | } |