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