projects / sgk-go / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Updated README: Equal sign not required with `--mode` flag.
[sgk-go] / regression / regress.pl
CommitLineData
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
38package REGRESS;
39
40use IPC::Open3;
41use IO::Handle;
42use Getopt::Long;
43use FileHandle;
44
45use FindBin;
46
47use strict;
48use warnings;
49
50use Carp;
51
52STDOUT->autoflush(1);
53
54my $helpstring = "
55
56Run with:
57
58regress.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
64Possible 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
73my %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
88my $trace_output="";
89my $cur_passed;
90my $result;
91my $correct_re;
92my $bang;
93my $top_moves;
94my $handicap_stones;
95my $sgfmove;
96my $vertex;
97my @vertices;
98my $first;
99my $second;
100my $resultb;
101my $resultw;
102my $scriptfile;
103my $pidt;
104my $pidg;
105my $testdir;
106my $goprog;
107my $verbose = 1;
108my $old_whole_gtp = "";
109my $html_whole_gtp = "";
110my $testfile;
111my $num;
112my $filepos;
113my $goprog_in ; # stdin of computer player
114my $goprog_out; # stdout of computer player
115my $goprog_err; # stderr of computer player
116my $passes;
117my $unexpected_pass;
118my $failures;
119my $unexpected_fail;
120my $numbers = "";
121my $boardsize = 19; #current boardsize
122my $testfile_out;
123my $all_batches;
124my $make_images;
125my $cputime;
126my $generate_sgf = 1;
127
128my $goprog_name = "unknown";
129my $goprog_version = "0";
130my $goprog_timestamp = 0;
131
132my $do_topmove = 0;
133my $one_gg_process = 0;
134
135my @failed_links;
136my @FAILED_links;
137
138my @counters = qw/connection_node owl_node reading_node trymove/;
139
140my %counters;
141
142my $next_cmd = "";
143my $prev_cmd = "";
144my $problem_set;
145my $wantshelp;
146
147GetOptions(
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
158if ($make_images) {
159 make_images();
160 exit;
161}
162
163my $s = (lc ($^O) eq 'mswin32') ? '\\' : '/';
164if (!$goprog) {
165 $goprog = "..${s}interface${s}gnugo";
166}
167
168if ($goprog !~ / /) {
169 $goprog .= " --mode gtp --quiet -t -w -d0x101840 --showtime";
170}
171
172die $helpstring unless defined $goprog;
173
174if ($wantshelp) {
175 print $helpstring;
176 exit;
177}
178
179
180
181if (!-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."
189if ($numbers) {
190 $numbers = "^($numbers)\$";
191}
192
193use 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
200print "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: $!";
203print "goprog pid: $pidg\n" if $verbose > 1;
204my ($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
210go_command("name");
211$_ = <$goprog_out>;
212if (/^=\s*(.*)/) {
213 ($goprog_name = $1) =~ s/\s*$//;
214}
215<$goprog_out>;
216go_command("version");
217$_ = <$goprog_out>;
218if (/^=\s*(.*)/) {
219 ($goprog_version = $1) =~ s/\s*$//;
220}
221<$goprog_out>;
222
223print "Name: " . $goprog_name ." ". $goprog_version . "\n" if $verbose > 1;
224
225if ($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
233if ($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
280if (!$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
289exit;
290
291
292my $g_curtestfile;
293
294sub regress_chunk {
295 my @lines = @_;
296}
297
298sub 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", "&nbsp;", "&nbsp;");
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
518sub 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
584sub html_encode {
585 my $r = shift;
586 $r =~ s/&/&amp;/g;
587 $r =~ s/</&lt;/g;
588 $r =~ s/>/&gt;/g;
589 return $r;
590}
591
592
593sub 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
825sub 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
837sub eat_one {
838 my ($equals, $move) = split(' ', eat(), 2);
839 return $move;
840}
841
842sub 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
854my %images;
855sub 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
866our $curdir;
867our $curfile;
868our $CURDIR;
869sub 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
895sub 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
907sub 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}
Fork of GNU Go supporting Xeon Phi coprocessors (and other modifications).