File Coverage

blib/lib/Chess/ChessKit/Board.pm

Criterion	Covered	Total	%
statement	9	305	2.9
branch	0	106	0.0
condition	0	30	0.0
subroutine	3	23	13.0
pod			n/a
total	12	464	2.5

#!/usr/bin/perl -w
####-----------------------------------
### File	: Board.pm
### Author	: Ch.Minc
### Purpose	: Package for ChessKit
### Version	: 1.2 2007/02/22
### copyright GNU license
####-----------------------------------

package Board ;

#package Chess::ChessKit::Board;

use warnings;
use strict;
use Chess::ChessKit::Move   ;


=head1 NAME

ChessKit::Board

=head1 VERSION

Version 1.2

=cut

=head1 SYNOPSIS

see ChessKit

=head1 FUNCTIONS

=head2 sub bestmove

Get the Best move as TMN means
see ChessKit

=head2 sub boardcopy

see ChessKit

=head2 sub can_castling

see ChessKit

=head2 sub cantake

see ChessKit

=head2 sub castling

see ChessKit

=head2 sub chessmovcnt

see ChessKit

=head2 sub chessmovcntint

see ChessKit

=head2 sub chessview

see ChessKit

=head2 sub deletepiece

see ChessKit

=head2 sub getpiece

see ChessKit

=head2 sub has_moved

see ChessKit

=head2 sub is_shaked

see ChessKit

=head2 sub new

see ChessKit

=head2 sub print

see ChessKit

=head2 sub put

see ChessKit

=head2 sub startgame

see ChessKit

=head2 sub valid

see ChessKit

=head2 sub vldmov

see ChessKit

=head2 sub genfen

see ChessKit

=head2 getfen

see ChessKit

=cut

=head1 AUTHOR

Charles Minc, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2005 Charles Minc, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# NOTE: piece means any chess piece or pawn
# NOTE  Blacks are designed by lower case letters and Whites by upper ones

# Board means here the chessboard with the pieces on it.
# The object here hereafter is nothing more that the position
# of pieces on their sqares.

# pieces are in upper case for Whites and lower case for Blacks
# as usually written in FEN

our $VERSION = '1.1' ;



sub new {
  my ($class,@args)=@_ ;
  my $self={} ;
  return bless ($self,$class) ;
}

sub startgame {
  # initial starting position of the game
  #usage $self->startgame(%position)

  my ($self,%arg)=@_ ;
  %{$self}=() ;
  my %poset=(
	     'K'=>["e1"],
	     'k'=>["e8"],
	     'Q'=>["d1"],
	     'q'=>["d8"],
	     'R'=>[qw(a1 h1)],
	     'r'=>[qw(a8 h8)],
	     'B'=>[qw(c1 f1)],
	     'b'=>[qw(c8 f8)],
	     'N'=>[qw(b1 g1)],
	     'n'=>[qw(b8 g8)],
	     'P'=>[qw(a2 b2 c2 d2 e2 f2 g2 h2)],
	     'p'=>[qw(a7 b7 c7 d7 e7 f7 g7 h7)]
	    ) ;
  %poset=%arg ?%arg :%poset ;
  foreach my $p (qw(K Q R N B P k q r n b p)) {
    foreach (@{$poset{$p}}) {
      $self->put($p,$_) ;
    }
  }

}

sub put {
  # place a piece on the board
  my($self,$piece,$location)=@_ ;
  $$self{$location}=$piece ;
}

sub print {
  # print the position of the pieces
  my($self)=@_ ;
  foreach (keys %{$self}) {
    print " loc= $_  piece=$$self{$_} \n" ;
  }
}

  sub boardcopy {
    my ($self,$bddest)=@_ ;
    %{$bddest}=() ;
    %{$bddest}=%{$self} ;
  }
sub getpiece{
  my($self,$loc)=@_ ;
  return ($$self{$loc} ) ;
}

sub deletepiece{
  my($self,$loc)=@_ ;
  delete $$self{$loc} ;
}

