File Coverage

blib/lib/Chess/PGN/Filter.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Parms;

use strict;
use warnings;
use Chess::PGN::EPD;
use vars '$AUTOLOAD';
use Carp;

sub new {
    my ($class,%arg) = @_;
    bless {
        _verbose => defined $arg{verbose} ? $arg{verbose} : 1, #default legacy verbose
        _filtertype => $arg{filtertype},
        _source => $arg{source},
        _fen => $arg{fen} || 'no',
        _position => $arg{position} || 'yes',
        _type => $arg{type} || ($arg{font} || 'marroquin'),
        _border => $arg{single} || 'single',
        _corner => $arg{square} || 'square',
        _legend => $arg{legend} || 'no',
        _size => $arg{size} || '5',
        _font => $arg{font} || 'Chess Kingdom',
        _ECO => $arg{ECO} || 'yes',
        _NIC => $arg{NIC} || 'no',
        _Opening => $arg{Opening} || 'yes',
        _substitutions => $arg{substitutions},
        _exclude => $arg{exclude},
        _comments => $arg{comments} || 'yes',
        _nags => $arg{nags} || 'yes',
        _ravs => $arg{ravs} || 'yes',
        _sticky => $arg{sticky} || 'yes',
        _autoround => $arg{autoround} || 'yes',
        _event => '',
        _site => '',
        _date => '',
        _round => '',
    }, $class;
}

sub AUTOLOAD {
    my ($self,$newval) = @_;

    $AUTOLOAD =~ /.*::get(_\w+)/ and return $self->{$1};
    $AUTOLOAD =~ /.*::set(_\w+)/ and do { $self->{$1} = $newval; return };
    $AUTOLOAD =~ /.*::if(_\w+)/ and return ($self->{$1} eq 'yes');
    croak "No such method: $AUTOLOAD\n";
}

sub DESTROY {
}

package Chess::PGN::Filter;

use 5.006;
use strict;
use warnings;
use Chess::PGN::Parse;
use Chess::PGN::EPD;
use Text::DelimMatch;
use Data::Dumper;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT = qw(
    &filter
);
our $VERSION = '0.15';


sub filter {
    my $parameters = new Parms(@_);
    my $filtered;
    if ($parameters->get_filtertype() eq 'XML') {
        $filtered = filterXML(@_);
    }
    elsif ($parameters->get_filtertype() eq 'TEXT') {
        $filtered = filterTEXT(@_);
    }
    elsif ($parameters->get_filtertype() eq 'DOM') {
        $filtered = [ filterDOM(@_) ];
    }
    else {
        die "Unknown filtertype: '$parameters->get_filtertype()' not supported.\n";
    }
    if ($parameters->get_verbose()) {
        print $parameters->get_filtertype() eq 'DOM' ? Dumper(@$filtered) : $filtered;
    }
    else {
        return $filtered;
    }
}

sub filterDOM {
    my $parms = new Parms(@_);
    my $file = $parms->get_source();
    my $filetext;

    {
        local $/ = undef;
        open(FILE,$file) or die "Couldn't open file:$file $!\n";
        $filetext = ;
        close(FILE);
    }
    return getDOM($filetext);
}

sub filterTEXT {
    my $parms = new Parms(@_);
    my $file = $parms->get_source();
    my @DOM;
    my $filetext;
    my $text = '';

    {
        local $/ = undef;
        open(FILE,$file) or die "Couldn't open file:$file $!\n";
        $filetext = ;
        close(FILE);
    }
    @DOM = getDOM($filetext);
    foreach (@DOM) {
        my $termination =  ($_->{'Tags'}->{'Result'} =~ /^1-0|0-1|1\/2-1\/2|\*$/ ? $_->{'Tags'}->{'Result'} : '*');
        my $movetext;
        my $move = 1;

        domExTags($parms,$_->{'Tags'}) if $parms->get_exclude();
        domSticky($parms,$_->{'Tags'}) if $parms->if_sticky();
        domAutoround($parms,$_->{'Tags'}) if $parms->if_autoround();
        domTaxonomy($parms,$_->{'Gametext'},$_->{'Tags'}) if doTax($parms);
        foreach  my $key ('Event','Site','Date','Round','White','Black','Result') {
            if ($_->{'Tags'}->{$key}) {
                if ($parms->get_substitutions()) {
                    while (my ($one,$another) = each(%{$parms->get_substitutions()})) {
                        if ($_->{'Tags'}->{$key} =~ /$one/) {
                            $_->{'Tags'}->{$key} =~ s/$one/$another/;
                        }
                    }
                }
                $text .= "[$key \"$_->{'Tags'}->{$key}\"]\n";
                delete($_->{'Tags'}->{$key});
            }
        }
        foreach my $key (sort keys %{$_->{'Tags'}}) {
            $text .= "[$key \"$_->{'Tags'}->{$key}\"]\n";
        }
        $text .= "\n";
        $movetext = domTEXTGametext($parms,$move,$_->{'Gametext'});
        $text .= join("\n",paragraph($movetext . $termination,78))."\n\n";
    }
    return $text;
}

