File Coverage

blib/lib/Chess/PGN/EPD.pm

Criterion	Covered	Total	%
statement	25	565	4.4
branch	1	424	0.2
condition	0	72	0.0
subroutine	6	28	21.4
pod	9	17	52.9
total	41	1106	3.7

package Chess::PGN::EPD;

use strict;
use warnings;
use Chess::PGN::Moves;
use Storable               qw( retrieve );
use Try::Tiny              qw( try catch );

require Exporter;

my ( $hECO, $hNIC, $hOpening );
my %hash = (
    ECO     => \$hECO,
    NIC     => \$hNIC,
    Opening => \$hOpening
);

my $ECO_path;
my $NIC_path;
my $Opening_path;

($ECO_path,$NIC_path,$Opening_path) = GetPaths('Chess::PGN::EPD');

try {
    $hECO = retrieve($ECO_path);
} catch {
    print "Couldn't open $ECO_path : $!";
    exit;
};
try {
    $hNIC = retrieve($NIC_path);
} catch {
    print "Couldn't open $NIC_path : $!";
    exit;
};
try {
    $hOpening = retrieve($Opening_path);
} catch {
    print "Couldn't open $Opening_path : $!";
    exit;
};

our @ISA    = qw(Exporter);
our @EXPORT = qw(
  &epdcode
  &epdset
  &epdfromto
  &epdstr
  &epdlist
  &epdgetboard
  &epdTaxonomy
  &psquares
  %font2map
);
our $VERSION = '0.31';

our %font2map = (
    'Chess Cases'           => 'leschemelle',
    'Chess Adventurer'      => 'marroquin',
    'Chess Alfonso-X'       => 'marroquin',
    'Chess Alpha'           => 'bentzen1',
    'Chess Berlin'          => 'bentzen2',
    'Chess Condal'          => 'marroquin',
    'Chess Harlequin'       => 'marroquin',
    'Chess Kingdom'         => 'marroquin',
    'Chess Leipzig'         => 'marroquin',
    'Chess Line'            => 'marroquin',
    'Chess Lucena'          => 'marroquin',
    'Chess Magnetic'        => 'marroquin',
    'Chess Mark'            => 'marroquin',
    'Chess Marroquin'       => 'marroquin',
    'Chess Maya'            => 'marroquin',
    'Chess Mediaeval'       => 'marroquin',
    'Chess Merida'          => 'marroquin',
    'Chess Millennia'       => 'marroquin',
    'Chess Miscel'          => 'marroquin',
    'Chess Montreal'        => 'katch',
    'Chess Motif'           => 'marroquin',
    'Chess Plain'           => 'hickey',
    'Chess Regular'         => 'scott1',
    'Chess Usual'           => 'scott2',
    'Chess Utrecht'         => 'bodlaender',
    'Tilburg'               => 'tilburg',
    'Traveller Standard V3' => 'cowderoy',
);

my %board = qw(
  a1 R a2 P a7 p a8 r
  b1 N b2 P b7 p b8 n
  c1 B c2 P c7 p c8 b
  d1 Q d2 P d7 p d8 q
  e1 K e2 P e7 p e8 k
  f1 B f2 P f7 p f8 b
  g1 N g2 P g7 p g8 n
  h1 R h2 P h7 p h8 r
);
my $Kc = 1;
my $Qc = 1;
my $kc = 1;
my $qc = 1;
my $w  = 1;

my @onwhite = (
    1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0,
    1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1,
    0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1,
);

