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