sub chessview {
  my $self=shift ;
  print "\n" ;
  my @alpha=qw(a b c d e f g h) ;
  my @digit=qw(8 7 6 5 4 3 2 1) ;
  foreach my $num (@digit) {
    foreach my $let (@alpha) {
      my $p=$$self{$let.$num} ;
      print defined($p) ? $p : "." , " " ;
    }
    print "\n" ;
  }
  print "\n" ;
}

sub cantake{

  #usage $self->cantake(who=>'Q',where=>'h8')

  my ($self,%arg)=@_ ;
  my $piece=$arg{who} ;
  my $where=$arg{where} ;

  my %color=(qw /B 0 K 0 N 0 P 0 Q 0 R 0 U 0 b 1 k 1 n 1 p 1 q 1 r 1 u 1/ ) ;
  # U,u is used for pawn taking
  my $wanted=$self->getpiece($where) ;
  if (defined($wanted) && ($color{$piece} != $color{$wanted} )) {
    return $wanted ;
  } else {
    return "no" ;
  }
}

sub valid{
  # check valid moves
  my ($self,%arg)=@_ ;
  my $caval=$arg{mov} ;
  my $set=$arg{valid} ;
  my $piece=$arg{piece} ;

  my $i=0 ;
  for (  my $m=0 ; $m<=7 ;  $m++ ) {
    if (defined( @{$caval->[$m]})) {
      foreach (0..$#{$caval->[$m]}) {
	my $c= $caval->[$m][$_];
	my $p=$self->getpiece($c) ;
	# pawn catching
	if ($piece =~/U/i) {
	  $set->[$i++]=$c if ( $self->cantake(who=>$piece,where=>$c) ne "no" ) ;
	  last ;
	}
	if ( !defined($p) ) {
	  $set->[$i++]=$c ;
	} elsif ($piece =~/P/i) {
	  last ;
	} elsif ( $self->cantake(who=>$piece,where=>$c) eq "no") {
	  last ;
	} else {
	  $set->[$i++]=$c ; last ;
	}
      }
    }
  }
}



sub vldmov{

  my %default=(qw/recur yes/ ) ;
  my ($self,%arg)=@_ ;
  %arg=(%default,%arg) ;

  my $set=$arg{valid} ;
  my $piece=$arg{piece} ;
  my $num=$arg{row} ;
  my $let=$arg{col} ;
  my $control=$arg{recur} ;
  my $caval=[[]] ;
  $Move::gmv{$piece}(row=>$num-1, col =>ord($let)-ord('a'),mov=>$caval,color=>$piece) ;
  $self->valid(valid=>$set,mov=>$caval,piece=>$piece) ;

  # Treat the Pawn move as a special piece called U when capture

  if ($piece =~ /P/i) {
    my $upiece=($piece =~ /P/) ? 'U':'u' ;
    $caval=[[]] ;
    $Move::gmv{$upiece}(row=>$num-1, col =>ord($let)-ord('a'),mov=>$caval,color=>$upiece) ;
    my $uset=[] ;
    $self->valid(valid=>$uset,mov=>$caval,piece=>$upiece) ;
    @{$set}=(@{$set},@{$uset}) ;
  }
  return if ($control eq 'no') ;

  # a valid move is without check
  # if king is checked and no move without checks means mat
  # if king is w/o     and no move again   "       "    pat but


  my $uset=[] ;
  my $chkbd=Board->new() ;
  my $king= $piece =~ /[QKNBRPU]/ ? 'K':'k' ;
  foreach my $to (0..$#{$set}) {
    $self->boardcopy($chkbd) ;
    $chkbd->deletepiece($let.$num) ;
    $chkbd->put($piece,$set->[$to]) ;
    if ($chkbd->is_shaked(king=>$king,out=>'n') ne 'yes') {
      push(@{$uset},$set->[$to]) ;
    }
  }
  @{$set}=(@{$uset}) ;
}

