git.sesse.net Git - remoteglot/blob - 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;