File Coverage

blib/lib/Games/Go/SGF.pm

Criterion	Covered	Total	%
statement	21	203	10.3
branch	0	72	0.0
condition	0	20	0.0
subroutine	7	40	17.5
pod	3	14	21.4
total	31	349	8.8

package Games::Go::SGF;

use 5.006;
use strict;
use warnings;
use Carp;
use IO::File;
use English;
use Parse::RecDescent;

require Exporter;

our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw() ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw();
our $VERSION = '0.11';
our $AUTOLOAD;

{
  my %nodehash;
  my %onersfound;
  my %duplicates;

  # organise a node's property values and tags
  # drop leading [, and trailing ]

  sub store {
    my ($ident, $values) = @_;
    if (exists($nodehash{tags})) {
      if ($nodehash{tags} !~ /,$ident,/) {
        $nodehash{tags} .= $ident.',';
      }
    } else {
      $nodehash{tags} = ','.$ident.','
    }

    if (exists($nodehash{$ident})){
      $nodehash{$ident} = join (',', $nodehash{$ident}, map (substr($_,1,-1), @{$values}));
    } else {
      $nodehash{$ident} = join (',', map (substr($_,1,-1), @{$values}));
    }
  }

  # detect duplicate tags and mixed nodes

  sub isDuplicate {
    my $ident = shift;

    # bad sgf if more than one of these in a file
    my $oners = ',SZ,GM,ST,FF,CA,AP,RU,SZ,KM,';
    if (exists($onersfound{$ident}) and $oners =~ /,$ident,/) {
      print 'Duplicated ',$ident, ' property',"\n";
      return 1;
    }
    $onersfound{$ident} = undef;

    # bad sgf if any of these are duplicated in a node
    my $singletons = ',B,W,PL,MN,';
    if (exists($duplicates{$ident}) and $singletons =~ /,$ident,/) {
      print 'Duplicated ',$ident, ' property',"\n";
      return 1;
    }

    # bad sgf if both of these are in a node
    my $alones = ',B,W,';
    if ((grep (exists($duplicates{$_}),('B','W')) ) and $alones =~ /,$ident,/) {
      print $ident, ' property not allowed in this node',"\n";
      return 1;
    }

    # flag mixed nodes - if this is B or W, have we already got AB or AW or AE
    my $setup = ',AB,AW,AE,';
    if ((grep (exists($duplicates{$_}),('B','W')) ) and $setup =~ /,$ident,/) {
      print 'Setup and move in the same node',"\n";
      return 1;
    }

    # flag mixed nodes - if this is AB or AW or AE, have we already got B or W
    my $move = ',B,W,';
    if ((grep (exists($duplicates{$_}),('AB','AW','AE')) ) and $move =~ /,$ident,/) {
      print 'Setup and move in the same node',"\n";
      return 1;
    }

    $duplicates{$ident} = 0;

    return 0;
  }

  # return and clear the tags and values for a node

  sub unload {
    my %hash = %nodehash;
    %nodehash = ();
    %duplicates = ();
    return %hash
  }

  sub refresh {
    %onersfound = ();
    %nodehash = ();
    %duplicates = ();
  }

}

