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         # 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;