File Coverage

blib/lib/Games/Go/SGF/Grove.pm

Criterion	Covered	Total	%
statement	38	178	21.3
branch	15	70	21.4
condition	11	27	40.7
subroutine	9	36	25.0
pod	4	4	100.0
total	77	315	24.4

=head1 NAME

Games::Go::SGF::Grove - SGF the Perl way

=head1 SYNOPSIS

 use Games::Go::SGF::Grove;

 $game = load_sgf $path;
 save_sgf $path, $game;

 $game = decode_sgf $sgf_data;
 $sgf_data = encode_sgf $game;

=head1 DESCRIPTION

This module loads and saves Go SGF files. Unlike other modules, it doesn't
build a very fancy data structure with lot's of java-like accessors
but instead returns a simple Perl data structure you can inspect with
Data::Dumper and modify easily. The structure follows the SGF file format
very closely.

The SGF format is documented here: L.

All the functions below use a common data format and throw exceptions on
any errors.

=over 4

=cut

package Games::Go::SGF::Grove;

use strict;
no warnings;

use Carp;

use base Exporter::;

our $VERSION = '1.01';
our @EXPORT = qw(load_sgf save_sgf encode_sgf decode_sgf);

=item $game = load_sgf $path

Tries to read the file given by C<$path> and parses it as an SGF file,
returning the parsed data structure.

=item save_sgf $path, $game

Saves the SGF data to the specified file.

=item $game = decode_sgf $sgf_data

Tries to parse the given string into a Pelr data structure and returns it.

=item $sgf_data = encode_sgf $game

Takes a Perl data structure and serialises it into an SGF file. Anything
stored in the structure that isn't understood by this module will be
silently ignored.

=cut

sub decode_sgf($) {
   my ($sgf_data) = @_;

   Games::Go::SGF::Grove::Parser::->new->decode_sgf ($sgf_data)
}

sub encode_sgf($) {
   my ($game) = @_;

   Games::Go::SGF::Grove::Parser::->new->encode_sgf ($game)
}

sub load_sgf($) {
   my ($path) = @_;

   open my $fh, "<:perlio", $path
      or Carp::croak "$path: $!";

   local $/;
   decode_sgf <$fh>
}

sub save_sgf($$) {
   my ($path, $game) = @_;

   open my $fh, ">:perlio", $path
      or Carp::croak "$path: $!";

   print $fh encode_sgf $game;
}

=back

=head2 The Game Data structure

The SGF game is represented by a linked Perl data structure consisting of
unblessed hashes and arrays.

SGF files are a forest of trees, called a collection (i.e. you can have
multiple games stored in a file). The C and C
functions returns this collection as a reference to an array containing
the individual game trees (usually there is only one, though).

Each individual tree is again an array of nodes representing the main line
of play.

Each node is simply a hash reference. Each SGF property is stored with the
(uppercase) property name as the key, and a property-dependent value for
the contents (e.g., a black move is stored as C<< B => [3, 5] >>.

If there are any variations/branches/alternate lines of play, then these
are stored in the array reference in the C key (those again
are game trees, so array references themselves).

This module reserves all uppercase key names for SGF properties, the key
C and all keys starting with an underscore (C<_xxx>) as it's
own. Users of this module may store additional attributes that don't
conflict with these names in any node.

Unknown properties will be stored as scalars with the (binary) property
contents. Text nodes will always be decoded into Unicode text and encoded
into whatever the CA property of the root node says (default: C).

When saving, all uppercase keys will be saved, lowercase keys will be
ignored.

For the actual encoding of other types, best decode some example game that
contains them and use Data::Dumper. Here is such an example:

  [ # list of game-trees, only one here
    [ # the main node sequence
      { # the root node, contains some variations
        DI => '7k',
        AP => undef,
        CO => '5',
        DP => '40',
        GE => 'tesuji',
        AW => [
                  [ 2, 16 ], [ 3, 15 ], [ 15, 9 ], [ 14, 13 ], ...
              ],
        C  => 'White just played a ladder block at h12.',
        variations => [ # list of variations, only one
                        [ # sequence of variation moves
                          { B => [  7,  5 ] }, # a black move
                          { W => [ 12, 12 ] }, # a white move
                          ... and so on
                        ]
                      ],
      }
    ]
  }

=cut

package Games::Go::SGF::Grove::Parser;

no warnings;
use strict 'vars';

use Encode ();
use Carp qw(croak);

my $ws = qr{[\x00-\x20]*}s;
my $property; # property => propertyinfo

sub new {
   my $class = shift;
   bless { @_ }, $class;
}

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

   my $pos = pos $self->{sgf};

   my $tail = substr $self->{sgf}, $pos, 32;
   $tail =~ s/[\x00-\x1f]+/ /g;

   croak "$error (at octet $pos, '$tail')";
}

