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

   1 #! /usr/bin/perl
   2
   3 #
   4 # remoteglot - Connects an abitrary UCI-speaking engine to ICS for easier post-game
   5 #              analysis, or for live analysis of relayed games. (Do not use for
   6 #              cheating! Cheating is bad for your karma, and your abuser flag.)
   7 #
   8 # Copyright 2007 Steinar H. Gunderson <sgunderson@bigfoot.com>
   9 # Licensed under the GNU General Public License, version 2.
  10 #
  11
  12 use Net::Telnet;
  13 use FileHandle;
  14 use IPC::Open2;
  15 use Time::HiRes;
  16 use strict;
  17 use warnings;
  18
  19 $SIG{ALRM} = sub { output_screen(); };
  20
  21 $| = 1;
  22
  23 my $server = "freechess.org";
  24 my $target = "Sesse";
  25 # my $engine = "/usr/games/toga2";
  26 my $engine = "wine rybka22-mpw32.exe";
  27
  28 # open the chess engine
  29 my $pid = IPC::Open2::open2(*UCIREAD, *UCIWRITE, $engine);
  30 my %uciinfo = ();
  31 my %ficsinfo = ();
  32 print UCIWRITE "uci\n";
  33
  34 # gobble the options
  35 while (<UCIREAD>) {
  36         /uciok/ && last;
  37 }
  38
  39 print UCIWRITE "setoption name UCI_AnalyseMode value true\n";
  40 print UCIWRITE "setoption name NalimovPath value c:\\nalimov\n";
  41 print UCIWRITE "setoption name NalimovUsage value Normally\n";
  42 # print UCIWRITE "setoption name Contempt value 1000\n";
  43 # print UCIWRITE "setoption name Outlook value Ultra Optimistic\n";
  44 print UCIWRITE "ucinewgame\n";
  45
  46 print "Chess engine ready.\n";
  47
  48 # now talk to FICS
  49 my $t = Net::Telnet->new(Timeout => 10, Prompt => '/fics% /');
  50 #$t->input_log(\*STDOUT);
  51 $t->open($server);
  52 $t->print("guest");
  53 $t->waitfor('/Press return to enter the server/');
  54 $t->cmd("");
  55
  56 # set some options
  57 $t->cmd("set shout 0");
  58 $t->cmd("set seek 0");
  59 $t->cmd("set style 12");
  60 $t->cmd("observe $target");
  61
  62 # main loop
  63 print "FICS ready.\n";
  64 while (1) {
  65         my $rin = '';
  66         vec($rin, fileno(UCIREAD), 1) = 1;
  67         vec($rin, fileno($t), 1) = 1;
  68
  69         my ($nfound, $timeleft) = select($rin, undef, undef, 5.0);
  70         my $sleep = 1.0;
  71
  72         while (1) {
  73                 my $line = $t->getline(Timeout => 0, errmode => 'return');
  74                 last if (!defined($line));
  75
  76                 chomp $line;
  77                 $line =~ tr/\r//d;
  78                 if ($line =~ /^<12> /) {
  79                         my $fen = style12_to_fen($line);
  80                         print UCIWRITE "stop\n";
  81                         print UCIWRITE "position fen $fen\n";
  82                         print UCIWRITE "go infinite\n";
  83                         #print "stop\n";
  84                         #print "position fen $fen\n";
  85                         #print "go infinite\n";
  86                 }
  87                 #print "FICS: [$line]\n";
  88                 $sleep = 0;
  89         }
  90
  91         # any fun on the UCI channel?
  92         if (vec($rin, fileno(UCIREAD), 1)) {
  93                 my $line = <UCIREAD>;
  94                 chomp $line;
  95                 $line =~ tr/\r//d;
  96                 #print "UCI: $line\n";
  97                 if ($line =~ /^info/) {
  98                         my (@infos) = split / /, $line;
  99                         shift @infos;
 100
 101                         parse_infos(@infos);
 102                 }
 103                 $sleep = 0;
 104
 105                 # don't update too often
 106                 Time::HiRes::alarm(0.2);
 107         }
 108
 109         sleep $sleep;
 110 }
 111
 112 sub parse_infos {
 113         my (@x) = @_;
 114
 115         while (scalar @x > 0) {
 116                 if ($x[0] =~ /^(currmove|currmovenumber|time|nodes|nps|cpuload|hashfull|depth|seldepth|multipv|time|tbhits)$/) {
 117                         my $key = shift @x;
 118                         my $value = shift @x;
 119                         $uciinfo{$key} = $value;
 120                         next;
 121                 }
 122                 if ($x[0] eq 'score') {
 123                         shift @x;
 124
 125                         delete $uciinfo{'score_cp'};
 126                         delete $uciinfo{'score_mate'};
 127
 128                         while ($x[0] =~ /^(cp|mate|lowerbound|upperbound)$/) {
 129                                 if ($x[0] eq 'cp') {
 130                                         shift @x;
 131                                         $uciinfo{'score_cp'} = shift @x;
 132                                 } elsif ($x[0] eq 'mate') {
 133                                         shift @x;
 134                                         $uciinfo{'score_mate'} = shift @x;
 135                                 } else {
 136                                         shift @x;
 137                                 }
 138                         }
 139                         next;
 140                 }
 141                 if ($x[0] eq 'pv') {
 142                         $uciinfo{'pv'} = [ @x[1..$#x] ];
 143                         last;
 144                 }
 145                 if ($x[0] eq 'UCI_AnalyseMode' || $x[0] eq 'setting' || $x[0] eq 'contempt') {
 146                         last;
 147                 }
 148
 149                 #print "unknown info '$x[0]', trying to recover...\n";
 150                 #shift @x;
 151                 die "Unknown info '" . join(',', @x) . "'";
 152
 153         }
 154 }
 155
 156 sub style12_to_fen {
 157         my $str = shift;
 158         my (@x) = split / /, $str;
 159
 160         $ficsinfo{'board'} = [ @x[1..8] ];
 161         $ficsinfo{'toplay'} = $x[9];
 162
 163         # the board itself
 164         my (@board) = @x[1..8];
 165         for my $rank (0..7) {
 166                 $board[$rank] =~ s/(-+)/length($1)/ge;
 167         }
 168         my $fen = join('/', @board);
 169
 170         # white/black to move
 171         $fen .= " ";
 172         $fen .= lc($x[9]);
 173
 174         # castling
 175         my $castling = "";
 176         $castling .= "K" if ($x[11] == 1);
 177         $castling .= "Q" if ($x[12] == 1);
 178         $castling .= "k" if ($x[13] == 1);
 179         $castling .= "q" if ($x[14] == 1);
 180         $castling = "-" if ($castling eq "");
 181         $fen .= " ";
 182         $fen .= $castling;
 183
 184         # en passant
 185         my $ep = "-";
 186         if ($x[10] != -1) {
 187                 $ep = (qw(a b c d e f g h))[$x[10]];
 188                 if ($x[9] eq 'B') {
 189                         $ep .= "3";
 190                 } else {
 191                         $ep .= "6";
 192                 }
 193         }
 194         $fen .= " ";
 195         $fen .= $ep;
 196
 197         # half-move clock
 198         $fen .= " ";
 199         $fen .= $x[15];
 200
 201         # full-move clock
 202         $fen .= " ";
 203         $fen .= $x[26];
 204
 205         return $fen;
 206 }
 207
 208 sub prettyprint_pv {
 209         my ($board, @pvs) = @_;
 210
 211         if (scalar @pvs == 0 || !defined($pvs[0])) {
 212                 return ();
 213         }
 214
 215         my $pv = shift @pvs;
 216         my $from_col = ord(substr($pv, 0, 1)) - ord('a');
 217         my $from_row = 7 - (ord(substr($pv, 1, 1)) - ord('1'));
 218         my $to_col   = ord(substr($pv, 2, 1)) - ord('a');
 219         my $to_row   = 7 - (ord(substr($pv, 3, 1)) - ord('1'));
 220
 221         my $pretty;
 222         my $piece = substr($board->[$from_row], $from_col, 1);
 223
 224         # white short castling
 225         if ($pv eq 'e1g1' && $piece eq 'K') {
 226                 my @nb = @$board;
 227
 228                 # king
 229                 substr($nb[7], 4, 1, '-');
 230                 substr($nb[7], 6, 1, $piece);
 231
 232                 # rook
 233                 substr($nb[7], 7, 1, '-');
 234                 substr($nb[7], 5, 1, 'R');
 235
 236                 return ('0-0', prettyprint_pv(\@nb, @pvs));
 237         }
 238
 239         # white long castling
 240         if ($pv eq 'e1b1' && $piece eq 'K') {
 241                 my @nb = @$board;
 242
 243                 # king
 244                 substr($nb[7], 4, 1, '-');
 245                 substr($nb[7], 2, 1, $piece);
 246
 247                 # rook
 248                 substr($nb[7], 0, 1, '-');
 249                 substr($nb[7], 2, 1, 'R');
 250
 251                 return ('0-0-0', prettyprint_pv(\@nb, @pvs));
 252         }
 253
 254         # black short castling
 255         if ($pv eq 'e8g8' && $piece eq 'k') {
 256                 my @nb = @$board;
 257
 258                 # king
 259                 substr($nb[0], 4, 1, '-');
 260                 substr($nb[0], 6, 1, $piece);
 261
 262                 # rook
 263                 substr($nb[0], 7, 1, '-');
 264                 substr($nb[0], 5, 1, 'R');
 265
 266                 return ('0-0', prettyprint_pv(\@nb, @pvs));
 267         }
 268
 269         # black long castling
 270         if ($pv eq 'e8b8' && $piece eq 'k') {
 271                 my @nb = @$board;
 272
 273                 # king
 274                 substr($nb[0], 4, 1, '-');
 275                 substr($nb[0], 2, 1, $piece);
 276
 277                 # rook
 278                 substr($nb[0], 0, 1, '-');
 279                 substr($nb[0], 2, 1, 'R');
 280
 281                 return ('0-0-0', prettyprint_pv(\@nb, @pvs));
 282         }
 283
 284         # check if the from-piece is a pawn
 285         if (lc($piece) eq 'p') {
 286                 # attack?
 287                 if (substr($board->[$to_row], $to_col, 1) ne '-') {
 288                         $pretty = substr($pv, 0, 1) . 'x' . substr($pv, 2, 2);
 289                 } else {
 290                         $pretty = substr($pv, 2, 2);
 291
 292                         if (length($pv) == 5) {
 293                                 # promotion
 294                                 $pretty .= "=";
 295                                 $pretty .= uc(substr($pv, 4, 1));
 296
 297                                 if ($piece eq 'p') {
 298                                         $piece = substr($pv, 4, 1);
 299                                 } else {
 300                                         $piece = uc(substr($pv, 4, 1));
 301                                 }
 302                         }
 303                 }
 304         } else {
 305                 $pretty = uc($piece);
 306
 307                 # see how many of these pieces could go here, in all
 308                 my $num_total = 0;
 309                 for my $col (0..7) {
 310                         for my $row (0..7) {
 311                                 next unless (substr($board->[$row], $col, 1) eq $piece);
 312                                 ++$num_total if (can_reach($board, $piece, $row, $col, $to_row, $to_col));
 313                         }
 314                 }
 315
 316                 # see how many of these pieces from the given row could go here
 317                 my $num_row = 0;
 318                 for my $col (0..7) {
 319                         next unless (substr($board->[$from_row], $col, 1) eq $piece);
 320                         ++$num_row if (can_reach($board, $piece, $from_row, $col, $to_row, $to_col));
 321                 }
 322
 323                 # and same for columns
 324                 my $num_col = 0;
 325                 for my $row (0..7) {
 326                         next unless (substr($board->[$row], $from_col, 1) eq $piece);
 327                         ++$num_col if (can_reach($board, $piece, $row, $from_col, $to_row, $to_col));
 328                 }
 329
 330                 # see if we need to disambiguate
 331                 if ($num_total > 1) {
 332                         if ($num_col == 1) {
 333                                 $pretty .= substr($pv, 0, 1);
 334                         } elsif ($num_row == 1) {
 335                                 $pretty .= substr($pv, 1, 1);
 336                         } else {
 337                                 $pretty .= substr($pv, 0, 2);
 338                         }
 339                 }
 340
 341                 # attack?
 342                 if (substr($board->[$to_row], $to_col, 1) ne '-') {
 343                         $pretty .= 'x';
 344                 }
 345
 346                 $pretty .= substr($pv, 2, 2);
 347         }
 348
 349         # update the board
 350         my @nb = @$board;
 351         substr($nb[$from_row], $from_col, 1, '-');
 352         substr($nb[$to_row], $to_col, 1, $piece);
 353
 354         if (in_mate(\@nb)) {
 355                 $pretty .= '#';
 356         } elsif (in_check(\@nb) ne 'none') {
 357                 $pretty .= '+';
 358         }
 359
 360         return ($pretty, prettyprint_pv(\@nb, @pvs));
 361 }
 362
 363 sub output_screen {
 364         #return;
 365
 366         print  "\ecAnalysis:\n";
 367         if (defined($uciinfo{'score_mate'})) {
 368                 printf "  Mate in %d\n", $uciinfo{'score_mate'};
 369         } else {
 370                 my $score = $uciinfo{'score_cp'} * 0.01;
 371                 if ($ficsinfo{'toplay'} eq 'B') {
 372                         $score = -$score;
 373                 }
 374                 printf "  Score: %+5.2f\n", $score;
 375         }
 376         print  "  PV: ", join(', ', prettyprint_pv($ficsinfo{'board'}, @{$uciinfo{'pv'}}));
 377         print  "\n";
 378         printf "  %u nodes, %7u nodes/sec, depth %u ply",
 379                 $uciinfo{'nodes'}, $uciinfo{'nps'}, $uciinfo{'depth'};
 380         if (exists($uciinfo{'tbhits'})) {
 381                 printf ", %u Nalimov hits", $uciinfo{'tbhits'};
 382         }
 383         if (exists($uciinfo{'seldepth'})) {
 384                 printf " (%u selective)", $uciinfo{'seldepth'};
 385         }
 386         print  "\n\n";
 387 }
 388
 389 sub find_kings {
 390         my $board = shift;
 391         my ($wkr, $wkc, $bkr, $bkc);
 392
 393         for my $row (0..7) {
 394                 for my $col (0..7) {
 395                         my $piece = substr($board->[$row], $col, 1);
 396                         if ($piece eq 'K') {
 397                                 ($wkr, $wkc) = ($row, $col);
 398                         } elsif ($piece eq 'k') {
 399                                 ($bkr, $bkc) = ($row, $col);
 400                         }
 401                 }
 402         }
 403
 404         return ($wkr, $wkc, $bkr, $bkc);
 405 }
 406
 407 sub in_mate {
 408         my $board = shift;
 409         my $check = in_check($board);
 410         return 0 if ($check eq 'none');
 411
 412         # try all possible moves for the side in check
 413         for my $row (0..7) {
 414                 for my $col (0..7) {
 415                         my $piece = substr($board->[$row], $col, 1);
 416                         next if ($piece eq '-');
 417
 418                         if ($check eq 'white') {
 419                                 next if ($piece eq lc($piece));
 420                         } else {
 421                                 next if ($piece eq uc($piece));
 422                         }
 423
 424                         for my $dest_row (0..7) {
 425                                 for my $dest_col (0..7) {
 426                                         next if ($row == $dest_row && $col == $dest_col);
 427                                         next unless (can_reach($board, $piece, $row, $col, $dest_row, $dest_col));
 428
 429                                         my @nb = @$board;
 430                                         substr($nb[$row], $col, 1, '-');
 431                                         substr($nb[$dest_row], $dest_col, 1, $piece);
 432
 433                                         my $new_check = in_check(\@nb);
 434                                         return 0 if ($new_check ne $check && $new_check ne 'both');
 435                                 }
 436                         }
 437                 }
 438         }
 439
 440         # nothing to do; mate
 441         return 1;
 442 }
 443
 444 sub in_check {
 445         my $board = shift;
 446         my ($black_check, $white_check) = (0, 0);
 447
 448         my ($wkr, $wkc, $bkr, $bkc) = find_kings($board);
 449
 450         # check all pieces for the possibility of threatening the two kings
 451         for my $row (0..7) {
 452                 for my $col (0..7) {
 453                         my $piece = substr($board->[$row], $col, 1);
 454                         next if ($piece eq '-' || lc($piece) eq 'k');
 455
 456                         if (uc($piece) eq $piece) {
 457                                 # white piece
 458                                 $black_check = 1 if (can_reach($board, $piece, $row, $col, $bkr, $bkc));
 459                         } else {
 460                                 # black piece
 461                                 $white_check = 1 if (can_reach($board, $piece, $row, $col, $wkr, $wkc));
 462                         }
 463                 }
 464         }
 465
 466         if ($black_check && $white_check) {
 467                 return 'both';
 468         } elsif ($black_check) {
 469                 return 'black';
 470         } elsif ($white_check) {
 471                 return 'white';
 472         } else {
 473                 return 'none';
 474         }
 475 }
 476
 477 sub can_reach {
 478         my ($board, $piece, $from_row, $from_col, $to_row, $to_col) = @_;
 479
 480         # can't eat your own piece
 481         my $dest_piece = substr($board->[$to_row], $to_col, 1);
 482         if ($dest_piece ne '-') {
 483                 return 0 if (($piece eq lc($piece)) == ($dest_piece eq lc($dest_piece)));
 484         }
 485
 486         if (lc($piece) eq 'k') {
 487                 return (abs($from_row - $to_row) <= 1 && abs($from_col - $to_col) <= 1);
 488         }
 489         if (lc($piece) eq 'r') {
 490                 return 0 unless ($from_row == $to_row || $from_col == $to_col);
 491
 492                 # check that there's a clear passage
 493                 if ($from_row == $to_row) {
 494                         if ($from_col > $to_col) {
 495                                 ($to_col, $from_col) = ($from_col, $to_col);
 496                         }
 497
 498                         for my $c (($from_col+1)..($to_col-1)) {
 499                                 my $middle_piece = substr($board->[$to_row], $c, 1);
 500                                 return 0 if ($middle_piece ne '-');
 501                         }
 502
 503                         return 1;
 504                 } else {
 505                         if ($from_row > $to_row) {
 506                                 ($to_row, $from_row) = ($from_row, $to_row);
 507                         }
 508
 509                         for my $r (($from_row+1)..($to_row-1)) {
 510                                 my $middle_piece = substr($board->[$r], $to_col, 1);
 511                                 return 0 if ($middle_piece ne '-');
 512                         }
 513
 514                         return 1;
 515                 }
 516         }
 517         if (lc($piece) eq 'b') {
 518                 return 0 unless (abs($from_row - $to_row) == abs($from_col - $to_col));
 519
 520                 my $dr = ($to_row - $from_row) / abs($to_row - $from_row);
 521                 my $dc = ($to_col - $from_col) / abs($to_col - $from_col);
 522
 523                 my $r = $from_row + $dr;
 524                 my $c = $from_col + $dc;
 525
 526                 while ($r != $to_row) {
 527                         my $middle_piece = substr($board->[$r], $c, 1);
 528                         return 0 if ($middle_piece ne '-');
 529
 530                         $r += $dr;
 531                         $c += $dc;
 532                 }
 533
 534                 return 1;
 535         }
 536         if (lc($piece) eq 'n') {
 537                 my $diff_r = abs($from_row - $to_row);
 538                 my $diff_c = abs($from_col - $to_col);
 539                 return 1 if ($diff_r == 2 && $diff_c == 1);
 540                 return 1 if ($diff_r == 1 && $diff_c == 2);
 541                 return 0;
 542         }
 543         if ($piece eq 'q') {
 544                 return (can_reach($board, 'r', $from_row, $from_col, $to_row, $to_col) ||
 545                         can_reach($board, 'b', $from_row, $from_col, $to_row, $to_col));
 546         }
 547         if ($piece eq 'Q') {
 548                 return (can_reach($board, 'R', $from_row, $from_col, $to_row, $to_col) ||
 549                         can_reach($board, 'B', $from_row, $from_col, $to_row, $to_col));
 550         }
 551         if ($piece eq 'p') {
 552                 # black pawn
 553                 if ($to_col == $from_col && $to_row == $from_row + 1) {
 554                         return ($dest_piece eq '-');
 555                 }
 556                 if (abs($to_col - $from_col) == 1 && $to_row == $from_row + 1) {
 557                         return ($dest_piece ne '-');
 558                 }
 559                 return 0;
 560         }
 561         if ($piece eq 'P') {
 562                 # white pawn
 563                 if ($to_col == $from_col && $to_row == $from_row - 1) {
 564                         return ($dest_piece eq '-');
 565                 }
 566                 if (abs($to_col - $from_col) == 1 && $to_row == $from_row - 1) {
 567                         return ($dest_piece ne '-');
 568                 }
 569                 return 0;
 570         }
 571
 572         # unknown piece
 573         return 0;
 574 }