sub doTax {
    my $parms = shift;

    return ($parms->if_ECO() or $parms->if_NIC() or $parms->if_Opening());
}

sub domExTags {
    my $parms = shift;
    my $tag = shift;
    my $array = $parms->get_exclude();

    foreach  (@$array) {
        if (exists($tag->{$_})) {
            delete($tag->{$_});
        }
    }

}

sub domAutoround {
    my $parms = shift;
    my $tag = shift;

    if (exists($tag->{'Round'})) {
        my $value = $tag->{'Round'};

        if ($value eq '' or $value eq '?') {
            my $round = $parms->get_round();

            $tag->{'Round'} = ++$round;
            $parms->set_round($round);
        }
        else {
        	$parms->set_round($value);
        }
    }
}

sub domSticky {
    my $parms = shift;
    my $tag = shift;

    if (exists($tag->{'Event'})) {
        my $value = $tag->{'Event'};

        if ($value eq '' or $value eq '?') {
            $tag->{'Event'} = $parms->get_event();
        }
        else {
        	$parms->set_event($value);
        }
    }
    if (exists($tag->{'Site'})) {
        my $value = $tag->{'Site'};

        if ($value eq '' or $value eq '?') {
            $tag->{'Site'} = $parms->get_site();
        }
        else {
        	$parms->set_site($value);
        }
    }
    if (exists($tag->{'Date'})) {
        my $value = $tag->{'Date'};

        if ($value eq '' or $value eq '??.??.??') {
            $tag->{'Date'} = $parms->get_date();
        }
        else {
        	$parms->set_date($value);
        }
    }
}

sub domTaxonomy {
    my $parms = shift;
    my $gametext = shift;
    my $tag = shift;
    my @epd = reverse domEPD($gametext);

    if (exists($tag->{'ECO'})) {
        my $tax = $tag->{'ECO'};

        if ($tax eq '?' or $tax eq '') {
            $tag->{'ECO'} = epdcode('ECO',\@epd)
        }
    }
    else {
        $tag->{'ECO'} = epdcode('ECO',\@epd) if $parms->if_ECO();
    }
    if (exists($tag->{'NIC'})) {
        my $tax = $tag->{'NIC'};

        if ($tax eq '?' or $tax eq '') {
            $tag->{'NIC'} = epdcode('NIC',\@epd)
        }
    }
    else {
        $tag->{'NIC'} = epdcode('NIC',\@epd) if $parms->if_NIC();
    }
    if (exists($tag->{'Opening'})) {
        my $tax = $tag->{'Opening'};

        if ($tax eq '?' or $tax eq '') {
            $tag->{'Opening'} = epdcode('Opening',\@epd)
        }
    }
    else {
        $tag->{'Opening'} = epdcode('Opening',\@epd) if $parms->if_Opening();
    }
}

sub domTEXTGametext {
    my $parms = shift;
    my $move = shift;
    my $Gametext = shift;
    my $movetext = '';

    foreach my $element (@{$Gametext}) {
        if ($element->{'Movenumber'} % 2) {
            $movetext .= "$move. ";
        }
        else {
            $move++;
        }
        $movetext .= $element->{'Movetext'} . " ";
        if ($element->{'Comment'}) {
            $movetext =~ s/\s$//;
            $movetext .= '(' . $element->{'Comment'} . ')' if $parms->if_comments();
        }
        if ($element->{'Nag'}) {
            my $s = $element->{'Nag'};

            if ($s) {
                if ($s < 6) {
                    $movetext =~ s/\s$//;
                    $movetext .= NAG($s);
                }
                else {
                    $movetext =~ s/\s$//;
                    $movetext .= "\$$s" if $parms->if_nags();
                }
            }
        }
        if ($element->{'Rav'}) {
                my $ravtext = domTEXTGametext($parms,$move,$element->{'Rav'});

                $ravtext =~ s/\s$//;
                $movetext =~ s/\s$//;
                $movetext .= "{$ravtext}";
        }
    }
    return $movetext;
}