sub chessmovcnt{
  # scan the board and count the valid moves
  # not removed for sake of backward compatibility
  # replaced by chessmovcnt
  my ($self,%arg)=@_ ;

  my %sum=('w'=>0,'b'=>0) ;

  foreach my $num (reverse 1..8) {
    foreach my $let ('a'..'h') {
      my $p=$$self{$let.$num} ;
      if (defined($p)) {
	my $set=[] ;
	$self->vldmov(row=>$num, col=>$let,piece=>$p,valid=>$set) ;
	$p =~ /[BKNPQR]/ ? ( $sum{w} +=@{$set}) :($sum{b} +=@{$set} ) ;
      }
    }
  }
  return ($sum{w},$sum{b}) ;
}

sub chessmovcntint{
  # scan the board and count the valid moves
  my ($self,%arg)=@_ ;

my %sum=('w'=>[],'b'=>[]) ;

  foreach my $num (reverse 1..8) {
    foreach my $let ('a'..'h') {
      my $p=$$self{$let.$num} ;
      if (defined($p)) {
	my $set=[] ;
	$self->vldmov(row=>$num, col=>$let,piece=>$p,valid=>$set) ;
	$p =~ /[BKNPQR]/ ? (push @{$sum{w}}, @{$set}) :(push @{$sum{b}},@{$set} ) ;
      }
    }
  }
return %sum ;
}

sub bestmove{
  my ($self)=@_ ;
  # parameters  w or b
  my %bm ;
  foreach my $loc (sort keys %{$self} ) {
    my $piece=$self->{$loc} ;
    my ($let,$num)=split('',$loc) ;
    my $set=[] ;
    $self->vldmov(row=>$num, col=>$let,piece=>$piece,valid=>$set) ;
    my $size=@{$set} ;
    foreach my $try (@{$set}) {
      my $capture=$self->{$try} ;
      $self->deletepiece($loc) ;
      $self->put($piece,$try) ;
      my $bset=[] ;
      my($sumw,$sumb)=$self->chessmovcnt ;
      $bm{$piece}{$loc}{$try}{'w'}=$sumw;
      $bm{$piece}{$loc}{$try}{'b'}=$sumb;
      defined($capture) ? $self->put($capture,$try):$self->deletepiece($try) ;
      $self->put($piece,$loc) ;
    }
  }
  my %max ;
  my %min ;
  #return $bm ;
  foreach my $color ('w','b') {
    my $max=0 ;
    my $min=1000 ;
    foreach my $piece (keys %bm) {
      foreach my $where (keys %{$bm{$piece}} ) {
	foreach my $to (keys %{$bm{$piece}{$where}} ) {

	  my $value= $bm{$piece}{$where}{$to}{$color} ;
	  $max=$max > $value ? $max : $value ;
	  $min=$min < $value ? $min : $value ;
	}
      }
    }
    $max{$color}=$max ;
    $min{$color}=$min ;
  }
  #print the min & max
  foreach my $color ('w','b') {
    foreach my $piece (keys %bm) {
      foreach my $where (keys %{$bm{$piece}} ) {
	foreach my $to (keys %{$bm{$piece}{$where}} ) {

	  my $value= $bm{$piece}{$where}{$to}{$color} ;
	  if ( ($value == $min{$color}) || ($value == $max{$color}) ) {
	    print " $piece from $where to $to give for $color :",$value,"\n" ;
	  }
	}
      }
    }
  }
}

sub is_shaked {
  my ($self,%arg)=@_ ;
  my $king=$arg{king} ;
  my $out=$arg{out} ;

  my $diag="" ;
  my $locking ;

  # where is the king
  foreach ( keys %{$self} ) {
    if ($king eq $self->{$_}) {
      $locking=$_ ; last ;
    }
  }
  my $color=$king =~/K/ ? "qknbrpu" : "QKNBRPU" ;
  foreach my $loc ( keys %{$self} ) {
    my $piece=$self->{$loc} ;
    if ($piece =~ /[$color]/) {
      my ($let,$num)=split('',$loc) ;
      my $set=[] ;
      $self->vldmov(row=>$num, col=>$let,piece=>$piece,valid=>$set,recur=>'no') ;
      my $size=@{$set} ;
      #    for debug
      #    foreach (0..$#{$set}){
      #    print " $king is shaked by $piece at $loc \n" if ($locking eq $set->[$_]) ;}
      # conditional outputting by flag $out='y'
      foreach (0..$#{$set}) {
	if ( defined( $set->[$_]) && ($locking eq $set->[$_]) ) {
	  $diag='yes' ;
	  print " $king is shaked by $piece at $loc \n" if ($out eq 'y') ;
	  # note: "shake" is a joke written here in place of "check" after a while writing this, ouf!
	}
      }
    }
  }
  return $diag ;
}


