File Coverage

blib/lib/Chess/ChessKit/Trad.pm

Criterion	Covered	Total	%
statement	18	198	9.0
branch	0	100	0.0
condition	0	21	0.0
subroutine	6	12	50.0
pod			n/a
total	24	331	7.2

 #!/usr/bin/perl -w
 ####-----------------------------------
 ### File	: Trad.pm
 ### Author	: C.Minc
 ### Purpose	: chess translator
 ### Version	: 1.1 2007/12/22
 ### copyright GNU license
 ####-----------------------------------


package Trad ;

#package Chess::ChessKit::Trad ;

use warnings;
use strict;

=head1 NAME

ChessKit::Trad

=head1 VERSION

Version 1.1

=cut

=head1 SYNOPSIS

see ChessKit

=head1 FUNCTIONS

=head2 sub dscrip

see ChessKit

=head2 sub mauv

retrieve the move from notation
see ChessKit

=head2 sub promote

retrieve the element of pawn promotion
see ChessKit

=head2 sub resolve

resolve move ambiguity of the destination square
see ChessKit

=head2 sub resolve_deb

resolve move ambiguity of the starting square
see ChessKit

=head2 sub trad

High level interface for translating notation
from languages
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

our $VERSION = '1.0' ;

use strict ;
use Symbol ;
use Chess::ChessKit::Board  ;


require Exporter ;

use vars qw(
            @ISA
            @EXPORT
             );
our @ISA =qw(Exporter) ;

our @EXPORT = qw( %country $bd );

# this part concerns only algrbraic notation

our %country=(
Czech       =>'Czech     ',
Danish      =>'Danish    ',
Dutch       =>'Dutch     ',
English     =>'English   ',
Estonian    =>'Estonian  ',
Finnish     =>'Finnish   ',
French      =>'French    ',
German      =>'German    ',
Hungarian   =>'Hungarian ',
Icelandic   =>'Icelandic ',
Italian     =>'Italian   ',
Norwegian   =>'Norwegian ',
Polish      =>'Polish    ',
Portuguese  =>'Portuguese',
Romanian    =>'Romanian  ',
Spanish     =>'Spanish   ',
Swedish     =>'Swedish   ') ;


