X-Git-Url: https://git.sesse.net/?p=remoteglot;a=blobdiff_plain;f=remoteglot.pl;h=a0c1bf12987b526964e03a6a1cb62c1b4d0c4a4c;hp=675ef5011ec20788b08a343b0596083b5c853366;hb=de97cece71fe4a5f64a88a807805608c7a289813;hpb=be27a8c1495840effbd3c0044e205bfa5ca06808 diff --git a/remoteglot.pl b/remoteglot.pl index 675ef50..a0c1bf1 100755 --- a/remoteglot.pl +++ b/remoteglot.pl @@ -15,11 +15,13 @@ 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'; @@ -35,6 +37,14 @@ 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; @@ -209,7 +219,6 @@ sub handle_fics { for my $pos ($pos_waiting, $pos_calculating) { next if (!defined($pos)); if ($pos->fen() eq $pos_for_movelist->fen()) { - $pos->{'history'} = \@uci_movelist; $pos->{'pretty_history'} = \@pretty_movelist; } } @@ -266,40 +275,59 @@ sub handle_pgn { } my $pgn = Chess::PGN::Parse->new(undef, $body); - if (!defined($pgn) || !$pgn->read_game()) { + if (!defined($pgn) || !$pgn->read_game() || $body !~ /^\[/) { warn "Error in parsing PGN from $url\n"; } else { - $pgn->quick_parse_game; - my $pos = Position->start_pos($pgn->white, $pgn->black); - my $moves = $pgn->moves; - my @uci_moves = (); - for my $move (@$moves) { - my $uci_move; - ($pos, $uci_move) = $pos->make_pretty_move($move); - push @uci_moves, $uci_move; - } - $pos->{'history'} = \@uci_moves; - $pos->{'pretty_history'} = $moves; - - # 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; + 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"; } - } - 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); + + $pgn->parse_game({ save_comments => 'yes' }); + my $pos = Position->start_pos($pgn->white, $pgn->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_col, $from_row, $to_col, $to_row, $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; + } + $pos->{'result'} = $pgn->result; + $pos->{'pretty_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"; } } @@ -310,18 +338,38 @@ sub handle_pgn { 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"); } @@ -440,10 +488,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; } @@ -569,7 +616,7 @@ sub output { } output_screen(); - output_json(); + output_json(0); $latest_update = [Time::HiRes::gettimeofday]; } @@ -691,13 +738,28 @@ 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->{'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; + } + 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'} = long_score($info, $pos_calculating, ''); $json->{'short_score'} = short_score($info, $pos_calculating, ''); + $json->{'plot_score'} = plot_score($info, $pos_calculating, ''); + $json->{'using_lomonosov'} = defined($remoteglotconf::tb_serial_key); $json->{'nodes'} = $info->{'nodes'}; $json->{'nps'} = $info->{'nps'}; @@ -706,8 +768,7 @@ sub output_json { $json->{'seldepth'} = $info->{'seldepth'}; $json->{'tablebase'} = $info->{'tablebase'}; - # single-PV only for now - $json->{'pv_uci'} = $info->{'pv'}; + $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'}}) ]; my %refutation_lines = (); @@ -731,17 +792,149 @@ sub output_json { pretty_move => $pretty_move, pv_pretty => \@pretty_pv, }; - $refutation_lines{$pv->[0]}->{'pv_uci'} = $pv; }; } } $json->{'refutation_lines'} = \%refutation_lines; - open my $fh, ">", $remoteglotconf::json_output . ".tmp" + # Piece together historic score information, to the degree we have it. + if (!$historic_json_only && exists($pos_calculating->{'pretty_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->{'pretty_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'} + ]; + } + ++$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.) + 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'; + + push @games, { + id => $ref->{'id'}, + name => "$white–$black", + url => $ref->{'url'} + }; + }; + 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->{'pretty_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->{'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->{'engine'}{'name'}, $new_depth, $new_nodes); + $dbh->commit; + } + } + } +} + +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($remoteglotconf::json_output . ".tmp", $remoteglotconf::json_output); + rename($filename . ".tmp", $filename); +} + +sub id_for_pos { + my ($pos, $halfmove_num) = @_; + + $halfmove_num //= scalar @{$pos->{'pretty_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 { @@ -843,6 +1036,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) = @_; @@ -895,6 +1118,124 @@ 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->{'pretty_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;