sub has_moved {

  # set the status of Rook and king to know if they are
  # always at there original place
  # must be called after every moves

  my ($self,%arg)=@_ ;
  my $status=$arg{status} ;
  my %default= (qw/ini no/) ;
  %arg=(%default,%arg) ;

  %{$status}=( qw/KK no  kk no KR no QR no kr no qr no/) if ($arg{ini} eq 'y') ;
  my %hereis=qw(KK e1 kk e8 KR h1 QR a1 kr h8 qr a8) ;

  foreach my $piece (keys %hereis ) {
    my $p=substr($piece,1,1) ;
    my $q=defined($self->{$hereis{$piece }}) ? $self->{$hereis{$piece }}:"rien" ;
    $status->{$piece}=
      ( $p eq $q ) &&  ($status->{$piece} eq 'no') ? 'no' : 'yes' ;

  }

}

sub castling{
  my ($self,%arg)=@_ ;
  my $couleur=$arg{couleur} ;
  my $side=$arg{side} ;
  my $status=$arg{status} ;
  my $out=$arg{out}?$arg{out}:'no'  ;


  my ($la,$Kk,$Rr,$babor)=$couleur eq 'White' ? (1,'K','R', $side) : (8,'k','r',lc($side) ) ;
  my @rank = $side eq 'K' ? (qw/e h g f/): (qw/e a c d/) ;

  $self->can_castling(roq=>$babor . $Kk,status=>$status,out=>$out) ne 'no' or die " castling move is wrong" ;

  $self->deletepiece($rank[0].$la ) ;
  $self->deletepiece($rank[1].$la ) ;
  $self->put($Kk,$rank[2].$la) ;
  $self->put($Rr,$rank[3].$la) ;

  return ;

}


sub can_castling {

  # return $diag and if $diag = 'no' means: castling could not be done
  my ($self,%arg)=@_ ;
  my $roq=$arg{roq} ;
  my $status=$arg{status} ;
  my $out=$arg{out}?$arg{out}:'no'  ;
  my $diag="yes" ;

  # setting conditions
  # Are the king and rook at their initial position (special) with no moves ($status)
  # status  (ep,wkr,wqr,,K,bkr,bqr,k)
  # KK for white King(K) King side castling (K) and so on.

  my %cds=(
	   KK=>[qw(KK KR V1 V2)],
	   QK=>[qw(KK QR V3 V4)],
	   kk=>[qw(kk kr v1 v2)],
	   qk=>[qw(kk qr v1 v2)]) ;

  my %special=
    qw(KK e1 V1 f1 V2 g1 V3 d1 V4 c1 kk e8 v1 f8 v2 g8 v3 d8 v4 c8 KR h1 QR a1 kr h8 qr a8) ;

  my $resu=( $status->{ $cds{$roq}->[0]} eq 'no') &&
    ( $status->{ $cds{$roq}->[1]} eq 'no') &&
      (!defined $self->{ $special{$cds{$roq}->[2]} } ) &&
	(!defined $self->{ $special{$cds{$roq}->[3]} } ) ;

  return $diag='no' unless ($resu) ;

  # then is it in "checks" because of the virtual king move during castling ?

  my $color=$cds{$roq}->[0] =~/KK/ ? "qknbrpu" : "QKNBRPU" ;
  my @locking=( $special{$cds{$roq}->[0]}, $special{$cds{$roq}->[1]}, $special{$cds{$roq}->[2]} ) ;

  foreach my $loc ( keys %{$self} ) {
    my $piece=$self->{$loc} ;
    if ($piece =~ /[$color]/) {
      my ($let,$num)=split('',$loc) ;
      my $set=[] ;
      $self->vldmov(row=>$num, col=>$let,piece=>$piece,valid=>$set,recur=>'no') ;
      my $size=@{$set} ;
      #    foreach (0..$#{$set}){
      #    print " $king is shaked by $piece at $loc \n" if ($locking eq $set->[$_]) ;}
      foreach (0..$#{$set}) {
        foreach my $l (0..2) {
	  if ( defined( $set->[$_]) && ($locking[$l] eq $set->[$_]) ) {
	    $diag='no' ;
	    print " roq is shaked by $piece at $loc \n" if ($out eq 'yes') ;
	  }
	}
      }
    }
  }
  return $diag ;
}

