Small microoptimization in Board::clone.
[remoteglot] / Board.pm
1 #! /usr/bin/perl
2 #
3 # There are too many chess modules on CPAN already, so here's another one...
4 #
5 use strict;
6 use warnings;
7
8 package Board;
9
10 sub new {
11         my ($class, @rows) = @_;
12         my $board = [];
13
14         for my $row (0..7) {
15                 for my $col (0..7) {
16                         $board->[$row][$col] = substr($rows[$row], $col, 1);
17                 }
18         }
19
20         return bless $board;
21 }
22
23 sub clone {
24         my ($board) = shift;
25         my $nb = [];
26
27         for my $row (0..7) {
28                 $nb->[$row] = [ @{$board->[$row]} ];
29         }
30
31         return bless $nb;
32 }
33
34 # Returns a new board.
35 sub make_move {
36         my ($board, $from_row, $from_col, $to_row, $to_col, $promo) = @_;
37         my $move = move_to_uci_notation($from_row, $from_col, $to_row, $to_col, $promo);
38         my $piece = $board->[$from_row][$from_col];
39         my $nb = $board->clone();
40
41         if ($piece eq '-') {
42                 die "Invalid move $move";
43         }
44
45         # white short castling
46         if ($move eq 'e1g1' && $piece eq 'K') {
47                 # king
48                 $nb->[7][4] = '-';
49                 $nb->[7][6] = $piece;
50
51                 # rook
52                 $nb->[7][7] = '-';
53                 $nb->[7][5] = 'R';
54
55                 return $nb;
56         }
57
58         # white long castling
59         if ($move eq 'e1c1' && $piece eq 'K') {
60                 # king
61                 $nb->[7][4] = '-';
62                 $nb->[7][2] = $piece;
63
64                 # rook
65                 $nb->[7][0] = '-';
66                 $nb->[7][3] = 'R';
67
68                 return $nb;
69         }
70
71         # black short castling
72         if ($move eq 'e8g8' && $piece eq 'k') {
73                 # king
74                 $nb->[0][4] = '-';
75                 $nb->[0][6] = $piece;
76
77                 # rook
78                 $nb->[0][7] = '-';
79                 $nb->[0][5] = 'r';
80
81                 return $nb;
82         }
83
84         # black long castling
85         if ($move eq 'e8c8' && $piece eq 'k') {
86                 # king
87                 $nb->[0][4] = '-';
88                 $nb->[0][2] = $piece;
89
90                 # rook
91                 $nb->[0][0] = '-';
92                 $nb->[0][3] = 'r';
93
94                 return $nb;
95         }
96
97         # check if the from-piece is a pawn
98         if (lc($piece) eq 'p') {
99                 # attack?
100                 if ($from_col != $to_col) {
101                         # en passant?
102                         if ($board->[$to_row][$to_col] eq '-') {
103                                 if ($piece eq 'p') {
104                                         $nb->[$to_row - 1][$to_col] = '-';
105                                 } else {
106                                         $nb->[$to_row + 1][$to_col] = '-';
107                                 }
108                         }
109                 }
110                 if (defined($promo) && $promo ne '') {
111                         if ($piece eq 'p') {
112                                 $piece = lc($promo);
113                         } else {
114                                 $piece = uc($promo);
115                         }
116                 }
117         }
118
119         # update the board
120         $nb->[$from_row][$from_col] = '-';
121         $nb->[$to_row][$to_col] = $piece;
122
123         return $nb;
124 }
125
126 sub _pos_to_square {
127         my ($row, $col) = @_;
128         return sprintf("%c%d", ord('a') + $col, 8 - $row);
129 }
130
131 sub _col_letter_to_num {
132         return ord(shift) - ord('a');
133 }
134
135 sub _row_letter_to_num {
136         return 7 - (ord(shift) - ord('1'));
137 }
138
139 sub _square_to_pos {
140         my ($square) = @_;
141         $square =~ /^([a-h])([1-8])$/ or die "Invalid square $square";  
142         return (_row_letter_to_num($2), _col_letter_to_num($1));
143 }
144
145 sub move_to_uci_notation {
146         my ($from_row, $from_col, $to_row, $to_col, $promo) = @_;
147         $promo //= "";
148         return _pos_to_square($from_row, $from_col) . _pos_to_square($to_row, $to_col) . $promo;
149 }
150
151 sub parse_pretty_move {
152         my ($board, $move, $toplay) = @_;
153
154         # Strip check or mate
155         $move =~ s/[+#]$//;
156
157         if ($move eq '0-0' or $move eq 'O-O') {
158                 if ($toplay eq 'W') {
159                         return (_square_to_pos('e1'), _square_to_pos('g1'));
160                 } else {
161                         return (_square_to_pos('e8'), _square_to_pos('g8'));
162                 }
163         } elsif ($move eq '0-0-0' or $move eq 'O-O-O') {
164                 if ($toplay eq 'W') {
165                         return (_square_to_pos('e1'), _square_to_pos('c1'));
166                 } else {
167                         return (_square_to_pos('e8'), _square_to_pos('c8'));
168                 }
169         }
170
171         # Parse promo
172         my $promo;
173         if ($move =~ s/=([QRNB])$//) {
174                 $promo = $1;
175         }
176
177         $move =~ /^([KQRBN])?([a-h])?([1-8])?x?([a-h][1-8])$/ or die "Invalid move $move";
178         my $piece = $1 // 'P';
179         my $from_col = defined($2) ? _col_letter_to_num($2) : undef;
180         my $from_row = defined($3) ? _row_letter_to_num($3) : undef;
181         my ($to_row, $to_col) = _square_to_pos($4);
182         
183         # Find all possible from-squares that could have been meant.
184         my @squares = ();
185         if ($toplay eq 'B') {
186                 $piece = lc($piece);
187         }
188         for my $row (0..7) {
189                 next if (defined($from_row) && $from_row != $row);
190                 for my $col (0..7) {
191                         next if (defined($from_col) && $from_col != $col);
192                         next if ($board->[$row][$col] ne $piece);
193                         next if (!$board->can_reach($piece, $row, $col, $to_row, $to_col));
194
195                         # See if doing this move would put us in check
196                         # (yes, there are clients that expect us to do this).
197                         my $check = $board->make_move($row, $col, $to_row, $to_col, $promo)->in_check();
198                         next if ($check eq 'both' ||
199                                  ($toplay eq 'W' && $check eq 'white') ||
200                                  ($toplay eq 'B' && $check eq 'black'));
201
202                         push @squares, [ $row, $col ];
203                 }
204         }
205         if (scalar @squares != 1) {
206                 die "Ambigious or impossible move $move";
207         }
208         return (@{$squares[0]}, $to_row, $to_col, $promo);
209 }
210
211 sub fen {
212         my ($board) = @_;
213         my @rows = ();
214         for my $row (0..7) {
215                 my $str = join('', @{$board->[$row]});
216                 $str =~ s/(-+)/length($1)/ge;
217                 push @rows, $str;
218         }
219
220         return join('/', @rows);
221 }
222
223 sub can_reach {
224         my ($board, $piece, $from_row, $from_col, $to_row, $to_col) = @_;
225         
226         # can't eat your own piece
227         my $dest_piece = $board->[$to_row][$to_col];
228         if ($dest_piece ne '-') {
229                 return 0 if (($piece eq lc($piece)) == ($dest_piece eq lc($dest_piece)));
230         }
231
232         if (lc($piece) eq 'k') {
233                 return (abs($from_row - $to_row) <= 1 && abs($from_col - $to_col) <= 1);
234         }
235         if (lc($piece) eq 'r') {
236                 return 0 unless ($from_row == $to_row || $from_col == $to_col);
237
238                 # check that there's a clear passage
239                 if ($from_row == $to_row) {
240                         if ($from_col > $to_col) {
241                                 ($to_col, $from_col) = ($from_col, $to_col);
242                         }
243
244                         for my $c (($from_col+1)..($to_col-1)) {
245                                 my $middle_piece = $board->[$to_row][$c];
246                                 return 0 if ($middle_piece ne '-');
247                         }
248
249                         return 1;
250                 } else {
251                         if ($from_row > $to_row) {
252                                 ($to_row, $from_row) = ($from_row, $to_row);
253                         }
254
255                         for my $r (($from_row+1)..($to_row-1)) {
256                                 my $middle_piece = $board->[$r][$to_col];
257                                 return 0 if ($middle_piece ne '-');     
258                         }
259
260                         return 1;
261                 }
262         }
263         if (lc($piece) eq 'b') {
264                 return 0 unless (abs($from_row - $to_row) == abs($from_col - $to_col));
265
266                 my $dr = ($to_row - $from_row) / abs($to_row - $from_row);
267                 my $dc = ($to_col - $from_col) / abs($to_col - $from_col);
268
269                 my $r = $from_row + $dr;
270                 my $c = $from_col + $dc;
271
272                 while ($r != $to_row) {
273                         my $middle_piece = $board->[$r][$c];
274                         return 0 if ($middle_piece ne '-');
275                         
276                         $r += $dr;
277                         $c += $dc;
278                 }
279
280                 return 1;
281         }
282         if (lc($piece) eq 'n') {
283                 my $diff_r = abs($from_row - $to_row);
284                 my $diff_c = abs($from_col - $to_col);
285                 return 1 if ($diff_r == 2 && $diff_c == 1);
286                 return 1 if ($diff_r == 1 && $diff_c == 2);
287                 return 0;
288         }
289         if ($piece eq 'q') {
290                 return (can_reach($board, 'r', $from_row, $from_col, $to_row, $to_col) ||
291                         can_reach($board, 'b', $from_row, $from_col, $to_row, $to_col));
292         }
293         if ($piece eq 'Q') {
294                 return (can_reach($board, 'R', $from_row, $from_col, $to_row, $to_col) ||
295                         can_reach($board, 'B', $from_row, $from_col, $to_row, $to_col));
296         }
297
298         if ($piece eq 'p') {
299                 # black pawn
300                 if ($to_col == $from_col && $to_row == $from_row + 1) {
301                         return ($dest_piece eq '-');
302                 }
303                 if ($to_col == $from_col && $from_row == 1 && $to_row == 3) {
304                         my $middle_piece = $board->[2][$to_col];
305                         return ($dest_piece eq '-' && $middle_piece eq '-');
306                 }
307                 if (abs($to_col - $from_col) == 1 && $to_row == $from_row + 1) {
308                         if ($dest_piece eq '-') {
309                                 # En passant. TODO: check that the last move was indeed an EP move
310                                 return ($to_row == 5 && $board->[4][$to_col] eq 'P');
311                         } else {
312                                 return 1;
313                         }
314                 }
315                 return 0;
316         }
317         if ($piece eq 'P') {
318                 # white pawn
319                 if ($to_col == $from_col && $to_row == $from_row - 1) {
320                         return ($dest_piece eq '-');
321                 }
322                 if ($to_col == $from_col && $from_row == 6 && $to_row == 4) {
323                         my $middle_piece = $board->[5][$to_col];
324                         return ($dest_piece eq '-' && $middle_piece eq '-');
325                 }
326                 if (abs($to_col - $from_col) == 1 && $to_row == $from_row - 1) {
327                         if ($dest_piece eq '-') {
328                                 # En passant. TODO: check that the last move was indeed an EP move
329                                 return ($to_row == 2 && $board->[3][$to_col] eq 'p');
330                         } else {
331                                 return 1;
332                         }
333                 }
334                 return 0;
335         }
336         
337         # unknown piece
338         return 0;
339 }
340
341 # Returns 'none', 'white', 'black' or 'both', depending on which sides are in check.
342 # The latter naturally indicates an invalid position.
343 sub in_check {
344         my $board = shift;
345         my ($black_check, $white_check) = (0, 0);
346
347         my ($wkr, $wkc, $bkr, $bkc) = _find_kings($board);
348
349         # check all pieces for the possibility of threatening the two kings
350         for my $row (0..7) {
351                 for my $col (0..7) {
352                         my $piece = $board->[$row][$col];
353                         next if ($piece eq '-');
354                 
355                         if (uc($piece) eq $piece) {
356                                 # white piece
357                                 $black_check = 1 if ($board->can_reach($piece, $row, $col, $bkr, $bkc));
358                         } else {
359                                 # black piece
360                                 $white_check = 1 if ($board->can_reach($piece, $row, $col, $wkr, $wkc));
361                         }
362                 }
363         }
364
365         if ($black_check && $white_check) {
366                 return 'both';
367         } elsif ($black_check) {
368                 return 'black';
369         } elsif ($white_check) {
370                 return 'white';
371         } else {
372                 return 'none';
373         }
374 }
375
376 sub _find_kings {
377         my $board = shift;
378         my ($wkr, $wkc, $bkr, $bkc);
379
380         for my $row (0..7) {
381                 for my $col (0..7) {
382                         my $piece = $board->[$row][$col];
383                         if ($piece eq 'K') {
384                                 ($wkr, $wkc) = ($row, $col);
385                         } elsif ($piece eq 'k') {
386                                 ($bkr, $bkc) = ($row, $col);
387                         }
388                 }
389         }
390
391         return ($wkr, $wkc, $bkr, $bkc);
392 }
393
394 # Returns if any side is in mate.
395 sub in_mate {
396         my $board = shift;
397         my $check = $board->in_check();
398         return 0 if ($check eq 'none');
399
400         # try all possible moves for the side in check
401         for my $row (0..7) {
402                 for my $col (0..7) {
403                         my $piece = $board->[$row][$col];
404                         next if ($piece eq '-');
405
406                         if ($check eq 'white') {
407                                 next if ($piece eq lc($piece));
408                         } else {
409                                 next if ($piece eq uc($piece));
410                         }
411
412                         for my $dest_row (0..7) {
413                                 for my $dest_col (0..7) {
414                                         next if ($row == $dest_row && $col == $dest_col);
415                                         next unless ($board->can_reach($piece, $row, $col, $dest_row, $dest_col));
416
417                                         my $nb = $board->clone();
418                                         $nb->[$row][$col] = '-';
419                                         $nb->[$dest_row][$dest_col] = $piece;
420                                         my $new_check = $nb->in_check();
421                                         return 0 if ($new_check ne $check && $new_check ne 'both');
422                                 }
423                         }
424                 }
425         }
426
427         # nothing to do; mate
428         return 1;
429 }
430
431 # Returns the short algebraic form of the move, as well as the new position.
432 sub prettyprint_move {
433         my ($board, $from_row, $from_col, $to_row, $to_col, $promo) = @_;
434         my $pretty = $board->_prettyprint_move_no_check_or_mate($from_row, $from_col, $to_row, $to_col, $promo);
435
436         my $nb = $board->make_move($from_row, $from_col, $to_row, $to_col, $promo);
437         if ($nb->in_mate()) {
438                 $pretty .= '#';
439         } elsif ($nb->in_check() ne 'none') {
440                 $pretty .= '+';
441         }
442         return ($pretty, $nb);
443 }
444
445 sub _prettyprint_move_no_check_or_mate {
446         my ($board, $from_row, $from_col, $to_row, $to_col, $promo) = @_;
447         my $piece = $board->[$from_row][$from_col];
448         my $move = move_to_uci_notation($from_row, $from_col, $to_row, $to_col, $promo);
449
450         if ($piece eq '-') {
451                 die "Invalid move $move";
452         }
453
454         # white short castling
455         if ($move eq 'e1g1' && $piece eq 'K') {
456                 return '0-0';
457         }
458
459         # white long castling
460         if ($move eq 'e1c1' && $piece eq 'K') {
461                 return '0-0-0';
462         }
463
464         # black short castling
465         if ($move eq 'e8g8' && $piece eq 'k') {
466                 return '0-0';
467         }
468
469         # black long castling
470         if ($move eq 'e8c8' && $piece eq 'k') {
471                 return '0-0-0';
472         }
473
474         my $pretty;
475
476         # check if the from-piece is a pawn
477         if (lc($piece) eq 'p') {
478                 # attack?
479                 if ($from_col != $to_col) {
480                         $pretty = substr($move, 0, 1) . 'x' . _pos_to_square($to_row, $to_col);
481                 } else {
482                         $pretty = _pos_to_square($to_row, $to_col);
483
484                         if (defined($promo) && $promo ne '') {
485                                 # promotion
486                                 $pretty .= "=";
487                                 $pretty .= $promo;
488                         }
489                 }
490                 return $pretty;
491         }
492
493         $pretty = uc($piece);
494
495         # see how many of these pieces could go here, in all
496         my $num_total = 0;
497         for my $col (0..7) {
498                 for my $row (0..7) {
499                         next unless ($board->[$row][$col] eq $piece);
500                         ++$num_total if ($board->can_reach($piece, $row, $col, $to_row, $to_col));
501                 }
502         }
503
504         # see how many of these pieces from the given row could go here
505         my $num_row = 0;
506         for my $col (0..7) {
507                 next unless ($board->[$from_row][$col] eq $piece);
508                 ++$num_row if ($board->can_reach($piece, $from_row, $col, $to_row, $to_col));
509         }
510
511         # and same for columns
512         my $num_col = 0;
513         for my $row (0..7) {
514                 next unless ($board->[$row][$from_col] eq $piece);
515                 ++$num_col if ($board->can_reach($piece, $row, $from_col, $to_row, $to_col));
516         }
517
518         # see if we need to disambiguate
519         if ($num_total > 1) {
520                 if ($num_col == 1) {
521                         $pretty .= substr($move, 0, 1);
522                 } elsif ($num_row == 1) {
523                         $pretty .= substr($move, 1, 1);
524                 } else {
525                         $pretty .= substr($move, 0, 2);
526                 }
527         }
528
529         # attack?
530         if ($board->[$to_row][$to_col] ne '-') {
531                 $pretty .= 'x';
532         }
533
534         $pretty .= _pos_to_square($to_row, $to_col);
535         return $pretty;
536 }
537
538 1;