my %FontMap = (
    hicky => {
        OnBlack            => 'OMASTLPNBRQK@',
        OnWhite            => 'omastlpnbrqk:',
        SingleBox          => '12345678',
        DoubleBox          => '!"#$%&\'(',
        SingleRounded      => '[]\^',
        DoubleRounded      => '<>;=/',
        SingleLeftLegend   => 'cdefghij',
        DoubleLeftLegend   => 'CDEFGHIJ',
        SingleBottomLegend => 'wxyz{|}~',
        DoubleBottomLegend => ')*+,-./0',
    },
    marroquin => {
        OnBlack            => 'OMVTWLPNBRQK+',
        OnWhite            => 'omvtwlpnbrqk ',
        SingleBox          => '12345789',
        DoubleBox          => '!"#$%/()',
        SingleRounded      => 'asdf',
        DoubleRounded      => 'ASDF',
        SingleLeftLegend   => "\300\301\302\303\034\305\306\307",
        DoubleLeftLegend   => "\340\341\342\343\344\345\346\347",
        SingleBottomLegend => "\310\311\312\313\314\315\316\317",
        DoubleBottomLegend => "\350\351\352\353\354\355\356\357",
    },
    leschemelle => {
        OnBlack            => 'OMVTWLPNBRQK+',
        OnWhite            => 'omvtwlpnbrqk ',
        SingleBox          => '12345789',
        DoubleBox          => '!"#$%/()',
        SingleRounded      => 'asdf',
        DoubleRounded      => 'ASDF',
        SingleLeftLegend   => "\300\301\302\303\034\305\306\307",
        DoubleLeftLegend   => "\340\341\342\343\344\345\346\347",
        SingleBottomLegend => "\310\311\312\313\314\315\316\317",
        DoubleBottomLegend => "\350\351\352\353\354\355\356\357",
    },
    linares => {
        OnBlack            => '0hg41i)HG$!Id',
        OnWhite            => 'pnbrqkPNBRQKw',
        SingleBox          => 'W_W[]W-W',
        DoubleBox          => 'cuC{}vlV',
        SingleRounded      => 'WWWW',
        DoubleRounded      => 'cCvV',
        SingleLeftLegend   => "\332\333\334\335\336\337\340\341",
        DoubleLeftLegend   => '(765&32%',
        SingleBottomLegend => "\301\302\303\304\305\306\307\310",
        DoubleBottomLegend => ',./9EFJM',
    },
    linares1 => {
        OnBlack            => '0hg41i)HG$!Id',
        OnWhite            => 'pnbrqkPNBRQKw',
        SingleBox          => '>;?:
        DoubleBox          => '>;?:
        SingleRounded      => '>?A@',
        DoubleRounded      => '>?A@',
        SingleLeftLegend   => '::::::::',
        DoubleLeftLegend   => '::::::::',
        SingleBottomLegend => '========',
        DoubleBottomLegend => '========',
    },
    linares2 => {
        OnBlack            => '0hg41i)HG$!Id',
        OnWhite            => 'pnbrqkPNBRQKw',
        SingleBox          => '^xY|yUz\\',
        DoubleBox          => '^xY|yUz\\',
        SingleRounded      => '^YU\\',
        DoubleRounded      => '^YU\\',
        SingleLeftLegend   => '||||||||',
        DoubleLeftLegend   => '||||||||',
        SingleBottomLegend => 'zzzzzzzz',
        DoubleBottomLegend => 'zzzzzzzz',
    },
    cowderoy => {
        OnBlack            => '$#!&%"*)\',+(0',
        OnWhite            => 'pnbrqkPNBRQK ',
        SingleBox          => '78946123',
        DoubleBox          => '78946123',
        SingleRounded      => '7913',
        DoubleRounded      => '7913',
        SingleLeftLegend   => '44444444',
        DoubleLeftLegend   => '44444444',
        SingleBottomLegend => '22222222',
        DoubleBottomLegend => '22222222',
    },
    bentzen1 => {
        OnBlack            => 'OJNTWLPHBRQK+',
        OnWhite            => 'ojntwlphbrqk ',
        SingleBox          => '!"#$%&\'(',
        DoubleBox          => '12345789',
        SingleRounded      => '!#&(',
        DoubleRounded      => '1379',
        SingleLeftLegend   => "\340\341\342\343\344\345\346\347",
        DoubleLeftLegend   => "\300\301\302\303\304\305\306\307",
        SingleBottomLegend => "\350\351\352\353\354\355\356\357",
        DoubleBottomLegend => "\310\311\312\313\314\315\316\317",
    },
    bentzen2 => {
        OnBlack            => 'OJNTWLPHBRQK+',
        OnWhite            => 'ojntwlphbrqk ',
        SingleBox          => '12345789',
        DoubleBox          => '12345789',
        SingleRounded      => '1379',
        DoubleRounded      => '1379',
        SingleLeftLegend   => '44444444',
        DoubleLeftLegend   => '44444444',
        SingleBottomLegend => '88888888',
        DoubleBottomLegend => '88888888',
    },
    scott1 => {
        OnBlack            => 'OJNTWLPHBRQK+',
        OnWhite            => 'ojntwlphbrqk*',
        SingleBox          => '(-)/\[_]',
        DoubleBox          => '(-)/\[_]',
        SingleRounded      => '(-)/\[_]',
        DoubleRounded      => '(-)/\[_]',
        SingleLeftLegend   => '////////',
        DoubleLeftLegend   => '////////',
        SingleBottomLegend => '________',
        DoubleBottomLegend => '________',
    },
    scott2 => {
        OnBlack            => 'OMVTWLPNBRQK+',
        OnWhite            => 'omvtwlpnbrqk ',
        SingleBox          => '12345789',
        DoubleBox          => '!"#$%/()',
        SingleRounded      => 'asdf',
        DoubleRounded      => 'ASDF',
        SingleLeftLegend   => '44444444',
        DoubleLeftLegend   => '$$$$$$$$',
        SingleBottomLegend => '44444444',
        DoubleBottomLegend => '$$$$$$$$',
    },
    bodlaender => {
        OnBlack            => 'OMVTWLomvtwl/',
        OnWhite            => 'PNBRQKpnbrqk ',
        SingleBox          => '51632748',
        DoubleBox          => '51632748',
        SingleRounded      => '51632748',
        DoubleRounded      => '51632748',
        SingleLeftLegend   => '33333333',
        DoubleLeftLegend   => '33333333',
        SingleBottomLegend => '44444444',
        DoubleBottomLegend => '44444444',
    },
    katch => {
        OnBlack            => 'OMVTWLPNBRQK/',
        OnWhite            => 'omvtwlpnbrqk ',
        SingleBox          => '12345789',
        DoubleBox          => '12345789',
        SingleRounded      => '12345789',
        DoubleRounded      => '12345789',
        SingleLeftLegend   => '44444444',
        DoubleLeftLegend   => '44444444',
        SingleBottomLegend => '88888888',
        DoubleBottomLegend => '88888888',
    },
    dummy => {
        OnBlack            => '',
        OnWhite            => '',
        SingleBox          => '',
        DoubleBox          => '',
        SingleRounded      => '',
        DoubleRounded      => '',
        SingleLeftLegend   => '',
        DoubleLeftLegend   => '',
        SingleBottomLegend => '',
        DoubleBottomLegend => '',
    },
);

