Initial checkin.
[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 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 }