X-Git-Url: https://git.sesse.net/?p=remoteglot;a=blobdiff_plain;f=remoteglot.pl;h=d8a7925c9137cfe548b0b9729a98f8daf3defac7;hp=7846e83ef46f5d4090f50103a395e5a50c7ce767;hb=HEAD;hpb=b0c92beb6f269bd49bcc5eda11eae553251e121d diff --git a/remoteglot.pl b/remoteglot.pl index 7846e83..b5db356 100755 --- a/remoteglot.pl +++ b/remoteglot.pl @@ -1,11 +1,10 @@ #! /usr/bin/perl # -# remoteglot - Connects an abitrary UCI-speaking engine to ICS for easier post-game -# analysis, or for live analysis of relayed games. (Do not use for -# cheating! Cheating is bad for your karma, and your abuser flag.) +# remoteglot - Connects an abitrary UCI-speaking engine to a (live) PGN, +# for live analysis of relayed games. # -# Copyright 2007 Steinar H. Gunderson +# Copyright 2007 Steinar H. Gunderson # Licensed under the GNU General Public License, version 2. # @@ -14,13 +13,11 @@ use AnyEvent::Handle; use AnyEvent::HTTP; use Chess::PGN::Parse; use EV; -use Net::Telnet; -use FileHandle; +use File::Slurp; use IPC::Open2; use Time::HiRes; use JSON::XS; use URI::Escape; -use Tie::Persistent; use DBI; use DBD::Pg; require 'Position.pm'; @@ -36,7 +33,6 @@ my $output_timer = undef; my $http_timer = undef; my $stop_pgn_fetch = 0; my $tb_retry_timer = undef; -my %tb_cache = (); my $tb_lookup_running = 0; my $last_written_json = undef; @@ -49,12 +45,6 @@ $dbh->{RaiseError} = 1; $| = 1; -open(FICSLOG, ">ficslog.txt") - or die "ficslog.txt: $!"; -print FICSLOG "Log starting.\n"; -select(FICSLOG); -$| = 1; - open(UCILOG, ">ucilog.txt") or die "ucilog.txt: $!"; print UCILOG "Log starting.\n"; @@ -68,66 +58,43 @@ select(TBLOG); $| = 1; select(STDOUT); +umask 0022; # analysis.json should not be served to users. # open the chess engine my $engine = open_engine($remoteglotconf::engine_cmdline, 'E1', sub { handle_uci(@_, 1); }); my $engine2 = open_engine($remoteglotconf::engine2_cmdline, 'E2', sub { handle_uci(@_, 0); }); my $last_move; my $last_text = ''; -my ($pos_waiting, $pos_calculating, $pos_calculating_second_engine); +my ($pos_calculating, $pos_calculating_second_engine); -uciprint($engine, "setoption name UCI_AnalyseMode value true"); -while (my ($key, $value) = each %remoteglotconf::engine_config) { - uciprint($engine, "setoption name $key value $value"); -} +# If not undef, we've started calculating this position but haven't ever given out +# any analysis for it, so we're on a forced timer to do so. +my $pos_calculating_started = undef; + +# If not undef, we've output this position, but without a main PV, so we're on +# _another_ forced timer to do so. +my $pos_pv_started = undef; +my $last_output_had_pv = 0; + +setoptions($engine, \%remoteglotconf::engine_config); uciprint($engine, "ucinewgame"); if (defined($engine2)) { - uciprint($engine2, "setoption name UCI_AnalyseMode value true"); - while (my ($key, $value) = each %remoteglotconf::engine2_config) { - uciprint($engine2, "setoption name $key value $value"); - } + setoptions($engine2, \%remoteglotconf::engine2_config); uciprint($engine2, "setoption name MultiPV value 500"); uciprint($engine2, "ucinewgame"); } print "Chess engine ready.\n"; -# now talk to FICS -my $t = Net::Telnet->new(Timeout => 10, Prompt => '/fics% /'); -$t->input_log(\*FICSLOG); -$t->open($remoteglotconf::server); -$t->print($remoteglotconf::nick); -$t->waitfor('/Press return to enter the server/'); -$t->cmd(""); - -# set some options -$t->cmd("set shout 0"); -$t->cmd("set seek 0"); -$t->cmd("set style 12"); - -my $ev1 = AnyEvent->io( - fh => fileno($t), - poll => 'r', - cb => sub { # what callback to execute - while (1) { - my $line = $t->getline(Timeout => 0, errmode => 'return'); - return if (!defined($line)); - - chomp $line; - $line =~ tr/\r//d; - handle_fics($line); - } - } -); if (defined($remoteglotconf::target)) { - if ($remoteglotconf::target =~ /^http:/) { - fetch_pgn($remoteglotconf::target); - } else { - $t->cmd("observe $remoteglotconf::target"); + if ($remoteglotconf::target =~ /^(?:\/|https?:)/) { + my $target = $remoteglotconf::target; + # Convenience. + $target =~ s#https://lichess.org/broadcast/.*/([^/]+)?$#https://lichess.org/api/stream/broadcast/round/$1.pgn#; + fetch_pgn($target); } } -print "FICS ready.\n"; # Engine events have already been set up by Engine.pm. EV::run; @@ -139,7 +106,12 @@ sub handle_uci { $line =~ s/ / /g; # Sometimes needed for Zappa Mexico print UCILOG localtime() . " $engine->{'tag'} <= $line\n"; - if ($line =~ /^info/) { + + # If we've sent a stop command, gobble up lines until we see bestmove. + return if ($engine->{'stopping'} && $line !~ /^bestmove/); + $engine->{'stopping'} = 0; + + if ($line =~ /^info/ && $line !~ / cluster /) { my (@infos) = split / /, $line; shift @infos; @@ -151,24 +123,6 @@ sub handle_uci { parse_ids($engine, @ids); } - if ($line =~ /^bestmove/) { - if ($primary) { - return if (!$remoteglotconf::uci_assume_full_compliance); - if (defined($pos_waiting)) { - uciprint($engine, "position fen " . $pos_waiting->fen()); - uciprint($engine, "go infinite"); - - $pos_calculating = $pos_waiting; - $pos_waiting = undef; - } - } else { - $engine2->{'info'} = {}; - my $pos = $pos_waiting // $pos_calculating; - uciprint($engine2, "position fen " . $pos->fen()); - uciprint($engine2, "go infinite"); - $pos_calculating_second_engine = $pos; - } - } output(); } @@ -177,107 +131,74 @@ my $pos_for_movelist = undef; my @uci_movelist = (); my @pretty_movelist = (); -sub handle_fics { - my $line = shift; - if ($line =~ /^<12> /) { - handle_position(Position->new($line)); - $t->cmd("moves"); - } - if ($line =~ /^Movelist for game /) { - my $pos = $pos_waiting // $pos_calculating; - if (defined($pos)) { - @uci_movelist = (); - @pretty_movelist = (); - $pos_for_movelist = Position->start_pos($pos->{'player_w'}, $pos->{'player_b'}); - $getting_movelist = 1; - } - } - if ($getting_movelist && - $line =~ /^\s* \d+\. \s+ # move number - (\S+) \s+ \( [\d:.]+ \) \s* # first move, then time - (?: (\S+) \s+ \( [\d:.]+ \) )? # second move, then time - /x) { +# Starts periodic fetching of PGNs from the given URL. +sub fetch_pgn { + my ($url) = @_; + if ($url =~ m#^/#) { # Local file. eval { - my $uci_move; - ($pos_for_movelist, $uci_move) = $pos_for_movelist->make_pretty_move($1); - push @uci_movelist, $uci_move; - push @pretty_movelist, $1; - - if (defined($2)) { - ($pos_for_movelist, $uci_move) = $pos_for_movelist->make_pretty_move($2); - push @uci_movelist, $uci_move; - push @pretty_movelist, $2; - } + local $/ = undef; + open my $fh, "<", $url + or die "$url: $!"; + my $pgn = <$fh>; + close $fh; + handle_pgn($pgn, '', $url); }; if ($@) { - warn "Error when getting FICS move history: $@"; - $getting_movelist = 0; - } - } - if ($getting_movelist && - $line =~ /^\s+ \{.*\} \s+ (?: \* | 1\/2-1\/2 | 0-1 | 1-0 )/x) { - # End of movelist. - for my $pos ($pos_waiting, $pos_calculating) { - next if (!defined($pos)); - if ($pos->fen() eq $pos_for_movelist->fen()) { - $pos->{'pretty_history'} = \@pretty_movelist; - } - } - $getting_movelist = 0; - } - if ($line =~ /^([A-Za-z]+)(?:\([A-Z]+\))* tells you: (.*)$/) { - my ($who, $msg) = ($1, $2); - - next if (grep { $_ eq $who } (@remoteglotconf::masters) == 0); - - if ($msg =~ /^fics (.*?)$/) { - $t->cmd("tell $who Executing '$1' on FICS."); - $t->cmd($1); - } elsif ($msg =~ /^uci (.*?)$/) { - $t->cmd("tell $who Sending '$1' to the engine."); - print { $engine->{'write'} } "$1\n"; - } elsif ($msg =~ /^pgn (.*?)$/) { - my $url = $1; - $t->cmd("tell $who Starting to poll '$url'."); - fetch_pgn($url); - } elsif ($msg =~ /^stoppgn$/) { - $t->cmd("tell $who Stopping poll."); - $stop_pgn_fetch = 1; - $http_timer = undef; - } elsif ($msg =~ /^quit$/) { - $t->cmd("tell $who Bye bye."); - exit; - } else { - $t->cmd("tell $who Couldn't understand '$msg', sorry."); + warn "$url: $@"; + $http_timer = AnyEvent->timer(after => $remoteglotconf::poll_frequency, cb => sub { + fetch_pgn($url); + }); } + } else { + my $buffer = ''; + AnyEvent::HTTP::http_get($url, + on_body => sub { + handle_partial_pgn(@_, \$buffer, $url); + }, + sub { + end_pgn(@_, \$buffer, $url); + }); } - #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) = @_; +sub handle_partial_pgn { + my ($body, $header, $buffer, $url) = @_; if ($stop_pgn_fetch) { $stop_pgn_fetch = 0; $http_timer = undef; - return; + return 0; } + $$buffer .= $body; + while ($$buffer =~ s/^\s*(.*)\n\n\n//s) { + handle_pgn($1, $url); + } + return 1; +} + +sub end_pgn { + my ($body, $header, $buffer, $url) = @_; + handle_pgn($$buffer, $url); + $$buffer = ""; + $http_timer = AnyEvent->timer(after => $remoteglotconf::poll_frequency, cb => sub { + fetch_pgn($url); + }); +} + +sub handle_pgn { + my ($body, $url) = @_; my $pgn = Chess::PGN::Parse->new(undef, $body); - if (!defined($pgn) || !$pgn->read_game() || $body !~ /^\[/) { - warn "Error in parsing PGN from $url\n"; + if (!defined($pgn)) { + warn "Error in parsing PGN from $url [body='$body']\n"; + } elsif (!$pgn->read_game()) { + warn "Error in reading PGN game from $url [body='$body']\n"; + } elsif ($body !~ /^\[/) { + warn "Malformed PGN from $url [body='$body']\n"; } else { eval { # Skip to the right game. @@ -287,18 +208,49 @@ sub handle_pgn { } $pgn->parse_game({ save_comments => 'yes' }); - my $pos = Position->start_pos($pgn->white, $pgn->black); + my $white = $pgn->white; + my $black = $pgn->black; + $white =~ s/,.*//; # Remove first name. + $black =~ s/,.*//; # Remove first name. + my $tags = $pgn->tags(); + my $pos; + if (exists($tags->{'FEN'})) { + $pos = Position->from_fen($tags->{'FEN'}); + $pos->{'last_move'} = 'none'; + $pos->{'player_w'} = $white; + $pos->{'player_b'} = $black; + $pos->{'start_fen'} = $tags->{'FEN'}; + } else { + $pos = Position->start_pos($white, $black); + } + if (exists($tags->{'Variant'}) && + $tags->{'Variant'} =~ /960|fischer/i) { + $pos->{'chess960'} = 1; + } else { + $pos->{'chess960'} = 0; + } my $moves = $pgn->moves; my @uci_moves = (); + my @repretty_moves = (); for my $move (@$moves) { - my $uci_move; - ($pos, $uci_move) = $pos->make_pretty_move($move); + my ($npos, $uci_move) = $pos->make_pretty_move($move); push @uci_moves, $uci_move; + + # Re-prettyprint the move. + my ($from_row, $from_col, $to_row, $to_col, $promo) = parse_uci_move($uci_move); + my ($pretty, undef) = $pos->{'board'}->prettyprint_move($from_row, $from_col, $to_row, $to_col, $promo); + push @repretty_moves, $pretty; + $pos = $npos; + } + if ($pgn->result eq '1-0' || $pgn->result eq '1/2-1/2' || $pgn->result eq '0-1') { + $pos->{'result'} = $pgn->result; } - $pos->{'result'} = $pgn->result; - $pos->{'pretty_history'} = $moves; + my @extra_moves = (); + $pos = extend_from_manual_override($pos, \@repretty_moves, \@extra_moves); extract_clock($pgn, $pos); + $pos->{'history'} = \@repretty_moves; + $pos->{'extra_moves'} = \@extra_moves; # Sometimes, PGNs lose a move or two for a short while, # or people push out new ones non-atomically. @@ -326,7 +278,7 @@ sub handle_pgn { } } - $http_timer = AnyEvent->timer(after => 1.0, cb => sub { + $http_timer = AnyEvent->timer(after => $remoteglotconf::poll_frequency, cb => sub { fetch_pgn($url); }); } @@ -335,22 +287,19 @@ sub handle_position { my ($pos) = @_; find_clock_start($pos, $pos_calculating); - # if this is already in the queue, ignore it (just update the result) - if (defined($pos_waiting) && $pos->fen() eq $pos_waiting->fen()) { - $pos_waiting->{'result'} = $pos->{'result'}; - return; - } - - # if we're already chewing on this and there's nothing else in the queue, - # also ignore it - if (!defined($pos_waiting) && defined($pos_calculating) && - $pos->fen() eq $pos_calculating->fen()) { + # If we're already chewing on this and there's nothing else in the queue, + # ignore it. + if (defined($pos_calculating) && $pos->fen() eq $pos_calculating->fen()) { $pos_calculating->{'result'} = $pos->{'result'}; + for my $key ('white_clock', 'black_clock', 'white_clock_target', 'black_clock_target') { + $pos_calculating->{$key} //= $pos->{$key}; + } + $pos_calculating->{'extra_moves'} = $pos->{'extra_moves'}; return; } - # if we're already thinking on something, stop and wait for the engine - # to approve + # If we're already thinking on something, stop and wait for the engine + # to approve. if (defined($pos_calculating)) { # Store the final data we have for this position in the history, # with the precise clock information we just got from the new @@ -358,56 +307,60 @@ sub handle_position { # the position.) # # Do not output anything new to the main analysis; that's - # going to be obsolete really soon. + # going to be obsolete really soon. (Exception: If we've never + # output anything for this move, ie., it didn't hit the 200ms + # limit, spit it out to the user anyway. It's probably a really + # fast blitz game or something, and it's good to show the moves + # as they come in even without great analysis.) $pos_calculating->{'white_clock'} = $pos->{'white_clock'}; $pos_calculating->{'black_clock'} = $pos->{'black_clock'}; delete $pos_calculating->{'white_clock_target'}; delete $pos_calculating->{'black_clock_target'}; - output_json(1); - if (!defined($pos_waiting)) { - uciprint($engine, "stop"); - } - if ($remoteglotconf::uci_assume_full_compliance) { - $pos_waiting = $pos; + if (defined($pos_calculating_started)) { + output_json(0); } else { - uciprint($engine, "position fen " . $pos->fen()); - uciprint($engine, "go infinite"); - $pos_calculating = $pos; + output_json(1); } - } else { - # it's wrong just to give the FEN (the move history is useful, - # and per the UCI spec, we should really have sent "ucinewgame"), - # but it's easier - uciprint($engine, "position fen " . $pos->fen()); - uciprint($engine, "go infinite"); - $pos_calculating = $pos; + $pos_calculating_started = [Time::HiRes::gettimeofday]; + $pos_pv_started = undef; + + # Ask the engine to stop; we will throw away its data until it + # sends us "bestmove", signaling the end of it. + $engine->{'stopping'} = 1; + uciprint($engine, "stop"); + } + + # It's wrong to just give the FEN (the move history is useful, + # and per the UCI spec, we should really have sent "ucinewgame"), + # but it's easier, and it works around a Stockfish repetition issue. + if ($engine->{'chess960'} != $pos->{'chess960'}) { + uciprint($engine, "setoption name UCI_Chess960 value " . ($pos->{'chess960'} ? 'true' : 'false')); + $engine->{'chess960'} = $pos->{'chess960'}; } + uciprint($engine, "position fen " . $pos->fen()); + uciprint($engine, "go infinite"); + $pos_calculating = $pos; + $pos_calculating_started = [Time::HiRes::gettimeofday]; + $pos_pv_started = undef; if (defined($engine2)) { if (defined($pos_calculating_second_engine)) { + $engine2->{'stopping'} = 1; uciprint($engine2, "stop"); - } else { - uciprint($engine2, "position fen " . $pos->fen()); - uciprint($engine2, "go infinite"); - $pos_calculating_second_engine = $pos; } + if ($engine2->{'chess960'} != $pos->{'chess960'}) { + uciprint($engine2, "setoption name UCI_Chess960 value " . ($pos->{'chess960'} ? 'true' : 'false')); + $engine2->{'chess960'} = $pos->{'chess960'}; + } + uciprint($engine2, "position fen " . $pos->fen()); + uciprint($engine2, "go infinite"); + $pos_calculating_second_engine = $pos; $engine2->{'info'} = {}; } $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, - # since if no move has happened in the last half - # hour, the analysis/relay has most likely stopped - # and we should stop hogging server resources. - # - $t->cmd("date"); } sub parse_infos { @@ -450,6 +403,7 @@ sub parse_infos { delete $info->{'score_cp' . $mpv}; delete $info->{'score_mate' . $mpv}; + delete $info->{'splicepos' . $mpv}; while ($x[0] eq 'cp' || $x[0] eq 'mate') { if ($x[0] eq 'cp') { @@ -483,10 +437,9 @@ sub parse_ids { my ($engine, @x) = @_; while (scalar @x > 0) { - if ($x[0] =~ /^(name|author)$/) { - my $key = shift @x; + if ($x[0] eq 'name') { my $value = join(' ', @x); - $engine->{'id'}{$key} = $value; + $engine->{'id'}{'author'} = $value; last; } @@ -502,10 +455,14 @@ sub prettyprint_pv_no_cache { return (); } - my $pv = shift @pvs; - my ($from_col, $from_row, $to_col, $to_row, $promo) = parse_uci_move($pv); - my ($pretty, $nb) = $board->prettyprint_move($from_row, $from_col, $to_row, $to_col, $promo); - return ( $pretty, prettyprint_pv_no_cache($nb, @pvs) ); + my @ret = (); + for my $pv (@pvs) { + my ($from_row, $from_col, $to_row, $to_col, $promo) = parse_uci_move($pv); + my ($pretty, $nb) = $board->prettyprint_move($from_row, $from_col, $to_row, $to_col, $promo); + push @ret, $pretty; + $board = $nb; + } + return @ret; } sub prettyprint_pv { @@ -521,60 +478,114 @@ sub prettyprint_pv { } } +my %tbprobe_cache = (); + +sub complete_using_tbprobe { + my ($pos, $info, $mpv) = @_; + + # We need Fathom installed to do standalone TB probes. + return if (!defined($remoteglotconf::fathom_cmdline)); + + # If we already have a mate, don't bother; in some cases, it would even be + # better than a tablebase score. + return if defined($info->{'score_mate' . $mpv}); + + # If we have a draw or near-draw score, there's also not much interesting + # we could add from a tablebase. We only really want mates. + return if ($info->{'score_cp' . $mpv} >= -12250 && $info->{'score_cp' . $mpv} <= 12250); + + # Run through the PV until we are at a 6-man position. + # TODO: We could in theory only have 5-man data. + my @pv = @{$info->{'pv' . $mpv}}; + my $key = $pos->fen() . " " . join('', @pv); + my @moves = (); + my $splicepos; + if (exists($tbprobe_cache{$key})) { + my $c = $tbprobe_cache{$key}; + @moves = @{$c->{'moves'}}; + $splicepos = $c->{'splicepos'}; + } else { + if ($mpv ne '') { + # Force doing at least one move of the PV. + my $move = shift @pv; + push @moves, $move; + $pos = $pos->make_move(parse_uci_move($move)); + } + + while ($pos->num_pieces() > 7 && $#pv > -1) { + my $move = shift @pv; + push @moves, $move; + $pos = $pos->make_move(parse_uci_move($move)); + } + + return if ($pos->num_pieces() > 7); + + my $fen = $pos->fen(); + my $pgn_text = `$remoteglotconf::fathom_cmdline "$fen"`; + my $pgn = Chess::PGN::Parse->new(undef, $pgn_text); + return if (!defined($pgn) || !$pgn->read_game() || ($pgn->result ne '0-1' && $pgn->result ne '1-0')); + $pgn->quick_parse_game; + + # Splice the PV from the tablebase onto what we have so far. + $splicepos = scalar @moves; + for my $move (@{$pgn->moves}) { + last if $move eq '#'; + last if $move eq '1-0'; + last if $move eq '0-1'; + last if $move eq '1/2-1/2'; + my $uci_move; + ($pos, $uci_move) = $pos->make_pretty_move($move); + push @moves, $uci_move; + } + + $tbprobe_cache{$key} = { + moves => \@moves, + splicepos => $splicepos + }; + } + + $info->{'pv' . $mpv} = \@moves; + + my $matelen = int((1 + scalar @moves) / 2); + if ((scalar @moves) % 2 == 0) { + $info->{'score_mate' . $mpv} = -$matelen; + } else { + $info->{'score_mate' . $mpv} = $matelen; + } + $info->{'splicepos' . $mpv} = $splicepos; +} + sub output { #return; return if (!defined($pos_calculating)); - # Don't update too often. - my $age = Time::HiRes::tv_interval($latest_update); - if ($age < $remoteglotconf::update_max_interval) { - my $wait = $remoteglotconf::update_max_interval + 0.01 - $age; - $output_timer = AnyEvent->timer(after => $wait, cb => \&output); - return; - } - 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 + $t->{'score'}) / 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; - } + # Don't update too often. + my $wait = $remoteglotconf::update_max_interval - Time::HiRes::tv_interval($latest_update); + if (defined($pos_calculating_started)) { + my $new_pos_wait = $remoteglotconf::update_force_after_move - Time::HiRes::tv_interval($pos_calculating_started); + $wait = $new_pos_wait if ($new_pos_wait < $wait); + } + if (!$last_output_had_pv && has_pv($info)) { + if (!defined($pos_pv_started)) { + $pos_pv_started = [Time::HiRes::gettimeofday]; } - $info->{'pv'} = $pv; - $info->{'tablebase'} = 1; - } else { - $info->{'tablebase'} = 0; + # We just got initial PV, and we're in a hurry since we gave out a blank one earlier, + # so give us just 200ms more to increase the quality and then force a display. + my $new_pos_wait = $remoteglotconf::update_force_after_move - Time::HiRes::tv_interval($pos_pv_started); + $wait = $new_pos_wait if ($new_pos_wait < $wait); + } + if ($wait > 0.0) { + $output_timer = AnyEvent->timer(after => $wait + 0.01, cb => \&output); + return; } + $pos_pv_started = undef; + + # We're outputting something for this position now, so the special handling + # for new positions is off. + undef $pos_calculating_started; # # Some programs _always_ report MultiPV, even with only one PV. @@ -582,9 +593,11 @@ sub output { # specified. # if (exists($info->{'pv1'}) && !exists($info->{'pv2'})) { - for my $key (qw(pv score_cp score_mate nodes nps depth seldepth tbhits)) { + for my $key (qw(pv score_cp score_mate nodes nps depth seldepth tbhits splicepos)) { if (exists($info->{$key . '1'})) { $info->{$key} = $info->{$key . '1'}; + } else { + delete $info->{$key}; } } } @@ -611,9 +624,28 @@ sub output { return; } + # Now do our own Syzygy tablebase probes to convert scores like +123.45 to mate. + if (exists($info->{'pv'})) { + complete_using_tbprobe($pos_calculating, $info, ''); + } + + my $mpv = 1; + while (exists($info->{'pv' . $mpv})) { + complete_using_tbprobe($pos_calculating, $info, $mpv); + ++$mpv; + } + output_screen(); output_json(0); $latest_update = [Time::HiRes::gettimeofday]; + $last_output_had_pv = has_pv($info); +} + +sub has_pv { + my $info = shift; + return 1 if (exists($info->{'pv'}) && (scalar(@{$info->{'pv'}}) > 0)); + return 1 if (exists($info->{'pv1'}) && (scalar(@{$info->{'pv1'}}) > 0)); + return 0; } sub output_screen { @@ -639,6 +671,11 @@ sub output_screen { } return unless (exists($pos_calculating->{'board'})); + + my $extra_moves = $pos_calculating->{'extra_moves'}; + if (defined($extra_moves) && scalar @$extra_moves > 0) { + $text .= " Manual move extensions: " . join(' ', @$extra_moves) . "\n"; + } if (exists($info->{'pv1'}) && exists($info->{'pv2'})) { # multi-PV @@ -691,16 +728,14 @@ sub output_screen { $text .= "\n\n"; } - #$text .= book_info($pos_calculating->fen(), $pos_calculating->{'board'}, $pos_calculating->{'toplay'}); - my @refutation_lines = (); if (defined($engine2)) { for (my $mpv = 1; $mpv < 500; ++$mpv) { my $info = $engine2->{'info'}; last if (!exists($info->{'pv' . $mpv})); eval { + complete_using_tbprobe($pos_calculating_second_engine, $info, $mpv); my $pv = $info->{'pv' . $mpv}; - my $pretty_move = join('', prettyprint_pv($pos_calculating_second_engine, $pv->[0])); my @pretty_pv = prettyprint_pv($pos_calculating_second_engine, @$pv); if (scalar @pretty_pv > 5) { @@ -739,10 +774,28 @@ sub output_json { my $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->{'plot_score'} = plot_score($info, $pos_calculating, ''); + $json->{'engine'} = $engine->{'id'}; + if (defined($remoteglotconf::engine_url)) { + $json->{'engine'}{'url'} = $remoteglotconf::engine_url; + } + if (defined($remoteglotconf::engine_details)) { + $json->{'engine'}{'details'} = $remoteglotconf::engine_details; + } + my @grpc_backends = (); + if (defined($remoteglotconf::engine_grpc_backend)) { + push @grpc_backends, $remoteglotconf::engine_grpc_backend; + } + if (defined($remoteglotconf::engine2_grpc_backend)) { + push @grpc_backends, $remoteglotconf::engine2_grpc_backend; + } + $json->{'internal'}{'grpc_backends'} = \@grpc_backends; + if (defined($remoteglotconf::move_source)) { + $json->{'move_source'} = $remoteglotconf::move_source; + } + if (defined($remoteglotconf::move_source_url)) { + $json->{'move_source_url'} = $remoteglotconf::move_source_url; + } + $json->{'score'} = score_digest($info, $pos_calculating, ''); $json->{'nodes'} = $info->{'nodes'}; $json->{'nps'} = $info->{'nps'}; @@ -750,9 +803,7 @@ sub output_json { $json->{'tbhits'} = $info->{'tbhits'}; $json->{'seldepth'} = $info->{'seldepth'}; $json->{'tablebase'} = $info->{'tablebase'}; - - $json->{'pv_uci'} = $info->{'pv'}; # Still needs to be there for the JS to calculate arrows; only for the primary PV, though! - $json->{'pv_pretty'} = [ prettyprint_pv($pos_calculating, @{$info->{'pv'}}) ]; + $json->{'pv'} = [ prettyprint_pv($pos_calculating, @{$info->{'pv'}}) ]; my %refutation_lines = (); my @refutation_lines = (); @@ -764,42 +815,52 @@ sub output_json { last if (!exists($info->{'pv' . $mpv})); eval { + complete_using_tbprobe($pos_calculating, $info, $mpv); my $pv = $info->{'pv' . $mpv}; my $pretty_move = join('', prettyprint_pv($pos_calculating, $pv->[0])); my @pretty_pv = prettyprint_pv($pos_calculating, @$pv); - $refutation_lines{$pv->[0]} = { - sort_key => $pretty_move, + $refutation_lines{$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), - pretty_move => $pretty_move, - pv_pretty => \@pretty_pv, + score => score_digest($info, $pos_calculating, $mpv), + move => $pretty_move, + pv => \@pretty_pv, }; + if (exists($info->{'splicepos' . $mpv})) { + $refutation_lines{$pretty_move}->{'splicepos'} = $info->{'splicepos' . $mpv}; + } }; } } $json->{'refutation_lines'} = \%refutation_lines; # Piece together historic score information, to the degree we have it. - if (!$historic_json_only && exists($pos_calculating->{'pretty_history'})) { + if (!$historic_json_only && exists($pos_calculating->{'history'})) { my %score_history = (); + local $dbh->{AutoCommit} = 0; my $q = $dbh->prepare('SELECT * FROM scores WHERE id=?'); - my $pos = Position->start_pos('white', 'black'); + my $pos; + if (exists($pos_calculating->{'start_fen'})) { + $pos = Position->from_fen($pos_calculating->{'start_fen'}); + } else { + $pos = Position->start_pos('white', 'black'); + } + $pos->{'chess960'} = $pos_calculating->{'chess960'}; my $halfmove_num = 0; - for my $move (@{$pos_calculating->{'pretty_history'}}) { + for my $move (@{$pos_calculating->{'history'}}) { my $id = id_for_pos($pos, $halfmove_num); my $ref = $dbh->selectrow_hashref($q, undef, $id); if (defined($ref)) { $score_history{$halfmove_num} = [ - $ref->{'plot_score'}, - $ref->{'short_score'} + $ref->{'score_type'}, + $ref->{'score_value'} ]; } ++$halfmove_num; ($pos) = $pos->make_pretty_move($move); } $q->finish; + $dbh->commit; # If at any point we are missing 10 consecutive moves, # truncate the history there. This is so we don't get into @@ -823,6 +884,45 @@ sub output_json { $json->{'score_history'} = \%score_history; } + # Give out a list of other games going on. (Empty is fine.) + # TODO: Don't bother reading our own file, the data will be stale anyway. + if (!$historic_json_only) { + my @games = (); + + my $q = $dbh->prepare('SELECT * FROM current_games ORDER BY priority DESC, id'); + $q->execute; + while (my $ref = $q->fetchrow_hashref) { + eval { + my $other_game_contents = File::Slurp::read_file($ref->{'json_path'}); + my $other_game_json = JSON::XS::decode_json($other_game_contents); + + die "Missing position" if (!exists($other_game_json->{'position'})); + my $white = $other_game_json->{'position'}{'player_w'} // die 'Missing white'; + my $black = $other_game_json->{'position'}{'player_b'} // die 'Missing black'; + + my $game = { + id => $ref->{'id'}, + name => "$white–$black", + url => $ref->{'url'}, + hashurl => $ref->{'hash_url'}, + }; + if (defined($other_game_json->{'position'}{'result'})) { + $game->{'result'} = $other_game_json->{'position'}{'result'}; + } else { + $game->{'score'} = $other_game_json->{'score'}; + } + push @games, $game; + }; + if ($@) { + warn "Could not add external game " . $ref->{'json_path'} . ": $@"; + } + } + + if (scalar @games > 0) { + $json->{'games'} = \@games; + } + } + my $json_enc = JSON::XS->new; $json_enc->canonical(1); my $encoded = $json_enc->encode($json); @@ -832,8 +932,8 @@ sub output_json { $last_written_json = $encoded; } - if (exists($pos_calculating->{'pretty_history'}) && - defined($remoteglotconf::json_history_dir)) { + if (exists($pos_calculating->{'history'}) && + defined($remoteglotconf::json_history_dir) && defined($json->{'engine'}{name})) { my $id = id_for_pos($pos_calculating); my $filename = $remoteglotconf::json_history_dir . "/" . $id . ".json"; @@ -845,17 +945,21 @@ sub output_json { my $new_depth = $json->{'depth'} // 0; my $new_nodes = $json->{'nodes'} // 0; if (!defined($old_engine) || - $old_engine ne $json->{'id'}{'name'} || + $old_engine ne $json->{'engine'}{'name'} || $new_depth > $old_depth || ($new_depth == $old_depth && $new_nodes >= $old_nodes)) { atomic_set_contents($filename, $encoded); - if (defined($json->{'plot_score'})) { - local $dbh->{AutoCommit} = 0; - $dbh->do('DELETE FROM scores WHERE id=?', undef, $id); - $dbh->do('INSERT INTO scores (id, plot_score, short_score, engine, depth, nodes) VALUES (?,?,?,?,?,?)', undef, - $id, $json->{'plot_score'}, $json->{'short_score'}, - $json->{'id'}{'name'}, $new_depth, $new_nodes); - $dbh->commit; + if (defined($json->{'score'})) { + $dbh->do('INSERT INTO scores (id, score_type, score_value, engine, depth, nodes) VALUES (?,?,?,?,?,?) ' . + ' ON CONFLICT (id) DO UPDATE SET ' . + ' score_type=EXCLUDED.score_type, ' . + ' score_value=EXCLUDED.score_value, ' . + ' engine=EXCLUDED.engine, ' . + ' depth=EXCLUDED.depth, ' . + ' nodes=EXCLUDED.nodes', + undef, + $id, $json->{'score'}[0], $json->{'score'}[1], + $json->{'engine'}{'name'}, $new_depth, $new_nodes); } } } @@ -874,7 +978,7 @@ sub atomic_set_contents { sub id_for_pos { my ($pos, $halfmove_num) = @_; - $halfmove_num //= scalar @{$pos->{'pretty_history'}}; + $halfmove_num //= scalar @{$pos->{'history'}}; (my $fen = $pos->fen()) =~ tr,/ ,-_,; return "move$halfmove_num-$fen"; } @@ -925,30 +1029,45 @@ sub short_score { return undef; } -sub score_sort_key { - my ($info, $pos, $mpv, $invert) = @_; +# Sufficient for computing long_score, short_score, plot_score and +# (with side-to-play information) score_sort_key. +sub score_digest { + my ($info, $pos, $mpv) = @_; if (defined($info->{'score_mate' . $mpv})) { my $mate = $info->{'score_mate' . $mpv}; - my $score; - if ($mate > 0) { - # Side to move mates - $score = 99999 - $mate; - } else { - # Side to move is getting mated (note the double negative for $mate) - $score = -99999 - $mate; + if ($pos->{'toplay'} eq 'B') { + $mate = -$mate; } - if ($invert) { - $score = -$score; + if (exists($info->{'splicepos' . $mpv})) { + my $sp = $info->{'splicepos' . $mpv}; + if ($mate > 0) { + return ['T', $sp]; + } else { + return ['t', $sp]; + } + } else { + if ($mate > 0) { + return ['M', $mate]; + } elsif ($mate < 0) { + return ['m', -$mate]; + } elsif ($pos->{'toplay'} eq 'B') { + return ['M', 0]; + } else { + return ['m', 0]; + } } - return $score; } else { if (exists($info->{'score_cp' . $mpv})) { my $score = $info->{'score_cp' . $mpv}; - if ($invert) { + if ($pos->{'toplay'} eq 'B') { $score = -$score; } - return $score; + if ($score == 0 && $info->{'tablebase'}) { + return ['d', undef]; + } else { + return ['cp', int($score)]; + } } } @@ -963,10 +1082,19 @@ sub long_score { if ($pos->{'toplay'} eq 'B') { $mate = -$mate; } - if ($mate > 0) { - return sprintf "White mates in %u", $mate; + if (exists($info->{'splicepos' . $mpv})) { + my $sp = $info->{'splicepos' . $mpv}; + if ($mate > 0) { + return sprintf "White wins in %u", int(($sp + 1) * 0.5); + } else { + return sprintf "Black wins in %u", int(($sp + 1) * 0.5); + } } else { - return sprintf "Black mates in %u", -$mate; + if ($mate > 0) { + return sprintf "White mates in %u", $mate; + } else { + return sprintf "Black mates in %u", -$mate; + } } } else { if (exists($info->{'score_cp' . $mpv})) { @@ -1018,56 +1146,32 @@ sub plot_score { return undef; } -my %book_cache = (); -sub book_info { - my ($fen, $board, $toplay) = @_; - - if (exists($book_cache{$fen})) { - return $book_cache{$fen}; - } +sub extend_from_manual_override { + my ($pos, $moves, $extra_moves) = @_; - my $ret = `./booklook $fen`; - return "" if ($ret =~ /Not found/ || $ret eq ''); - - my @moves = (); - - for my $m (split /\n/, $ret) { - my ($move, $annotation, $win, $draw, $lose, $rating, $rating_div) = split /,/, $m; - - my $pmove; - if ($move eq '') { - $pmove = '(current)'; - } else { - ($pmove) = prettyprint_pv_no_cache($board, $move); - $pmove .= $annotation; + my $q = $dbh->prepare('SELECT next_move FROM game_extensions WHERE fen=? AND history=? AND player_w=? AND player_b=? AND (CURRENT_TIMESTAMP - ts) < INTERVAL \'1 hour\''); + while (1) { + my $player_w = $pos->{'player_w'}; + my $player_b = $pos->{'player_b'}; + if ($player_w =~ /^base64:(.*)$/) { + $player_w = MIME::Base64::decode_base64($1); } - - my $score; - if ($toplay eq 'W') { - $score = 1.0 * $win + 0.5 * $draw + 0.0 * $lose; - } else { - $score = 0.0 * $win + 0.5 * $draw + 1.0 * $lose; + if ($player_b =~ /^base64:(.*)$/) { + $player_b = MIME::Base64::decode_base64($1); } - my $n = $win + $draw + $lose; - - my $percent; - if ($n == 0) { - $percent = " "; + #use Data::Dumper; print Dumper([$pos->fen(), JSON::XS::encode_json($moves), $player_w, $player_b]); + $q->execute($pos->fen(), JSON::XS::encode_json($moves), $player_w, $player_b); + my $ref = $q->fetchrow_hashref; + if (defined($ref)) { + my $move = $ref->{'next_move'}; + ($pos) = $pos->make_pretty_move($move); + push @$moves, $move; + push @$extra_moves, $move; } else { - $percent = sprintf "%4u%%", int(100.0 * $score / $n + 0.5); + last; } - - push @moves, [ $pmove, $n, $percent, $rating ]; - } - - @moves[1..$#moves] = sort { $b->[2] cmp $a->[2] } @moves[1..$#moves]; - - my $text = "Book moves:\n\n Perf. N Rating\n\n"; - for my $m (@moves) { - $text .= sprintf " %-10s %s %6u %4s\n", $m->[0], $m->[2], $m->[1], $m->[3] } - - return $text; + return $pos; } sub extract_clock { @@ -1131,14 +1235,13 @@ sub find_clock_start { return; } - # TODO(sesse): Maybe we can get the number of moves somehow else for FICS games. # The history is needed for id_for_pos. - if (!exists($pos->{'pretty_history'})) { + if (!exists($pos->{'history'})) { return; } my $id = id_for_pos($pos); - my $clock_info = $dbh->selectrow_hashref('SELECT * FROM clock_info WHERE id=?', undef, $id); + my $clock_info = $dbh->selectrow_hashref('SELECT * FROM clock_info WHERE id=? AND COALESCE(white_clock_target, black_clock_target) >= EXTRACT(EPOCH FROM (CURRENT_TIMESTAMP - INTERVAL \'1 day\'));', undef, $id); if (defined($clock_info)) { $pos->{'white_clock'} //= $clock_info->{'white_clock'}; $pos->{'black_clock'} //= $clock_info->{'black_clock'}; @@ -1188,84 +1291,6 @@ sub find_clock_start { $dbh->commit; } -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 $uci_move; - ($pvpos, $uci_move) = $pvpos->make_pretty_move($move); - push @uci_moves, $uci_move; - } - $tb_cache{$fen} = { - result => $pgn->result, - pv => \@uci_moves, - score => $response->{'Response'}{'Score'}, - }; - 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)); @@ -1287,5 +1312,18 @@ sub parse_uci_move { my $to_col = col_letter_to_num(substr($move, 2, 1)); my $to_row = row_letter_to_num(substr($move, 3, 1)); my $promo = substr($move, 4, 1); - return ($from_col, $from_row, $to_col, $to_row, $promo); + return ($from_row, $from_col, $to_row, $to_col, $promo); +} + +sub setoptions { + my ($engine, $config) = @_; + uciprint($engine, "setoption name UCI_AnalyseMode value true"); + uciprint($engine, "setoption name Analysis Contempt value Off"); + if (exists($config->{'Threads'})) { # Threads first, because clearing hash can be multithreaded then. + uciprint($engine, "setoption name Threads value " . $config->{'Threads'}); + } + while (my ($key, $value) = each %$config) { + next if $key eq 'Threads'; + uciprint($engine, "setoption name $key value $value"); + } }