sub getfen {

# translate from the fen string $fen
# to a hash reference $posini used
# as initialisation for the game

# work with pointers $posini & $status

my $self=shift ;
my $fen=shift ;
my $posini=shift ;
my $status=shift ;

  my @fields=split ' ', $fen ;
# reinitialisation of the chessboard means reset of :
  %{$posini}=() ;
  # extended empty squares with '-'
  $fields[0] =~ s/(\d)/'-'x $1/ge ;

  # delete useless '/'
  $fields[0] =~ s!/!!g ;
  my @pospck=split '',$fields[0] ;

  # suppose le string bien forme
  $#pospck == 63 or die ("**** fen mal formé ($#pospck)  **** \n") ;

 COL:for (reverse 1..8){
  ROW:for my $rank ('a'..'h'){
      my $piece=shift @pospck ;
      push( @{${$posini}{$piece}} ,$rank . $_) unless ($piece eq '-') ;
    }
  }
# except status others values are not in use .
#   shift @fields ;
# my $colmove=shift @fields ;
  my $fenstat=$fields[2] ;
#  my $ep=shift @fields ;
#  my $ply=shift @fields ;
#  my $nmove=shift @fields ;

($fenstat =~ /K/) ?( $status->{KR}='no'): ($status->{KR}='yes') ;
($fenstat =~ /Q/) ? ($status->{QR}='no') : ($status->{QR}='yes') ;
($fenstat =~ /k/) ? ($status->{kr}='no'): ($status->{kr}='yes') ;
($fenstat =~ /q/) ? ($status->{qr}='no'): ($status->{qr}='yes') ;

#don't know which ones, of the king or the rook, has moved
# assume it's only the rook for sake of simplicity
$status->{KK}='no' ;
$status->{kk}='no' ;
}

sub genfen {
# generate the fen from the current board
# parameters $objet,$move color('w',-,'b'),$roque status
# $ep en passant , $ply ply count, $move number
  my $self=shift ;
  my $colmove=shift ;
  my $status=shift ;
  my $ep=shift ;
  my $ply=shift ;
  my $nmove=shift ;

  my $fen ;
  foreach my $num (reverse 1..8) {
    foreach my $let ('a'..'h') {
      my $p=$$self{$let.$num} ;
      $fen .= defined($p) ? $p : "."  ;
    }
    $fen .='/' unless $num ==1;
  }
  $fen=~ s/(\.+)/length($1)/eg ;

my $fenstat .=($status->{KK} eq 'yes' || $status->{KR} eq 'yes') ? "" : "K" ;
$fenstat .=($status->{KK} eq 'yes' || $status->{QR} eq 'yes') ? "": "Q" ;
$fenstat .=($status->{kk} eq 'yes' || $status->{kr} eq 'yes') ? "": "k" ;
$fenstat .=($status->{kk} eq 'yes' || $status->{qr} eq 'yes') ? "" : "q" ;
$fenstat ="-" unless  length($fenstat) ;
print " genfen $fenstat \n" ;
  return ($fen . ' ' . $colmove . ' ' . $fenstat . ' '. $ep .' ' . $ply .' ' . $nmove );
}

1;