X-Git-Url: https://git.sesse.net/?p=remoteglot;a=blobdiff_plain;f=remoteglot.pl;h=5982ecad214a65b4b6613efdeb90295eaf907dc2;hp=dd913f6a6855b45263c043691a380da6514a2920;hb=b3460eff1614aaa74a09a581f04edb8722c87667;hpb=f19e1618521811dad0e260ff79645d7055b1b7b7 diff --git a/remoteglot.pl b/remoteglot.pl index dd913f6..5982eca 100755 --- a/remoteglot.pl +++ b/remoteglot.pl @@ -19,6 +19,7 @@ use FileHandle; use IPC::Open2; use Time::HiRes; use JSON::XS; +use URI::Escape; require 'Position.pm'; require 'Engine.pm'; require 'config.pm'; @@ -30,6 +31,9 @@ no warnings qw(once); $SIG{ALRM} = sub { output(); }; my $latest_update = undef; my $http_timer = undef; +my $tb_retry_timer = undef; +my %tb_cache = (); +my $tb_lookup_running = 0; $| = 1; @@ -44,6 +48,13 @@ open(UCILOG, ">ucilog.txt") print UCILOG "Log starting.\n"; select(UCILOG); $| = 1; + +open(TBLOG, ">tblog.txt") + or die "tblog.txt: $!"; +print TBLOG "Log starting.\n"; +select(TBLOG); +$| = 1; + select(STDOUT); # open the chess engine @@ -82,8 +93,6 @@ $t->cmd(""); $t->cmd("set shout 0"); $t->cmd("set seek 0"); $t->cmd("set style 12"); -$t->cmd("observe $remoteglotconf::target"); -print "FICS ready.\n"; my $ev1 = AnyEvent->io( fh => fileno($t), @@ -99,6 +108,15 @@ my $ev1 = AnyEvent->io( } } ); +if (defined($remoteglotconf::target)) { + if ($remoteglotconf::target =~ /^http:/) { + fetch_pgn($remoteglotconf::target); + } else { + $t->cmd("observe $remoteglotconf::target"); + } +} +print "FICS ready.\n"; + # Engine events have already been set up by Engine.pm. EV::run; @@ -161,9 +179,7 @@ sub handle_fics { } elsif ($msg =~ /^pgn (.*?)$/) { my $url = $1; $t->cmd("tell $who Starting to poll '$url'."); - AnyEvent::HTTP::http_get($url, sub { - handle_pgn(@_, $url); - }); + fetch_pgn($url); } elsif ($msg =~ /^stoppgn$/) { $t->cmd("tell $who Stopping poll."); $http_timer = undef; @@ -177,6 +193,18 @@ sub handle_fics { #print "FICS: [$line]\n"; } +# Starts periodic fetching of PGNs from the given URL. +sub fetch_pgn { + my ($url) = @_; + AnyEvent::HTTP::http_get($url, sub { + handle_pgn(@_, $url); + }); +} + +my ($last_pgn_white, $last_pgn_black); +my @last_pgn_uci_moves = (); +my $pgn_hysteresis_counter = 0; + sub handle_pgn { my ($body, $header, $url) = @_; my $pgn = Chess::PGN::Parse->new(undef, $body); @@ -194,13 +222,31 @@ sub handle_pgn { } $pos->{'history'} = \@uci_moves; $pos->{'pretty_history'} = $moves; - handle_position($pos); + + # Sometimes, PGNs lose a move or two for a short while, + # or people push out new ones non-atomically. + # Thus, if we PGN doesn't change names but becomes + # shorter, we mistrust it for a few seconds. + my $trust_pgn = 1; + if (defined($last_pgn_white) && defined($last_pgn_black) && + $last_pgn_white eq $pgn->white && + $last_pgn_black eq $pgn->black && + scalar(@uci_moves) < scalar(@last_pgn_uci_moves)) { + if (++$pgn_hysteresis_counter < 3) { + $trust_pgn = 0; + } + } + if ($trust_pgn) { + $last_pgn_white = $pgn->white; + $last_pgn_black = $pgn->black; + @last_pgn_uci_moves = @uci_moves; + $pgn_hysteresis_counter = 0; + handle_position($pos); + } } $http_timer = AnyEvent->timer(after => 1.0, cb => sub { - AnyEvent::HTTP::http_get($url, sub { - handle_pgn(@_, $url); - }); + fetch_pgn($url); }); } @@ -251,6 +297,8 @@ sub handle_position { $engine->{'info'} = {}; $last_move = time; + schedule_tb_lookup(); + # # Output a command every move to note that we're # still paying attention -- this is a good tradeoff, @@ -385,6 +433,46 @@ sub output { } my $info = $engine->{'info'}; + + # + # If we have tablebase data from a previous lookup, replace the + # engine data with the data from the tablebase. + # + my $fen = $pos_calculating->fen(); + if (exists($tb_cache{$fen})) { + for my $key (qw(pv score_cp score_mate nodes nps depth seldepth tbhits)) { + delete $info->{$key . '1'}; + delete $info->{$key}; + } + $info->{'nodes'} = 0; + $info->{'nps'} = 0; + $info->{'depth'} = 0; + $info->{'seldepth'} = 0; + $info->{'tbhits'} = 0; + + my $t = $tb_cache{$fen}; + my $pv = $t->{'pv'}; + my $matelen = int((1 + scalar @$pv) / 2); + if ($t->{'result'} eq '1/2-1/2') { + $info->{'score_cp'} = 0; + } elsif ($t->{'result'} eq '1-0') { + if ($pos_calculating->{'toplay'} eq 'B') { + $info->{'score_mate'} = -$matelen; + } else { + $info->{'score_mate'} = $matelen; + } + } else { + if ($pos_calculating->{'toplay'} eq 'B') { + $info->{'score_mate'} = $matelen; + } else { + $info->{'score_mate'} = -$matelen; + } + } + $info->{'pv'} = $pv; + $info->{'tablebase'} = 1; + } else { + $info->{'tablebase'} = 0; + } # # Some programs _always_ report MultiPV, even with only one PV. @@ -520,7 +608,7 @@ sub output_screen { my $key = $pretty_move; my $line = sprintf(" %-6s %6s %3s %s", $pretty_move, - short_score($info, $pos_calculating_second_engine, $mpv, 0), + short_score($info, $pos_calculating_second_engine, $mpv), "d" . $info->{'depth' . $mpv}, join(', ', @pretty_pv)); push @refutation_lines, [ $key, $line ]; @@ -550,12 +638,14 @@ sub output_json { $json->{'position'} = $pos_calculating->to_json_hash(); $json->{'id'} = $engine->{'id'}; $json->{'score'} = long_score($info, $pos_calculating, ''); + $json->{'short_score'} = short_score($info, $pos_calculating, ''); $json->{'nodes'} = $info->{'nodes'}; $json->{'nps'} = $info->{'nps'}; $json->{'depth'} = $info->{'depth'}; $json->{'tbhits'} = $info->{'tbhits'}; $json->{'seldepth'} = $info->{'seldepth'}; + $json->{'tablebase'} = $info->{'tablebase'}; # single-PV only for now $json->{'pv_uci'} = $info->{'pv'}; @@ -578,7 +668,7 @@ sub output_json { sort_key => $pretty_move, depth => $info->{'depth' . $mpv}, score_sort_key => score_sort_key($info, $pos_calculating, $mpv, 0), - pretty_score => short_score($info, $pos_calculating, $mpv, 0), + pretty_score => short_score($info, $pos_calculating, $mpv), pretty_move => $pretty_move, pv_pretty => \@pretty_pv, }; @@ -588,11 +678,11 @@ sub output_json { } $json->{'refutation_lines'} = \%refutation_lines; - open my $fh, ">/srv/analysis.sesse.net/www/analysis.json.tmp" + open my $fh, ">", $remoteglotconf::json_output . ".tmp" or return; print $fh JSON::XS::encode_json($json); close $fh; - rename("/srv/analysis.sesse.net/www/analysis.json.tmp", "/srv/analysis.sesse.net/www/analysis.json"); + rename($remoteglotconf::json_output . ".tmp", $remoteglotconf::json_output); } sub uciprint { @@ -602,13 +692,9 @@ sub uciprint { } sub short_score { - my ($info, $pos, $mpv, $invert) = @_; - - $invert //= 0; - if ($pos->{'toplay'} eq 'B') { - $invert = !$invert; - } + my ($info, $pos, $mpv) = @_; + my $invert = ($pos->{'toplay'} eq 'B'); if (defined($info->{'score_mate' . $mpv})) { if ($invert) { return sprintf "M%3d", -$info->{'score_mate' . $mpv}; @@ -619,7 +705,11 @@ sub short_score { if (exists($info->{'score_cp' . $mpv})) { my $score = $info->{'score_cp' . $mpv} * 0.01; if ($score == 0) { - return " 0.00"; + if ($info->{'tablebase'}) { + return "TB draw"; + } else { + return " 0.00"; + } } if ($invert) { $score = -$score; @@ -639,10 +729,10 @@ sub score_sort_key { my $score; if ($mate > 0) { # Side to move mates - $mate = 99999 - $mate; + $score = 99999 - $mate; } else { # Side to move is getting mated (note the double negative for $mate) - $mate = -99999 - $mate; + $score = -99999 - $mate; } if ($invert) { $score = -$score; @@ -678,7 +768,11 @@ sub long_score { if (exists($info->{'score_cp' . $mpv})) { my $score = $info->{'score_cp' . $mpv} * 0.01; if ($score == 0) { - return "Score: 0.00"; + if ($info->{'tablebase'}) { + return "Theoretical draw"; + } else { + return "Score: 0.00"; + } } if ($pos->{'toplay'} eq 'B') { $score = -$score; @@ -742,6 +836,83 @@ sub book_info { return $text; } +sub schedule_tb_lookup { + return if (!defined($remoteglotconf::tb_serial_key)); + my $pos = $pos_waiting // $pos_calculating; + return if (exists($tb_cache{$pos->fen()})); + + # If there's more than seven pieces, there's not going to be an answer, + # so don't bother. + return if ($pos->num_pieces() > 7); + + # Max one at a time. If it's still relevant when it returns, + # schedule_tb_lookup() will be called again. + return if ($tb_lookup_running); + + $tb_lookup_running = 1; + my $url = 'http://158.250.18.203:6904/tasks/addtask?auth.login=' . + $remoteglotconf::tb_serial_key . + '&auth.password=aquarium&type=0&fen=' . + URI::Escape::uri_escape($pos->fen()); + print TBLOG "Downloading $url...\n"; + AnyEvent::HTTP::http_get($url, sub { + handle_tb_lookup_return(@_, $pos, $pos->fen()); + }); +} + +sub handle_tb_lookup_return { + my ($body, $header, $pos, $fen) = @_; + print TBLOG "Response for [$fen]:\n"; + print TBLOG $header . "\n\n"; + print TBLOG $body . "\n\n"; + eval { + my $response = JSON::XS::decode_json($body); + if ($response->{'ErrorCode'} != 0) { + die "Unknown tablebase server error: " . $response->{'ErrorDesc'}; + } + my $state = $response->{'Response'}{'StateString'}; + if ($state eq 'COMPLETE') { + my $pgn = Chess::PGN::Parse->new(undef, $response->{'Response'}{'Moves'}); + if (!defined($pgn) || !$pgn->read_game()) { + warn "Error in parsing PGN\n"; + } else { + $pgn->quick_parse_game; + my $pvpos = $pos; + my $moves = $pgn->moves; + my @uci_moves = (); + for my $move (@$moves) { + my ($from_row, $from_col, $to_row, $to_col, $promo) = $pvpos->parse_pretty_move($move); + push @uci_moves, Board::move_to_uci_notation($from_row, $from_col, $to_row, $to_col, $promo); + $pvpos = $pvpos->make_move($from_row, $from_col, $to_row, $to_col, $promo); + } + $tb_cache{$fen} = { + result => $pgn->result, + pv => \@uci_moves + }; + output(); + } + } elsif ($state =~ /QUEUED/ || $state =~ /PROCESSING/) { + # Try again in a second. Note that if we have changed + # position in the meantime, we might query a completely + # different position! But that's fine. + } else { + die "Unknown response state " . $state; + } + + # Wait a second before we schedule another one. + $tb_retry_timer = AnyEvent->timer(after => 1.0, cb => sub { + $tb_lookup_running = 0; + schedule_tb_lookup(); + }); + }; + if ($@) { + warn "Error in tablebase lookup: $@"; + + # Don't try this one again, but don't block new lookups either. + $tb_lookup_running = 0; + } +} + sub open_engine { my ($cmdline, $tag, $cb) = @_; return undef if (!defined($cmdline));