sub trad {
    (my $fileresult, my $file, my $lang ,my $lang2)=@_ ;

my %trad2eng=(
Czech       =>'JSVDK',
Danish      =>'SLTDK',
Dutch       =>'PLTDK',
English     =>'NBRQK',
Estonian    =>'ROVLK',
Finnish     =>'RLTDK',
French      =>'CFTDR',
German      =>'SLTDK',
Hungarian   =>'HFBVK',
Icelandic   =>'RBHDK',
Italian     =>'CATDR',
Norwegian   =>'SLTDK',
Polish      =>'SGWHK',
Portuguese  =>'CBTDR',
Romanian    =>'CNTDR',
Spanish     =>'CATDR',
Swedish     =>'SLTDK') ;

print "from $lang to $lang2\n " ;
my $piece=$trad2eng{$lang} ;
my $prom=substr($piece,0,4) ;
my @ltr=split( // ,$piece );
my @ltr2=split( // ,$trad2eng{$lang2} );

my %trad2en=("" => "", $ltr[0] => $ltr2[0],  $ltr[1] => $ltr2[1],  $ltr[2] => $ltr2[2],  $ltr[3] => $ltr2[3], $ltr[4] => $ltr2[4]) ;

    open(OFILE,">",$fileresult) ;

    open(HFILE,$file) or die "cannot open file $file  ";
    my @line= ;

foreach (@line) {

# because we can find also something like that :3. d4, cxd4 ; 4. Cxd4, e5; 5. Cdb5, Cf6 ;
 s/([$piece]?)([a-h]?[1-8]?\s*x?\s*[a-h][1-8][\+#]?\s*)(?:[,;]*)(\s*\=?\s*)([$prom]?)/$trad2en{$1}$2$3$trad2en{$4}/g ;

# piece  ^^
# column or line ^^^  ^^^
# capture                     ^
#  destination square               ^^^  ^^^
#  promotion                                                                 ^^^
#

# just as above to delete semi-colons and commas
s/([O-]?O-O\s*)(?:[,;]*)/$1/g ;

print OFILE $_ ;
    }

    close(HFILE) ;
    close(OFILE) ;
    return ;
}


# the following part concerns only english descriptive notation

my @from ,
my @to ;
my $status={} ;			# used to valid castling
my @moves ;
our $bd ;


# this array below is used to reverse the column numbering of the Black moves
my @black=(0,8,7,6,5,4,3,2,1) ;

# the following make the correspondance of the row naming between
# descriptive and algebraic notation

my %algebra=(QR=>'a',
	     QN=>'b',
	     QB=>'c',
	     Q=> 'd',
	     K=> 'e',
	     KB=>'f',
	     KN=>'g',
	     KR=>'h') ;

sub dscrip {

my (%arg)=@_ ;
my @sauces=@{$arg{mov}} ;
my %study=%{$arg{ini}}if ( defined($arg{ini})) ;
@moves=() ;

# read a game @sauces in descriptive notation return a game in
# long algebraic notation @moves
# chess is initialized with %study if nothing usual initial chess game position
# usage:
#@array_of_moves=&Trad::dscrip(ini=>ref_someposition or not,
#                              mov=>ref_set_of_moves)


$bd=Board->new() ;
$bd->startgame(%study) ;
$bd->has_moved(status=>$status,ini=>'y') ;

# for debug
#$bd->chessview ;

# main loop to translate notation

for (my $i=0; $i<=$#sauces ; $i++) {

# parse the white & black moves



#  $sauces[$i]=~ /(\d*\.)\s*(O|\w*\/?\d?)(-|x)([PQKNBR|O-O|O]*)(\d)?\s*(ch|e\.p\.|\([QNBR]\)|=\s*[QNBR])?\s*(O|\w*\/?\d?)(-|x)([PQKNBR|O-O|O]*)(\d)?\s*(ch|e\.p\.|\([QNBR]\)|=[QNBR])?\s*/ ;
#  #                 1         2           3          4          5               6                 7            8          9           10                   11



my $cnt=$sauces[$i]=~ tr/-x/-x/ ;
my $pattern=qr/\s*(O|\w*\/?\d?)(-|x)([PQKNBR|O-O|O]*)(\d)?\s*(ch|e\.p\.|\([QNBR]\)|=\s*[QNBR])?/ x $cnt  ;
$sauces[$i]=~ /(\d*\.)$pattern\s*/ ;

  my $n=$1 ;
  my $wpiece=$2 ;
  my $waction=$3 ;
  my $wdestalpha=$4 ;
  my $wdestnum=$5 ? $5 : "";
  my $wechec=$6 ? $6 : "" ;
# for debug
#  print "splitting results: $n $wpiece $waction $wdestalpha $wdestnum $wechec " ;
  mauv($bd,'White',$wpiece ,$waction ,$wdestalpha, $wdestnum ,$wechec) ;

#  my $bpiece=$7 ;
#  my $baction=$8 ;
#  my $bdestalpha=$9 ;
  my $bpiece= $cnt==2  ? $7 : "";
  my $baction= $cnt==2 ? $8 : "";
  my $bdestalpha= $cnt==2 ? $9 : "";
  my $bdestnum=$10 ? $10 : "";
  my $bechec=$11 ? $11 : "" ;

# for debug
if($cnt == 2){
#  print "$bpiece $baction $bdestalpha $bdestnum $bechec \n" ;
  mauv($bd,'Black',$bpiece ,$baction ,$bdestalpha ,$bdestnum ,$bechec) ;}

#print $n ;
}

# for debug
#$bd->chessview ;

return @moves ;


sub mauv{
  my $bd=shift ;
  my ($color,$wpiece, $waction, $wdestalpha, $wdestnum ,$wechec)=@_ ;

  @from=() ;
  @to=() ;

  # find the set of pieces for the start of the moves


  my $fpiece= $wpiece ;
  my $roq=$wpiece .  $waction .  $wdestalpha ;

  if ( $roq =~ /O-O-O/ ) {

    $bd->castling(side=>'Q',status=>$status,couleur=>$color );
    push(@moves,$roq) ;
    return ;
  } elsif ( $roq =~/O-O/ ) {

    $bd->castling(side=>'K',status=>$status,couleur=>$color );
    push(@moves,$roq) ;
    return ;

  } elsif ($fpiece =~ /^[PKQRBN]$/ ) {
@from=grep { $color eq 'White'? $fpiece eq $bd->{$_} :  lc $fpiece eq $bd->{$_} }  (keys %{$bd})  ;
  } else {
    $fpiece=&resolve_deb($color,$wpiece,$waction, $wdestalpha, $wdestnum ,$wechec) ;
  }
  # find the set of possible arrival cases

  if (!defined ($algebra{$wdestalpha} )) {
    &resolve($bd,$color,$wpiece,$waction, $wdestalpha, $wdestnum ,$wechec) ;
  } else {
    my $exp= $algebra{$wdestalpha} ;
    my $num=$color eq 'White' ? $wdestnum : $black[$wdestnum] ;
    push @to,$exp .  $num ;

    my $exp2=( ($wpiece eq 'P') ? "" : ( (length($wpiece) == 2) ? substr( $wpiece,1,1) : $wpiece  ))  .  $exp . $num ;

  }
# for debug
#  print  "**from ", @from , "## to ", @to ,"\n";

  # select the right move(s)


  foreach my $f (0..$#from) {
    foreach my $t (0..$#to) {
      my $set=[] ;
      ## $set contient tous les coups valides (sans echec donc)
      my $tpiece=$color eq 'White'  ? $fpiece : lc($fpiece) ;
      $bd->vldmov(row=>chr(vec($from[$f],1,8)),
		  col=>chr( vec($from[$f],0,8)),
		  piece=>$tpiece,
		  valid=>$set) ;

      foreach (0..$#{$set}) {
	if ($set->[$_] eq  $to[$t]) {
	  # asap la case de destination est trouvée le coup est joué
	  my $hadak= uc($tpiece) . $from[$f] ;
	  $hadak .= (defined($bd->getpiece($to[$t])) ? 'x' :'-' ) . $to[$t];
	  $hadak=~ s/P//g  ;
          ($tpiece,my $promo)=&promote($tpiece,chr(vec($to[$t],1,8)),$wechec) ;
	  push(@moves,$hadak . $promo) ;
	  $bd->deletepiece($from[$f]) ;
	  $bd->put($tpiece, $to[$t]) ;
#          for debug
#	  $bd->chessview ;
	  last  ;
	}
      }
    }
  }

  return ;
}

sub resolve{
  my $bd=shift ;
  my ($color,$wpiece,$waction, $wdestalpha, $wdestnum ,$wechec)=@_ ;

  # resout les ambiguités

  # prise en passant
  if ($wechec eq 'e.p.') {
    my %pred=(a=>'',b=>'a',c=>'b',d=>'c',e=>'d',f=>'e',g=>'f',h=>'g') ;
    my %suiv=(a=>'b',b=>'c',c=>'d',d=>'e',e=>'f',f=>'g',g=>'h',h=>'') ;
    my @ep ;

    my ( $c,$pion)= $color eq 'White'? ('Black','p'): ('White','P') ;
    my $cto=$color eq 'White' ? '5' : '4' ;
    my $n=$moves[$#moves] ;
    my ($col,$row)=split('',substr( $n,-2) ) ;
    push @to, $c eq 'White' ? $col . '3' : $col . '6' ;

    foreach (@from) {
      if ( ($_ eq $pred{$col}.$cto ) || ($_ eq  $suiv{$col}.$cto )) {
	push @ep , $_ ;
      }
    }
    # ep entre 1 et 2 mais $#to=0 max
    if (@ep >= 1) {
      @from=@ep ;
      # pas propre à ce niveau mais efficace

      $bd->deletepiece($col.$row) ;
      $bd->put($pion, $to[0]) ;

      return ;
    } else {
      print "erreur sur ep", @ep, "\n" ;
      return ;
    }
  }

  # ambiguité de cote K or Q
  if ($wdestalpha=~ /^[BRN]$/ && $wdestnum ne '') {
    my $num=($color eq 'White' ? $wdestnum : $black[$wdestnum]) ;
    push @to ,$algebra{'K' . $wdestalpha} .  $num ;
    push @to ,$algebra{'Q' . $wdestalpha} .  $num ;
    return ;
  }

  # ambiguité prise de piece
  if ($wdestalpha=~ /^[BRNP]$/ && $waction eq 'x') {
    my $tpiece=$color eq 'White' ? lc($wdestalpha) :uc($wdestalpha) ;
    foreach my $loc (keys %{$bd}) {
      if ($bd->{$loc} eq $tpiece ) {
	push @to,$loc;
      }
      ;
    }

    return ;
  }

  # ambiguité prise de pion
  #  /[QK|][BRN]P/
  if ($wdestalpha=~ /^[BRN]P$/ && $waction eq 'x') {
    my $opp=$color eq 'White' ? 'p' :'P' ;
    foreach my $sq (keys %{$bd}) {
      my $piece= $bd->{$sq} ;
      my $rk=substr($sq,0,1) ;
      if ($piece eq $opp ) {
	my $wx ;
	if ($wdestalpha=~ /^([BRN])P$/ ) {
	  my $wx=$1 ;
	  foreach ('Q','K') {
	    if ($algebra{$_ . $wx} eq $rk) {
	      push @to,$sq  ;
	    }
	  }
	} else {
	  foreach ('Q','K') {
	    if ($algebra{$_ } eq $rk) {
	      push @to,$sq  ;
	    }
	  }
	}
      }
    }
    return ;
  }

  # ambiguités persistantes
  print "****   ambiguity   *** \n" ;
  return ;
}

sub resolve_deb {

  my ($color,$wpiece,$waction, $wdestalpha, $wdestnum ,$wechec)=@_ ;
  my $truepiece ;
  my $side ;
  my $piece ;
  my $col ;
  my $rank ;
  my $wcol ;
  my $loc ;
  my $case ;
  #ambiguité sur colonne

  if ($wpiece =~ /^([QRBKN])\/([1-8])$/) {
    # $truepiece=$1 ;
    ($wcol,$truepiece)=$color eq 'White' ? ($2,$1): ($black[$2],lc($1)) ;
    foreach $case (keys %{$bd}) {
      ($rank, $col)=split(//,$case) ;
      if ( ($bd->{$case} eq $truepiece)  && ($col == $wcol)  ) {
	push @from,$case ;
      }
    }
    return ($truepiece) ;
  }

  #ambiguité sur queen side  & king side
  #  ex  N=e4  et N =g8 => QN=e4 et KN=g8  e
  # pb avec 3 pieces ??

  if ($wpiece =~ /(^[QK])([QRBN]$)/ ) {
    $truepiece=$color eq 'White' ? $2:lc($2) ;
    $side=$1 ;
    my $i=0 ;
    my @loc ;

    foreach $case (keys %{$bd} ) {
      if ($bd->{$case} eq $truepiece ) {
	$loc[$i]= $case ;$i++ ;
      }
    }

    if ($#loc < 2) {
      push @from,( $side eq 'Q' ? ( ( substr($loc[0],0,1) lt substr($loc[1],0,1)) ? $loc[0]: $loc[1] )
		   : ( ( substr($loc[0],0,1) gt substr($loc[1],0,1)) ? $loc[0]: $loc[1] )) ;}
    else {
      print " ambiguity :  piece number gt  à 2 : $#loc \n  " ;
    }
  }

  return ($truepiece) ;

  # ambiguités peristantes = not solved

  print "ambiguity at start of the mpve \n" ;

  return ;
}



sub promote{
#check if the pawn get the last rank
# usage (piece chosen , = piece chosen)=promote(pawn,row location,piece chosen)
# dual syntax for the chosen piece X: =X or (X)
my $tpiece=shift ;
  my $row=shift ;
  my $wechec=shift ;

  if( $tpiece eq 'P' && $row==8){
# retrieve the piece to promote
$wechec=~ s/[\(|=]\s*([QNBR])\s*\)?/$1/ ;
return ($wechec,'='. uc($wechec) ) ;}

  if( $tpiece eq 'p' && $row==1){
# retrieve the piece to promote
$wechec=~ s/[\(|=]\s*([QNBR])\s*\)?/$1/ ;
return (lc $wechec,'='. uc($wechec) ) ;}
# not a pawn to promote , nothing to do
return ($tpiece,"") ;
}
}
1 ;