X-Git-Url: https://git.sesse.net/?p=remoteglot;a=blobdiff_plain;f=remoteglot.pl;h=6a5778a0b96b3c321d0095b21fa92bd67d018904;hp=4e6edc68308f3524b252c765d61394126107f6cc;hb=b9fb6e88fc023303181e384719c8e2d3f19133a2;hpb=25b4c5b0537cb335c09c7b1bf4e765c5aa6cf412 diff --git a/remoteglot.pl b/remoteglot.pl index 4e6edc6..6a5778a 100755 --- a/remoteglot.pl +++ b/remoteglot.pl @@ -28,12 +28,17 @@ use warnings; 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; + +# TODO: Persist (parts of) this so that we can restart. +my %clock_target_for_pos = (); $| = 1; @@ -199,7 +204,6 @@ sub handle_fics { }; if ($@) { warn "Error when getting FICS move history: $@"; - exit; $getting_movelist = 0; } } @@ -209,7 +213,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; } } @@ -232,6 +235,7 @@ sub handle_fics { 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."); @@ -257,40 +261,55 @@ 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()) { + 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 ($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 { + $pgn->parse_game({ save_comments => 'yes' }); + 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; } - } - 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); + $pos->{'result'} = $pgn->result; + $pos->{'pretty_history'} = $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"; } } @@ -301,6 +320,7 @@ sub handle_pgn { sub handle_position { my ($pos) = @_; + find_clock_start($pos); # if this is already in the queue, ignore it return if (defined($pos_waiting) && $pos->fen() eq $pos_waiting->fen()); @@ -313,6 +333,19 @@ sub handle_position { # 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"); } @@ -477,7 +510,8 @@ sub output { # Don't update too often. my $age = Time::HiRes::tv_interval($latest_update); if ($age < $remoteglotconf::update_max_interval) { - Time::HiRes::alarm($remoteglotconf::update_max_interval + 0.01 - $age); + my $wait = $remoteglotconf::update_max_interval + 0.01 - $age; + $output_timer = AnyEvent->timer(after => $wait, cb => \&output); return; } @@ -501,7 +535,7 @@ sub output { my $t = $tb_cache{$fen}; my $pv = $t->{'pv'}; - my $matelen = int((1 + scalar @$pv) / 2); + 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') { @@ -559,7 +593,7 @@ sub output { } output_screen(); - output_json(); + output_json(0); $latest_update = [Time::HiRes::gettimeofday]; } @@ -681,6 +715,7 @@ sub output_screen { } sub output_json { + my $historic_json_only = shift; my $info = $engine->{'info'}; my $json = {}; @@ -696,8 +731,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 = (); @@ -721,17 +755,76 @@ 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" + my $encoded = JSON::XS::encode_json($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 $filename = $remoteglotconf::json_history_dir . "/" . id_for_pos($pos_calculating) . ".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($filename); + my $new_depth = $json->{'depth'} // 0; + my $new_nodes = $json->{'nodes'} // 0; + if (!defined($old_engine) || + $old_engine ne $json->{'id'}{'name'} || + $new_depth > $old_depth || + ($new_depth == $old_depth && $new_nodes >= $old_nodes)) { + atomic_set_contents($filename, $encoded); + } + } +} + +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 = shift; + + my $halfmove_num = scalar @{$pos->{'pretty_history'}}; + (my $fen = $pos->fen()) =~ tr,/ ,-_,; + return "move$halfmove_num-$fen"; +} + +sub get_json_analysis_stats { + my $filename = shift; + + my ($engine, $depth, $nodes); + + open my $fh, "<", $filename + or return undef; + local $/ = undef; + eval { + my $json = JSON::XS::decode_json(<$fh>); + $engine = $json->{'id'}{'name'} // die; + $depth = $json->{'depth'} // 0; + $nodes = $json->{'nodes'} // 0; + }; + close $fh; + if ($@) { + warn "Error in decoding $filename: $@"; + return undef; + } + return ($engine, $depth, $nodes); } sub uciprint { @@ -885,6 +978,89 @@ 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'} = $tags->{'WhiteClock'}; + $pos->{'black_clock'} = $tags->{'BlackClock'}; + + $pos->{'white_clock'} =~ s/\b(\d)\b/0$1/g; + $pos->{'black_clock'} =~ s/\b(\d)\b/0$1/g; + 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=(\d+:\d+:\d+)/ && + $comments->{$black_key} =~ /tl=(\d+:\d+:\d+)/) { + $comments->{$white_key} =~ /tl=(\d+:\d+:\d+)/; + $pos->{'white_clock'} = $1; + $comments->{$black_key} =~ /tl=(\d+:\d+:\d+)/; + $pos->{'black_clock'} = $1; + return; + } +} + +sub find_clock_start { + my $pos = shift; + + # 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') { + return; + } + + # TODO(sesse): Maybe we can get the number of moves somehow else for FICS games. + if (!exists($pos->{'pretty_history'})) { + return; + } + + my $id = id_for_pos($pos); + if (exists($clock_target_for_pos{$id})) { + if ($pos->{'toplay'} eq 'W') { + $pos->{'white_clock_target'} = $clock_target_for_pos{$id}; + } else { + $pos->{'black_clock_target'} = $clock_target_for_pos{$id}; + } + return; + } + + # OK, we haven't seen this position before, so we assume the move + # happened right now. + my $key = ($pos->{'toplay'} eq 'W') ? 'white_clock' : 'black_clock'; + if (!exists($pos->{$key})) { + # No clock information. + return; + } + $pos->{$key} =~ /(\d+):(\d+):(\d+)/; + my $time_left = $1 * 3600 + $2 * 60 + $3; + $clock_target_for_pos{$id} = time + $time_left; + if ($pos->{'toplay'} eq 'W') { + $pos->{'white_clock_target'} = $clock_target_for_pos{$id}; + } else { + $pos->{'black_clock_target'} = $clock_target_for_pos{$id}; + } +} + sub schedule_tb_lookup { return if (!defined($remoteglotconf::tb_serial_key)); my $pos = $pos_waiting // $pos_calculating; @@ -930,12 +1106,14 @@ sub handle_tb_lookup_return { my $moves = $pgn->moves; my @uci_moves = (); for my $move (@$moves) { - my ($pvpos, $uci_move) = $pvpos->make_pretty_move($move); + 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 + pv => \@uci_moves, + score => $response->{'Response'}{'Score'}, }; output(); }