3 # There are too many chess modules on CPAN already, so here's another one...
11 my ($class, @rows) = @_;
16 $board->[$row][$col] = substr($rows[$row], $col, 1);
29 $nb->[$row][$col] = $board->[$row][$col];
36 # Returns a new board.
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();
44 die "Invalid move $move";
47 # white short castling
48 if ($move eq 'e1g1' && $piece eq 'K') {
61 if ($move eq 'e1c1' && $piece eq 'K') {
73 # black short castling
74 if ($move eq 'e8g8' && $piece eq 'k') {
87 if ($move eq 'e8c8' && $piece eq 'k') {
99 # check if the from-piece is a pawn
100 if (lc($piece) eq 'p') {
102 if ($from_col != $to_col) {
104 if ($board->[$to_row][$to_col] eq '-') {
106 $nb->[$to_row + 1][$to_col] = '-';
108 $nb->[$to_row - 1][$to_col] = '-';
123 $nb->[$from_row][$from_col] = '-';
124 $nb->[$to_row][$to_col] = $piece;
129 sub _move_to_uci_notation {
130 my ($from_row, $from_col, $to_row, $to_col, $promo) = @_;
132 return sprintf("%c%d%c%d%s", ord('a') + $from_col, 8 - $from_row, ord('a') + $to_col, 8 - $to_row, $promo);
139 my $str = join('', @{$board->[$row]});
140 $str =~ s/(-+)/length($1)/ge;
144 return join('/', @rows);
148 my ($board, $piece, $from_row, $from_col, $to_row, $to_col) = @_;
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)));
156 if (lc($piece) eq 'k') {
157 return (abs($from_row - $to_row) <= 1 && abs($from_col - $to_col) <= 1);
159 if (lc($piece) eq 'r') {
160 return 0 unless ($from_row == $to_row || $from_col == $to_col);
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);
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 '-');
175 if ($from_row > $to_row) {
176 ($to_row, $from_row) = ($from_row, $to_row);
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 '-');
187 if (lc($piece) eq 'b') {
188 return 0 unless (abs($from_row - $to_row) == abs($from_col - $to_col));
190 my $dr = ($to_row - $from_row) / abs($to_row - $from_row);
191 my $dc = ($to_col - $from_col) / abs($to_col - $from_col);
193 my $r = $from_row + $dr;
194 my $c = $from_col + $dc;
196 while ($r != $to_row) {
197 my $middle_piece = $board->[$r][$c];
198 return 0 if ($middle_piece ne '-');
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);
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));
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));
225 if ($to_col == $from_col && $to_row == $from_row + 1) {
226 return ($dest_piece eq '-');
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 '-');
232 if (abs($to_col - $from_col) == 1 && $to_row == $from_row + 1) {
233 return ($dest_piece ne '-');
239 if ($to_col == $from_col && $to_row == $from_row - 1) {
240 return ($dest_piece eq '-');
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 '-');
246 if (abs($to_col - $from_col) == 1 && $to_row == $from_row - 1) {
247 return ($dest_piece ne '-');
256 # Returns 'none', 'white', 'black' or 'both', depending on which sides are in check.
257 # The latter naturally indicates an invalid position.
260 my ($black_check, $white_check) = (0, 0);
262 my ($wkr, $wkc, $bkr, $bkc) = _find_kings($board);
264 # check all pieces for the possibility of threatening the two kings
267 my $piece = $board->[$row][$col];
268 next if ($piece eq '-');
270 if (uc($piece) eq $piece) {
272 $black_check = 1 if ($board->can_reach($piece, $row, $col, $bkr, $bkc));
275 $white_check = 1 if ($board->can_reach($piece, $row, $col, $wkr, $wkc));
280 if ($black_check && $white_check) {
282 } elsif ($black_check) {
284 } elsif ($white_check) {
293 my ($wkr, $wkc, $bkr, $bkc);
297 my $piece = $board->[$row][$col];
299 ($wkr, $wkc) = ($row, $col);
300 } elsif ($piece eq 'k') {
301 ($bkr, $bkc) = ($row, $col);
306 return ($wkr, $wkc, $bkr, $bkc);
309 # Returns if any side is in mate.
312 my $check = $board->in_check();
313 return 0 if ($check eq 'none');
315 # try all possible moves for the side in check
318 my $piece = $board->[$row][$col];
319 next if ($piece eq '-');
321 if ($check eq 'white') {
322 next if ($piece eq lc($piece));
324 next if ($piece eq uc($piece));
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));
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');
342 # nothing to do; mate