3 # There are too many chess modules on CPAN already, so here's another one...
13 # Takes in a FICS style 12-type position.
15 my ($class, $str) = @_;
17 my (@x) = split / /, $str;
19 $pos->{'board'} = Board->new(@x[1..8]);
20 $pos->{'toplay'} = $x[9];
21 $pos->{'ep_file_num'} = $x[10];
22 $pos->{'white_castle_k'} = $x[11] ? 'h' : undef;
23 $pos->{'white_castle_q'} = $x[12] ? 'a' : undef;
24 $pos->{'black_castle_k'} = $x[13] ? 'h' : undef;
25 $pos->{'black_castle_q'} = $x[14] ? 'a' : undef;
26 $pos->{'time_since_100move_rule_reset'} = $x[15];
27 $pos->{'player_w'} = $x[17];
28 $pos->{'player_b'} = $x[18];
29 $pos->{'player_w'} =~ s/^W?[FCIG]M//;
30 $pos->{'player_b'} =~ s/^W?[FCIG]M//;
31 $pos->{'white_clock'} = $x[24];
32 $pos->{'black_clock'} = $x[25];
33 $pos->{'move_num'} = $x[26];
34 if ($x[27] =~ /([a-h][1-8])-([a-h][1-8])/) {
35 $pos->{'last_move_uci'} = $1 . $2;
37 $pos->{'last_move_uci'} = undef;
39 $pos->{'last_move'} = $x[29];
40 $pos->{'prettyprint_cache'} = {};
41 $pos->{'tbprobe_cache'} = {};
48 my ($class, $white, $black) = @_;
49 $white = "base64:" . MIME::Base64::encode_base64($white);
50 $black = "base64:" . MIME::Base64::encode_base64($black);
51 return $class->new("<12> rnbqkbnr pppppppp -------- -------- -------- -------- PPPPPPPP RNBQKBNR W -1 1 1 1 1 0 dummygamenum $white $black -2 dummytime dummyincrement 39 39 dummytime dummytime 1 none (0:00) none 0 0 0");
55 my ($class, $fen) = @_;
56 my ($board, $toplay, $castling, $ep_square, $halfmove_clock, $fullmove_clock) = split / /, $fen;
59 $board =~ s/(\d)/"-"x$1/ge;
60 $pos->{'board'} = Board->new(split /\//, $board);
61 $board = $pos->{'board'};
62 $pos->{'toplay'} = uc($toplay);
64 if ($ep_square =~ /^([a-h])/) {
65 $pos->{'ep_file_num'} = ord($1) - ord('a');
67 $pos->{'ep_file_num'} = -1;
70 # X-FEN castling rights parsing.
71 if ($castling =~ /K/) {
72 $pos->{'white_castle_k'} = _col_num_to_letter(_find_piece_col_from_right($board->[7], 'R'));
74 if ($castling =~ /Q/) {
75 $pos->{'white_castle_q'} = _col_num_to_letter(_find_piece_col($board->[7], 'R'));
77 while ($castling =~ s/([A-H])//) {
78 my $rook_col = lc($1);
79 my $king_col = _col_num_to_letter(_find_piece_col($board->[7], 'K'));
80 if ($rook_col lt $king_col) {
81 $pos->{'white_castle_q'} = $rook_col;
83 $pos->{'white_castle_k'} = $rook_col;
86 if ($castling =~ /k/) {
87 $pos->{'black_castle_k'} = _col_num_to_letter(_find_piece_col_from_right($board->[0], 'r'));
89 if ($castling =~ /q/) {
90 $pos->{'black_castle_q'} = _col_num_to_letter(_find_piece_col($board->[0], 'r'));
92 while ($castling =~ s/([a-h])//) {
94 my $king_col = _col_num_to_letter(_find_piece_col($board->[0], 'k'));
95 if ($rook_col lt $king_col) {
96 $pos->{'black_castle_q'} = $rook_col;
98 $pos->{'black_castle_k'} = $rook_col;
101 $pos->{'time_since_100move_rule_reset'} = $halfmove_clock // 0;
102 $pos->{'player_w'} = 'white';
103 $pos->{'player_b'} = 'black';
104 $pos->{'white_clock'} = 0;
105 $pos->{'black_clock'} = 0;
106 $pos->{'move_num'} = $fullmove_clock // 0;
107 $pos->{'last_move_uci'} = undef;
108 $pos->{'last_move'} = undef;
109 $pos->{'prettyprint_cache'} = {};
110 $pos->{'tbprobe_cache'} = {};
120 my $fen = $pos->{'board'}->fen();
122 # white/black to move
124 $fen .= lc($pos->{'toplay'});
126 # Castling (X-FEN compatible).
128 if (defined($pos->{'white_castle_k'})) {
129 my $outer_rook_col = _col_num_to_letter(_find_piece_col_from_right($pos->{'board'}[7], 'R'));
130 if ($outer_rook_col eq $pos->{'white_castle_k'}) {
133 $castling .= uc($pos->{'white_castle_k'});
136 if (defined($pos->{'white_castle_q'})) {
137 my $outer_rook_col = _col_num_to_letter(_find_piece_col($pos->{'board'}[7], 'R'));
138 if ($outer_rook_col eq $pos->{'white_castle_q'}) {
141 $castling .= uc($pos->{'white_castle_q'});
144 if (defined($pos->{'black_castle_k'})) {
145 my $outer_rook_col = _col_num_to_letter(_find_piece_col_from_right($pos->{'board'}[0], 'r'));
146 if ($outer_rook_col eq $pos->{'black_castle_k'}) {
149 $castling .= $pos->{'black_castle_k'};
152 if (defined($pos->{'black_castle_q'})) {
153 my $outer_rook_col = _col_num_to_letter(_find_piece_col($pos->{'board'}[0], 'r'));
154 if ($outer_rook_col eq $pos->{'black_castle_q'}) {
157 $castling .= $pos->{'black_castle_q'};
160 $castling = "-" if ($castling eq "");
161 # $castling = "-"; # chess960
167 if ($pos->{'ep_file_num'} != -1) {
168 my $col = $pos->{'ep_file_num'};
169 $ep = (qw(a b c d e f g h))[$col];
171 if ($pos->{'toplay'} eq 'B') {
182 $fen .= $pos->{'time_since_100move_rule_reset'};
186 $fen .= $pos->{'move_num'};
193 my $json = { %$pos, fen => $pos->fen() };
194 delete $json->{'board'};
195 delete $json->{'prettyprint_cache'};
196 delete $json->{'tbprobe_cache'};
197 delete $json->{'black_castle_k'};
198 delete $json->{'black_castle_q'};
199 delete $json->{'white_castle_k'};
200 delete $json->{'white_castle_q'};
201 delete $json->{'time_since_100move_rule_reset'};
202 delete $json->{'chess960'} if (!$json->{'chess960'});
203 if ($json->{'player_w'} =~ /^base64:(.*)$/) {
204 $json->{'player_w'} = MIME::Base64::decode_base64($1);
206 if ($json->{'player_b'} =~ /^base64:(.*)$/) {
207 $json->{'player_b'} = MIME::Base64::decode_base64($1);
212 sub parse_pretty_move {
213 my ($pos, $move) = @_;
214 return $pos->{'board'}->parse_pretty_move($move, $pos->{'toplay'}, $pos->{'chess960'}, $pos->{'white_castle_k'}, $pos->{'white_castle_q'}, $pos->{'black_castle_k'}, $pos->{'black_castle_q'});
219 return $pos->{'board'}->num_pieces();
222 # Returns a new Position object.
224 my ($pos, $from_row, $from_col, $to_row, $to_col, $promo, $pretty_move) = @_;
226 my $from_square = _pos_to_square($from_row, $from_col);
227 my $to_square = _pos_to_square($to_row, $to_col);
230 $np->{'board'} = $pos->{'board'}->make_move($from_row, $from_col, $to_row, $to_col, $promo);
231 if ($pos->{'toplay'} eq 'W') {
232 $np->{'toplay'} = 'B';
233 $np->{'move_num'} = $pos->{'move_num'};
235 $np->{'toplay'} = 'W';
236 $np->{'move_num'} = $pos->{'move_num'} + 1;
239 my $piece = $pos->{'board'}[$from_row][$from_col];
240 my $dest_piece = $pos->{'board'}[$to_row][$to_col];
242 # Find out if this was a two-step pawn move.
243 if (lc($piece) eq 'p' && abs($from_row - $to_row) == 2) {
244 $np->{'ep_file_num'} = $from_col;
246 $np->{'ep_file_num'} = -1;
250 $np->{'white_castle_k'} = $pos->{'white_castle_k'};
251 $np->{'white_castle_q'} = $pos->{'white_castle_q'};
252 $np->{'black_castle_k'} = $pos->{'black_castle_k'};
253 $np->{'black_castle_q'} = $pos->{'black_castle_q'};
255 $np->{'white_castle_k'} = undef;
256 $np->{'white_castle_q'} = undef;
257 } elsif ($piece eq 'k') {
258 $np->{'black_castle_k'} = undef;
259 $np->{'black_castle_q'} = undef;
260 } elsif (defined($np->{'white_castle_q'}) &&
261 ($from_square eq ($np->{'white_castle_q'} . '1') ||
262 $to_square eq ($np->{'white_castle_q'} . '1'))) {
263 $np->{'white_castle_q'} = undef;
264 } elsif (defined($np->{'white_castle_k'}) &&
265 ($from_square eq ($np->{'white_castle_k'} . '1') ||
266 $to_square eq ($np->{'white_castle_k'} . '1'))) {
267 $np->{'white_castle_k'} = undef;
268 } elsif (defined($np->{'black_castle_q'}) &&
269 ($from_square eq ($np->{'black_castle_q'} . '8') ||
270 $to_square eq ($np->{'black_castle_q'} . '8'))) {
271 $np->{'black_castle_q'} = undef;
272 } elsif (defined($np->{'black_castle_k'}) &&
273 ($from_square eq ($np->{'black_castle_k'} . '8') ||
274 $to_square eq ($np->{'black_castle_k'} . '8'))) {
275 $np->{'black_castle_k'} = undef;
278 # 50-move rule. Note that castle does not reset the counter, per FIDE rules.
279 my $castling = (lc($piece) eq 'k' && abs($from_col - $to_col) > 1) || # King moves two squares.
280 ($piece eq 'K' && $dest_piece eq 'R') || # Chess960-style king-takes-rook.
281 ($piece eq 'k' && $dest_piece eq 'r');
282 if (!$castling && (lc($piece) eq 'p' || $dest_piece ne '-')) {
283 $np->{'time_since_100move_rule_reset'} = 0;
285 $np->{'time_since_100move_rule_reset'} = $pos->{'time_since_100move_rule_reset'} + 1;
287 $np->{'player_w'} = $pos->{'player_w'};
288 $np->{'player_b'} = $pos->{'player_b'};
289 $np->{'chess960'} = $pos->{'chess960'};
290 if (exists($pos->{'start_fen'})) {
291 $np->{'start_fen'} = $pos->{'start_fen'};
293 if (defined($pretty_move)) {
294 $np->{'last_move'} = $pretty_move;
296 my ($move, $nb) = $pos->{'board'}->prettyprint_move($from_row, $from_col, $to_row, $to_col, $promo);
297 $np->{'last_move'} = $move;
299 $np->{'last_move_uci'} = Board::move_to_uci_notation($from_row, $from_col, $to_row, $to_col, $promo);
304 # Returns a new Position object, and the parsed UCI move.
305 sub make_pretty_move {
306 my ($pos, $move) = @_;
308 my ($from_row, $from_col, $to_row, $to_col, $promo) = $pos->parse_pretty_move($move);
309 my $uci_move = Board::move_to_uci_notation($from_row, $from_col, $to_row, $to_col, $promo);
310 $pos = $pos->make_move($from_row, $from_col, $to_row, $to_col, $promo);
311 return ($pos, $uci_move);
315 my ($row, $col) = @_;
316 return sprintf("%c%d", ord('a') + $col, 8 - $row);
323 for my $pv_move (@pv) {
324 my ($from_row, $from_col, $to_row, $to_col, $promo) = _parse_uci_move($pv_move);
325 $pvpos = $pvpos->make_move($from_row, $from_col, $to_row, $to_col, $promo);
331 sub _col_num_to_letter {
333 return sprintf("%c", ord('a') + $col);
336 sub _col_letter_to_num {
337 return ord(shift) - ord('a');
340 sub _row_letter_to_num {
341 return 7 - (ord(shift) - ord('1'));
344 sub _find_piece_col {
345 my ($row, $piece) = @_;
347 return $col if ($row->[$col] eq $piece);
349 die "Could not find piece $piece";
352 sub _find_piece_col_from_right {
353 my ($row, $piece) = @_;
354 for my $col (reverse 0..7) {
355 return $col if ($row->[$col] eq $piece);
357 die "Could not find piece $piece";
360 sub _parse_uci_move {
362 my $from_col = _col_letter_to_num(substr($move, 0, 1));
363 my $from_row = _row_letter_to_num(substr($move, 1, 1));
364 my $to_col = _col_letter_to_num(substr($move, 2, 1));
365 my $to_row = _row_letter_to_num(substr($move, 3, 1));
366 my $promo = substr($move, 4, 1);
367 return ($from_row, $from_col, $to_row, $to_col, $promo);