my %convertPalView = (
    'r',
    '',
    'n',
    '',
    'b',
    '',
    'q',
    '',
    'k',
    '',
    'p',
    '',
    'R',
    '',
    'N',
    '',
    'B',
    '',
    'Q',
    '',
    'K',
    '',
    'P',
    '',
    ' ',
    '',
    '-',
    '',
);

sub epdcode {
    my $key = shift;
    my $epd  = shift;
    my $code;
    my $h = ${$hash{$key}};

    for ( @{$epd} ) {
        $code = $h->{$_};           ## no critic
        last if $code;
    }
    return ( $code or 'Unknown' );
}

sub epdset {
    if ( my $epd = shift ) {
        my @array = split( /\/|\s/, $epd );
        my $file = '8';

        %board = ();
        $Kc    = 0;
        $Qc    = 0;
        $kc    = 0;
        $qc    = 0;
        for ( 0 .. 7 ) {
            $array[$_] =~ s/(\d+)/'_' x $1/ge;
            my @row = split( '', $array[$_] );
            my $rank = 'a';
            for my $piece (@row) {
                $board{"$rank$file"} = $piece if $piece ne '_';
                $rank++;
            }
            $file--;
        }
        $w = ( $array[8] eq 'w' );
        for ( split( '', $array[9] ) ) {
            if ( $_ eq 'K' ) {
                $Kc = 1;
            }
            elsif ( $_ eq 'Q' ) {
                $Qc = 1;
            }
            elsif ( $_ eq 'k' ) {
                $kc = 1;
            }
            elsif ( $_ eq 'q' ) {
                $qc = 1;
            }
        }
    }
    else {
        %board = qw(
          a1 R a2 P a7 p a8 r
          b1 N b2 P b7 p b8 n
          c1 B c2 P c7 p c8 b
          d1 Q d2 P d7 p d8 q
          e1 K e2 P e7 p e8 k
          f1 B f2 P f7 p f8 b
          g1 N g2 P g7 p g8 n
          h1 R h2 P h7 p h8 r
        );
        $w  = 1;
        $Kc = 1;
        $Qc = 1;
        $kc = 1;
        $qc = 1;
    }
    return;
}

