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