git.sesse.net Git - remoteglot/blob - remoteglot.pl

   1 #! /usr/bin/perl
   2
   3 #
   4 # remoteglot - Connects an abitrary UCI-speaking engine to a (live) PGN,
   5 #              for live analysis of relayed games.
   6 #
   7 # Copyright 2007 Steinar H. Gunderson <steinar+remoteglot@gunderson.no>
   8 # Licensed under the GNU General Public License, version 2.
   9 #
  10
  11 use AnyEvent;
  12 use AnyEvent::Handle;
  13 use AnyEvent::HTTP;
  14 use Chess::PGN::Parse;
  15 use EV;
  16 use File::Slurp;
  17 use IPC::Open2;
  18 use Time::HiRes;
  19 use JSON::XS;
  20 use URI::Escape;
  21 use DBI;
  22 use DBD::Pg;
  23 require 'Position.pm';
  24 require 'Engine.pm';
  25 require 'config.pm';
  26 use strict;
  27 use warnings;
  28 no warnings qw(once);
  29
  30 # Program starts here
  31 my $latest_update = undef;
  32 my $output_timer = undef;
  33 my $http_timer = undef;
  34 my $stop_pgn_fetch = 0;
  35 my $tb_retry_timer = undef;
  36 my $tb_lookup_running = 0;
  37 my $last_written_json = undef;
  38
  39 # Persisted so we can restart.
  40 # TODO: Figure out an appropriate way to deal with database restarts
  41 # and/or Postgres going away entirely.
  42 my $dbh = DBI->connect($remoteglotconf::dbistr, $remoteglotconf::dbiuser, $remoteglotconf::dbipass)
  43         or die DBI->errstr;
  44 $dbh->{RaiseError} = 1;
  45
  46 $| = 1;
  47
  48 open(UCILOG, ">ucilog.txt")
  49         or die "ucilog.txt: $!";
  50 print UCILOG "Log starting.\n";
  51 select(UCILOG);
  52 $| = 1;
  53
  54 open(TBLOG, ">tblog.txt")
  55         or die "tblog.txt: $!";
  56 print TBLOG "Log starting.\n";
  57 select(TBLOG);
  58 $| = 1;
  59
  60 select(STDOUT);
  61 umask 0022;  # analysis.json should not be served to users.
  62
  63 # open the chess engine
  64 my $engine = open_engine($remoteglotconf::engine_cmdline, 'E1', sub { handle_uci(@_, 1); });
  65 my $engine2 = open_engine($remoteglotconf::engine2_cmdline, 'E2', sub { handle_uci(@_, 0); });
  66 my $last_move;
  67 my $last_text = '';
  68 my ($pos_calculating, $pos_calculating_second_engine);
  69
  70 # If not undef, we've started calculating this position but haven't ever given out
  71 # any analysis for it, so we're on a forced timer to do so.
  72 my $pos_calculating_started = undef;
  73
  74 # If not undef, we've output this position, but without a main PV, so we're on
  75 # _another_ forced timer to do so.
  76 my $pos_pv_started = undef;
  77 my $last_output_had_pv = 0;
  78
  79 setoptions($engine, \%remoteglotconf::engine_config);
  80 uciprint($engine, "ucinewgame");
  81
  82 if (defined($engine2)) {
  83         setoptions($engine2, \%remoteglotconf::engine2_config);
  84         uciprint($engine2, "setoption name MultiPV value 500");
  85         uciprint($engine2, "ucinewgame");
  86 }
  87
  88 print "Chess engine ready.\n";
  89
  90 if (defined($remoteglotconf::target)) {
  91         if ($remoteglotconf::target =~ /^(?:\/|https?:)/) {
  92                 my $target = $remoteglotconf::target;
  93                 # Convenience.
  94                 $target =~ s#https://lichess.org/broadcast/.*/([^/]+)?$#https://lichess.org/api/stream/broadcast/round/$1.pgn#;
  95                 fetch_pgn($target);
  96         }
  97 }
  98
  99 # Engine events have already been set up by Engine.pm.
 100 EV::run;
 101
 102 sub handle_uci {
 103         my ($engine, $line, $primary) = @_;
 104
 105         return if $line =~ /(upper|lower)bound/;
 106
 107         $line =~ s/  / /g;  # Sometimes needed for Zappa Mexico
 108         print UCILOG localtime() . " $engine->{'tag'} <= $line\n";
 109
 110         # If we've sent a stop command, gobble up lines until we see bestmove.
 111         return if ($engine->{'stopping'} && $line !~ /^bestmove/);
 112         $engine->{'stopping'} = 0;
 113
 114         if ($line =~ /^info/ && $line !~ / cluster /) {
 115                 my (@infos) = split / /, $line;
 116                 shift @infos;
 117
 118                 parse_infos($engine, @infos);
 119         }
 120         if ($line =~ /^id/) {
 121                 my (@ids) = split / /, $line;
 122                 shift @ids;
 123
 124                 parse_ids($engine, @ids);
 125         }
 126         output();
 127 }
 128
 129 my $getting_movelist = 0;
 130 my $pos_for_movelist = undef;
 131 my @uci_movelist = ();
 132 my @pretty_movelist = ();
 133
 134 # Starts periodic fetching of PGNs from the given URL.
 135 sub fetch_pgn {
 136         my ($url) = @_;
 137         if ($url =~ m#^/#) {  # Local file.
 138                 eval {
 139                         local $/ = undef;
 140                         open my $fh, "<", $url
 141                                 or die "$url: $!";
 142                         my $pgn = <$fh>;
 143                         close $fh;
 144                         handle_pgn($pgn, '', $url);
 145                 };
 146                 if ($@) {
 147                         warn "$url: $@";
 148                         $http_timer = AnyEvent->timer(after => $remoteglotconf::poll_frequency, cb => sub {
 149                                 fetch_pgn($url);
 150                         });
 151                 }
 152         } else {
 153                 my $buffer = '';
 154                 AnyEvent::HTTP::http_get($url,
 155                         on_body => sub {
 156                                 handle_partial_pgn(@_, \$buffer, $url);
 157                         },
 158                         sub {
 159                                 end_pgn(@_, \$buffer, $url);
 160                         });
 161         }
 162 }
 163
 164 my ($last_pgn_white, $last_pgn_black);
 165 my @last_pgn_uci_moves = ();
 166 my $pgn_hysteresis_counter = 0;
 167
 168 sub handle_partial_pgn {
 169         my ($body, $header, $buffer, $url) = @_;
 170
 171         if ($stop_pgn_fetch) {
 172                 $stop_pgn_fetch = 0;
 173                 $http_timer = undef;
 174                 return 0;
 175         }
 176         $$buffer .= $body;
 177         while ($$buffer =~ s/^\s*(.*)\n\n\n//s) {
 178                 handle_pgn($1, $url);
 179         }
 180         return 1;
 181 }
 182
 183 sub end_pgn {
 184         my ($body, $header, $buffer, $url) = @_;
 185         handle_pgn($$buffer, $url);
 186         $$buffer = "";
 187         $http_timer = AnyEvent->timer(after => $remoteglotconf::poll_frequency, cb => sub {
 188                 fetch_pgn($url);
 189         });
 190 }
 191
 192 sub handle_pgn {
 193         my ($body, $url) = @_;
 194
 195         my $pgn = Chess::PGN::Parse->new(undef, $body);
 196         if (!defined($pgn)) {
 197                 warn "Error in parsing PGN from $url [body='$body']\n";
 198         } elsif (!$pgn->read_game()) {
 199                 warn "Error in reading PGN game from $url [body='$body']\n";
 200         } elsif ($body !~ /^\[/) {
 201                 warn "Malformed PGN from $url [body='$body']\n";
 202         } else {
 203                 eval {
 204                         # Skip to the right game.
 205                         while (defined($remoteglotconf::pgn_filter) &&
 206                                !&$remoteglotconf::pgn_filter($pgn)) {
 207                                 $pgn->read_game() or die "Out of games during filtering";
 208                         }
 209
 210                         $pgn->parse_game({ save_comments => 'yes' });
 211                         my $white = $pgn->white;
 212                         my $black = $pgn->black;
 213                         $white =~ s/,.*//;  # Remove first name.
 214                         $black =~ s/,.*//;  # Remove first name.
 215                         my $tags = $pgn->tags();
 216                         my $pos;
 217                         if (exists($tags->{'FEN'})) {
 218                                 $pos = Position->from_fen($tags->{'FEN'});
 219                                 $pos->{'last_move'} = 'none';
 220                                 $pos->{'player_w'} = $white;
 221                                 $pos->{'player_b'} = $black;
 222                                 $pos->{'start_fen'} = $tags->{'FEN'};
 223                         } else {
 224                                 $pos = Position->start_pos($white, $black);
 225                         }
 226                         if (exists($tags->{'Variant'}) &&
 227                             $tags->{'Variant'} =~ /960|fischer/i) {
 228                                 $pos->{'chess960'} = 1;
 229                         } else {
 230                                 $pos->{'chess960'} = 0;
 231                         }
 232                         my $moves = $pgn->moves;
 233                         my @uci_moves = ();
 234                         my @repretty_moves = ();
 235                         for my $move (@$moves) {
 236                                 my ($npos, $uci_move) = $pos->make_pretty_move($move);
 237                                 push @uci_moves, $uci_move;
 238
 239                                 # Re-prettyprint the move.
 240                                 my ($from_row, $from_col, $to_row, $to_col, $promo) = parse_uci_move($uci_move);
 241                                 my ($pretty, undef) = $pos->{'board'}->prettyprint_move($from_row, $from_col, $to_row, $to_col, $promo);
 242                                 push @repretty_moves, $pretty;
 243                                 $pos = $npos;
 244                         }
 245                         if ($pgn->result eq '1-0' || $pgn->result eq '1/2-1/2' || $pgn->result eq '0-1') {
 246                                 $pos->{'result'} = $pgn->result;
 247                         }
 248
 249                         my @extra_moves = ();
 250                         $pos = extend_from_manual_override($pos, \@repretty_moves, \@extra_moves);
 251                         extract_clock($pgn, $pos);
 252                         $pos->{'history'} = \@repretty_moves;
 253                         $pos->{'extra_moves'} = \@extra_moves;
 254
 255                         # Sometimes, PGNs lose a move or two for a short while,
 256                         # or people push out new ones non-atomically.
 257                         # Thus, if we PGN doesn't change names but becomes
 258                         # shorter, we mistrust it for a few seconds.
 259                         my $trust_pgn = 1;
 260                         if (defined($last_pgn_white) && defined($last_pgn_black) &&
 261                             $last_pgn_white eq $pgn->white &&
 262                             $last_pgn_black eq $pgn->black &&
 263                             scalar(@uci_moves) < scalar(@last_pgn_uci_moves)) {
 264                                 if (++$pgn_hysteresis_counter < 3) {
 265                                         $trust_pgn = 0;
 266                                 }
 267                         }
 268                         if ($trust_pgn) {
 269                                 $last_pgn_white = $pgn->white;
 270                                 $last_pgn_black = $pgn->black;
 271                                 @last_pgn_uci_moves = @uci_moves;
 272                                 $pgn_hysteresis_counter = 0;
 273                                 handle_position($pos);
 274                         }
 275                 };
 276                 if ($@) {
 277                         warn "Error in parsing moves from $url: $@\n";
 278                 }
 279         }
 280
 281         $http_timer = AnyEvent->timer(after => $remoteglotconf::poll_frequency, cb => sub {
 282                 fetch_pgn($url);
 283         });
 284 }
 285
 286 sub handle_position {
 287         my ($pos) = @_;
 288         find_clock_start($pos, $pos_calculating);
 289
 290         # If we're already chewing on this and there's nothing else in the queue,
 291         # ignore it.
 292         if (defined($pos_calculating) && $pos->fen() eq $pos_calculating->fen()) {
 293                 $pos_calculating->{'result'} = $pos->{'result'};
 294                 for my $key ('white_clock', 'black_clock', 'white_clock_target', 'black_clock_target') {
 295                         $pos_calculating->{$key} //= $pos->{$key};
 296                 }
 297                 $pos_calculating->{'extra_moves'} = $pos->{'extra_moves'};
 298                 return;
 299         }
 300
 301         # If we're already thinking on something, stop and wait for the engine
 302         # to approve.
 303         if (defined($pos_calculating)) {
 304                 # Store the final data we have for this position in the history,
 305                 # with the precise clock information we just got from the new
 306                 # position. (Historic positions store the clock at the end of
 307                 # the position.)
 308                 #
 309                 # Do not output anything new to the main analysis; that's
 310                 # going to be obsolete really soon. (Exception: If we've never
 311                 # output anything for this move, ie., it didn't hit the 200ms
 312                 # limit, spit it out to the user anyway. It's probably a really
 313                 # fast blitz game or something, and it's good to show the moves
 314                 # as they come in even without great analysis.)
 315                 $pos_calculating->{'white_clock'} = $pos->{'white_clock'};
 316                 $pos_calculating->{'black_clock'} = $pos->{'black_clock'};
 317                 delete $pos_calculating->{'white_clock_target'};
 318                 delete $pos_calculating->{'black_clock_target'};
 319
 320                 if (defined($pos_calculating_started)) {
 321                         output_json(0);
 322                 } else {
 323                         output_json(1);
 324                 }
 325                 $pos_calculating_started = [Time::HiRes::gettimeofday];
 326                 $pos_pv_started = undef;
 327
 328                 # Ask the engine to stop; we will throw away its data until it
 329                 # sends us "bestmove", signaling the end of it.
 330                 $engine->{'stopping'} = 1;
 331                 uciprint($engine, "stop");
 332         }
 333
 334         # It's wrong to just give the FEN (the move history is useful,
 335         # and per the UCI spec, we should really have sent "ucinewgame"),
 336         # but it's easier, and it works around a Stockfish repetition issue.
 337         if ($engine->{'chess960'} != $pos->{'chess960'}) {
 338                 uciprint($engine, "setoption name UCI_Chess960 value " . ($pos->{'chess960'} ? 'true' : 'false'));
 339                 $engine->{'chess960'} = $pos->{'chess960'};
 340         }
 341         uciprint($engine, "position fen " . $pos->fen());
 342         uciprint($engine, "go infinite");
 343         $pos_calculating = $pos;
 344         $pos_calculating_started = [Time::HiRes::gettimeofday];
 345         $pos_pv_started = undef;
 346
 347         if (defined($engine2)) {
 348                 if (defined($pos_calculating_second_engine)) {
 349                         $engine2->{'stopping'} = 1;
 350                         uciprint($engine2, "stop");
 351                 }
 352                 if ($engine2->{'chess960'} != $pos->{'chess960'}) {
 353                         uciprint($engine2, "setoption name UCI_Chess960 value " . ($pos->{'chess960'} ? 'true' : 'false'));
 354                         $engine2->{'chess960'} = $pos->{'chess960'};
 355                 }
 356                 uciprint($engine2, "position fen " . $pos->fen());
 357                 uciprint($engine2, "go infinite");
 358                 $pos_calculating_second_engine = $pos;
 359                 $engine2->{'info'} = {};
 360         }
 361
 362         $engine->{'info'} = {};
 363         $last_move = time;
 364 }
 365
 366 sub parse_infos {
 367         my ($engine, @x) = @_;
 368         my $mpv = '';
 369
 370         my $info = $engine->{'info'};
 371
 372         # Search for "multipv" first of all, since e.g. Stockfish doesn't put it first.
 373         for my $i (0..$#x - 1) {
 374                 if ($x[$i] eq 'multipv') {
 375                         $mpv = $x[$i + 1];
 376                         next;
 377                 }
 378         }
 379
 380         while (scalar @x > 0) {
 381                 if ($x[0] eq 'multipv') {
 382                         # Dealt with above
 383                         shift @x;
 384                         shift @x;
 385                         next;
 386                 }
 387                 if ($x[0] eq 'currmove' || $x[0] eq 'currmovenumber' || $x[0] eq 'cpuload') {
 388                         my $key = shift @x;
 389                         my $value = shift @x;
 390                         $info->{$key} = $value;
 391                         next;
 392                 }
 393                 if ($x[0] eq 'depth' || $x[0] eq 'seldepth' || $x[0] eq 'hashfull' ||
 394                     $x[0] eq 'time' || $x[0] eq 'nodes' || $x[0] eq 'nps' ||
 395                     $x[0] eq 'tbhits') {
 396                         my $key = shift @x;
 397                         my $value = shift @x;
 398                         $info->{$key . $mpv} = $value;
 399                         next;
 400                 }
 401                 if ($x[0] eq 'score') {
 402                         shift @x;
 403
 404                         delete $info->{'score_cp' . $mpv};
 405                         delete $info->{'score_mate' . $mpv};
 406                         delete $info->{'splicepos' . $mpv};
 407
 408                         while ($x[0] eq 'cp' || $x[0] eq 'mate') {
 409                                 if ($x[0] eq 'cp') {
 410                                         shift @x;
 411                                         $info->{'score_cp' . $mpv} = shift @x;
 412                                 } elsif ($x[0] eq 'mate') {
 413                                         shift @x;
 414                                         $info->{'score_mate' . $mpv} = shift @x;
 415                                 } else {
 416                                         shift @x;
 417                                 }
 418                         }
 419                         next;
 420                 }
 421                 if ($x[0] eq 'pv') {
 422                         $info->{'pv' . $mpv} = [ @x[1..$#x] ];
 423                         last;
 424                 }
 425                 if ($x[0] eq 'string' || $x[0] eq 'UCI_AnalyseMode' || $x[0] eq 'setting' || $x[0] eq 'contempt') {
 426                         last;
 427                 }
 428
 429                 #print "unknown info '$x[0]', trying to recover...\n";
 430                 #shift @x;
 431                 die "Unknown info '" . join(',', @x) . "'";
 432
 433         }
 434 }
 435
 436 sub parse_ids {
 437         my ($engine, @x) = @_;
 438
 439         while (scalar @x > 0) {
 440                 if ($x[0] eq 'name') {
 441                         my $value = join(' ', @x);
 442                         $engine->{'id'}{'author'} = $value;
 443                         last;
 444                 }
 445
 446                 # unknown
 447                 shift @x;
 448         }
 449 }
 450
 451 sub prettyprint_pv_no_cache {
 452         my ($board, @pvs) = @_;
 453
 454         if (scalar @pvs == 0 || !defined($pvs[0])) {
 455                 return ();
 456         }
 457
 458         my @ret = ();
 459         for my $pv (@pvs) {
 460                 my ($from_row, $from_col, $to_row, $to_col, $promo) = parse_uci_move($pv);
 461                 my ($pretty, $nb) = $board->prettyprint_move($from_row, $from_col, $to_row, $to_col, $promo);
 462                 push @ret, $pretty;
 463                 $board = $nb;
 464         }
 465         return @ret;
 466 }
 467
 468 sub prettyprint_pv {
 469         my ($pos, @pvs) = @_;
 470
 471         my $cachekey = join('', @pvs);
 472         if (exists($pos->{'prettyprint_cache'}{$cachekey})) {
 473                 return @{$pos->{'prettyprint_cache'}{$cachekey}};
 474         } else {
 475                 my @res = prettyprint_pv_no_cache($pos->{'board'}, @pvs);
 476                 $pos->{'prettyprint_cache'}{$cachekey} = \@res;
 477                 return @res;
 478         }
 479 }
 480
 481 my %tbprobe_cache = ();
 482
 483 sub complete_using_tbprobe {
 484         my ($pos, $info, $mpv) = @_;
 485
 486         # We need Fathom installed to do standalone TB probes.
 487         return if (!defined($remoteglotconf::fathom_cmdline));
 488
 489         # If we already have a mate, don't bother; in some cases, it would even be
 490         # better than a tablebase score.
 491         return if defined($info->{'score_mate' . $mpv});
 492
 493         # If we have a draw or near-draw score, there's also not much interesting
 494         # we could add from a tablebase. We only really want mates.
 495         return if ($info->{'score_cp' . $mpv} >= -12250 && $info->{'score_cp' . $mpv} <= 12250);
 496
 497         # Run through the PV until we are at a 6-man position.
 498         # TODO: We could in theory only have 5-man data.
 499         my @pv = @{$info->{'pv' . $mpv}};
 500         my $key = $pos->fen() . " " . join('', @pv);
 501         my @moves = ();
 502         my $splicepos;
 503         if (exists($tbprobe_cache{$key})) {
 504                 my $c = $tbprobe_cache{$key};
 505                 @moves = @{$c->{'moves'}};
 506                 $splicepos = $c->{'splicepos'};
 507         } else {
 508                 if ($mpv ne '') {
 509                         # Force doing at least one move of the PV.
 510                         my $move = shift @pv;
 511                         push @moves, $move;
 512                         $pos = $pos->make_move(parse_uci_move($move));
 513                 }
 514
 515                 while ($pos->num_pieces() > 7 && $#pv > -1) {
 516                         my $move = shift @pv;
 517                         push @moves, $move;
 518                         $pos = $pos->make_move(parse_uci_move($move));
 519                 }
 520
 521                 return if ($pos->num_pieces() > 7);
 522
 523                 my $fen = $pos->fen();
 524                 my $pgn_text = `$remoteglotconf::fathom_cmdline "$fen"`;
 525                 my $pgn = Chess::PGN::Parse->new(undef, $pgn_text);
 526                 return if (!defined($pgn) || !$pgn->read_game() || ($pgn->result ne '0-1' && $pgn->result ne '1-0'));
 527                 $pgn->quick_parse_game;
 528
 529                 # Splice the PV from the tablebase onto what we have so far.
 530                 $splicepos = scalar @moves;
 531                 for my $move (@{$pgn->moves}) {
 532                         last if $move eq '#';
 533                         last if $move eq '1-0';
 534                         last if $move eq '0-1';
 535                         last if $move eq '1/2-1/2';
 536                         my $uci_move;
 537                         ($pos, $uci_move) = $pos->make_pretty_move($move);
 538                         push @moves, $uci_move;
 539                 }
 540
 541                 $tbprobe_cache{$key} = {
 542                         moves => \@moves,
 543                         splicepos => $splicepos
 544                 };
 545         }
 546
 547         $info->{'pv' . $mpv} = \@moves;
 548
 549         my $matelen = int((1 + scalar @moves) / 2);
 550         if ((scalar @moves) % 2 == 0) {
 551                 $info->{'score_mate' . $mpv} = -$matelen;
 552         } else {
 553                 $info->{'score_mate' . $mpv} = $matelen;
 554         }
 555         $info->{'splicepos' . $mpv} = $splicepos;
 556 }
 557
 558 sub output {
 559         #return;
 560
 561         return if (!defined($pos_calculating));
 562
 563         my $info = $engine->{'info'};
 564
 565         # Don't update too often.
 566         my $wait = $remoteglotconf::update_max_interval - Time::HiRes::tv_interval($latest_update);
 567         if (defined($pos_calculating_started)) {
 568                 my $new_pos_wait = $remoteglotconf::update_force_after_move - Time::HiRes::tv_interval($pos_calculating_started);
 569                 $wait = $new_pos_wait if ($new_pos_wait < $wait);
 570         }
 571         if (!$last_output_had_pv && has_pv($info)) {
 572                 if (!defined($pos_pv_started)) {
 573                         $pos_pv_started = [Time::HiRes::gettimeofday];
 574                 }
 575                 # We just got initial PV, and we're in a hurry since we gave out a blank one earlier,
 576                 # so give us just 200ms more to increase the quality and then force a display.
 577                 my $new_pos_wait = $remoteglotconf::update_force_after_move - Time::HiRes::tv_interval($pos_pv_started);
 578                 $wait = $new_pos_wait if ($new_pos_wait < $wait);
 579         }
 580         if ($wait > 0.0) {
 581                 $output_timer = AnyEvent->timer(after => $wait + 0.01, cb => \&output);
 582                 return;
 583         }
 584         $pos_pv_started = undef;
 585
 586         # We're outputting something for this position now, so the special handling
 587         # for new positions is off.
 588         undef $pos_calculating_started;
 589
 590         #
 591         # Some programs _always_ report MultiPV, even with only one PV.
 592         # In this case, we simply use that data as if MultiPV was never
 593         # specified.
 594         #
 595         if (exists($info->{'pv1'}) && !exists($info->{'pv2'})) {
 596                 for my $key (qw(pv score_cp score_mate nodes nps depth seldepth tbhits splicepos)) {
 597                         if (exists($info->{$key . '1'})) {
 598                                 $info->{$key} = $info->{$key . '1'};
 599                         } else {
 600                                 delete $info->{$key};
 601                         }
 602                 }
 603         }
 604
 605         #
 606         # Check the PVs first. if they're invalid, just wait, as our data
 607         # is most likely out of sync. This isn't a very good solution, as
 608         # it can frequently miss stuff, but it's good enough for most users.
 609         #
 610         eval {
 611                 my $dummy;
 612                 if (exists($info->{'pv'})) {
 613                         $dummy = prettyprint_pv($pos_calculating, @{$info->{'pv'}});
 614                 }
 615
 616                 my $mpv = 1;
 617                 while (exists($info->{'pv' . $mpv})) {
 618                         $dummy = prettyprint_pv($pos_calculating, @{$info->{'pv' . $mpv}});
 619                         ++$mpv;
 620                 }
 621         };
 622         if ($@) {
 623                 $engine->{'info'} = {};
 624                 return;
 625         }
 626
 627         # Now do our own Syzygy tablebase probes to convert scores like +123.45 to mate.
 628         if (exists($info->{'pv'})) {
 629                 complete_using_tbprobe($pos_calculating, $info, '');
 630         }
 631
 632         my $mpv = 1;
 633         while (exists($info->{'pv' . $mpv})) {
 634                 complete_using_tbprobe($pos_calculating, $info, $mpv);
 635                 ++$mpv;
 636         }
 637
 638         output_screen();
 639         output_json(0);
 640         $latest_update = [Time::HiRes::gettimeofday];
 641         $last_output_had_pv = has_pv($info);
 642 }
 643
 644 sub has_pv {
 645         my $info = shift;
 646         return 1 if (exists($info->{'pv'}) && (scalar(@{$info->{'pv'}}) > 0));
 647         return 1 if (exists($info->{'pv1'}) && (scalar(@{$info->{'pv1'}}) > 0));
 648         return 0;
 649 }
 650
 651 sub output_screen {
 652         my $info = $engine->{'info'};
 653         my $id = $engine->{'id'};
 654
 655         my $text = 'Analysis';
 656         if ($pos_calculating->{'last_move'} ne 'none') {
 657                 if ($pos_calculating->{'toplay'} eq 'W') {
 658                         $text .= sprintf ' after %u. ... %s', ($pos_calculating->{'move_num'}-1), $pos_calculating->{'last_move'};
 659                 } else {
 660                         $text .= sprintf ' after %u. %s', $pos_calculating->{'move_num'}, $pos_calculating->{'last_move'};
 661                 }
 662                 if (exists($id->{'name'})) {
 663                         $text .= ',';
 664                 }
 665         }
 666
 667         if (exists($id->{'name'})) {
 668                 $text .= " by $id->{'name'}:\n\n";
 669         } else {
 670                 $text .= ":\n\n";
 671         }
 672
 673         return unless (exists($pos_calculating->{'board'}));
 674
 675         my $extra_moves = $pos_calculating->{'extra_moves'};
 676         if (defined($extra_moves) && scalar @$extra_moves > 0) {
 677                 $text .= "  Manual move extensions: " . join(' ', @$extra_moves) . "\n";
 678         }
 679
 680         if (exists($info->{'pv1'}) && exists($info->{'pv2'})) {
 681                 # multi-PV
 682                 my $mpv = 1;
 683                 while (exists($info->{'pv' . $mpv})) {
 684                         $text .= sprintf "  PV%2u", $mpv;
 685                         my $score = short_score($info, $pos_calculating, $mpv);
 686                         $text .= "  ($score)" if (defined($score));
 687
 688                         my $tbhits = '';
 689                         if (exists($info->{'tbhits' . $mpv}) && $info->{'tbhits' . $mpv} > 0) {
 690                                 if ($info->{'tbhits' . $mpv} == 1) {
 691                                         $tbhits = ", 1 tbhit";
 692                                 } else {
 693                                         $tbhits = sprintf ", %u tbhits", $info->{'tbhits' . $mpv};
 694                                 }
 695                         }
 696
 697                         if (exists($info->{'nodes' . $mpv}) && exists($info->{'nps' . $mpv}) && exists($info->{'depth' . $mpv})) {
 698                                 $text .= sprintf " (%5u kn, %3u kn/s, %2u ply$tbhits)",
 699                                         $info->{'nodes' . $mpv} / 1000, $info->{'nps' . $mpv} / 1000, $info->{'depth' . $mpv};
 700                         }
 701
 702                         $text .= ":\n";
 703                         $text .= "  " . join(', ', prettyprint_pv($pos_calculating, @{$info->{'pv' . $mpv}})) . "\n";
 704                         $text .= "\n";
 705                         ++$mpv;
 706                 }
 707         } else {
 708                 # single-PV
 709                 my $score = long_score($info, $pos_calculating, '');
 710                 $text .= "  $score\n" if defined($score);
 711                 $text .=  "  PV: " . join(', ', prettyprint_pv($pos_calculating, @{$info->{'pv'}}));
 712                 $text .=  "\n";
 713
 714                 if (exists($info->{'nodes'}) && exists($info->{'nps'}) && exists($info->{'depth'})) {
 715                         $text .= sprintf "  %u nodes, %7u nodes/sec, depth %u ply",
 716                                 $info->{'nodes'}, $info->{'nps'}, $info->{'depth'};
 717                 }
 718                 if (exists($info->{'seldepth'})) {
 719                         $text .= sprintf " (%u selective)", $info->{'seldepth'};
 720                 }
 721                 if (exists($info->{'tbhits'}) && $info->{'tbhits'} > 0) {
 722                         if ($info->{'tbhits'} == 1) {
 723                                 $text .= ", one Syzygy hit";
 724                         } else {
 725                                 $text .= sprintf ", %u Syzygy hits", $info->{'tbhits'};
 726                         }
 727                 }
 728                 $text .= "\n\n";
 729         }
 730
 731         my @refutation_lines = ();
 732         if (defined($engine2)) {
 733                 for (my $mpv = 1; $mpv < 500; ++$mpv) {
 734                         my $info = $engine2->{'info'};
 735                         last if (!exists($info->{'pv' . $mpv}));
 736                         eval {
 737                                 complete_using_tbprobe($pos_calculating_second_engine, $info, $mpv);
 738                                 my $pv = $info->{'pv' . $mpv};
 739                                 my $pretty_move = join('', prettyprint_pv($pos_calculating_second_engine, $pv->[0]));
 740                                 my @pretty_pv = prettyprint_pv($pos_calculating_second_engine, @$pv);
 741                                 if (scalar @pretty_pv > 5) {
 742                                         @pretty_pv = @pretty_pv[0..4];
 743                                         push @pretty_pv, "...";
 744                                 }
 745                                 my $key = $pretty_move;
 746                                 my $line = sprintf("  %-6s %6s %3s  %s",
 747                                         $pretty_move,
 748                                         short_score($info, $pos_calculating_second_engine, $mpv),
 749                                         "d" . $info->{'depth' . $mpv},
 750                                         join(', ', @pretty_pv));
 751                                 push @refutation_lines, [ $key, $line ];
 752                         };
 753                 }
 754         }
 755
 756         if ($#refutation_lines >= 0) {
 757                 $text .= "Shallow search of all legal moves:\n\n";
 758                 for my $line (sort { $a->[0] cmp $b->[0] } @refutation_lines) {
 759                         $text .= $line->[1] . "\n";
 760                 }
 761                 $text .= "\n\n";
 762         }
 763
 764         if ($last_text ne $text) {
 765                 print "\e[H\e[2J"; # clear the screen
 766                 print $text;
 767                 $last_text = $text;
 768         }
 769 }
 770
 771 sub output_json {
 772         my $historic_json_only = shift;
 773         my $info = $engine->{'info'};
 774
 775         my $json = {};
 776         $json->{'position'} = $pos_calculating->to_json_hash();
 777         $json->{'engine'} = $engine->{'id'};
 778         if (defined($remoteglotconf::engine_url)) {
 779                 $json->{'engine'}{'url'} = $remoteglotconf::engine_url;
 780         }
 781         if (defined($remoteglotconf::engine_details)) {
 782                 $json->{'engine'}{'details'} = $remoteglotconf::engine_details;
 783         }
 784         my @grpc_backends = ();
 785         if (defined($remoteglotconf::engine_grpc_backend)) {
 786                 push @grpc_backends, $remoteglotconf::engine_grpc_backend;
 787         }
 788         if (defined($remoteglotconf::engine2_grpc_backend)) {
 789                 push @grpc_backends, $remoteglotconf::engine2_grpc_backend;
 790         }
 791         $json->{'internal'}{'grpc_backends'} = \@grpc_backends;
 792         if (defined($remoteglotconf::move_source)) {
 793                 $json->{'move_source'} = $remoteglotconf::move_source;
 794         }
 795         if (defined($remoteglotconf::move_source_url)) {
 796                 $json->{'move_source_url'} = $remoteglotconf::move_source_url;
 797         }
 798         $json->{'score'} = score_digest($info, $pos_calculating, '');
 799
 800         $json->{'nodes'} = $info->{'nodes'};
 801         $json->{'nps'} = $info->{'nps'};
 802         $json->{'depth'} = $info->{'depth'};
 803         $json->{'tbhits'} = $info->{'tbhits'};
 804         $json->{'seldepth'} = $info->{'seldepth'};
 805         $json->{'tablebase'} = $info->{'tablebase'};
 806         $json->{'pv'} = [ prettyprint_pv($pos_calculating, @{$info->{'pv'}}) ];
 807
 808         my %refutation_lines = ();
 809         my @refutation_lines = ();
 810         if (defined($engine2)) {
 811                 for (my $mpv = 1; $mpv < 500; ++$mpv) {
 812                         my $info = $engine2->{'info'};
 813                         my $pretty_move = "";
 814                         my @pretty_pv = ();
 815                         last if (!exists($info->{'pv' . $mpv}));
 816
 817                         eval {
 818                                 complete_using_tbprobe($pos_calculating, $info, $mpv);
 819                                 my $pv = $info->{'pv' . $mpv};
 820                                 my $pretty_move = join('', prettyprint_pv($pos_calculating, $pv->[0]));
 821                                 my @pretty_pv = prettyprint_pv($pos_calculating, @$pv);
 822                                 $refutation_lines{$pretty_move} = {
 823                                         depth => $info->{'depth' . $mpv},
 824                                         score => score_digest($info, $pos_calculating, $mpv),
 825                                         move => $pretty_move,
 826                                         pv => \@pretty_pv,
 827                                 };
 828                                 if (exists($info->{'splicepos' . $mpv})) {
 829                                         $refutation_lines{$pretty_move}->{'splicepos'} = $info->{'splicepos' . $mpv};
 830                                 }
 831                         };
 832                 }
 833         }
 834         $json->{'refutation_lines'} = \%refutation_lines;
 835
 836         # Piece together historic score information, to the degree we have it.
 837         if (!$historic_json_only && exists($pos_calculating->{'history'})) {
 838                 my %score_history = ();
 839
 840                 local $dbh->{AutoCommit} = 0;
 841                 my $q = $dbh->prepare('SELECT * FROM scores WHERE id=?');
 842                 my $pos;
 843                 if (exists($pos_calculating->{'start_fen'})) {
 844                         $pos = Position->from_fen($pos_calculating->{'start_fen'});
 845                 } else {
 846                         $pos = Position->start_pos('white', 'black');
 847                 }
 848                 $pos->{'chess960'} = $pos_calculating->{'chess960'};
 849                 my $halfmove_num = 0;
 850                 for my $move (@{$pos_calculating->{'history'}}) {
 851                         my $id = id_for_pos($pos, $halfmove_num);
 852                         my $ref = $dbh->selectrow_hashref($q, undef, $id);
 853                         if (defined($ref)) {
 854                                 $score_history{$halfmove_num} = [
 855                                         $ref->{'score_type'},
 856                                         $ref->{'score_value'}
 857                                 ];
 858                         }
 859                         ++$halfmove_num;
 860                         ($pos) = $pos->make_pretty_move($move);
 861                 }
 862                 $q->finish;
 863                 $dbh->commit;
 864
 865                 # If at any point we are missing 10 consecutive moves,
 866                 # truncate the history there. This is so we don't get into
 867                 # a situation where we e.g. start analyzing at move 45,
 868                 # but we have analysis for 1. e4 from some completely different game
 869                 # and thus show a huge hole.
 870                 my $consecutive_missing = 0;
 871                 my $truncate_until = 0;
 872                 for (my $i = $halfmove_num; $i --> 0; ) {
 873                         if ($consecutive_missing >= 10) {
 874                                 delete $score_history{$i};
 875                                 next;
 876                         }
 877                         if (exists($score_history{$i})) {
 878                                 $consecutive_missing = 0;
 879                         } else {
 880                                 ++$consecutive_missing;
 881                         }
 882                 }
 883
 884                 $json->{'score_history'} = \%score_history;
 885         }
 886
 887         # Give out a list of other games going on. (Empty is fine.)
 888         # TODO: Don't bother reading our own file, the data will be stale anyway.
 889         if (!$historic_json_only) {
 890                 my @games = ();
 891
 892                 my $q = $dbh->prepare('SELECT * FROM current_games ORDER BY priority DESC, id');
 893                 $q->execute;
 894                 while (my $ref = $q->fetchrow_hashref) {
 895                         eval {
 896                                 my $other_game_contents = File::Slurp::read_file($ref->{'json_path'});
 897                                 my $other_game_json = JSON::XS::decode_json($other_game_contents);
 898
 899                                 die "Missing position" if (!exists($other_game_json->{'position'}));
 900                                 my $white = $other_game_json->{'position'}{'player_w'} // die 'Missing white';
 901                                 my $black = $other_game_json->{'position'}{'player_b'} // die 'Missing black';
 902
 903                                 my $game = {
 904                                         id => $ref->{'id'},
 905                                         name => "$white–$black",
 906                                         url => $ref->{'url'},
 907                                         hashurl => $ref->{'hash_url'},
 908                                 };
 909                                 if (defined($other_game_json->{'position'}{'result'})) {
 910                                         $game->{'result'} = $other_game_json->{'position'}{'result'};
 911                                 } else {
 912                                         $game->{'score'} = $other_game_json->{'score'};
 913                                 }
 914                                 push @games, $game;
 915                         };
 916                         if ($@) {
 917                                 warn "Could not add external game " . $ref->{'json_path'} . ": $@";
 918                         }
 919                 }
 920
 921                 if (scalar @games > 0) {
 922                         $json->{'games'} = \@games;
 923                 }
 924         }
 925
 926         my $json_enc = JSON::XS->new;
 927         $json_enc->canonical(1);
 928         my $encoded = $json_enc->encode($json);
 929         unless ($historic_json_only || !defined($remoteglotconf::json_output) ||
 930                 (defined($last_written_json) && $last_written_json eq $encoded)) {
 931                 atomic_set_contents($remoteglotconf::json_output, $encoded);
 932                 $last_written_json = $encoded;
 933         }
 934
 935         if (exists($pos_calculating->{'history'}) &&
 936             defined($remoteglotconf::json_history_dir) && defined($json->{'engine'}{name})) {
 937                 my $id = id_for_pos($pos_calculating);
 938                 my $filename = $remoteglotconf::json_history_dir . "/" . $id . ".json";
 939
 940                 # Overwrite old analysis (assuming it exists at all) if we're
 941                 # using a different engine, or if we've calculated deeper.
 942                 # nodes is used as a tiebreaker. Don't bother about Multi-PV
 943                 # data; it's not that important.
 944                 my ($old_engine, $old_depth, $old_nodes) = get_json_analysis_stats($id);
 945                 my $new_depth = $json->{'depth'} // 0;
 946                 my $new_nodes = $json->{'nodes'} // 0;
 947                 if (!defined($old_engine) ||
 948                     $old_engine ne $json->{'engine'}{'name'} ||
 949                     $new_depth > $old_depth ||
 950                     ($new_depth == $old_depth && $new_nodes >= $old_nodes)) {
 951                         atomic_set_contents($filename, $encoded);
 952                         if (defined($json->{'score'})) {
 953                                 $dbh->do('INSERT INTO scores (id, score_type, score_value, engine, depth, nodes) VALUES (?,?,?,?,?,?) ' .
 954                                          '    ON CONFLICT (id) DO UPDATE SET ' .
 955                                          '        score_type=EXCLUDED.score_type, ' .
 956                                          '        score_value=EXCLUDED.score_value, ' .
 957                                          '        engine=EXCLUDED.engine, ' .
 958                                          '        depth=EXCLUDED.depth, ' .
 959                                          '        nodes=EXCLUDED.nodes',
 960                                         undef,
 961                                         $id, $json->{'score'}[0], $json->{'score'}[1],
 962                                         $json->{'engine'}{'name'}, $new_depth, $new_nodes);
 963                         }
 964                 }
 965         }
 966 }
 967
 968 sub atomic_set_contents {
 969         my ($filename, $contents) = @_;
 970
 971         open my $fh, ">", $filename . ".tmp"
 972                 or return;
 973         print $fh $contents;
 974         close $fh;
 975         rename($filename . ".tmp", $filename);
 976 }
 977
 978 sub id_for_pos {
 979         my ($pos, $halfmove_num) = @_;
 980
 981         $halfmove_num //= scalar @{$pos->{'history'}};
 982         (my $fen = $pos->fen()) =~ tr,/ ,-_,;
 983         return "move$halfmove_num-$fen";
 984 }
 985
 986 sub get_json_analysis_stats {
 987         my $id = shift;
 988         my $ref = $dbh->selectrow_hashref('SELECT * FROM scores WHERE id=?', undef, $id);
 989         if (defined($ref)) {
 990                 return ($ref->{'engine'}, $ref->{'depth'}, $ref->{'nodes'});
 991         } else {
 992                 return ('', 0, 0);
 993         }
 994 }
 995
 996 sub uciprint {
 997         my ($engine, $msg) = @_;
 998         $engine->print($msg);
 999         print UCILOG localtime() . " $engine->{'tag'} => $msg\n";
1000 }
1001
1002 sub short_score {
1003         my ($info, $pos, $mpv) = @_;
1004
1005         my $invert = ($pos->{'toplay'} eq 'B');
1006         if (defined($info->{'score_mate' . $mpv})) {
1007                 if ($invert) {
1008                         return sprintf "M%3d", -$info->{'score_mate' . $mpv};
1009                 } else {
1010                         return sprintf "M%3d", $info->{'score_mate' . $mpv};
1011                 }
1012         } else {
1013                 if (exists($info->{'score_cp' . $mpv})) {
1014                         my $score = $info->{'score_cp' . $mpv} * 0.01;
1015                         if ($score == 0) {
1016                                 if ($info->{'tablebase'}) {
1017                                         return "TB draw";
1018                                 } else {
1019                                         return " 0.00";
1020                                 }
1021                         }
1022                         if ($invert) {
1023                                 $score = -$score;
1024                         }
1025                         return sprintf "%+5.2f", $score;
1026                 }
1027         }
1028
1029         return undef;
1030 }
1031
1032 # Sufficient for computing long_score, short_score, plot_score and
1033 # (with side-to-play information) score_sort_key.
1034 sub score_digest {
1035         my ($info, $pos, $mpv) = @_;
1036
1037         if (defined($info->{'score_mate' . $mpv})) {
1038                 my $mate = $info->{'score_mate' . $mpv};
1039                 if ($pos->{'toplay'} eq 'B') {
1040                         $mate = -$mate;
1041                 }
1042                 if (exists($info->{'splicepos' . $mpv})) {
1043                         my $sp = $info->{'splicepos' . $mpv};
1044                         if ($mate > 0) {
1045                                 return ['T', $sp];
1046                         } else {
1047                                 return ['t', $sp];
1048                         }
1049                 } else {
1050                         if ($mate > 0) {
1051                                 return ['M', $mate];
1052                         } elsif ($mate < 0) {
1053                                 return ['m', -$mate];
1054                         } elsif ($pos->{'toplay'} eq 'B') {
1055                                 return ['M', 0];
1056                         } else {
1057                                 return ['m', 0];
1058                         }
1059                 }
1060         } else {
1061                 if (exists($info->{'score_cp' . $mpv})) {
1062                         my $score = $info->{'score_cp' . $mpv};
1063                         if ($pos->{'toplay'} eq 'B') {
1064                                 $score = -$score;
1065                         }
1066                         if ($score == 0 && $info->{'tablebase'}) {
1067                                 return ['d', undef];
1068                         } else {
1069                                 return ['cp', int($score)];
1070                         }
1071                 }
1072         }
1073
1074         return undef;
1075 }
1076
1077 sub long_score {
1078         my ($info, $pos, $mpv) = @_;
1079
1080         if (defined($info->{'score_mate' . $mpv})) {
1081                 my $mate = $info->{'score_mate' . $mpv};
1082                 if ($pos->{'toplay'} eq 'B') {
1083                         $mate = -$mate;
1084                 }
1085                 if (exists($info->{'splicepos' . $mpv})) {
1086                         my $sp = $info->{'splicepos' . $mpv};
1087                         if ($mate > 0) {
1088                                 return sprintf "White wins in %u", int(($sp + 1) * 0.5);
1089                         } else {
1090                                 return sprintf "Black wins in %u", int(($sp + 1) * 0.5);
1091                         }
1092                 } else {
1093                         if ($mate > 0) {
1094                                 return sprintf "White mates in %u", $mate;
1095                         } else {
1096                                 return sprintf "Black mates in %u", -$mate;
1097                         }
1098                 }
1099         } else {
1100                 if (exists($info->{'score_cp' . $mpv})) {
1101                         my $score = $info->{'score_cp' . $mpv} * 0.01;
1102                         if ($score == 0) {
1103                                 if ($info->{'tablebase'}) {
1104                                         return "Theoretical draw";
1105                                 } else {
1106                                         return "Score:  0.00";
1107                                 }
1108                         }
1109                         if ($pos->{'toplay'} eq 'B') {
1110                                 $score = -$score;
1111                         }
1112                         return sprintf "Score: %+5.2f", $score;
1113                 }
1114         }
1115
1116         return undef;
1117 }
1118
1119 # For graphs; a single number in centipawns, capped at +/- 500.
1120 sub plot_score {
1121         my ($info, $pos, $mpv) = @_;
1122
1123         my $invert = ($pos->{'toplay'} eq 'B');
1124         if (defined($info->{'score_mate' . $mpv})) {
1125                 my $mate = $info->{'score_mate' . $mpv};
1126                 if ($invert) {
1127                         $mate = -$mate;
1128                 }
1129                 if ($mate > 0) {
1130                         return 500;
1131                 } else {
1132                         return -500;
1133                 }
1134         } else {
1135                 if (exists($info->{'score_cp' . $mpv})) {
1136                         my $score = $info->{'score_cp' . $mpv};
1137                         if ($invert) {
1138                                 $score = -$score;
1139                         }
1140                         $score = 500 if ($score > 500);
1141                         $score = -500 if ($score < -500);
1142                         return int($score);
1143                 }
1144         }
1145
1146         return undef;
1147 }
1148
1149 sub extend_from_manual_override {
1150         my ($pos, $moves, $extra_moves) = @_;
1151
1152         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\'');
1153         while (1) {
1154                 my $player_w = $pos->{'player_w'};
1155                 my $player_b = $pos->{'player_b'};
1156                 if ($player_w =~ /^base64:(.*)$/) {
1157                         $player_w = MIME::Base64::decode_base64($1);
1158                 }
1159                 if ($player_b =~ /^base64:(.*)$/) {
1160                         $player_b = MIME::Base64::decode_base64($1);
1161                 }
1162                 #use Data::Dumper; print Dumper([$pos->fen(), JSON::XS::encode_json($moves), $player_w, $player_b]);
1163                 $q->execute($pos->fen(), JSON::XS::encode_json($moves), $player_w, $player_b);
1164                 my $ref = $q->fetchrow_hashref;
1165                 if (defined($ref)) {
1166                         my $move = $ref->{'next_move'};
1167                         ($pos) = $pos->make_pretty_move($move);
1168                         push @$moves, $move;
1169                         push @$extra_moves, $move;
1170                 } else {
1171                         last;
1172                 }
1173         }
1174         return $pos;
1175 }
1176
1177 sub extract_clock {
1178         my ($pgn, $pos) = @_;
1179
1180         # Look for extended PGN clock tags.
1181         my $tags = $pgn->tags;
1182         if (exists($tags->{'WhiteClock'}) && exists($tags->{'BlackClock'})) {
1183                 $pos->{'white_clock'} = hms_to_sec($tags->{'WhiteClock'});
1184                 $pos->{'black_clock'} = hms_to_sec($tags->{'BlackClock'});
1185                 return;
1186         }
1187
1188         # Look for TCEC-style time comments.
1189         my $moves = $pgn->moves;
1190         my $comments = $pgn->comments;
1191         my $last_black_move = int((scalar @$moves) / 2);
1192         my $last_white_move = int((1 + scalar @$moves) / 2);
1193
1194         my $black_key = $last_black_move . "b";
1195         my $white_key = $last_white_move . "w";
1196
1197         if (exists($comments->{$white_key}) &&
1198             exists($comments->{$black_key}) &&
1199             $comments->{$white_key} =~ /(?:tl=|clk )(\d+:\d+:\d+)/ &&
1200             $comments->{$black_key} =~ /(?:tl=|clk )(\d+:\d+:\d+)/) {
1201                 $comments->{$white_key} =~ /(?:tl=|clk )(\d+:\d+:\d+)/;
1202                 $pos->{'white_clock'} = hms_to_sec($1);
1203                 $comments->{$black_key} =~ /(?:tl=|clk )(\d+:\d+:\d+)/;
1204                 $pos->{'black_clock'} = hms_to_sec($1);
1205                 return;
1206         }
1207
1208         delete $pos->{'white_clock'};
1209         delete $pos->{'black_clock'};
1210 }
1211
1212 sub hms_to_sec {
1213         my $hms = shift;
1214         return undef if (!defined($hms));
1215         $hms =~ /(\d+):(\d+):(\d+)/;
1216         return $1 * 3600 + $2 * 60 + $3;
1217 }
1218
1219 sub find_clock_start {
1220         my ($pos, $prev_pos) = @_;
1221
1222         # If the game is over, the clock is stopped.
1223         if (exists($pos->{'result'}) &&
1224             ($pos->{'result'} eq '1-0' ||
1225              $pos->{'result'} eq '1/2-1/2' ||
1226              $pos->{'result'} eq '0-1')) {
1227                 return;
1228         }
1229
1230         # When we don't have any moves, we assume the clock hasn't started yet.
1231         if ($pos->{'move_num'} == 1 && $pos->{'toplay'} eq 'W') {
1232                 if (defined($remoteglotconf::adjust_clocks_before_move)) {
1233                         &$remoteglotconf::adjust_clocks_before_move(\$pos->{'white_clock'}, \$pos->{'black_clock'}, 1, 'W');
1234                 }
1235                 return;
1236         }
1237
1238         # The history is needed for id_for_pos.
1239         if (!exists($pos->{'history'})) {
1240                 return;
1241         }
1242
1243         my $id = id_for_pos($pos);
1244         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);
1245         if (defined($clock_info)) {
1246                 $pos->{'white_clock'} //= $clock_info->{'white_clock'};
1247                 $pos->{'black_clock'} //= $clock_info->{'black_clock'};
1248                 if ($pos->{'toplay'} eq 'W') {
1249                         $pos->{'white_clock_target'} = $clock_info->{'white_clock_target'};
1250                 } else {
1251                         $pos->{'black_clock_target'} = $clock_info->{'black_clock_target'};
1252                 }
1253                 return;
1254         }
1255
1256         # OK, we haven't seen this position before, so we assume the move
1257         # happened right now.
1258
1259         # See if we should do our own clock management (ie., clock information
1260         # is spurious or non-existent).
1261         if (defined($remoteglotconf::adjust_clocks_before_move)) {
1262                 my $wc = $pos->{'white_clock'} // $prev_pos->{'white_clock'};
1263                 my $bc = $pos->{'black_clock'} // $prev_pos->{'black_clock'};
1264                 if (defined($prev_pos->{'white_clock_target'})) {
1265                         $wc = $prev_pos->{'white_clock_target'} - time;
1266                 }
1267                 if (defined($prev_pos->{'black_clock_target'})) {
1268                         $bc = $prev_pos->{'black_clock_target'} - time;
1269                 }
1270                 &$remoteglotconf::adjust_clocks_before_move(\$wc, \$bc, $pos->{'move_num'}, $pos->{'toplay'});
1271                 $pos->{'white_clock'} = $wc;
1272                 $pos->{'black_clock'} = $bc;
1273         }
1274
1275         my $key = ($pos->{'toplay'} eq 'W') ? 'white_clock' : 'black_clock';
1276         if (!exists($pos->{$key})) {
1277                 # No clock information.
1278                 return;
1279         }
1280         my $time_left = $pos->{$key};
1281         my ($white_clock_target, $black_clock_target);
1282         if ($pos->{'toplay'} eq 'W') {
1283                 $white_clock_target = $pos->{'white_clock_target'} = time + $time_left;
1284         } else {
1285                 $black_clock_target = $pos->{'black_clock_target'} = time + $time_left;
1286         }
1287         local $dbh->{AutoCommit} = 0;
1288         $dbh->do('DELETE FROM clock_info WHERE id=?', undef, $id);
1289         $dbh->do('INSERT INTO clock_info (id, white_clock, black_clock, white_clock_target, black_clock_target) VALUES (?, ?, ?, ?, ?)', undef,
1290                 $id, $pos->{'white_clock'}, $pos->{'black_clock'}, $white_clock_target, $black_clock_target);
1291         $dbh->commit;
1292 }
1293
1294 sub open_engine {
1295         my ($cmdline, $tag, $cb) = @_;
1296         return undef if (!defined($cmdline));
1297         return Engine->open($cmdline, $tag, $cb);
1298 }
1299
1300 sub col_letter_to_num {
1301         return ord(shift) - ord('a');
1302 }
1303
1304 sub row_letter_to_num {
1305         return 7 - (ord(shift) - ord('1'));
1306 }
1307
1308 sub parse_uci_move {
1309         my $move = shift;
1310         my $from_col = col_letter_to_num(substr($move, 0, 1));
1311         my $from_row = row_letter_to_num(substr($move, 1, 1));
1312         my $to_col   = col_letter_to_num(substr($move, 2, 1));
1313         my $to_row   = row_letter_to_num(substr($move, 3, 1));
1314         my $promo    = substr($move, 4, 1);
1315         return ($from_row, $from_col, $to_row, $to_col, $promo);
1316 }
1317
1318 sub setoptions {
1319         my ($engine, $config) = @_;
1320         uciprint($engine, "setoption name UCI_AnalyseMode value true");
1321         uciprint($engine, "setoption name Analysis Contempt value Off");
1322         if (exists($config->{'Threads'})) {  # Threads first, because clearing hash can be multithreaded then.
1323                 uciprint($engine, "setoption name Threads value " . $config->{'Threads'});
1324         }
1325         while (my ($key, $value) = each %$config) {
1326                 next if $key eq 'Threads';
1327                 uciprint($engine, "setoption name $key value $value");
1328         }
1329 }