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