sub decode_sgf {
   my ($self, $sgf) = @_;

   # correct lines
   if ($sgf =~ /[^\015\012]\015/) {
      $sgf =~ s/\015\012?/\n/g;
   } else {
      $sgf =~ s/\012\015?/\n/g;
   }

   $self->{sgf} = $sgf;

   $self->{FF} = 1;
   $self->{CA} = 'WINDOWS-1252'; # too many files are
   $self->{GM} = 1;

   my @trees;

   eval {
      while ($self->{sgf} =~ /\G$ws(?=\()/sgoc) {
         push @trees, $self->decode_GameTree;
      }
   };

   croak $@ if $@;

   \@trees
}

sub decode_GameTree {
   my ($self) = @_;

   $self->{sgf} =~ /\G$ws\(/sgoc
      or $self->error ("GameTree does not start with '('");

   my $nodes = $self->decode_Sequence;

   while ($self->{sgf} =~ /\G$ws(?=\()/sgoc) {
      push @{$nodes->[-1]{variations}}, $self->decode_GameTree;
   }
   $self->{sgf} =~ /\G$ws\)/sgoc
      or $self->error ("GameTree does not end with ')'");

   $nodes
}

sub postprocess {
   my $self = shift;

   for (@_) {
      if ("ARRAY" eq ref) {
         $self->postprocess (@$_);
      } elsif ("HASH" eq ref) {
         if (exists $_->{_text}) {
            my $value = $_->{_text};
            $value =~ s/\\\n/ /g;
            $value =~ s/\\(.)/$1/g;
            $_ = eval { Encode::decode $self->{CA}, $value } || $value;
         } else {
            $self->postprocess (values %$_);
         }
      }
   }
}

sub decode_Sequence {
   my ($self) = @_;

   my (@nodes, $node, $name, $value, $prop, @val);

   while ($self->{sgf} =~ /\G$ws;/goc) {
      push @nodes, $node = {};
      # Node
      while ($self->{sgf} =~ /\G$ws([A-Za-z]+)/goc) {
         # Property
         $name = $1;
         $name =~ y/a-z//d; # believe me, they exist
         $prop = $property->{$name};

         while ($self->{sgf} =~
            /
               \G $ws
               \[
                  (
                     (?:
                        [^\\\]]+ # any sequence without \ or ]
                        | \\.    # any quoted char
                        | \]     # hack to allow ] followed by somehting that doesn't look like SGF
                          (?! \s* (?: [A-Z]+\[ | [\[;()] ) )
                     )*
                  )
               \]
            /sgocx
         ) {
            # PropValue
            $value = $1;
            if ($prop) {
               @val = $prop->{in}->($self, $value, $prop);

               if ($prop->{is_list}) {
                  push @{$node->{$name}}, @val
               } else {
                  $node->{$name} = $val[0];

                  $self->{CA} = $val[0] if $name eq "CA";
               }
            } else {
               #warn "unknown property '$name', will be saved unchanged.";#d#
               push @{$node->{$name}}, $value;
            }
         }
      }

      # postprocess nodes, currently only to decode text and simpletext
      $self->postprocess ($node);
   }

   \@nodes
}

sub encode_sgf($) {
   my ($self, $game) = @_;

   $self->{sgf} = "";

   $self->{FF} = 4;
   $self->{CA} = 'UTF-8';
   $self->{GM} = 1;
   $self->{AP} = ["Games::Go::SGF::Grove", $VERSION];

   $self->encode_GameTree ($_, 1) for @$game;

   $self->{sgf}
}

sub encode_GameTree {
   my ($self, $sequence, $is_root) = @_;

   if ($is_root) {
      my $root = $sequence->[0];

      $root->{CA} ||= $self->{CA};
      $root->{FF} ||= $self->{FF};
      $root->{GM} ||= $self->{GM};
      $root->{AP} ||= $self->{AP};

      $self->{CA} = $root->{CA};
   }

   $self->{sgf} .= "(";
   $self->encode_Sequence ($sequence);
   $self->{sgf} .= ")";
}

sub encode_Sequence {
   my ($self, $sequence) = @_;

   my ($value, $prop);

   for my $node (@$sequence) {
      $self->{sgf} .= ";";

      for my $name (sort keys %$node) {
         next unless $name eq uc $name;

         $value = $node->{$name};

         $self->{sgf} .= "$name\[";

         if ($prop = $property->{$name}) {
            if ($prop->{is_list}) {
               $self->{sgf} .= join "][", map $prop->{out}->($self, $_), @$value;
            } else {
               $self->{sgf} .= $prop->{out}->($self, $value);
            }
         } else {
            $self->{sgf} .=
               ref $value
                  ? join "][", @$value
                  : $value;
         }

         $self->{sgf} .= "]";
      }

      $self->encode_GameTree ($_) for @{ $node->{variations} };
   }
}

#############################################################################

=head2 Property Type Structure

A property type is a hash like this:

   {
     name => "SQ",
     group => {
                name => "Markup properties",
                restrictions => "CR, MA, SL, SQ and TR points must be unique, ...",
              },
     related => "TR, CR, LB, SL, AR, MA, LN",
     function => "Marks the given points with a square.\nPoints must be unique.",
     propertytype => "-",
     propvalue => "list of point"
     is_list => 1,
   }

=cut


{
   my ($group, $name, $value, $prop);

   my (%char2coord, %coord2char);

   {
      my @coord = ("a" .. "z", "A" .. "Z");

      for (0.. $#coord) {
         $char2coord{ $coord[$_] } = $_;
         $coord2char{ $_ } = $coord[$_];
      }
   }

   sub _parsetype($);
   sub _parsetype {
      for (shift) {
         if (s/e?list of //) {
            $prop->{is_list} = 1;
            return _parsetype $_;

         } elsif (s/composed (\S+)\s+(?:':'\s+)?(\S+)//) {
            $prop->{composed} = 1;
            my ($i, $o) = ($1, $2);
            my ($i1, $o1, $i2, $o2) = (_parsetype $i, _parsetype $o);
            return (
                  sub {
                     if ($_[1] =~ /^((?:[^\\:]+|\\.)*)(?::(.*))?$/s) {
                        # or $_[0]->error ("'Compose' ($i:$o) expected, got '$_[1]'");
                        my ($l, $r) = ($1, $2);

                        [
                           $i1->($_[0], $l),
                           defined $r ? $i2->($_[0], $r) : undef,
                        ]
                     }
                  },
                  sub {
                     $o1->($_[0], $_[1][0])
                     . ":"
                     . $o2->($_[0], $_[1][1])
                  },
               );

         } elsif (s/double//) {
            return (
                  sub {
                     $_[1] =~ /^[12]$/
                        or $_[0]->error ("'Double' (1|2) expected, got '$_[1]'");
                     $_[1]
                  },
                  sub {
                     $_[1]
                  },
               );
         } elsif (s/color//) {
            return (
                  sub {
                     # too many broken programs write this wrong
                     return "B" if $_[1] eq "1";
                     return "W" if $_[1] eq "2";

                     $_[1] =~ /^[BW]$/i
                        or $_[0]->error ("'Color' (B|W) expected, got '$_[1]'");
                     lc $_[1]
                  },
                  sub {
                     uc $_[1]
                  },
               );
         } elsif (s/none//) {
            return (
                  sub {
                     $_[1] =~ /^$/i
                        or $_[0]->error ("'None' expected, got '$_[1]'");
                     undef
                  },
                  sub {
                     "",
                  },
               );
         } elsif (s/point// || s/move// || s/stone//) {
            return (
                  sub {
                     if ($_[2]->{is_list}) {
                        if ($_[1] =~ /^([^:]+):(.*)$/) {
                           my ($ul, $dr) = ($1, $2);
                           my ($x1, $y1) = map $char2coord{$_}, split //, $ul;
                           my ($x2, $y2) = map $char2coord{$_}, split //, $dr;
                           my @stones;
                           for (my $d = $x1; $d <= $x2; $d++) {
                              for (my $i = $y1; $i <= $y2; $i++) {
                                 push @stones, [$d, $i];
                              }
                           }
                           return @stones;
                        }
                     }
                     $_[1] =~ /^(.)(.)$/
                        ? [ $char2coord{$1}, $char2coord{$2} ]
                        : []
                  },
                  sub {
                     $coord2char{$_[1][0]} . $coord2char{$_[1][1]}
                  },
               );
         } elsif (s/real// || s/number//) {
            return (
                  sub {
                     $_[1]
                  },
                  sub {
                     $_[1]
                  },
               );
         } elsif (s/text// || s/simpletext//i) {
            return (
                  sub {
                     { _text => $_[1] }
                  },
                  sub {
                     my $str = Encode::encode $_[0]{CA}, $_[1];
                     $str =~ s/([\:\]\\])/\\$1/g;
                     $str
                  },
               );
         } else {
            die "FATAL: garbled DATA section, unknown type '$_'";
         }
      }
   }

   while () {
      if (/^(\S+):\t(.*)/) {
         if ($name eq "Restrictions") {
            $group->{restrictions} = $value;
         } elsif ($name eq "Property") {
            $property->{$value} =
            $prop = {
               name  => $value,
               group => $group,
            };
         } elsif ($name ne "") {
            $prop->{lc $name} = $value;
            if ($name eq "Propvalue") {
               ($prop->{in}, $prop->{out}) = _parsetype $value;
            }
         }
         $name = $1;
         $value = $2;
      } elsif (/^\t\t(.*)/) {
         $value .= "\n$1";
      } elsif (/(\S.*)/) {
         $group = {
            name => $1,
         };
      } elsif (/^$/) {
         # nop
      } else {
         die "FATAL: DATA section garbled\n";
      }
   }
}

1;

=head1 AUTHOR

 Marc Lehmann
 Robin Redeker

=cut

# now node descriptions follow

__DATA__