sub epdstr {
    my %parameters = @_;
    if ( $parameters{'board'} ) {
        my %board;
        my $hashref = $parameters{'board'};

        for ( keys %$hashref ) {
            $board{$_} = $$hashref{$_};
        }
        $parameters{'epd'} = epd( 0, 0, 0, 0, 0, 0, %board );
    }
    my $epd;
    my $type;
    try {
        $epd = $parameters{'epd'};
    } catch {
        print "Missing epd parameter: $!\n";
        exit;
    };
    try {
        $type = lc( $parameters{'type'} );
    } catch {
        print "Missing type parameter: $!\n";
        exit;
    };
    my ( $border, $corner, $legend ) = ( 'single', 'square', 'no' );

    $border = lc( $parameters{'border'} ) if exists( $parameters{'border'} );
    $corner = lc( $parameters{'corner'} ) if exists( $parameters{'corner'} );
    $legend = lc( $parameters{'legend'} ) if exists( $parameters{'legend'} );
    my @array = split( /\/|\s/, $epd );
    my @board;
    if ( $type eq 'diagram' ) {
        for ( 0 .. 7 ) {
            $array[$_] =~ s/(\d+)/'_' x $1/ge;
            $array[$_] =~
              s/_/(((pos $array[$_]) % 2) xor ($_ % 2)) ? '-' : ' '/ge;
            push( @board, 8 - $_ . "  " . $array[$_] );
        }
        push( @board, '   abcdefgh' );
    }
    elsif ( $type eq 'text' ) {
        for ( 0 .. 7 ) {
            $array[$_] =~ s/(\d+)/'_' x $1/ge;
            $array[$_] =~
              s/_/(((pos $array[$_]) % 2) xor ($_ % 2)) ? '-' : ' '/ge;
            push( @board, $array[$_] );
        }
    }
    elsif ( $type eq 'palview' ) {
        my @diagram;
        my $table;

        for ( 0 .. 7 ) {
            $array[$_] =~ s/(\d+)/'_' x $1/ge;
            $array[$_] =~
              s/_/(((pos $array[$_]) % 2) xor ($_ % 2)) ? '-' : ' '/ge;
            push( @diagram, $array[$_] );
        }
        for (@diagram) {
            for ( split(//) ) {
                $table .= $convertPalView{$_};
            }
            $table .= "";
            push( @board, $table );
            $table = '';
        }
    }
    elsif ( $type eq 'latex' ) {
        push( @board, '\\begin{diagram}' );
        push( @board, '\\board' );
        for ( 0 .. 7 ) {
            $array[$_] =~ s/(\d+)/'_' x $1/ge;
            $array[$_] =~
              s/_/(((pos $array[$_]) % 2) xor ($_ % 2)) ? '*' : ' '/ge;
            push( @board, '{' . $array[$_] . '}' );
        }
        push( @board, '\\end{diagram}' );
    }
    elsif ( $type eq 'tilburg' ) {
        for ( 0 .. 7 ) {
            $array[$_] =~ s/(\d+)/'_' x $1/ge;
            $array[$_] =~
s/([pnbrqkPNBRQK_])/mappiece(pos $array[$_],$_,$1,"\341\345\351\355\361\365\337\343\347\353\357\363
\335","\340\344\350\354\360\364\336\342\346\352\356\362\334")/ge;
            push( @board, $array[$_] );
        }
    }
    else {
        @board = configureboard( $type, $border, $corner, $legend );
        for ( 0 .. 7 ) {
            $array[$_] =~ s/(\d+)/'_' x $1/ge;
            $array[$_] =~
s/([pnbrqkPNBRQK_])/mappiece(pos $array[$_],$_,$1,$FontMap{$type}{'OnBlack'},$FontMap{$type}
{'OnWhite'})/ge;
            substr( $board[ $_ + 1 ], 1, 8 ) = $array[$_];
        }
    }
    return @board;
}

sub configureboard {
    my $type   = shift;
    my $border = shift;
    my $corner = shift;
    my $legend = shift;
    my $single = $border eq 'single';
    my $box    = $FontMap{$type}{ $single ? 'SingleBox' : 'DoubleBox' };
    my @board;

    if ( $corner eq 'rounded' ) {
        my $corners =
          $FontMap{$type}{ $single ? 'SingleRounded' : 'DoubleRounded' };

        substr( $box, 0, 1 ) = substr( $corners, 0, 1 );
        substr( $box, 2, 1 ) = substr( $corners, 1, 1 );
        substr( $box, 5, 1 ) = substr( $corners, 2, 1 );
        substr( $box, 7, 1 ) = substr( $corners, 3, 1 );
    }
    push( @board,
            substr( $box, 0, 1 )
          . substr( $box, 1, 1 ) x 8
          . substr( $box, 2, 1 ) );
    for ( 0 .. 7 ) {
        push( @board, substr( $box, 3, 1 ) . ' ' x 8 . substr( $box, 4, 1 ) );
    }
    push( @board,
            substr( $box, 5, 1 )
          . substr( $box, 6, 1 ) x 8
          . substr( $box, 7, 1 ) );
    if ( $legend eq 'yes' ) {
        my $left =
          $FontMap{$type}{ $single ? 'SingleLeftLegend' : 'DoubleLeftLegend' };
        my $bottom =
          $FontMap{$type}{ $single
            ? 'SingleBottomLegend'
            : 'DoubleBottomLegend' };

        for ( 1 .. 8 ) {
            substr( $board[$_], 0, 1 ) = substr( $left, $_ - 1, 1 );
        }
        substr( $board[-1], 1, 8 ) = $bottom;

    }
    return @board;
}

sub mappiece {
    my $x         = shift;
    my $y         = shift;
    my $piece     = shift;
    my $ifonblack = shift;
    my $ifonwhite = shift;
    my $onwhite   = $onwhite[ ( $y * 8 ) + $x ];
    my $which     = index( 'pnbrqkPNBRQK_', $piece );

    return substr( $onwhite ? $ifonwhite : $ifonblack, $which, 1 );
}

sub epdgetboard {
    if ( my $epd = shift ) {
        epdset($epd);
    }
    return $w, $Kc, $Qc, $kc, $qc, %board;
}

sub epdfromto {
    my @moves = @_;
    my @movelist;

    epdset();
    for (@moves) {
        if ($_) {
            my ( $piece, $to, $from, $promotion ) = movetype( $w, $_ );
            my $enpassant;
            my $ep = '-';
            my $castles = /O/ ? $_ : '';

            $Kc = 0 if $to eq 'h1';
            $Qc = 0 if $to eq 'a1';
            $kc = 0 if $to eq 'h8';
            $qc = 0 if $to eq 'a8';

            if ( $piece eq "P" ) {
                $piece = "p" if not $w;
                $promotion = lc($promotion) if $promotion and not $w;
                if ($from) {
                    $from .= substr( $to, 1, 1 );
                    if ($w) {
                        substr( $from, 1, 1 ) -= 1;
                    }
                    else {
                        $from++;
                    }
                }
                else {
                    $from = $to;

                    if ($w) {
                        substr( $from, 1, 1 ) -= 1;
                        unless ($board{$from}) {
                            $ep = $from;
                            substr( $from, 1, 1 ) -= 1;
                        }
                    }
                    else {
                        $from++;
                        unless ($board{$from}) {
                            $ep = $from;
                            $from++;
                        }
                    }
                }

                if ( substr( $from, 0, 1 ) ne substr( $to, 0, 1 ) ) {
                    if ( not $board{$to} ) {
                        $enpassant = $to;
                        if ($w) {
                            substr( $enpassant, 1, 1 ) =
                              chr( ord( substr( $enpassant, 1, 1 ) ) - 1 );
                        }
                        else {
                            substr( $enpassant, 1, 1 ) =
                              chr( ord( substr( $enpassant, 1, 1 ) ) + 1 );
                        }
                        $board{$enpassant} = undef;
                        $enpassant = defined($enpassant) ? $enpassant : '';
                        $from = defined($from) ? $from : '';
                        $to = defined($to) ? $to : '';
                    }
                }
                ( $board{$to}, $board{$from} ) =
                  ( $promotion ? $promotion : $board{$from}, undef );
                $piece = defined($piece) ? $piece : '';
                $from = defined($from) ? $from : '';
                $to = defined($to) ? $to : '';
                $promotion = defined($promotion) ? $promotion : '';
            }
            elsif ( $piece eq "KR" ) {
                my ( $k_from, $r_from ) = unpack( "A2A2", $from );
                my ( $k_to,   $r_to )   = unpack( "A2A2", $to );

                ( $board{$k_to}, $board{$k_from} ) = ( $board{$k_from}, undef );
                ( $board{$r_to}, $board{$r_from} ) = ( $board{$r_from}, undef );
                if ($w) {
                    $Kc = $Qc = 0;
                }
                else {
                    $kc = $qc = 0;
                }
            }
            else {
                my @piece_at;
                my @fromlist;

                $piece = lc($piece) if not $w;
                @piece_at = psquares( $piece, %board );
                if ($from) {
                    my @tmp;

                    $from = defined($from) ? $from : '';
                    if ( $from =~ /[a-h]/ ) {
                        for (@piece_at) {
                            push( @tmp, $_ )
                              if ( substr( $_, 0, 1 ) eq $from );
                        }
                    }
                    else {

                        for (@piece_at) {
                            push( @tmp, $_ )
                              if ( substr( $_, 1, 1 ) eq $from );
                        }
                    }
                    @piece_at = @tmp;
                }

                for my $square (@piece_at) {
                    for ( @{ $move_table{ uc($piece) }{$square} } ) {
                        push( @fromlist, $square ) if $_ eq $to;
                    }
                }
                if ( scalar(@fromlist) != 1 ) {
                    for (@fromlist) {
                        if (    canmove( $piece, $to, $_, %board )
                            and isLegal( $w, $_, $to, %board ) )
                        {
                            $from = $_;
                            last;
                        }
                    }
                }
                else {
                    $from = $fromlist[0];
                }
                if ( $piece =~ /[RrKk]/ ) {
                    if ( $piece eq 'R' ) {
                        $Kc = 0 if $from eq 'h1';
                        $Qc = 0 if $from eq 'a1';
                    }
                    elsif ( $piece eq 'r' ) {
                        $kc = 0 if $from eq 'h8';
                        $qc = 0 if $from eq 'a8';
                    }
                    elsif ( $piece eq 'K' ) {
                        $Kc = $Qc = 0;
                    }
                    else {
                        $kc = $qc = 0;
                    }
                }
                ( $board{$to}, $board{$from} ) = ( $board{$from}, undef );
                $piece = defined($piece) ? $piece : '';
                $from = defined($from) ? $from : '';
                $to = defined($to) ? $to : '';
            }
            my $movehash = {
                    piece => defined($piece) ? $piece : '',
                    from => defined($from) ? $from : '',
                    to => defined($to) ? $to : '',
                    promotion => defined($promotion) ? $promotion : '',
                    enpassant => defined($enpassant) ? $enpassant : '',
                    castles => defined($castles) ? $castles : '',
            };
            push(@movelist,$movehash);
            $w ^= 1;
        }
    }
    %board = ();
    return @movelist;
}

sub epdlist {
    my @moves = @_;
    my $debug = 0;
    my @epdlist;
    my $lineno = 1;

    if ( scalar @moves and $moves[-1] eq '1' ) {
        $debug = 1;
        pop @moves;
        if (%board) {
            print "\%board initialized\n";
        }
        else {
            print "\%board uninitialized\n";
        }
    }
    epdset();
    for (@moves) {
        Print(%board) if $debug;
        if ($_) {
            my ( $piece, $to, $from, $promotion ) = movetype( $w, $_ );
            my $enpassant;
            my $ep = '-';

            $Kc = 0 if $to eq 'h1';
            $Qc = 0 if $to eq 'a1';
            $kc = 0 if $to eq 'h8';
            $qc = 0 if $to eq 'a8';

            if ($debug) {
                print "Move[$lineno]='$_'";
                $lineno++;
                if ($piece) {
                    print ", piece='$piece'";
                    print ", to='$to'"               if $to;
                    print ", from='$from'"           if $from;
                    print ", promotion='$promotion'" if $promotion;
                }
                print "\n";
            }

            if ( $piece eq "P" ) {
                $piece = "p" if not $w;
                $promotion = lc($promotion) if $promotion and not $w;
                if ($from) {
                    $from .= substr( $to, 1, 1 );
                    if ($w) {
                        substr( $from, 1, 1 ) -= 1;
                    }
                    else {

                        $from++;
                    }
                }
                else {
                    $from = $to;

                    if ($w) {
                        substr( $from, 1, 1 ) -= 1;
                        unless ($board{$from}) {
                            $ep = $from;
                            substr( $from, 1, 1 ) -= 1;
                        }
                    }
                    else {
                        $from++;
                        unless ($board{$from}) {
                            $ep = $from;
                            $from++;
                        }
                    }
                }

                if ( substr( $from, 0, 1 ) ne substr( $to, 0, 1 ) ) {
                    if ( not $board{$to} ) {
                        $enpassant = $to;
                        if ($w) {
                            substr( $enpassant, 1, 1 ) =
                              chr( ord( substr( $enpassant, 1, 1 ) ) - 1 );
                        }
                        else {
                            substr( $enpassant, 1, 1 ) =
                              chr( ord( substr( $enpassant, 1, 1 ) ) + 1 );
                        }
                        $board{$enpassant} = undef;
                        if ($debug) {
                            print "\$enpassant='$enpassant' " if $enpassant;
                            print "\$from='$from' "           if $from;
                            print "\$to='$to'"                if $to;
                            print "\n";
                        }
                    }
                }
                ( $board{$to}, $board{$from} ) =
                  ( $promotion ? $promotion : $board{$from}, undef );
                if ($debug) {
                    print "\$piece='$piece' "         if $piece;
                    print "\$from='$from' "           if $from;
                    print "\$to='$to' "               if $to;
                    print "\$promotion='$promotion' " if $promotion;
                }
                push( @epdlist, epd( $w, $Kc, $Qc, $kc, $qc, $ep, %board ) );
                if ($debug) {
                    print "$epdlist[-1]\n";
                }
            }
            elsif ( $piece eq "KR" ) {
                my ( $k_from, $r_from ) = unpack( "A2A2", $from );
                my ( $k_to,   $r_to )   = unpack( "A2A2", $to );

                ( $board{$k_to}, $board{$k_from} ) = ( $board{$k_from}, undef );
                ( $board{$r_to}, $board{$r_from} ) = ( $board{$r_from}, undef );
                if ($w) {
                    $Kc = $Qc = 0;
                }
                else {
                    $kc = $qc = 0;
                }
                if ($debug) {
                    print $w ? "White" : "Black",
                      " castles from $k_from to $k_to\n";
                }
                push( @epdlist, epd( $w, $Kc, $Qc, $kc, $qc, $ep, %board ) );
                if ($debug) {
                    print "$epdlist[-1]\n";
                }
            }
            else {
                my @piece_at;
                my @fromlist;

                $piece = lc($piece) if not $w;
                @piece_at = psquares( $piece, %board );
                if ($debug) {
                    print "\@piece_at=", join( ",", @piece_at ), "\n"
                      if @piece_at;
                }
                if ($from) {
                    my @tmp;

                    if ($debug) {
                        print "\$from='$from'\n" if $from;
                    }
                    if ( $from =~ /[a-h]/ ) {
                        for (@piece_at) {
                            push( @tmp, $_ )
                              if ( substr( $_, 0, 1 ) eq $from );
                        }
                    }
                    else {

                        for (@piece_at) {
                            push( @tmp, $_ )
                              if ( substr( $_, 1, 1 ) eq $from );
                        }
                    }
                    @piece_at = @tmp;
                }

                for my $square (@piece_at) {
                    for ( @{ $move_table{ uc($piece) }{$square} } ) {
                        push( @fromlist, $square ) if $_ eq $to;
                    }
                }
                print "scalar \@fromlist = ", scalar(@fromlist), "\n" if $debug;
                if ( scalar(@fromlist) != 1 ) {
                    if ($debug) {
                        print "\@fromlist=", join( ",", @fromlist ), "\n"
                          if @fromlist;
                    }
                    for (@fromlist) {
                        if (    canmove( $piece, $to, $_, %board )
                            and isLegal( $w, $_, $to, %board ) )
                        {
                            $from = $_;
                            last;
                        }
                    }
                }
                else {
                    $from = $fromlist[0];
                }
                if ( $piece =~ /[RrKk]/ ) {
                    if ( $piece eq 'R' ) {
                        $Kc = 0 if $from eq 'h1';
                        $Qc = 0 if $from eq 'a1';
                    }
                    elsif ( $piece eq 'r' ) {
                        $kc = 0 if $from eq 'h8';
                        $qc = 0 if $from eq 'a8';
                    }
                    elsif ( $piece eq 'K' ) {
                        $Kc = $Qc = 0;
                    }
                    else {
                        $kc = $qc = 0;
                    }
                }
                ( $board{$to}, $board{$from} ) = ( $board{$from}, undef );
                if ($debug) {
                    print "\@piece_at=", join( ",", @piece_at ), "\n"
                      if @piece_at;
                    print "\$piece='$piece' " if $piece;
                    print "\$from='$from' "   if $from;
                    print "\$to='$to' "       if $to;
                }
                push( @epdlist, epd( $w, $Kc, $Qc, $kc, $qc, $ep, %board ) );
                if ($debug) {
                    print "$epdlist[-1]\n";
                }
                if ( not $from ) {
                    ShowPieces(%board);
                    Print(%board);
                    try {
                        $from;
                    } catch {
                        print "From undefined\n";
                        exit;
                    };
                }
            }
            $w ^= 1;
        }
    }
    %board = ();
    return @epdlist;
}

sub isLegal {
    my ( $w, $from, $to, %board ) = @_;
    my %board_copy = %board;
    my $kings_square;
    my @attack_list;

    ( $board_copy{$to}, $board_copy{$from} ) = ( $board_copy{$from}, undef );
    my $findking = $w ? 'K' : 'k';
    for ( keys %board_copy ) {
        if ( $board_copy{$_} and ( $board_copy{$_} eq $findking ) ) {
            $kings_square = $_;
            last;
        }
    }
    my $mask = $w ? 'qrnbp' : 'QRNBP';
    for my $square ( keys %board_copy ) {
        if ( $board_copy{$square} and $mask =~ /$board_copy{$square}/ ) {
            for ( @{ $move_table{ uc( $board_copy{$square} ) }{$square} } ) {
                push( @attack_list, $square ) if $_ eq $kings_square;
            }
        }
    }
    for (@attack_list) {
        if ( canmove( $board_copy{$_}, $kings_square, $_, %board_copy ) ) {
            return 0;
        }
    }
    return 1;
}

sub ShowPieces {
    my %board = @_;

    for my $square ( keys %board ) {
        my $piece = $board{$square};
        next unless $piece;
        print "'$square' == ", $piece, "\n";
    }
    return;
}

sub Print {
    my (%board)     = @_;
    my $whitesquare = 1;
    my @rows        = (
        [qw(a8 b8 c8 d8 e8 f8 g8 h8)], [qw(a7 b7 c7 d7 e7 f7 g7 h7)],
        [qw(a6 b6 c6 d6 e6 f6 g6 h6)], [qw(a5 b5 c5 d5 e5 f5 g5 h5)],
        [qw(a4 b4 c4 d4 e4 f4 g4 h4)], [qw(a3 b3 c3 d3 e3 f3 g3 h3)],
        [qw(a2 b2 c2 d2 e2 f2 g2 h2)], [qw(a1 b1 c1 d1 e1 f1 g1 h1)]
    );

    for ( 0 .. 7 ) {
        print "\n", 8 - $_, "  ";
        for ( @{ $rows[$_] } ) {
            if ( $board{$_} ) {
                print $board{$_};
            }
            elsif ($whitesquare) {
                print ' ';
            }
            else {
                print '-';
            }
            $whitesquare ^= 1;
        }
        $whitesquare ^= 1;
    }
    print "\n   abcdefgh\n\n";
    return;
}

sub movetype {
    my ( $w, $move ) = @_;
    my @result = "'$move':Not yet handled";
    my $from;
    my $to;

    if ( $move =~ /^O-O(?:\+|\#)?$/ ) {
        if ($w) {
            $from = "e1h1";
            $to   = "g1f1";
        }
        else {
            $from = "e8h8";
            $to   = "g8f8";
        }
        @result = ( "KR", $to, $from );
    }
    elsif ( $move =~ /^O-O-O(?:\+|\#)?$/ ) {

        if ($w) {
            $from = "e1a1";
            $to   = "c1d1";
        }
        else {
            $from = "e8a8";
            $to   = "c8d8";
        }
        @result = ( "KR", $to, $from );
    }
    elsif ( $move =~ /^([2-7])([a-h][1-8])(?:\+|\#)?$/ ) {
        @result = ( "P", $2 );
    }
    elsif ( $move =~ /^([a-h][1-8])(?:\+|\#)?$/ ) {
        @result = ( "P", $1 );
    }
    elsif ( $move =~ /^([a-h])x?([a-h][1-8])(?:\+|\#)?$/ ) {
        @result = ( "P", $2, $1 );
    }
    elsif ( $move =~ /^([a-h][18])=?([RNBQ])(?:\+|\#)?$/ ) {
        @result = ( "P", $1, undef, $2 );
    }
    elsif ( $move =~ /^([a-h])x([a-h][18])=?([RNBQ])(?:\+|\#)?$/ ) {
        @result = ( "P", $2, $1, $3 );
    }
    elsif ( $move =~ /^([RNBQK])([a-h][1-8])(?:\+|\#)?$/ ) {
        @result = ( $1, $2 );
    }
    elsif ( $move =~ /^([RNBQK])x([a-h][1-8])(?:\+|\#)?$/ ) {
        @result = ( $1, $2 );
    }
    elsif ( $move =~ /^([RNBQK])([a-h]|[1-8])([a-h][1-8])(?:\+|\#)?$/ ) {
        @result = ( $1, $3, $2 );
    }
    elsif ( $move =~ /^([RNBQK])([a-h][1-8])([a-h][1-8])(?:\+|\#)?$/ ) {
      @result = ( $1, $3, $2 );
    }
    elsif ( $move =~ /^([RNBQK])([a-h]|[1-8])x([a-h][1-8])(?:\+|\#)?$/ ) {
        @result = ( $1, $3, $2 );
    }
    elsif ( $move =~ /^([RNBQK])([a-h][1-8])x([a-h][1-8])(?:\+|\#)?$/ ) {
        @result = ( $1, $3, $2 );
    }
    return @result;
}

sub psquares {
    my ( $piece, %board ) = @_;

    return grep { $_ and $board{$_} and ( $board{$_} eq $piece ) } sort keys %board;
}

sub epd {
    my ( $w, $Kc, $Qc, $kc, $qc, $ep, %board ) = @_;
    my @key = qw(
      a8 b8 c8 d8 e8 f8 g8 h8
      a7 b7 c7 d7 e7 f7 g7 h7
      a6 b6 c6 d6 e6 f6 g6 h6
      a5 b5 c5 d5 e5 f5 g5 h5
      a4 b4 c4 d4 e4 f4 g4 h4
      a3 b3 c3 d3 e3 f3 g3 h3
      a2 b2 c2 d2 e2 f2 g2 h2
      a1 b1 c1 d1 e1 f1 g1 h1
    );
    my $n;
    my $piece;
    my $epd;

    for ( 0 .. 63 ) {
        if ( $_ and ( $_ % 8 ) == 0 ) {
            if ($n) {
                $epd .= "$n";
                $n = 0;
            }
            $epd .= "/";
        }
        $piece = $board{ $key[$_] };

        if ($piece) {
            if ($n) {
                $epd .= "$n";
                $n = 0;
            }
            $epd .= $piece;
        }
        else {
            $n++;
        }
    }

    $epd .= "$n" if $n;
    $epd .= ( $w ? " b" : " w" );

    if ( $Kc or $Qc or $kc or $qc ) {
        $epd .= " ";
        $epd .= "K" if $Kc;
        $epd .= "Q" if $Qc;
        $epd .= "k" if $kc;
        $epd .= "q" if $qc;
    }
    else {
        $epd .= " -";
    }
    $epd .= " $ep";
    return $epd;
}

sub canmove {
    my ( $piece, $to, $from, %board ) = @_;
    my $lto;
    my $rto;
    my $lfrom;
    my $rfrom;
    my $result  = 1;
    my $offset  = 1;
    my $roffset = 1;
    my $loffset = 1;
    my $c       = 0;

    $to =~ /(.)(.)/;
    ( $lto, $rto ) = ( $1, $2 );
    $from =~ /(.)(.)/;
    ( $lfrom, $rfrom ) = ( $1, $2 );

    if ( $board{$from} and $board{to} ) {
        if ( defined( $board{$from} ) and defined( $board{$to} ) ) {
            if ( $board{$from}->color() == $board{$to}->color() ) {
                $result = 0;
            }
        }
    }
    elsif ( ( $rto eq $rfrom ) or ( $lto eq $lfrom ) ) {

        if (   ( $rto eq $rfrom and $lto lt $lfrom )
            or ( $lto eq $lfrom and $rto lt $rfrom ) )
        {
            $offset = -1;
        }

        if ( $lto eq $lfrom ) {
            $c = 1;
        }
        while ( $from ne $to ) {
            substr( $from, $c, 1 ) =
              chr( ord( substr( $from, $c, 1 ) ) + $offset );
            if ( defined( $board{$from} ) ) {
                $result = 0 if ( $from ne $to );
                last;
            }
        }
    }
    elsif ( $piece =~ /[bq]/i ) {

        if ( $rto lt $rfrom ) {
            $roffset = -1;
        }
        if ( $lto lt $lfrom ) {
            $loffset = -1;
        }
        while ( $from ne $to ) {
            substr( $from, 0, 1 ) =
              chr( ord( substr( $from, 0, 1 ) ) + $loffset );
            substr( $from, 1, 1 ) =
              chr( ord( substr( $from, 1, 1 ) ) + $roffset );
            if ( defined( $board{$from} ) ) {
                $result = 0 if ( $from ne $to );
                last;
            }
        }
    }
    return $result;
}

sub epdTaxonomy {
    my (%options) = @_;
    my @moves = @{$options{'moves'}};
    my @results;
    my ($eco,$nic,$opening);
    my @epd = reverse (epdlist(@moves));

    if ($options{'all'}) {
        $eco = epdcode('ECO',\@epd);
        $nic = epdcode('NIC',\@epd);
        $opening = epdcode('Opening',\@epd);
    }
    else {
        for (lc (keys %options)) {
            if ($_ eq 'eco') {
                $eco = epdcode('ECO',\@epd);
            }
            elsif ($_ eq 'nic') {
                $nic = epdcode('NIC',\@epd);
            }
            elsif ($_ eq 'Opening') {
                $opening = epdcode('Opening',\@epd);
            }
        }
    }
    if ($options{'astags'}) {
        push(@results,"[ECO \"$eco\"]") if $eco;
        push(@results,"[NIC \"$nic\"]") if $nic;
        push(@results,"[Opening \"$opening\"]") if $opening;
    }
    else {
        push(@results,$eco) if $eco;
        push(@results,$nic) if $nic;
        push(@results,$opening) if $opening;
    }
    return @results;
}

sub GetPaths {
    my $module = shift;
    my $sep;
    my $dbECO;
    my $dbNIC;
    my $dbOpening;

    s/::/\//g, s/$/.pm/ for $module;
    for (@INC) {
        if (/(\\|\/)Perl[\\\/]site[\\\/]lib$/i) {
            $sep = $1;
            $module = $_ . $sep . $module;
            last;
        }
    }
    $module =~ s/EPD.pm//;
    $dbECO = $module . 'db' . $sep . 'ECO.stor';
    $dbNIC = $module . 'db' . $sep . 'NIC.stor';
    $dbOpening = $module . 'db' . $sep . 'Opening.stor';
    return ($dbECO,$dbNIC,$dbOpening);
}

1;
__END__