my $grammar = q{
        File : GameTree { $return = $item[1]; Games::Go::SGF::refresh }
    GameTree : '(' Node(s) GameTree(s?) ')' {
                  $return = $item[2];
                  push @{$return} , bless( $item[3], 'Games::Go::SGF::Variation') if (@{$item[3]})
                }
        Node : ';' Property(s?) {
                  $return = bless({Games::Go::SGF::unload()}, 'Games::Go::SGF::Node')
                }
    Property : ...Validate Tag Value(s) {
                  Games::Go::SGF::store( $item[2], $item[3] );
                }
    Validate : (/B\[/|/W\[/)  MovePoint
              |('AB'|'AW'|'AE'|'CR'|'MA'|'SL'|'SQ'|'TR')  Point(s)
              |'PL'  Colour
              |/C\[/  Comment
              |'AP'|'CA'  Value
              |('SZ'|'FF'|'HA'|'OW'|'OB'|'ST'|'GM')  Integer
              |('BL'|'WL')  Real
              |'LB'  Markup(s)
              |/[A-Z]+/  Value(s)
         Tag : /[A-Z]+/  { $return = $item[1] }
       Value : /\[.*?(?
     Comment : /.*?(?
      Markup : /\[[a-zA-Z]{2}/ ':' /.*?(?
   MovePoint : /[a-zA-Z]{2}\][^\[]/ | /\]/
       Point : /\[[a-zA-Z]{2}\]/
     Integer : /\[\d+\]/
        Real :/\[\d+\.\d+\]|\[\d+\]/
      Colour : /\[[WB]\]/
};

sub new {
  my ($class, $file, $grammarflag) = @_;
  my $grammar = _choosegrammar($grammarflag);
  my $parser = new Parse::RecDescent $grammar or croak "Bad grammar!\n";
  my $fh = IO::File->new($file, '<') or croak $ERRNO;
  my $slurpfile = do { local $/; <$fh> };
  $fh->close or croak $ERRNO;
  my $a = $parser->File($slurpfile);
  defined $a or croak "Bad Go sgf\n";
  bless $a, 'Games::Go::SGF';
  _sew($a);
  return $a;
}

sub _sew {
  my $a = shift;
  $a->[0]->{moves_to_first_variation} = 0;
  for (0..@$a) {
    if (ref $a->[$_] eq 'Games::Go::SGF::Variation') {
      $a->[0]->{moves_to_first_variation} ||= $_;
      _sew($_) for $a->[$_]->variations;
    } else {
      $a->[$_]->{next} = $a->[$_+1];
    }
  }
}

sub _choosegrammar {
  my $grammarflag = shift;
  my $res;
  $grammarflag ||= 'lite';
  for ($grammarflag) {
    if ($_ eq 'lite')   { $res = $grammar;
                          $res =~ s/\.\.\.Validate//;
                          $res =~ s/\[2\], \$item\[3\]/\[1\], \$item\[2\]/;
                          $res =~ s/Validate.*Value\(s\)//s;
                          $res =~ s/Comment.*eofile/eofile/s;
                          last }
    if ($_ eq 'full')   { $res = $grammar; last }
    croak 'Unknown grammar type';
  }
  return $res
}

# Game info methods

sub date  {
  my ($self, $value) = @_;
  _setvalue($self, 'DT', $value) if ($value);
  return $self->[0]->{DT};
}

sub time  { date(@_) }

sub white {
  my ($self, $value) = @_;
  _setvalue($self, 'PW', $value) if ($value);
  return $self->[0]->{PW};
}

sub black {
  my ($self, $value) = @_;
  _setvalue($self, 'PB', $value) if ($value);
  return $self->[0]->{PB};
}

sub size  {
  my ($self, $value) = @_;
  _setvalue($self, 'SZ', $value) if ($value);
  return $self->[0]->{SZ};
}

sub komi  {
  my ($self, $value) = @_;
  _setvalue($self, 'KM', $value) if ($value);
  return $self->[0]->{KM};
}

sub delete{
  my ($self, $tag) = @_;
  if (exists $self->[0]->{$tag}) {
    delete $self->[0]->{$tag};
    $self->[0]->{tags} =~ s/$tag,?//;
  }
}

# change the value of a tag
# if a new tag is being created, add it to {tags}
sub _setvalue {
  my ($self, $tag, $value) = @_;
  $self->[0]->{tags} = join(',', $self->[0]->{tags}, $tag) unless (exists $self->[0]->{$tag});
  $self->[0]->{$tag} = $value;
}

sub move  { $_[0]->[$_[1]]; }

sub getsgf {
  my $self = shift;
  my $move_no = 0;
  my $startvar = 1; # used for formatting of output
  my $string = '(';

  while (my $walker = $self->move($move_no++)) {
    $string .= _donode($walker, $startvar);
    $startvar = 0;
  }

  $string .= ')'."\n";
  return $string
}

sub _iterate {
  my $startpoint = shift;
  my $v = 0;
  my $string;
  my @vars = $startpoint->variations;

  while (defined $vars[$v]){
    $string .= "\n".'(';
    my $startvar = 1;
    for (@{$vars[$v++]}){
      $string .= _donode($_, $startvar);
      $startvar = 0;
    }
    $string .= ')';
  }

  return $string
}

sub _donode {
  my ($node, $startvar) = @_;
  my $string = '';
  if (ref($node) eq 'Games::Go::SGF::Node'){
    $string .= "\n" unless $startvar;
    $string .= ';';
    if ($node->tags) {
      for (split (',', $node->tags)) {
        $string .= $_;
        my $property = $node->$_;
        if ($property) {
          for (split (',', $property)) {
            $string .= '['.$_.']';
          }
        } else {
          $string .= '[]';
        }
      }
    }
  } else {
    if (ref($node) eq 'Games::Go::SGF::Variation'){
      $string .= _iterate($node);
    }
  }
  return $string
}

sub AUTOLOAD {
  my ($self, $value) = @_;
  my $type = ref($self) or croak $self.' is not an object';
  my $name = $AUTOLOAD;
  $name =~ s/.*://;   # strip fully-qualified portion
  _setvalue($self, $name, $value) if ($value);
  return $self->[0]->{$name};
}

package Games::Go::SGF::Variation;
our $AUTOLOAD;
sub mainline   { return $_[0]->[0] }
sub variation  { return $_[0]->[$_[1]]}
sub variations { return @{$_[0]} }

# This is - as I shouldn't need to tell you - is a dirty hack.
# But I like it (Simon)
sub AUTOLOAD {
    $AUTOLOAD=~ s/Variation/Node/;
    &$AUTOLOAD($_[0]->mainline, @_[1..@_]);
}
sub DESTROY { }

package Games::Go::SGF::Node;
our $AUTOLOAD;

sub move { my $node = shift; $node->{B} || $node->{W} }

sub color { colour(shift) }

sub colour {
  my $node = shift;
  if (exists($node->{B})){'B'}
  else {
    if (exists($node->{W})){'W'}
    else {'None'}
  }
}

sub nodedump {
  my $node = shift;
  my $result;
  for (split(',',$node->{tags})) {$result .= join(' ', $_, $node->{$_}, "\n")}
  return $result
}

sub tags {
  my $node = shift;
  $node->{tags};
}

sub delete{
  my ($node, $tag) = @_;
  if (exists $node->{$tag}) {
    delete $node->{$tag};
    $node->{tags} =~ s/$tag,?//;
  }
}

sub AUTOLOAD {
  my ($node, $value) = @_;
  my $name = $AUTOLOAD;
  $name =~ s/.*://;   # strip fully-qualified portion
  _nodesetvalue($node, $name, $value) if $value;
  return $node->{$name};
}

sub _nodesetvalue {
  my ($node, $tag, $value) = @_;
  if (exists $node->{tags}) {
    $node->{tags} = join(',', $node->{tags}, $tag) unless exists $node->{$tag};
  } else {
    $node->{tags} = $tag;
  }
  $node->{$tag} = $value;
}

# Preloaded methods go here.

1;
__END__