X-Git-Url: https://git.sesse.net/?p=remoteglot;a=blobdiff_plain;f=remoteglot.pl;h=7f1a6687e72aa597827212a95a673b429e1b2bd2;hp=bb16ebcbd9931d23cc360dfac948b9faeed59c17;hb=7314c1611dbab18a6ebdd5934697dd5cf94ed437;hpb=a5d359eaff725889fd3554a7c3b7ac5088eb7c63 diff --git a/remoteglot.pl b/remoteglot.pl index bb16ebc..7f1a668 100755 --- a/remoteglot.pl +++ b/remoteglot.pl @@ -9,10 +9,18 @@ # Licensed under the GNU General Public License, version 2. # +use AnyEvent; +use AnyEvent::Handle; +use AnyEvent::HTTP; +use Chess::PGN::Parse; +use EV; use Net::Telnet; use FileHandle; use IPC::Open2; use Time::HiRes; +use JSON::XS; +require 'Position.pm'; +require 'Engine.pm'; use strict; use warnings; @@ -20,12 +28,9 @@ use warnings; my $server = "freechess.org"; my $target = "GMCarlsen"; my $engine_cmdline = "'./Deep Rybka 4 SSE42 x64'"; -my $engine2_cmdline = "./stockfish_13111119_x64_modern_sse42"; -my $telltarget = undef; # undef to be silent -my @tell_intervals = (5, 20, 60, 120, 240, 480, 960); # after each move +my $engine2_cmdline = "./stockfish_13111119_x64_modern_sse42"; # undef for none my $uci_assume_full_compliance = 0; # dangerous :-) -my $update_max_interval = 2.0; -my $second_engine_start_depth = 8; +my $update_max_interval = 1.0; my @masters = ( 'Sesse', 'Sessse', @@ -35,8 +40,9 @@ my @masters = ( ); # Program starts here -$SIG{ALRM} = sub { output_screen(); }; +$SIG{ALRM} = sub { output(); }; my $latest_update = undef; +my $http_timer = undef; $| = 1; @@ -54,13 +60,11 @@ $| = 1; select(STDOUT); # open the chess engine -my $engine = open_engine($engine_cmdline, 'E1'); -my $engine2 = open_engine($engine2_cmdline, 'E2'); -my ($last_move, $last_tell); +my $engine = open_engine($engine_cmdline, 'E1', sub { handle_uci(@_, 1); }); +my $engine2 = open_engine($engine2_cmdline, 'E2', sub { handle_uci(@_, 0); }); +my $last_move; my $last_text = ''; -my $last_told_text = ''; -my ($pos_waiting, $pos_calculating, $move_calculating_second_engine); -my %refutation_moves = (); +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"); @@ -69,13 +73,15 @@ uciprint($engine, "setoption name Hash value 1024"); # uciprint($engine, "setoption name MultiPV value 2"); uciprint($engine, "ucinewgame"); -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"); -# uciprint($engine2, "setoption name MultiPV value 2"); -uciprint($engine2, "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"); + uciprint($engine2, "setoption name MultiPV value 500"); + uciprint($engine2, "ucinewgame"); +} print "Chess engine ready.\n"; @@ -92,128 +98,28 @@ $t->cmd("set shout 0"); $t->cmd("set seek 0"); $t->cmd("set style 12"); $t->cmd("observe $target"); - -# main loop print "FICS ready.\n"; -while (1) { - my $rin = ''; - my $rout; - vec($rin, fileno($engine->{'read'}), 1) = 1; - vec($rin, fileno($engine2->{'read'}), 1) = 1; - vec($rin, fileno($t), 1) = 1; - - my ($nfound, $timeleft) = select($rout=$rin, undef, undef, 5.0); - my $sleep = 1.0; - - while (1) { - my $line = $t->getline(Timeout => 0, errmode => 'return'); - last if (!defined($line)); - - chomp $line; - $line =~ tr/\r//d; - if ($line =~ /^<12> /) { - my $pos = style12_to_pos($line); - - # if this is already in the queue, ignore it - next if (defined($pos_waiting) && $pos->{'fen'} eq $pos_waiting->{'fen'}); - - # if we're already chewing on this and there's nothing else in the queue, - # also ignore it - next if (!defined($pos_waiting) && defined($pos_calculating) && - $pos->{'fen'} eq $pos_calculating->{'fen'}); - - # if we're already thinking on something, stop and wait for the engine - # to approve - if (defined($pos_calculating)) { - if (!defined($pos_waiting)) { - uciprint($engine, "stop"); - } - if ($uci_assume_full_compliance) { - $pos_waiting = $pos; - } else { - uciprint($engine, "position fen " . $pos->{'fen'}); - uciprint($engine, "go infinite"); - $pos_calculating = $pos; - } - } else { - # it's wrong just to give the FEN (the move history is useful, - # and per the UCI spec, we should really have sent "ucinewgame"), - # but it's easier - uciprint($engine, "position fen " . $pos->{'fen'}); - uciprint($engine, "go infinite"); - $pos_calculating = $pos; - } - - %refutation_moves = calculate_refutation_moves($pos); - if (defined($move_calculating_second_engine)) { - uciprint($engine2, "stop"); - $move_calculating_second_engine = undef; - } else { - give_new_move_to_second_engine($pos); - } - $engine->{'info'} = {}; - $engine2->{'info'} = {}; - $last_move = time; - - # - # Output a command every move to note that we're - # still paying attention -- this is a good tradeoff, - # since if no move has happened in the last half - # hour, the analysis/relay has most likely stopped - # and we should stop hogging server resources. - # - $t->cmd("date"); - } - if ($line =~ /^([A-Za-z]+)(?:\([A-Z]+\))* tells you: (.*)$/) { - my ($who, $msg) = ($1, $2); - - next if (grep { $_ eq $who } (@masters) == 0); - - if ($msg =~ /^fics (.*?)$/) { - $t->cmd("tell $who Executing '$1' on FICS."); - $t->cmd($1); - } elsif ($msg =~ /^uci (.*?)$/) { - $t->cmd("tell $who Sending '$1' to the engine."); - print { $engine->{'write'} } "$1\n"; - } else { - $t->cmd("tell $who Couldn't understand '$msg', sorry."); - } - } - #print "FICS: [$line]\n"; - $sleep = 0; - } - - # any fun on the UCI channel? - if ($nfound > 0 && vec($rout, fileno($engine->{'read'}), 1) == 1) { - my @lines = read_lines($engine); - for my $line (@lines) { - next if $line =~ /(upper|lower)bound/; - handle_uci($engine, $line, 1); - } - $sleep = 0; +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)); - output_screen(); - } - if ($nfound > 0 && vec($rout, fileno($engine2->{'read'}), 1) == 1) { - my @lines = read_lines($engine2); - for my $line (@lines) { - next if $line =~ /(upper|lower)bound/; - handle_uci($engine2, $line, 0); + chomp $line; + $line =~ tr/\r//d; + handle_fics($line); } - $sleep = 0; - - output_screen(); } - - sleep $sleep; -} +); +# Engine events have already been set up by Engine.pm. +EV::run; sub handle_uci { my ($engine, $line, $primary) = @_; - chomp $line; - $line =~ tr/\r//d; $line =~ s/ / /g; # Sometimes needed for Zappa Mexico print UCILOG localtime() . " $engine->{'tag'} <= $line\n"; if ($line =~ /^info/) { @@ -232,23 +138,136 @@ sub handle_uci { if ($primary) { return if (!$uci_assume_full_compliance); if (defined($pos_waiting)) { - uciprint($engine, "position fen " . $pos_waiting->{'fen'}); + uciprint($engine, "position fen " . $pos_waiting->fen()); uciprint($engine, "go infinite"); $pos_calculating = $pos_waiting; $pos_waiting = undef; } } else { - if (defined($move_calculating_second_engine)) { - my $move = $refutation_moves{$move_calculating_second_engine}; - $move->{'pv'} = $engine->{'info'}{'pv'} // $engine->{'info'}{'pv1'}; - $move->{'score_cp'} = $engine->{'info'}{'score_cp'} // $engine->{'info'}{'score_cp1'} // 0; - $move->{'score_mate'} = $engine->{'info'}{'score_mate'} // $engine->{'info'}{'score_mate1'}; - $move->{'toplay'} = $pos_calculating->{'toplay'}; - } - give_new_move_to_second_engine($pos_waiting // $pos_calculating); + $engine2->{'info'} = {}; + my $pos = $pos_waiting // $pos_calculating; + uciprint($engine2, "position fen " . $pos->fen()); + uciprint($engine2, "go infinite"); + $pos_calculating_second_engine = $pos; + } + } + output(); +} + +sub handle_fics { + my $line = shift; + if ($line =~ /^<12> /) { + handle_position(Position->new($line)); + } + if ($line =~ /^([A-Za-z]+)(?:\([A-Z]+\))* tells you: (.*)$/) { + my ($who, $msg) = ($1, $2); + + next if (grep { $_ eq $who } (@masters) == 0); + + if ($msg =~ /^fics (.*?)$/) { + $t->cmd("tell $who Executing '$1' on FICS."); + $t->cmd($1); + } elsif ($msg =~ /^uci (.*?)$/) { + $t->cmd("tell $who Sending '$1' to the engine."); + print { $engine->{'write'} } "$1\n"; + } elsif ($msg =~ /^pgn (.*?)$/) { + my $url = $1; + $t->cmd("tell $who Starting to poll '$url'."); + AnyEvent::HTTP::http_get($url, sub { + handle_pgn(@_, $url); + }); + } elsif ($msg =~ /^stoppgn$/) { + $t->cmd("tell $who Stopping poll."); + $http_timer = undef; + } elsif ($msg =~ /^quit$/) { + $t->cmd("tell $who Bye bye."); + exit; + } else { + $t->cmd("tell $who Couldn't understand '$msg', sorry."); + } + } + #print "FICS: [$line]\n"; +} + +sub handle_pgn { + my ($body, $header, $url) = @_; + my $pgn = Chess::PGN::Parse->new(undef, $body); + if (!defined($pgn) || !$pgn->read_game()) { + 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; + 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); + } + handle_position($pos); + } + + $http_timer = AnyEvent->timer(after => 1.0, cb => sub { + AnyEvent::HTTP::http_get($url, sub { + handle_pgn(@_, $url); + }); + }); +} + +sub handle_position { + my ($pos) = @_; + + # if this is already in the queue, ignore it + return if (defined($pos_waiting) && $pos->fen() eq $pos_waiting->fen()); + + # 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 we're already thinking on something, stop and wait for the engine + # to approve + if (defined($pos_calculating)) { + if (!defined($pos_waiting)) { + uciprint($engine, "stop"); + } + if ($uci_assume_full_compliance) { + $pos_waiting = $pos; + } else { + uciprint($engine, "position fen " . $pos->fen()); + uciprint($engine, "go infinite"); + $pos_calculating = $pos; } + } else { + # it's wrong just to give the FEN (the move history is useful, + # and per the UCI spec, we should really have sent "ucinewgame"), + # but it's easier + uciprint($engine, "position fen " . $pos->fen()); + uciprint($engine, "go infinite"); + $pos_calculating = $pos; } + + if (defined($engine2)) { + if (defined($pos_calculating_second_engine)) { + uciprint($engine2, "stop"); + } else { + uciprint($engine2, "position fen " . $pos->fen()); + uciprint($engine2, "go infinite"); + $pos_calculating_second_engine = $pos; + } + $engine2->{'info'} = {}; + } + + $engine->{'info'} = {}; + $last_move = time; + + # + # Output a command every move to note that we're + # still paying attention -- this is a good tradeoff, + # since if no move has happened in the last half + # hour, the analysis/relay has most likely stopped + # and we should stop hogging server resources. + # + $t->cmd("date"); } sub parse_infos { @@ -257,19 +276,30 @@ sub parse_infos { my $info = $engine->{'info'}; + # Search for "multipv" first of all, since e.g. Stockfish doesn't put it first. + for my $i (0..$#x - 1) { + 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; - $mpv = 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; @@ -281,7 +311,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' || $x[0] eq 'lowerbound' || $x[0] eq 'upperbound') { if ($x[0] eq 'cp') { shift @x; $info->{'score_cp' . $mpv} = shift @x; @@ -325,185 +355,7 @@ sub parse_ids { } } -sub style12_to_pos { - my $str = shift; - my %pos = (); - my (@x) = split / /, $str; - - $pos{'board'} = [ @x[1..8] ]; - $pos{'toplay'} = $x[9]; - $pos{'ep_file_num'} = $x[10]; - $pos{'white_castle_k'} = $x[11]; - $pos{'white_castle_q'} = $x[12]; - $pos{'black_castle_k'} = $x[13]; - $pos{'black_castle_q'} = $x[14]; - $pos{'time_to_100move_rule'} = $x[15]; - $pos{'move_num'} = $x[26]; - $pos{'last_move'} = $x[29]; - $pos{'fen'} = make_fen(\%pos); - - return \%pos; -} - -sub make_fen { - my $pos = shift; - - # the board itself - my (@board) = @{$pos->{'board'}}; - for my $rank (0..7) { - $board[$rank] =~ s/(-+)/length($1)/ge; - } - my $fen = join('/', @board); - - # white/black to move - $fen .= " "; - $fen .= lc($pos->{'toplay'}); - - # castling - my $castling = ""; - $castling .= "K" if ($pos->{'white_castle_k'} == 1); - $castling .= "Q" if ($pos->{'white_castle_q'} == 1); - $castling .= "k" if ($pos->{'black_castle_k'} == 1); - $castling .= "q" if ($pos->{'black_castle_q'} == 1); - $castling = "-" if ($castling eq ""); - # $castling = "-"; # chess960 - $fen .= " "; - $fen .= $castling; - - # en passant - my $ep = "-"; - if ($pos->{'ep_file_num'} != -1) { - my $col = $pos->{'ep_file_num'}; - my $nep = (qw(a b c d e f g h))[$col]; - - if ($pos->{'toplay'} eq 'B') { - $nep .= "3"; - } else { - $nep .= "6"; - } - - # - # Showing the en passant square when actually no capture can be made - # seems to confuse at least Rybka. Thus, check if there's actually - # a pawn of the opposite side that can do the en passant move, and if - # not, just lie -- it doesn't matter anyway. I'm unsure what's the - # "right" thing as per the standard, though. - # - if ($pos->{'toplay'} eq 'B') { - $ep = $nep if ($col > 0 && substr($pos->{'board'}[4], $col-1, 1) eq 'p'); - $ep = $nep if ($col < 7 && substr($pos->{'board'}[4], $col+1, 1) eq 'p'); - } else { - $ep = $nep if ($col > 0 && substr($pos->{'board'}[3], $col-1, 1) eq 'P'); - $ep = $nep if ($col < 7 && substr($pos->{'board'}[3], $col+1, 1) eq 'P'); - } - } - $fen .= " "; - $fen .= $ep; - - # half-move clock - $fen .= " "; - $fen .= $pos->{'time_to_100move_rule'}; - - # full-move clock - $fen .= " "; - $fen .= $pos->{'move_num'}; - - return $fen; -} - -sub make_move { - my ($board, $from_row, $from_col, $to_row, $to_col, $promo) = @_; - my $move = move_to_uci_notation($from_row, $from_col, $to_row, $to_col, $promo); - my $piece = substr($board->[$from_row], $from_col, 1); - my @nb = @$board; - - if ($piece eq '-') { - die "Invalid move $move"; - } - - # white short castling - if ($move eq 'e1g1' && $piece eq 'K') { - # king - substr($nb[7], 4, 1, '-'); - substr($nb[7], 6, 1, $piece); - - # rook - substr($nb[7], 7, 1, '-'); - substr($nb[7], 5, 1, 'R'); - - return \@nb; - } - - # white long castling - if ($move eq 'e1c1' && $piece eq 'K') { - # king - substr($nb[7], 4, 1, '-'); - substr($nb[7], 2, 1, $piece); - - # rook - substr($nb[7], 0, 1, '-'); - substr($nb[7], 3, 1, 'R'); - - return \@nb; - } - - # black short castling - if ($move eq 'e8g8' && $piece eq 'k') { - # king - substr($nb[0], 4, 1, '-'); - substr($nb[0], 6, 1, $piece); - - # rook - substr($nb[0], 7, 1, '-'); - substr($nb[0], 5, 1, 'r'); - - return \@nb; - } - - # black long castling - if ($move eq 'e8c8' && $piece eq 'k') { - # king - substr($nb[0], 4, 1, '-'); - substr($nb[0], 2, 1, $piece); - - # rook - substr($nb[0], 0, 1, '-'); - substr($nb[0], 3, 1, 'r'); - - return \@nb; - } - - # check if the from-piece is a pawn - if (lc($piece) eq 'p') { - # attack? - if ($from_col != $to_col) { - # en passant? - if (substr($board->[$to_row], $to_col, 1) eq '-') { - if ($piece eq 'p') { - substr($nb[$to_row + 1], $to_col, 1, '-'); - } else { - substr($nb[$to_row - 1], $to_col, 1, '-'); - } - } - } else { - if ($promo ne '') { - if ($piece eq 'p') { - $piece = $promo; - } else { - $piece = uc($promo); - } - } - } - } - - # update the board - substr($nb[$from_row], $from_col, 1, '-'); - substr($nb[$to_row], $to_col, 1, $piece); - - return \@nb; -} - -sub prettyprint_pv { +sub prettyprint_pv_no_cache { my ($board, @pvs) = @_; if (scalar @pvs == 0 || !defined($pvs[0])) { @@ -511,115 +363,25 @@ sub prettyprint_pv { } my $pv = shift @pvs; - my $from_col = col_letter_to_num(substr($pv, 0, 1)); - my $from_row = row_letter_to_num(substr($pv, 1, 1)); - my $to_col = col_letter_to_num(substr($pv, 2, 1)); - my $to_row = row_letter_to_num(substr($pv, 3, 1)); - my $promo = substr($pv, 4, 1); - - my $nb = make_move($board, $from_row, $from_col, $to_row, $to_col, $promo); - my $piece = substr($board->[$from_row], $from_col, 1); - - if ($piece eq '-') { - die "Invalid move $pv"; - } - - # white short castling - if ($pv eq 'e1g1' && $piece eq 'K') { - return ('0-0', prettyprint_pv($nb, @pvs)); - } - - # white long castling - if ($pv eq 'e1c1' && $piece eq 'K') { - return ('0-0-0', prettyprint_pv($nb, @pvs)); - } - - # black short castling - if ($pv eq 'e8g8' && $piece eq 'k') { - return ('0-0', prettyprint_pv($nb, @pvs)); - } - - # black long castling - if ($pv eq 'e8c8' && $piece eq 'k') { - return ('0-0-0', prettyprint_pv($nb, @pvs)); - } - - my $pretty; - - # check if the from-piece is a pawn - if (lc($piece) eq 'p') { - # attack? - if ($from_col != $to_col) { - $pretty = substr($pv, 0, 1) . 'x' . substr($pv, 2, 2); - } else { - $pretty = substr($pv, 2, 2); + my ($from_col, $from_row, $to_col, $to_row, $promo) = parse_uci_move($pv); + my ($pretty, $nb) = $board->prettyprint_move($from_row, $from_col, $to_row, $to_col, $promo); + return ( $pretty, prettyprint_pv_no_cache($nb, @pvs) ); +} - if (length($pv) == 5) { - # promotion - $pretty .= "="; - $pretty .= uc(substr($pv, 4, 1)); +sub prettyprint_pv { + my ($pos, @pvs) = @_; - if ($piece eq 'p') { - $piece = substr($pv, 4, 1); - } else { - $piece = uc(substr($pv, 4, 1)); - } - } - } + my $cachekey = join('', @pvs); + if (exists($pos->{'prettyprint_cache'}{$cachekey})) { + return @{$pos->{'prettyprint_cache'}{$cachekey}}; } else { - $pretty = uc($piece); - - # see how many of these pieces could go here, in all - my $num_total = 0; - for my $col (0..7) { - for my $row (0..7) { - next unless (substr($board->[$row], $col, 1) eq $piece); - ++$num_total if (can_reach($board, $piece, $row, $col, $to_row, $to_col)); - } - } - - # see how many of these pieces from the given row could go here - my $num_row = 0; - for my $col (0..7) { - next unless (substr($board->[$from_row], $col, 1) eq $piece); - ++$num_row if (can_reach($board, $piece, $from_row, $col, $to_row, $to_col)); - } - - # and same for columns - my $num_col = 0; - for my $row (0..7) { - next unless (substr($board->[$row], $from_col, 1) eq $piece); - ++$num_col if (can_reach($board, $piece, $row, $from_col, $to_row, $to_col)); - } - - # see if we need to disambiguate - if ($num_total > 1) { - if ($num_col == 1) { - $pretty .= substr($pv, 0, 1); - } elsif ($num_row == 1) { - $pretty .= substr($pv, 1, 1); - } else { - $pretty .= substr($pv, 0, 2); - } - } - - # attack? - if (substr($board->[$to_row], $to_col, 1) ne '-') { - $pretty .= 'x'; - } - - $pretty .= substr($pv, 2, 2); - } - - if (in_mate($nb)) { - $pretty .= '#'; - } elsif (in_check($nb) ne 'none') { - $pretty .= '+'; + my @res = prettyprint_pv_no_cache($pos->{'board'}, @pvs); + $pos->{'prettyprint_cache'}{$cachekey} = \@res; + return @res; } - return ($pretty, prettyprint_pv($nb, @pvs)); } -sub output_screen { +sub output { #return; return if (!defined($pos_calculating)); @@ -630,11 +392,22 @@ sub output_screen { Time::HiRes::alarm($update_max_interval + 0.01 - $age); return; } - $latest_update = [Time::HiRes::gettimeofday]; - + my $info = $engine->{'info'}; - my $id = $engine->{'id'}; - + + # + # Some programs _always_ report MultiPV, even with only one PV. + # In this case, we simply use that data as if MultiPV was never + # specified. + # + if (exists($info->{'pv1'}) && !exists($info->{'pv2'})) { + for my $key (qw(pv score_cp score_mate nodes nps depth seldepth tbhits)) { + if (exists($info->{$key . '1'})) { + $info->{$key} = $info->{$key . '1'}; + } + } + } + # # Check the PVs first. if they're invalid, just wait, as our data # is most likely out of sync. This isn't a very good solution, as @@ -643,12 +416,12 @@ sub output_screen { eval { my $dummy; if (exists($info->{'pv'})) { - $dummy = prettyprint_pv($pos_calculating->{'board'}, @{$info->{'pv'}}); + $dummy = prettyprint_pv($pos_calculating, @{$info->{'pv'}}); } my $mpv = 1; while (exists($info->{'pv' . $mpv})) { - $dummy = prettyprint_pv($pos_calculating->{'board'}, @{$info->{'pv' . $mpv}}); + $dummy = prettyprint_pv($pos_calculating, @{$info->{'pv' . $mpv}}); ++$mpv; } }; @@ -657,6 +430,15 @@ sub output_screen { return; } + output_screen(); + output_json(); + $latest_update = [Time::HiRes::gettimeofday]; +} + +sub output_screen { + my $info = $engine->{'info'}; + my $id = $engine->{'id'}; + my $text = 'Analysis'; if ($pos_calculating->{'last_move'} ne 'none') { if ($pos_calculating->{'toplay'} eq 'W') { @@ -677,19 +459,6 @@ sub output_screen { return unless (exists($pos_calculating->{'board'})); - # - # Some programs _always_ report MultiPV, even with only one PV. - # In this case, we simply use that data as if MultiPV was never - # specified. - # - if (exists($info->{'pv1'}) && !exists($info->{'pv2'})) { - for my $key (qw(pv score_cp score_mate nodes nps depth seldepth tbhits)) { - if (exists($info->{$key . '1'})) { - $info->{$key} = $info->{$key . '1'}; - } - } - } - if (exists($info->{'pv1'}) && exists($info->{'pv2'})) { # multi-PV my $mpv = 1; @@ -713,7 +482,7 @@ sub output_screen { } $text .= ":\n"; - $text .= " " . join(', ', prettyprint_pv($pos_calculating->{'board'}, @{$info->{'pv' . $mpv}})) . "\n"; + $text .= " " . join(', ', prettyprint_pv($pos_calculating, @{$info->{'pv' . $mpv}})) . "\n"; $text .= "\n"; ++$mpv; } @@ -721,48 +490,51 @@ sub output_screen { # single-PV my $score = long_score($info, $pos_calculating, ''); $text .= " $score\n" if defined($score); - $text .= " PV: " . join(', ', prettyprint_pv($pos_calculating->{'board'}, @{$info->{'pv'}})); + $text .= " PV: " . join(', ', prettyprint_pv($pos_calculating, @{$info->{'pv'}})); $text .= "\n"; if (exists($info->{'nodes'}) && exists($info->{'nps'}) && exists($info->{'depth'})) { $text .= sprintf " %u nodes, %7u nodes/sec, depth %u ply", $info->{'nodes'}, $info->{'nps'}, $info->{'depth'}; } + if (exists($info->{'seldepth'})) { + $text .= sprintf " (%u selective)", $info->{'seldepth'}; + } if (exists($info->{'tbhits'}) && $info->{'tbhits'} > 0) { if ($info->{'tbhits'} == 1) { - $text .= ", one Nalimov hit"; + $text .= ", one Syzygy hit"; } else { - $text .= sprintf ", %u Nalimov hits", $info->{'tbhits'}; + $text .= sprintf ", %u Syzygy hits", $info->{'tbhits'}; } } - if (exists($info->{'seldepth'})) { - $text .= sprintf " (%u selective)", $info->{'seldepth'}; - } $text .= "\n\n"; } - #$text .= book_info($pos_calculating->{'fen'}, $pos_calculating->{'board'}, $pos_calculating->{'toplay'}); + #$text .= book_info($pos_calculating->fen(), $pos_calculating->{'board'}, $pos_calculating->{'toplay'}); my @refutation_lines = (); - for my $move (keys %refutation_moves) { - eval { - my $m = $refutation_moves{$move}; - die if ($m->{'depth'} < $second_engine_start_depth); - my $pretty_move = join('', prettyprint_pv($pos_calculating->{'board'}, $move)); - my @pretty_pv = prettyprint_pv($pos_calculating->{'board'}, $move, @{$m->{'pv'}}); - if (scalar @pretty_pv > 5) { - @pretty_pv = @pretty_pv[0..4]; - push @pretty_pv, "..."; - } - #my $key = score_sort_key($refutation_moves{$move}, $pos_calculating, '', 1); - my $key = $pretty_move; - my $line = sprintf(" %-6s %6s %3s %s", - $pretty_move, - short_score($refutation_moves{$move}, $pos_calculating, '', 1), - "d" . $m->{'depth'}, - join(', ', @pretty_pv)); - push @refutation_lines, [ $key, $line ]; - }; + if (defined($engine2)) { + for (my $mpv = 1; $mpv < 500; ++$mpv) { + my $info = $engine2->{'info'}; + last if (!exists($info->{'pv' . $mpv})); + eval { + 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) { + @pretty_pv = @pretty_pv[0..4]; + push @pretty_pv, "..."; + } + my $key = $pretty_move; + my $line = sprintf(" %-6s %6s %3s %s", + $pretty_move, + short_score($info, $pos_calculating_second_engine, $mpv, 0), + "d" . $info->{'depth' . $mpv}, + join(', ', @pretty_pv)); + push @refutation_lines, [ $key, $line ]; + }; + } } if ($#refutation_lines >= 0) { @@ -778,266 +550,63 @@ sub output_screen { print $text; $last_text = $text; } - - # Now construct the tell text, if any - return if (!defined($telltarget)); - - my $tell_text = ''; - - if (exists($id->{'name'})) { - $tell_text .= "Analysis by $id->{'name'} -- see http://analysis.sesse.net/ for more information\n"; - } else { - $tell_text .= "Computer analysis -- http://analysis.sesse.net/ for more information\n"; - } - - if (exists($info->{'pv1'}) && exists($info->{'pv2'})) { - # multi-PV - my $mpv = 1; - while (exists($info->{'pv' . $mpv})) { - $tell_text .= sprintf " PV%2u", $mpv; - my $score = short_score($info, $pos_calculating, $mpv); - $tell_text .= " ($score)" if (defined($score)); - - if (exists($info->{'depth' . $mpv})) { - $tell_text .= sprintf " (%2u ply)", $info->{'depth' . $mpv}; - } - - $tell_text .= ": "; - $tell_text .= join(', ', prettyprint_pv($pos_calculating->{'board'}, @{$info->{'pv' . $mpv}})); - $tell_text .= "\n"; - ++$mpv; - } - } else { - # single-PV - my $score = long_score($info, $pos_calculating, ''); - $tell_text .= " $score\n" if defined($score); - $tell_text .= " PV: " . join(', ', prettyprint_pv($pos_calculating->{'board'}, @{$info->{'pv'}})); - if (exists($info->{'depth'})) { - $tell_text .= sprintf " (depth %u ply)", $info->{'depth'}; - } - $tell_text .= "\n"; - } - - # see if a new tell is called for -- it is if the delay has expired _and_ - # this is not simply a repetition of the last one - if ($last_told_text ne $tell_text) { - my $now = time; - for my $iv (@tell_intervals) { - last if ($now - $last_move < $iv); - next if ($last_tell - $last_move >= $iv); - - for my $line (split /\n/, $tell_text) { - $t->print("tell $telltarget [$target] $line"); - } - - $last_told_text = $text; - $last_tell = $now; - - last; - } - } -} - -sub find_kings { - my $board = shift; - my ($wkr, $wkc, $bkr, $bkc); - - for my $row (0..7) { - for my $col (0..7) { - my $piece = substr($board->[$row], $col, 1); - if ($piece eq 'K') { - ($wkr, $wkc) = ($row, $col); - } elsif ($piece eq 'k') { - ($bkr, $bkc) = ($row, $col); - } - } - } - - return ($wkr, $wkc, $bkr, $bkc); -} - -sub in_mate { - my $board = shift; - my $check = in_check($board); - return 0 if ($check eq 'none'); - - # try all possible moves for the side in check - for my $row (0..7) { - for my $col (0..7) { - my $piece = substr($board->[$row], $col, 1); - next if ($piece eq '-'); - - if ($check eq 'white') { - next if ($piece eq lc($piece)); - } else { - next if ($piece eq uc($piece)); - } - - for my $dest_row (0..7) { - for my $dest_col (0..7) { - next if ($row == $dest_row && $col == $dest_col); - next unless (can_reach($board, $piece, $row, $col, $dest_row, $dest_col)); - - my @nb = @$board; - substr($nb[$row], $col, 1, '-'); - substr($nb[$dest_row], $dest_col, 1, $piece); - - my $new_check = in_check(\@nb); - return 0 if ($new_check ne $check && $new_check ne 'both'); - } - } - } - } - - # nothing to do; mate - return 1; } -sub in_check { - my $board = shift; - my ($black_check, $white_check) = (0, 0); - - my ($wkr, $wkc, $bkr, $bkc) = find_kings($board); - - # check all pieces for the possibility of threatening the two kings - for my $row (0..7) { - for my $col (0..7) { - my $piece = substr($board->[$row], $col, 1); - next if ($piece eq '-'); - - if (uc($piece) eq $piece) { - # white piece - $black_check = 1 if (can_reach($board, $piece, $row, $col, $bkr, $bkc)); - } else { - # black piece - $white_check = 1 if (can_reach($board, $piece, $row, $col, $wkr, $wkc)); - } - } - } - - if ($black_check && $white_check) { - return 'both'; - } elsif ($black_check) { - return 'black'; - } elsif ($white_check) { - return 'white'; - } else { - return 'none'; - } -} - -sub can_reach { - my ($board, $piece, $from_row, $from_col, $to_row, $to_col) = @_; - - # can't eat your own piece - my $dest_piece = substr($board->[$to_row], $to_col, 1); - if ($dest_piece ne '-') { - return 0 if (($piece eq lc($piece)) == ($dest_piece eq lc($dest_piece))); - } - - if (lc($piece) eq 'k') { - return (abs($from_row - $to_row) <= 1 && abs($from_col - $to_col) <= 1); - } - if (lc($piece) eq 'r') { - return 0 unless ($from_row == $to_row || $from_col == $to_col); - - # check that there's a clear passage - if ($from_row == $to_row) { - if ($from_col > $to_col) { - ($to_col, $from_col) = ($from_col, $to_col); - } - - for my $c (($from_col+1)..($to_col-1)) { - my $middle_piece = substr($board->[$to_row], $c, 1); - return 0 if ($middle_piece ne '-'); - } - - return 1; - } else { - if ($from_row > $to_row) { - ($to_row, $from_row) = ($from_row, $to_row); - } - - for my $r (($from_row+1)..($to_row-1)) { - my $middle_piece = substr($board->[$r], $to_col, 1); - return 0 if ($middle_piece ne '-'); - } - - return 1; - } - } - if (lc($piece) eq 'b') { - return 0 unless (abs($from_row - $to_row) == abs($from_col - $to_col)); - - my $dr = ($to_row - $from_row) / abs($to_row - $from_row); - my $dc = ($to_col - $from_col) / abs($to_col - $from_col); +sub output_json { + my $info = $engine->{'info'}; - my $r = $from_row + $dr; - my $c = $from_col + $dc; + my $json = {}; + $json->{'position'} = $pos_calculating->to_json_hash(); + $json->{'id'} = $engine->{'id'}; + $json->{'score'} = long_score($info, $pos_calculating, ''); - while ($r != $to_row) { - my $middle_piece = substr($board->[$r], $c, 1); - return 0 if ($middle_piece ne '-'); - - $r += $dr; - $c += $dc; - } + $json->{'nodes'} = $info->{'nodes'}; + $json->{'nps'} = $info->{'nps'}; + $json->{'depth'} = $info->{'depth'}; + $json->{'tbhits'} = $info->{'tbhits'}; + $json->{'seldepth'} = $info->{'seldepth'}; - return 1; - } - if (lc($piece) eq 'n') { - my $diff_r = abs($from_row - $to_row); - my $diff_c = abs($from_col - $to_col); - return 1 if ($diff_r == 2 && $diff_c == 1); - return 1 if ($diff_r == 1 && $diff_c == 2); - return 0; - } - if ($piece eq 'q') { - return (can_reach($board, 'r', $from_row, $from_col, $to_row, $to_col) || - can_reach($board, 'b', $from_row, $from_col, $to_row, $to_col)); - } - if ($piece eq 'Q') { - return (can_reach($board, 'R', $from_row, $from_col, $to_row, $to_col) || - can_reach($board, 'B', $from_row, $from_col, $to_row, $to_col)); - } + # single-PV only for now + $json->{'pv_uci'} = $info->{'pv'}; + $json->{'pv_pretty'} = [ prettyprint_pv($pos_calculating, @{$info->{'pv'}}) ]; - # TODO: en passant - if ($piece eq 'p') { - # black pawn - if ($to_col == $from_col && $to_row == $from_row + 1) { - return ($dest_piece eq '-'); - } - if ($to_col == $from_col && $from_row == 1 && $to_row == 3) { - my $middle_piece = substr($board->[2], $to_col, 1); - return ($dest_piece eq '-' && $middle_piece eq '-'); - } - if (abs($to_col - $from_col) == 1 && $to_row == $from_row + 1) { - return ($dest_piece ne '-'); - } - return 0; - } - if ($piece eq 'P') { - # white pawn - if ($to_col == $from_col && $to_row == $from_row - 1) { - return ($dest_piece eq '-'); - } - if ($to_col == $from_col && $from_row == 6 && $to_row == 4) { - my $middle_piece = substr($board->[5], $to_col, 1); - return ($dest_piece eq '-' && $middle_piece eq '-'); - } - if (abs($to_col - $from_col) == 1 && $to_row == $from_row - 1) { - return ($dest_piece ne '-'); - } - return 0; - } - - # unknown piece - return 0; + my %refutation_lines = (); + my @refutation_lines = (); + if (defined($engine2)) { + for (my $mpv = 1; $mpv < 500; ++$mpv) { + my $info = $engine2->{'info'}; + my $pretty_move = ""; + my @pretty_pv = (); + last if (!exists($info->{'pv' . $mpv})); + + eval { + 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, + 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, + }; + $refutation_lines{$pv->[0]}->{'pv_uci'} = $pv; + }; + } + } + $json->{'refutation_lines'} = \%refutation_lines; + + open my $fh, ">/srv/analysis.sesse.net/www/analysis.json.tmp" + or return; + print $fh JSON::XS::encode_json($json); + close $fh; + rename("/srv/analysis.sesse.net/www/analysis.json.tmp", "/srv/analysis.sesse.net/www/analysis.json"); } sub uciprint { my ($engine, $msg) = @_; - print { $engine->{'write'} } "$msg\n"; + $engine->print($msg); print UCILOG localtime() . " $engine->{'tag'} => $msg\n"; } @@ -1051,9 +620,9 @@ sub short_score { if (defined($info->{'score_mate' . $mpv})) { if ($invert) { - return sprintf "M%3d", $info->{'score_mate' . $mpv}; - } else { return sprintf "M%3d", -$info->{'score_mate' . $mpv}; + } else { + return sprintf "M%3d", $info->{'score_mate' . $mpv}; } } else { if (exists($info->{'score_cp' . $mpv})) { @@ -1074,16 +643,11 @@ sub short_score { sub score_sort_key { my ($info, $pos, $mpv, $invert) = @_; - $invert //= 0; - if ($pos->{'toplay'} eq 'B') { - $invert = !$invert; - } - if (defined($info->{'score_mate' . $mpv})) { if ($invert) { - return -(99999 - $info->{'score_mate' . $mpv}); - } else { return 99999 - $info->{'score_mate' . $mpv}; + } else { + return -(99999 - $info->{'score_mate' . $mpv}); } } else { if (exists($info->{'score_cp' . $mpv})) { @@ -1114,6 +678,9 @@ sub long_score { } else { if (exists($info->{'score_cp' . $mpv})) { my $score = $info->{'score_cp' . $mpv} * 0.01; + if ($score == 0) { + return "Score: 0.00"; + } if ($pos->{'toplay'} eq 'B') { $score = -$score; } @@ -1144,7 +711,7 @@ sub book_info { if ($move eq '') { $pmove = '(current)'; } else { - ($pmove) = prettyprint_pv($board, $move); + ($pmove) = prettyprint_pv_no_cache($board, $move); $pmove .= $annotation; } @@ -1177,129 +744,9 @@ sub book_info { } sub open_engine { - my ($cmdline, $tag) = @_; - my ($uciread, $uciwrite); - my $pid = IPC::Open2::open2($uciread, $uciwrite, $cmdline); - - my $engine = { - pid => $pid, - read => $uciread, - readbuf => '', - write => $uciwrite, - info => {}, - ids => {}, - tag => $tag, - }; - - uciprint($engine, "uci"); - - # gobble the options - while (<$uciread>) { - /uciok/ && last; - handle_uci($engine, $_); - } - - return $engine; -} - -sub read_lines { - my $engine = shift; - - # - # Read until we've got a full line -- if the engine sends part of - # a line and then stops we're pretty much hosed, but that should - # never happen. - # - while ($engine->{'readbuf'} !~ /\n/) { - my $tmp; - my $ret = sysread $engine->{'read'}, $tmp, 4096; - - if (!defined($ret)) { - next if ($!{EINTR}); - die "error in reading from the UCI engine: $!"; - } elsif ($ret == 0) { - die "EOF from UCI engine"; - } - - $engine->{'readbuf'} .= $tmp; - } - - # Blah. - my @lines = (); - while ($engine->{'readbuf'} =~ s/^([^\n]*)\n//) { - my $line = $1; - $line =~ tr/\r\n//d; - push @lines, $line; - } - return @lines; -} - -# Find all possible legal moves. -sub calculate_refutation_moves { - my $pos = shift; - my $board = $pos->{'board'}; - my %refutation_moves = (); - for my $col (0..7) { - for my $row (0..7) { - my $piece = substr($board->[$row], $col, 1); - - # Check that there's a piece of the right color on this square. - next if ($piece eq '-'); - if ($pos->{'toplay'} eq 'W') { - next if ($piece ne uc($piece)); - } else { - next if ($piece ne lc($piece)); - } - - for my $to_col (0..7) { - for my $to_row (0..7) { - next if ($col == $to_col && $row == $to_row); - next unless (can_reach($board, $piece, $row, $col, $to_row, $to_col)); - - my $promo = ""; # FIXME - my $nb = make_move($board, $row, $col, $to_row, $to_col, $promo); - my $check = in_check($nb); - next if ($check eq 'both'); - if ($pos->{'toplay'} eq 'W') { - next if ($check eq 'white'); - } else { - next if ($check eq 'black'); - } - my $move = move_to_uci_notation($row, $col, $to_row, $to_col, $promo); - $refutation_moves{$move} = { depth => $second_engine_start_depth - 1, score_cp => 0, pv => '' }; - } - } - } - } - return %refutation_moves; -} - -sub give_new_move_to_second_engine { - my $pos = shift; - - # Find the move that's been analyzed the shortest but is most promising. - # Tie-break on UCI move representation. - my $best_move = undef; - for my $move (sort keys %refutation_moves) { - if (!defined($best_move)) { - $best_move = $move; - next; - } - my $best = $refutation_moves{$best_move}; - my $this = $refutation_moves{$move}; - - if ($this->{'depth'} < $best->{'depth'} || - ($this->{'depth'} == $best->{'depth'} && $this->{'score_cp'} < $best->{'score_cp'})) { - $best_move = $move; - next; - } - } - - my $m = $refutation_moves{$best_move}; - ++$m->{'depth'}; - uciprint($engine2, "position fen " . $pos->{'fen'} . " moves " . $best_move); - uciprint($engine2, "go depth " . $m->{'depth'}); - $move_calculating_second_engine = $best_move; + my ($cmdline, $tag, $cb) = @_; + return undef if (!defined($cmdline)); + return Engine->open($cmdline, $tag, $cb); } sub col_letter_to_num { @@ -1310,8 +757,12 @@ sub row_letter_to_num { return 7 - (ord(shift) - ord('1')); } -sub move_to_uci_notation { - my ($from_row, $from_col, $to_row, $to_col, $promo) = @_; - $promo //= ""; - return sprintf("%c%d%c%d%s", ord('a') + $from_col, 8 - $from_row, ord('a') + $to_col, 8 - $to_row, $promo); +sub parse_uci_move { + my $move = shift; + my $from_col = col_letter_to_num(substr($move, 0, 1)); + my $from_row = row_letter_to_num(substr($move, 1, 1)); + 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); }