sub domEPD {
    my $Gametext = shift;
    my @epd;

    foreach my $element (@{$Gametext}) {
        push(@epd,$element->{'Epd'});
    }
    return @epd;
}

sub paragraph {
    my $s = shift;
    my $n = shift;
    my $m = $n;

    while ($m < length($s)) {
        while(substr($s,$m,1) ne ' ') {
            $m--;
        }
        if (substr($s,$m - 1,1) eq '.') {
            $m--;
            next;
        }
        substr($s,$m,1) = '|';
        $m += $n;
    }
    return split(/\|/,$s);
}

sub deLIMIT {
    my $t = shift;
    my $startdelim = shift;
    my $enddelim = shift;
    my $escape = shift;
    my $mc = new Text::DelimMatch($startdelim,$enddelim,$escape);
    my ($prefix,$match,$remainder) = $mc->match(' ' . $t . ' ');

    if ($match) {
        $match =~ s/^$startdelim//;
        $match =~ s/$enddelim$//;
        return ($prefix or '') . ($remainder or ''),$match;
    }
    else {
        return $t,'';
    }
}

sub parseComments {
    my $rcomments = shift;
    my $rravs = shift;
    my $rnags = shift;

    foreach  (keys %$rcomments) {
        my $t = $rcomments->{$_};
        my $NAG;
        my $RAV;
        my $COMMENT;

        ($t,$COMMENT) = deLIMIT($t,'\{','\}');
        ($t,$RAV) = deLIMIT($t,'\(','\)','{}');
        ($t,$NAG) = deLIMIT($t,'\$','\D');
        if ($RAV) {
            $rravs->{$_} = $RAV;
        }
        if ($NAG and $NAG ne '') {
            $rnags->{$_} = $NAG;
        }
        if ($COMMENT) {
            $rcomments->{$_} = $COMMENT;
        }
        else {
            delete($rcomments->{$_});
        }
   }
}

sub filterXML {
    my $parms = new Parms(@_);
    my $file = $parms->get_source();
    my @DOM;
    my $filetext;
    my $text = '';

    {
        local $/ = undef;
        open(FILE,$file) or die "Couldn't open file:$file $!\n";
        $filetext = ;
        close(FILE);
    }
    @DOM = getDOM($filetext);
    $file =~ s/.pgn//;
    $file = uc($file);
#-----------------------------------------------------------------------------
    $text .= <<"HEADER";




HEADER
#-----------------------------------------------------------------------------
    $text .= dom2XML($parms,@DOM);
    $text .= "\n";
    return $text;
}

sub dom2XML {
    my $parms = shift;
    my @DOM = @_;
    my $level = 0;
    my $result;
    my $text = '';

    foreach (@DOM) {
        $text .= "\t\n";
        $text .= "\t\t\n";
        foreach  my $key ('Event','Site','Date','Round','White','Black','Result') {
            if ($_->{'Tags'}->{$key}) {
                if ($key eq 'Result') {
                    $result = $_->{'Tags'}->{$key};

                    if ($result eq '1-0') {
                        $result = 'WHITEWIN';
                    }
                    elsif ($result eq '0-1') {
                        $result = 'BLACKWIN';
                    }
                    elsif ($result eq '1/2-1/2') {
                        $result = 'DRAW';
                    }
                    else {
                    	$result = 'UNKNOWN';
                    }
                    $text .= "\t\t\t\n";
                }
                elsif ($key eq 'Date') {
                    my @date = split(/\./,$_->{'Tags'}->{$key});

                    $text .= "\t\t\t\n";
                }
                else {
                    $text .= "\t\t\t<$key>$_->{'Tags'}->{$key}\n";
                }
                delete($_->{'Tags'}->{$key});
            }
        }
        foreach my $key (sort keys %{$_->{'Tags'}}) {
            $text .= "\t\t\t<$key>$_->{Tags}->{$key}\n";
        }
        $text .= "\t\t\n";
        $text .= dom2XMLGametext($parms,$level,$result,$_->{'Gametext'});
        $text .= "\t\n";
    }
    return $text;
}

