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