feb48937ebe94a5f7036b80f697ced09699b89f5
[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                 for my $col (0..7) {
29                         $nb->[$row][$col] = $board->[$row][$col];
30                 }
31         }
32
33         return bless $nb;
34 }
35
36 # Returns a new board.
37 sub make_move {
38         my ($board, $from_row, $from_col, $to_row, $to_col, $promo) = @_;
39         my $move = _move_to_uci_notation($from_row, $from_col, $to_row, $to_col, $promo);
40         my $piece = $board->[$from_row][$from_col];
41         my $nb = $board->clone();
42
43         if ($piece eq '-') {
44                 die "Invalid move $move";
45         }
46
47         # white short castling
48         if ($move eq 'e1g1' && $piece eq 'K') {
49                 # king
50                 $nb->[7][4] = '-';
51                 $nb->[7][6] = $piece;
52
53                 # rook
54                 $nb->[7][7] = '-';
55                 $nb->[7][5] = 'R';
56
57                 return $nb;
58         }
59
60         # white long castling
61         if ($move eq 'e1c1' && $piece eq 'K') {
62                 # king
63                 $nb->[7][4] = '-';
64                 $nb->[7][2] = $piece;
65
66                 # rook
67                 $nb->[7][0] = '-';
68                 $nb->[7][3] = 'R';
69
70                 return $nb;
71         }
72
73         # black short castling
74         if ($move eq 'e8g8' && $piece eq 'k') {
75                 # king
76                 $nb->[0][4] = '-';
77                 $nb->[0][6] = $piece;
78
79                 # rook
80                 $nb->[0][7] = '-';
81                 $nb->[0][5] = 'r';
82
83                 return $nb;
84         }
85
86         # black long castling
87         if ($move eq 'e8c8' && $piece eq 'k') {
88                 # king
89                 $nb->[0][4] = '-';
90                 $nb->[0][2] = $piece;
91
92                 # rook
93                 $nb->[0][0] = '-';
94                 $nb->[0][3] = 'r';
95
96                 return $nb;
97         }
98
99         # check if the from-piece is a pawn
100         if (lc($piece) eq 'p') {
101                 # attack?
102                 if ($from_col != $to_col) {
103                         # en passant?
104                         if ($board->[$to_row][$to_col] eq '-') {
105                                 if ($piece eq 'p') {
106                                         $nb->[$to_row + 1][$to_col] = '-';
107                                 } else {
108                                         $nb->[$to_row - 1][$to_col] = '-';
109                                 }
110                         }
111                 } else {
112                         if ($promo ne '') {
113                                 if ($piece eq 'p') {
114                                         $piece = $promo;
115                                 } else {
116                                         $piece = uc($promo);
117                                 }
118                         }
119                 }
120         }
121
122         # update the board
123         $nb->[$from_row][$from_col] = '-';
124         $nb->[$to_row][$to_col] = $piece;
125
126         return $nb;
127 }
128
129 sub _move_to_uci_notation {
130         my ($from_row, $from_col, $to_row, $to_col, $promo) = @_;
131         $promo //= "";
132         return sprintf("%c%d%c%d%s", ord('a') + $from_col, 8 - $from_row, ord('a') + $to_col, 8 - $to_row, $promo);
133 }
134
135 sub fen {
136         my ($board) = @_;
137         my @rows = ();
138         for my $row (0..7) {
139                 my $str = join('', @{$board->[$row]});
140                 $str =~ s/(-+)/length($1)/ge;
141                 push @rows, $str;
142         }
143
144         return join('/', @rows);
145 }
146
147 sub can_reach {
148         my ($board, $piece, $from_row, $from_col, $to_row, $to_col) = @_;
149         
150         # can't eat your own piece
151         my $dest_piece = $board->[$to_row][$to_col];
152         if ($dest_piece ne '-') {
153                 return 0 if (($piece eq lc($piece)) == ($dest_piece eq lc($dest_piece)));
154         }
155
156         if (lc($piece) eq 'k') {
157                 return (abs($from_row - $to_row) <= 1 && abs($from_col - $to_col) <= 1);
158         }
159         if (lc($piece) eq 'r') {
160                 return 0 unless ($from_row == $to_row || $from_col == $to_col);
161
162                 # check that there's a clear passage
163                 if ($from_row == $to_row) {
164                         if ($from_col > $to_col) {
165                                 ($to_col, $from_col) = ($from_col, $to_col);
166                         }
167
168                         for my $c (($from_col+1)..($to_col-1)) {
169                                 my $middle_piece = $board->[$to_row][$c];
170                                 return 0 if ($middle_piece ne '-');
171                         }
172
173                         return 1;
174                 } else {
175                         if ($from_row > $to_row) {
176                                 ($to_row, $from_row) = ($from_row, $to_row);
177                         }
178
179                         for my $r (($from_row+1)..($to_row-1)) {
180                                 my $middle_piece = $board->[$r][$to_col];
181                                 return 0 if ($middle_piece ne '-');     
182                         }
183
184                         return 1;
185                 }
186         }
187         if (lc($piece) eq 'b') {
188                 return 0 unless (abs($from_row - $to_row) == abs($from_col - $to_col));
189
190                 my $dr = ($to_row - $from_row) / abs($to_row - $from_row);
191                 my $dc = ($to_col - $from_col) / abs($to_col - $from_col);
192
193                 my $r = $from_row + $dr;
194                 my $c = $from_col + $dc;
195
196                 while ($r != $to_row) {
197                         my $middle_piece = $board->[$r][$c];
198                         return 0 if ($middle_piece ne '-');
199                         
200                         $r += $dr;
201                         $c += $dc;
202                 }
203
204                 return 1;
205         }
206         if (lc($piece) eq 'n') {
207                 my $diff_r = abs($from_row - $to_row);
208                 my $diff_c = abs($from_col - $to_col);
209                 return 1 if ($diff_r == 2 && $diff_c == 1);
210                 return 1 if ($diff_r == 1 && $diff_c == 2);
211                 return 0;
212         }
213         if ($piece eq 'q') {
214                 return (can_reach($board, 'r', $from_row, $from_col, $to_row, $to_col) ||
215                         can_reach($board, 'b', $from_row, $from_col, $to_row, $to_col));
216         }
217         if ($piece eq 'Q') {
218                 return (can_reach($board, 'R', $from_row, $from_col, $to_row, $to_col) ||
219                         can_reach($board, 'B', $from_row, $from_col, $to_row, $to_col));
220         }
221
222         # TODO: en passant
223         if ($piece eq 'p') {
224                 # black pawn
225                 if ($to_col == $from_col && $to_row == $from_row + 1) {
226                         return ($dest_piece eq '-');
227                 }
228                 if ($to_col == $from_col && $from_row == 1 && $to_row == 3) {
229                         my $middle_piece = $board->[2][$to_col];
230                         return ($dest_piece eq '-' && $middle_piece eq '-');
231                 }
232                 if (abs($to_col - $from_col) == 1 && $to_row == $from_row + 1) {
233                         return ($dest_piece ne '-');
234                 }
235                 return 0;
236         }
237         if ($piece eq 'P') {
238                 # white pawn
239                 if ($to_col == $from_col && $to_row == $from_row - 1) {
240                         return ($dest_piece eq '-');
241                 }
242                 if ($to_col == $from_col && $from_row == 6 && $to_row == 4) {
243                         my $middle_piece = $board->[5][$to_col];
244                         return ($dest_piece eq '-' && $middle_piece eq '-');
245                 }
246                 if (abs($to_col - $from_col) == 1 && $to_row == $from_row - 1) {
247                         return ($dest_piece ne '-');
248                 }
249                 return 0;
250         }
251         
252         # unknown piece
253         return 0;
254 }
255
256 # Returns 'none', 'white', 'black' or 'both', depending on which sides are in check.
257 # The latter naturally indicates an invalid position.
258 sub in_check {
259         my $board = shift;
260         my ($black_check, $white_check) = (0, 0);
261
262         my ($wkr, $wkc, $bkr, $bkc) = _find_kings($board);
263
264         # check all pieces for the possibility of threatening the two kings
265         for my $row (0..7) {
266                 for my $col (0..7) {
267                         my $piece = $board->[$row][$col];
268                         next if ($piece eq '-');
269                 
270                         if (uc($piece) eq $piece) {
271                                 # white piece
272                                 $black_check = 1 if ($board->can_reach($piece, $row, $col, $bkr, $bkc));
273                         } else {
274                                 # black piece
275                                 $white_check = 1 if ($board->can_reach($piece, $row, $col, $wkr, $wkc));
276                         }
277                 }
278         }
279
280         if ($black_check && $white_check) {
281                 return 'both';
282         } elsif ($black_check) {
283                 return 'black';
284         } elsif ($white_check) {
285                 return 'white';
286         } else {
287                 return 'none';
288         }
289 }
290
291 sub _find_kings {
292         my $board = shift;
293         my ($wkr, $wkc, $bkr, $bkc);
294
295         for my $row (0..7) {
296                 for my $col (0..7) {
297                         my $piece = $board->[$row][$col];
298                         if ($piece eq 'K') {
299                                 ($wkr, $wkc) = ($row, $col);
300                         } elsif ($piece eq 'k') {
301                                 ($bkr, $bkc) = ($row, $col);
302                         }
303                 }
304         }
305
306         return ($wkr, $wkc, $bkr, $bkc);
307 }
308
309 # Returns if any side is in mate.
310 sub in_mate {
311         my $board = shift;
312         my $check = $board->in_check();
313         return 0 if ($check eq 'none');
314
315         # try all possible moves for the side in check
316         for my $row (0..7) {
317                 for my $col (0..7) {
318                         my $piece = $board->[$row][$col];
319                         next if ($piece eq '-');
320
321                         if ($check eq 'white') {
322                                 next if ($piece eq lc($piece));
323                         } else {
324                                 next if ($piece eq uc($piece));
325                         }
326
327                         for my $dest_row (0..7) {
328                                 for my $dest_col (0..7) {
329                                         next if ($row == $dest_row && $col == $dest_col);
330                                         next unless ($board->can_reach($piece, $row, $col, $dest_row, $dest_col));
331
332                                         my $nb = $board->clone();
333                                         $nb->[$row][$col] = '-';
334                                         $nb->[$dest_row][$dest_col] = $piece;
335                                         my $new_check = $nb->in_check();
336                                         return 0 if ($new_check ne $check && $new_check ne 'both');
337                                 }
338                         }
339                 }
340         }
341
342         # nothing to do; mate
343         return 1;
344 }
345
346 1;