sub dom2XMLGametext {
    my $parms = shift;
    my $level = shift;
    my $result = shift;
    my $Gametext = shift;
    my $tabs = "\t" x 2 . "\t" x $level;
    my $text = '';
    my $diagram = sub {
        my $element = shift;
        my @rows = epdstr(
            epd => $element,
            type => $parms->get_type(),
            border => $parms->get_border(),
            corner => $parms->get_corner(),
            legend => $parms->get_legend()
            );
        my $text = '';

        $text .= qq|$tabs\t\n|;
        foreach my $row (@rows) {
            $text .= "$tabs\t\t$row\n";
        }
        $text .= "$tabs\t\n";
        return $text;
    };

    $text .= qq|$tabs\n|;
    foreach my $element (@{$Gametext}) {
        $text .= "$tabs\t$element->{'Movenumber'}\n";
        $text .= "$tabs\t$element->{'Movetext'}\n";
        if ($element->{'Rav'}) {
            $text .= dom2XMLGametext($parms,$level + 1,'UNKNOWN',$element->{'Rav'});
        }
        $text .= "$tabs\t$element->{'Comment'}\n" if $element->{'Comment'};
        if ($element->{'Nag'}) {
            my $s = $element->{'Nag'};
            if ($s eq '0' and ($parms->if_position() or $parms->get_position() eq 'nag')) {
                $text .= &$diagram($element->{'Epd'});
            }
            else {
            	$text .= "$tabs\t$element->{'Nag'}\n";
            }
        }
        $text .= "$tabs\t$element->{'Epd'}\n" if $parms->if_fen();
    }
    $text .= qq|$tabs\t\n|;
    $text .= "$tabs\n";
    if ($level == 0 and ($parms->if_position() or $parms->get_position() eq 'end')) {
        chop($tabs);
        $text .= &$diagram(@{$Gametext}[-1]->{'Epd'});
    }
    return $text;
}

sub getDOM {
    my $s = shift;
    my $pgn = new Chess::PGN::Parse undef, $s;
    my $games_ref = $pgn->read_all({save_comments => 'yes'});
    my @DOM;

    foreach  (@{$games_ref}) {
        my %comments;
        my %ravs;
        my %nags;
        my @moves;
        my @epd;
        my %tags;
        my %game;
        my @movelist;
        my @movesmade;
        my $position = 0;
        my $movenumber = 1;

        push(@DOM,\%game);
        foreach my $key  (keys %{$_}) {
            my $ref = $_->{$key};
            if (ref($ref)) {
                if ($key eq 'GameMoves') {
                    @moves = @{$ref};
                    @epd = epdlist(@moves);
                }
                elsif ($key eq 'GameComments') {
                    %comments = %{$ref};
                    parseComments(\%comments,\%ravs,\%nags);
                }
            }
            elsif ($ref) {
                if ($key ne 'Game') {
                    $tags{$key} = $ref;
                }
            }
        }
        $game{'Tags'} = \%tags;
        $game{'Gametext'} = \@movelist;
        foreach  (@moves) {
            my %move;
            my $ckey;

            $move{'Movetext'} = $_;
            $move{'Movenumber'} = $position;
            push(@movesmade,$_);
            if ($position % 2) {
                $ckey = "${movenumber}b";
                $movenumber++;
            }
            else {
                $ckey = "${movenumber}w";
            }
            $move{'Comment'} = $comments{$ckey} if (%comments and exists($comments{$ckey}));
            $move{'Nag'} = $nags{$ckey} if (%nags and exists($nags{$ckey}));
            if (%ravs and exists($ravs{$ckey})) {
                my $n = scalar(@movesmade) - 2;
                my @ravDOM = getDOM("[Result \"*\"]\n\n" . join(' ',@movesmade[0..$n++]) . " $ravs{$ckey}");

                delete($ravDOM[0]->{'Tags'});
                splice(@{$ravDOM[0]->{'Gametext'}},0,$n);
                $move{'Rav'} = $ravDOM[0]->{'Gametext'};
            }
            $move{'Epd'} = $epd[$position++];
            $move{'Movenumber'} = $position;
            push(@movelist,\%move);
        }
    }
    return @DOM;
}

1;
__END__