X-Git-Url: https://git.sesse.net/?p=remoteglot;a=blobdiff_plain;f=remoteglot.pl;h=9cbf820d5dcd336d5e0bff16d118da711462e84f;hp=40f7b9ed3f7da748454747af2794b100d9f3d992;hb=94f448c82ea3da610c8aca0030f977d1f54741d6;hpb=48957832d49cb870c610721bbda9ba24d060b324 diff --git a/remoteglot.pl b/remoteglot.pl index 40f7b9e..9cbf820 100755 --- a/remoteglot.pl +++ b/remoteglot.pl @@ -5,7 +5,7 @@ # analysis, or for live analysis of relayed games. (Do not use for # cheating! Cheating is bad for your karma, and your abuser flag.) # -# Copyright 2007 Steinar H. Gunderson +# Copyright 2007 Steinar H. Gunderson # Licensed under the GNU General Public License, version 2. # @@ -15,34 +15,36 @@ 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 DBI; +use DBD::Pg; require 'Position.pm'; require 'Engine.pm'; +require 'config.pm'; use strict; use warnings; - -# Configuration -my $server = "freechess.org"; -my $target = "GMCarlsen"; -my $engine_cmdline = "'./Deep Rybka 4 SSE42 x64'"; -my $engine2_cmdline = "./stockfish_13111119_x64_modern_sse42"; # undef for none -my $uci_assume_full_compliance = 0; # dangerous :-) -my $update_max_interval = 1.0; -my @masters = ( - 'Sesse', - 'Sessse', - 'Sesssse', - 'greatestguns', - 'beuki' -); +no warnings qw(once); # Program starts here -$SIG{ALRM} = sub { output(); }; my $latest_update = undef; +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; + +# Persisted so we can restart. +# TODO: Figure out an appropriate way to deal with database restarts +# and/or Postgres going away entirely. +my $dbh = DBI->connect($remoteglotconf::dbistr, $remoteglotconf::dbiuser, $remoteglotconf::dbipass) + or die DBI->errstr; +$dbh->{RaiseError} = 1; $| = 1; @@ -57,28 +59,34 @@ 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); +umask 0022; # analysis.json should not be served to users. # open the chess engine -my $engine = open_engine($engine_cmdline, 'E1', sub { handle_uci(@_, 1); }); -my $engine2 = open_engine($engine2_cmdline, 'E2', sub { handle_uci(@_, 0); }); +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); uciprint($engine, "setoption name UCI_AnalyseMode value true"); -# uciprint($engine, "setoption name NalimovPath value /srv/tablebase"); -uciprint($engine, "setoption name NalimovUsage value Rarely"); -uciprint($engine, "setoption name Hash value 1024"); -# uciprint($engine, "setoption name MultiPV value 2"); +while (my ($key, $value) = each %remoteglotconf::engine_config) { + uciprint($engine, "setoption name $key value $value"); +} uciprint($engine, "ucinewgame"); if (defined($engine2)) { uciprint($engine2, "setoption name UCI_AnalyseMode value true"); - # uciprint($engine2, "setoption name NalimovPath value /srv/tablebase"); - uciprint($engine2, "setoption name NalimovUsage value Rarely"); - uciprint($engine2, "setoption name Hash value 1024"); - uciprint($engine2, "setoption name Threads value 8"); + while (my ($key, $value) = each %remoteglotconf::engine2_config) { + uciprint($engine2, "setoption name $key value $value"); + } uciprint($engine2, "setoption name MultiPV value 500"); uciprint($engine2, "ucinewgame"); } @@ -86,40 +94,54 @@ if (defined($engine2)) { print "Chess engine ready.\n"; # now talk to FICS -my $t = Net::Telnet->new(Timeout => 10, Prompt => '/fics% /'); -$t->input_log(\*FICSLOG); -$t->open($server); -$t->print("SesseBOT"); -$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"); -$t->cmd("observe $target"); -print "FICS ready.\n"; - -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); - } - } -); +my ($t, $ev1); +if (defined($remoteglotconf::server)) { + $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"); + + $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 =~ /^https?:/) { + fetch_pgn($remoteglotconf::target); + } elsif (defined($t)) { + $t->cmd("observe $remoteglotconf::target"); + } +} +if (defined($t)) { + print "FICS ready.\n"; +} + # Engine events have already been set up by Engine.pm. EV::run; sub handle_uci { my ($engine, $line, $primary) = @_; + return if $line =~ /(upper|lower)bound/; + $line =~ s/ / /g; # Sometimes needed for Zappa Mexico print UCILOG localtime() . " $engine->{'tag'} <= $line\n"; if ($line =~ /^info/) { @@ -136,7 +158,7 @@ sub handle_uci { } if ($line =~ /^bestmove/) { if ($primary) { - return if (!$uci_assume_full_compliance); + return if (!$remoteglotconf::uci_assume_full_compliance); if (defined($pos_waiting)) { uciprint($engine, "position fen " . $pos_waiting->fen()); uciprint($engine, "go infinite"); @@ -155,15 +177,63 @@ sub handle_uci { output(); } +my $getting_movelist = 0; +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) { + 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; + } + }; + 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->{'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 } (@masters) == 0); + next if (grep { $_ eq $who } (@remoteglotconf::masters) == 0); if ($msg =~ /^fics (.*?)$/) { $t->cmd("tell $who Executing '$1' on FICS."); @@ -174,11 +244,10 @@ 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."); + $stop_pgn_fetch = 1; $http_timer = undef; } elsif ($msg =~ /^quit$/) { $t->cmd("tell $who Bye bye."); @@ -190,47 +259,137 @@ 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) = @_; + + if ($stop_pgn_fetch) { + $stop_pgn_fetch = 0; + $http_timer = undef; + return; + } + my $pgn = Chess::PGN::Parse->new(undef, $body); - if (!defined($pgn) || !$pgn->read_game()) { - 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 { - $pgn->quick_parse_game; - my $pos = Position->start_pos($pgn->white, $pgn->black); - my $moves = $pgn->moves; - for my $move (@$moves) { - my ($from_row, $from_col, $to_row, $to_col, $promo) = $pos->parse_pretty_move($move); - $pos = $pos->make_move($from_row, $from_col, $to_row, $to_col, $promo); + eval { + # Skip to the right game. + while (defined($remoteglotconf::pgn_filter) && + !&$remoteglotconf::pgn_filter($pgn)) { + $pgn->read_game() or die "Out of games during filtering"; + } + + $pgn->parse_game({ save_comments => 'yes' }); + my $white = $pgn->white; + my $black = $pgn->black; + $white =~ s/,.*//; # Remove first name. + $black =~ s/,.*//; # Remove first name. + my $pos = Position->start_pos($white, $black); + my $moves = $pgn->moves; + my @uci_moves = (); + my @repretty_moves = (); + for my $move (@$moves) { + 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->{'history'} = \@repretty_moves; + + extract_clock($pgn, $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); + } + }; + if ($@) { + warn "Error in parsing moves from $url: $@\n"; } - handle_position($pos); } $http_timer = AnyEvent->timer(after => 1.0, cb => sub { - AnyEvent::HTTP::http_get($url, sub { - handle_pgn(@_, $url); - }); + fetch_pgn($url); }); } sub handle_position { my ($pos) = @_; + find_clock_start($pos, $pos_calculating); - # if this is already in the queue, ignore it - return if (defined($pos_waiting) && $pos->fen() eq $pos_waiting->fen()); + # 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 - return if (!defined($pos_waiting) && defined($pos_calculating) && - $pos->fen() eq $pos_calculating->fen()); + if (!defined($pos_waiting) && defined($pos_calculating) && + $pos->fen() eq $pos_calculating->fen()) { + $pos_calculating->{'result'} = $pos->{'result'}; + return; + } # 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 + # position. (Historic positions store the clock at the end of + # the position.) + # + # Do not output anything new to the main analysis; that's + # going to be obsolete really soon. + $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 ($uci_assume_full_compliance) { + if ($remoteglotconf::uci_assume_full_compliance) { $pos_waiting = $pos; } else { uciprint($engine, "position fen " . $pos->fen()); @@ -260,6 +419,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, @@ -267,7 +428,9 @@ sub handle_position { # hour, the analysis/relay has most likely stopped # and we should stop hogging server resources. # - $t->cmd("date"); + if (defined($t)) { + $t->cmd("date"); + } } sub parse_infos { @@ -278,26 +441,28 @@ sub parse_infos { # Search for "multipv" first of all, since e.g. Stockfish doesn't put it first. for my $i (0..$#x - 1) { - if ($x[$i] =~ 'multipv') { + if ($x[$i] eq 'multipv') { $mpv = $x[$i + 1]; next; } } while (scalar @x > 0) { - if ($x[0] =~ 'multipv') { + if ($x[0] eq 'multipv') { # Dealt with above shift @x; shift @x; next; } - if ($x[0] =~ /^(currmove|currmovenumber|cpuload)$/) { + if ($x[0] eq 'currmove' || $x[0] eq 'currmovenumber' || $x[0] eq 'cpuload') { my $key = shift @x; my $value = shift @x; $info->{$key} = $value; next; } - if ($x[0] =~ /^(depth|seldepth|hashfull|time|nodes|nps|tbhits)$/) { + if ($x[0] eq 'depth' || $x[0] eq 'seldepth' || $x[0] eq 'hashfull' || + $x[0] eq 'time' || $x[0] eq 'nodes' || $x[0] eq 'nps' || + $x[0] eq 'tbhits') { my $key = shift @x; my $value = shift @x; $info->{$key . $mpv} = $value; @@ -309,7 +474,7 @@ sub parse_infos { delete $info->{'score_cp' . $mpv}; delete $info->{'score_mate' . $mpv}; - while ($x[0] =~ /^(cp|mate|lowerbound|upperbound)$/) { + while ($x[0] eq 'cp' || $x[0] eq 'mate') { if ($x[0] eq 'cp') { shift @x; $info->{'score_cp' . $mpv} = shift @x; @@ -341,10 +506,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; } @@ -361,7 +525,7 @@ sub prettyprint_pv_no_cache { } my $pv = shift @pvs; - my ($from_col, $from_row, $to_col, $to_row, $promo) = parse_uci_move($pv); + 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); return ( $pretty, prettyprint_pv_no_cache($nb, @pvs) ); } @@ -369,7 +533,7 @@ sub prettyprint_pv_no_cache { sub prettyprint_pv { my ($pos, @pvs) = @_; - my $cachekey = join('', @pvs); + my $cachekey = $pos->fen() . join('', @pvs); if (exists($pos->{'prettyprint_cache'}{$cachekey})) { return @{$pos->{'prettyprint_cache'}{$cachekey}}; } else { @@ -379,6 +543,72 @@ 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 = (); + if (exists($tbprobe_cache{$key})) { + @moves = @{$tbprobe_cache{$key}}; + } 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() > 6 && $#pv > -1) { + my $move = shift @pv; + push @moves, $move; + $pos = $pos->make_move(parse_uci_move($move)); + } + + return if ($pos->num_pieces() > 6); + + my $fen = $pos->fen(); + my $pgn_text = `fathom --path=/srv/syzygy "$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; + $info->{'pv' . $mpv} = \@moves; + + # Splice the PV from the tablebase onto what we have so far. + for my $move (@{$pgn->moves}) { + my $uci_move; + ($pos, $uci_move) = $pos->make_pretty_move($move); + push @moves, $uci_move; + } + + $tbprobe_cache{$key} = \@moves; + } + + $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; + } +} + sub output { #return; @@ -386,12 +616,53 @@ sub output { # Don't update too often. my $age = Time::HiRes::tv_interval($latest_update); - if ($age < $update_max_interval) { - Time::HiRes::alarm($update_max_interval + 0.01 - $age); + 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; + } + } + $info->{'pv'} = $pv; + $info->{'tablebase'} = 1; + } else { + $info->{'tablebase'} = 0; + } # # Some programs _always_ report MultiPV, even with only one PV. @@ -402,6 +673,8 @@ sub output { for my $key (qw(pv score_cp score_mate nodes nps depth seldepth tbhits)) { if (exists($info->{$key . '1'})) { $info->{$key} = $info->{$key . '1'}; + } else { + delete $info->{$key}; } } } @@ -428,8 +701,19 @@ 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(); + output_json(0); $latest_update = [Time::HiRes::gettimeofday]; } @@ -516,8 +800,8 @@ sub output_screen { 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) { @@ -527,7 +811,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 ]; @@ -551,22 +835,42 @@ sub output_screen { } sub output_json { + my $historic_json_only = shift; my $info = $engine->{'info'}; my $json = {}; $json->{'position'} = $pos_calculating->to_json_hash(); - $json->{'id'} = $engine->{'id'}; - $json->{'score'} = long_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->{'using_lomonosov'} = defined($remoteglotconf::tb_serial_key); $json->{'nodes'} = $info->{'nodes'}; $json->{'nps'} = $info->{'nps'}; $json->{'depth'} = $info->{'depth'}; $json->{'tbhits'} = $info->{'tbhits'}; $json->{'seldepth'} = $info->{'seldepth'}; - - # single-PV only for now - $json->{'pv_uci'} = $info->{'pv'}; - $json->{'pv_pretty'} = [ prettyprint_pv($pos_calculating, @{$info->{'pv'}}) ]; + $json->{'tablebase'} = $info->{'tablebase'}; + $json->{'pv'} = [ prettyprint_pv($pos_calculating, @{$info->{'pv'}}) ]; my %refutation_lines = (); my @refutation_lines = (); @@ -578,28 +882,171 @@ 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, 0), - pretty_move => $pretty_move, - pv_pretty => \@pretty_pv, + score => score_digest($info, $pos_calculating, $mpv), + move => $pretty_move, + pv => \@pretty_pv, }; - $refutation_lines{$pv->[0]}->{'pv_uci'} = $pv; }; } } $json->{'refutation_lines'} = \%refutation_lines; - open my $fh, ">/srv/analysis.sesse.net/www/analysis.json.tmp" + # Piece together historic score information, to the degree we have it. + if (!$historic_json_only && exists($pos_calculating->{'history'})) { + my %score_history = (); + + my $q = $dbh->prepare('SELECT * FROM scores WHERE id=?'); + my $pos = Position->start_pos('white', 'black'); + my $halfmove_num = 0; + 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->{'score_type'}, + $ref->{'score_value'} + ]; + } + ++$halfmove_num; + ($pos) = $pos->make_pretty_move($move); + } + $q->finish; + + # If at any point we are missing 10 consecutive moves, + # truncate the history there. This is so we don't get into + # a situation where we e.g. start analyzing at move 45, + # but we have analysis for 1. e4 from some completely different game + # and thus show a huge hole. + my $consecutive_missing = 0; + my $truncate_until = 0; + for (my $i = $halfmove_num; $i --> 0; ) { + if ($consecutive_missing >= 10) { + delete $score_history{$i}; + next; + } + if (exists($score_history{$i})) { + $consecutive_missing = 0; + } else { + ++$consecutive_missing; + } + } + + $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); + unless ($historic_json_only || !defined($remoteglotconf::json_output) || + (defined($last_written_json) && $last_written_json eq $encoded)) { + atomic_set_contents($remoteglotconf::json_output, $encoded); + $last_written_json = $encoded; + } + + if (exists($pos_calculating->{'history'}) && + defined($remoteglotconf::json_history_dir)) { + my $id = id_for_pos($pos_calculating); + my $filename = $remoteglotconf::json_history_dir . "/" . $id . ".json"; + + # Overwrite old analysis (assuming it exists at all) if we're + # using a different engine, or if we've calculated deeper. + # nodes is used as a tiebreaker. Don't bother about Multi-PV + # data; it's not that important. + my ($old_engine, $old_depth, $old_nodes) = get_json_analysis_stats($id); + my $new_depth = $json->{'depth'} // 0; + my $new_nodes = $json->{'nodes'} // 0; + if (!defined($old_engine) || + $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->{'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); + } + } + } +} + +sub atomic_set_contents { + my ($filename, $contents) = @_; + + open my $fh, ">", $filename . ".tmp" or return; - print $fh JSON::XS::encode_json($json); + print $fh $contents; close $fh; - rename("/srv/analysis.sesse.net/www/analysis.json.tmp", "/srv/analysis.sesse.net/www/analysis.json"); + rename($filename . ".tmp", $filename); +} + +sub id_for_pos { + my ($pos, $halfmove_num) = @_; + + $halfmove_num //= scalar @{$pos->{'history'}}; + (my $fen = $pos->fen()) =~ tr,/ ,-_,; + return "move$halfmove_num-$fen"; +} + +sub get_json_analysis_stats { + my $id = shift; + my $ref = $dbh->selectrow_hashref('SELECT * FROM scores WHERE id=?', undef, $id); + if (defined($ref)) { + return ($ref->{'engine'}, $ref->{'depth'}, $ref->{'nodes'}); + } else { + return ('', 0, 0); + } } sub uciprint { @@ -609,13 +1056,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}; @@ -626,7 +1069,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; @@ -638,22 +1085,28 @@ 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})) { - if ($invert) { - return 99999 - $info->{'score_mate' . $mpv}; - } else { - return -(99999 - $info->{'score_mate' . $mpv}); + my $mate = $info->{'score_mate' . $mpv}; + if ($pos->{'toplay'} eq 'B') { + $mate = -$mate; } + return ['m', $mate]; } 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)]; + } } } @@ -677,7 +1130,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; @@ -689,6 +1146,36 @@ sub long_score { return undef; } +# For graphs; a single number in centipawns, capped at +/- 500. +sub plot_score { + my ($info, $pos, $mpv) = @_; + + my $invert = ($pos->{'toplay'} eq 'B'); + if (defined($info->{'score_mate' . $mpv})) { + my $mate = $info->{'score_mate' . $mpv}; + if ($invert) { + $mate = -$mate; + } + if ($mate > 0) { + return 500; + } else { + return -500; + } + } else { + if (exists($info->{'score_cp' . $mpv})) { + my $score = $info->{'score_cp' . $mpv}; + if ($invert) { + $score = -$score; + } + $score = 500 if ($score > 500); + $score = -500 if ($score < -500); + return int($score); + } + } + + return undef; +} + my %book_cache = (); sub book_info { my ($fen, $board, $toplay) = @_; @@ -741,6 +1228,202 @@ sub book_info { return $text; } +sub extract_clock { + my ($pgn, $pos) = @_; + + # Look for extended PGN clock tags. + my $tags = $pgn->tags; + if (exists($tags->{'WhiteClock'}) && exists($tags->{'BlackClock'})) { + $pos->{'white_clock'} = hms_to_sec($tags->{'WhiteClock'}); + $pos->{'black_clock'} = hms_to_sec($tags->{'BlackClock'}); + return; + } + + # Look for TCEC-style time comments. + my $moves = $pgn->moves; + my $comments = $pgn->comments; + my $last_black_move = int((scalar @$moves) / 2); + my $last_white_move = int((1 + scalar @$moves) / 2); + + my $black_key = $last_black_move . "b"; + my $white_key = $last_white_move . "w"; + + if (exists($comments->{$white_key}) && + exists($comments->{$black_key}) && + $comments->{$white_key} =~ /(?:tl=|clk )(\d+:\d+:\d+)/ && + $comments->{$black_key} =~ /(?:tl=|clk )(\d+:\d+:\d+)/) { + $comments->{$white_key} =~ /(?:tl=|clk )(\d+:\d+:\d+)/; + $pos->{'white_clock'} = hms_to_sec($1); + $comments->{$black_key} =~ /(?:tl=|clk )(\d+:\d+:\d+)/; + $pos->{'black_clock'} = hms_to_sec($1); + return; + } + + delete $pos->{'white_clock'}; + delete $pos->{'black_clock'}; +} + +sub hms_to_sec { + my $hms = shift; + return undef if (!defined($hms)); + $hms =~ /(\d+):(\d+):(\d+)/; + return $1 * 3600 + $2 * 60 + $3; +} + +sub find_clock_start { + my ($pos, $prev_pos) = @_; + + # If the game is over, the clock is stopped. + if (exists($pos->{'result'}) && + ($pos->{'result'} eq '1-0' || + $pos->{'result'} eq '1/2-1/2' || + $pos->{'result'} eq '0-1')) { + return; + } + + # When we don't have any moves, we assume the clock hasn't started yet. + if ($pos->{'move_num'} == 1 && $pos->{'toplay'} eq 'W') { + if (defined($remoteglotconf::adjust_clocks_before_move)) { + &$remoteglotconf::adjust_clocks_before_move(\$pos->{'white_clock'}, \$pos->{'black_clock'}, 1, 'W'); + } + 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->{'history'})) { + return; + } + + my $id = id_for_pos($pos); + my $clock_info = $dbh->selectrow_hashref('SELECT * FROM clock_info WHERE id=?', undef, $id); + if (defined($clock_info)) { + $pos->{'white_clock'} //= $clock_info->{'white_clock'}; + $pos->{'black_clock'} //= $clock_info->{'black_clock'}; + if ($pos->{'toplay'} eq 'W') { + $pos->{'white_clock_target'} = $clock_info->{'white_clock_target'}; + } else { + $pos->{'black_clock_target'} = $clock_info->{'black_clock_target'}; + } + return; + } + + # OK, we haven't seen this position before, so we assume the move + # happened right now. + + # See if we should do our own clock management (ie., clock information + # is spurious or non-existent). + if (defined($remoteglotconf::adjust_clocks_before_move)) { + my $wc = $pos->{'white_clock'} // $prev_pos->{'white_clock'}; + my $bc = $pos->{'black_clock'} // $prev_pos->{'black_clock'}; + if (defined($prev_pos->{'white_clock_target'})) { + $wc = $prev_pos->{'white_clock_target'} - time; + } + if (defined($prev_pos->{'black_clock_target'})) { + $bc = $prev_pos->{'black_clock_target'} - time; + } + &$remoteglotconf::adjust_clocks_before_move(\$wc, \$bc, $pos->{'move_num'}, $pos->{'toplay'}); + $pos->{'white_clock'} = $wc; + $pos->{'black_clock'} = $bc; + } + + my $key = ($pos->{'toplay'} eq 'W') ? 'white_clock' : 'black_clock'; + if (!exists($pos->{$key})) { + # No clock information. + return; + } + my $time_left = $pos->{$key}; + my ($white_clock_target, $black_clock_target); + if ($pos->{'toplay'} eq 'W') { + $white_clock_target = $pos->{'white_clock_target'} = time + $time_left; + } else { + $black_clock_target = $pos->{'black_clock_target'} = time + $time_left; + } + local $dbh->{AutoCommit} = 0; + $dbh->do('DELETE FROM clock_info WHERE id=?', undef, $id); + $dbh->do('INSERT INTO clock_info (id, white_clock, black_clock, white_clock_target, black_clock_target) VALUES (?, ?, ?, ?, ?)', undef, + $id, $pos->{'white_clock'}, $pos->{'black_clock'}, $white_clock_target, $black_clock_target); + $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)); @@ -762,5 +1445,5 @@ 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); }