Some minor style12 parsing fixups.
[remoteglot] / Position.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 require 'Board.pm';
9
10 package Position;
11
12 # Takes in a FICS style 12-type position.
13 sub new {
14         my ($class, $str) = @_;
15         my $pos = {};
16         my (@x) = split / /, $str;
17
18         $pos->{'board'} = Board->new(@x[1..8]);
19         $pos->{'toplay'} = $x[9];
20         $pos->{'ep_file_num'} = $x[10];
21         $pos->{'white_castle_k'} = $x[11];
22         $pos->{'white_castle_q'} = $x[12];
23         $pos->{'black_castle_k'} = $x[13];
24         $pos->{'black_castle_q'} = $x[14];
25         $pos->{'time_since_100move_rule_reset'} = $x[15];
26         $pos->{'player_w'} = $x[17];
27         $pos->{'player_b'} = $x[18];
28         $pos->{'player_w'} =~ s/^W?[FCIG]M//;
29         $pos->{'player_b'} =~ s/^W?[FCIG]M//;
30         $pos->{'move_num'} = $x[26];
31         $pos->{'last_move'} = $x[29];
32
33         bless $pos, $class;
34         return $pos;
35 }
36
37 sub fen {
38         my $pos = shift;
39
40         # the board itself
41         my $fen = $pos->{'board'}->fen();
42
43         # white/black to move
44         $fen .= " ";
45         $fen .= lc($pos->{'toplay'});
46
47         # castling
48         my $castling = "";
49         $castling .= "K" if ($pos->{'white_castle_k'} == 1);
50         $castling .= "Q" if ($pos->{'white_castle_q'} == 1);
51         $castling .= "k" if ($pos->{'black_castle_k'} == 1);
52         $castling .= "q" if ($pos->{'black_castle_q'} == 1);
53         $castling = "-" if ($castling eq "");
54         # $castling = "-"; # chess960
55         $fen .= " ";
56         $fen .= $castling;
57
58         # en passant
59         my $ep = "-";
60         if ($pos->{'ep_file_num'} != -1) {
61                 my $col = $pos->{'ep_file_num'};
62                 my $nep = (qw(a b c d e f g h))[$col];
63
64                 if ($pos->{'toplay'} eq 'B') {
65                         $nep .= "3";
66                 } else {
67                         $nep .= "6";
68                 }
69
70                 #
71                 # Showing the en passant square when actually no capture can be made
72                 # seems to confuse at least Rybka. Thus, check if there's actually
73                 # a pawn of the opposite side that can do the en passant move, and if
74                 # not, just lie -- it doesn't matter anyway. I'm unsure what's the
75                 # "right" thing as per the standard, though.
76                 #
77                 if ($pos->{'toplay'} eq 'B') {
78                         $ep = $nep if ($col > 0 && $pos->{'board'}[4][$col-1] eq 'p');
79                         $ep = $nep if ($col < 7 && $pos->{'board'}[4][$col+1] eq 'p');
80                 } else {
81                         $ep = $nep if ($col > 0 && $pos->{'board'}[3][$col-1] eq 'P');
82                         $ep = $nep if ($col < 7 && $pos->{'board'}[3][$col+1] eq 'P');
83                 }
84         }
85         $fen .= " ";
86         $fen .= $ep;
87
88         # half-move clock
89         $fen .= " ";
90         $fen .= $pos->{'time_since_100move_rule_reset'};
91
92         # full-move clock
93         $fen .= " ";
94         $fen .= $pos->{'move_num'};
95
96         return $fen;
97 }
98
99 sub to_json_hash {
100         my $pos = shift;
101         return { %$pos, board => undef, fen => $pos->fen() };
102 }
103
104 1;