File Coverage

blib/lib/Games/Go/SGF2misc.pm

Criterion	Covered	Total	%
statement	25	27	92.5
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	34	36	94.4

package Games::Go::SGF2misc;

use strict;
no warnings;

use Carp;
use Parse::Lex;
use Data::Dumper;
use Compress::Zlib;
use CGI qw(escapeHTML);

our $VERSION = 0.9782;

1;

# main calls
# new {{{
sub new {
    my $this = shift;
       $this = bless {}, $this;

    if( $ENV{DEBUG} > 0 ) {
        use Number::Format;
        use Devel::Size qw(total_size);
        use Time::HiRes qw(time);

        $this->{frm} = new Number::Format;
    }

    return $this;
}
# }}}
# parse {{{
sub parse {
    my $this = shift;
    my $file = shift;

    if( -f $file ) {
        local $/;  # Enable local "slurp" ... ie, by unsetting $/ for this local scope, it will not end lines on \n
        open SGFIN, $file or die "couldn't open $file: $!";

        our $FILENAME = $file;

        return $this->parse_internal(\*SGFIN);
    }

    $this->{error} = "Parse Error reading $file: unknown";
    return 0;
}
# }}}
# parse_string {{{
sub parse_string {
    my $this = shift;
    my $string = shift;

    our $FILENAME = "STRING";

    return $this->parse_internal($string);
}
# }}}
# parse_internal {{{
sub parse_internal {
    my $this = shift;
    my $file = shift;

    our $FILENAME;

    for my $k (keys %$this) {
        delete $this->{$k} unless {Time=>1, frm=>1}->{$k};
    }
    $global::lex_error = undef;

    $this->_time("parse");

    my @rules = (
        VALUE  => '(?:\[\]|\[(?s:.*?[^\x5c])\])',

        BCOL   => '\(',                   # begin collection
        ECOL   => '\)',                   # end collection
        PID    => '(?:CoPyright|[A-Z]+)', # property identifier (CoPyright is the spurious IGS tag, assholes)
        NODE   => ';',                    # new node
        WSPACE => '[\s\r\n]',

        qw(ERROR  .*), sub {
            $global::lex_error = "Parse Error reading $FILENAME: $_[1]\n";
        }
    );

    Parse::Lex->trace if $ENV{DEBUG} > 30;

    my $lex = Parse::Lex->new(@rules); $^W = 0; no warnings;
       $lex->from($file);

    $this->{parse} = { p => undef, n => [], c=>[] }; # p => parent, n => nodes, c => child Collections

    my $ref = $this->{parse};  # our current position

    # parse rules:
    my $nos = -1;  # the current node (array position).  -1 when we're not in a node
    my $pid = 0;   # 0 unless we just got a pid; otherwise, node array position

    TOKEN: while (1) {
        my $token = $lex->next;

        if (not $lex->eoi) {
            my $C = $token->name;
            my $V = $token->text;

            if( $C eq "ERROR" or defined $global::lex_error ) {
                $global::lex_error = "Parse Error reading $FILENAME: unknown"; # TODO: this $file should be ... the name of it instead
                $this->{error} = $global::lex_error;
                return 0;
            }

            if( $C eq "BCOL" ) {
                push @{ $ref->{c} }, { p=>$ref, n=>[], c=>[] };
                $ref = $ref->{c}[$#{ $ref->{c} }];
                $nos = -1;

            } elsif( $C eq "ECOL" ) {
                $ref = $ref->{p};
                $nos = -1;

            } elsif( $C eq "NODE" ) {
                push @{ $ref->{n} }, [];
                $nos = $#{ $ref->{n} };

            }

            # this get's it's own if block for the $pid
            if( $C eq "PID" ) {
                if( $nos == -1 ) {
                    $this->{error} = "Parse Error reading $FILENAME: property identifier ($V) in strange place";
                    return 0;
                }
                push @{ $ref->{n}[$nos] }, {P=>$V};
                $pid = $#{ $ref->{n}[$nos] };

            } elsif( $C eq "VALUE" ) {
                $V =~ s/^\[//ms; $V =~ s/\]$//ms;
                $V =~ s/\\(.)/$1/msg;

                if( $nos == -1 or $pid == -1 ) {
                    $this->{error} = "Parse Error reading $FILENAME: property value ($V) in strange place";
                    return 0;
                }
                if( defined $ref->{n}[$nos][$pid]{V} ) {
                    push @{ $ref->{n}[$nos] }, {P=>$ref->{n}[$nos][$pid]{P}};
                    $pid = $#{ $ref->{n}[$nos] };
                }

                $ref->{n}[$nos][$pid]{V} = $V;

            } elsif( $C eq "WSPACE" ) {
                # don't set pid to -1 here (2006-5-12)

            } else {
                $pid = -1;
            }

        } else {
            last TOKEN;
        }
    }

    $this->_time("parse");

    print STDERR "SGF Parsed!  Calling internal _parse() routine\n" if $ENV{DEBUG} > 0;
    print STDERR "\$this size (before _parse)= ", $this->{frm}->format_bytes(total_size( $this )), "\n" if $ENV{DEBUG} > 0;

    $this->_time("_parse");

    my $r = $this->_parse(0, $this->{parse});

    $this->_time("_parse");

    print STDERR "\$this size (after _parse)= ", $this->{frm}->format_bytes(total_size( $this )), "\n" if $ENV{DEBUG} > 0;

    print STDERR "rebuilding {refdb} (for ref2id/id2ref)\n" if $ENV{DEBUG} > 0;

    $this->_time("_nodelist");

    $this->{nodelist} = { map {$this->_ref2id($_) => $this->_nodelist([], $_)} @{$this->{gametree}} };

    $this->_time("_nodelist");

    print STDERR "\$this size (after _nodelist())= ", $this->{frm}->format_bytes(total_size( $this )), "\n" if $ENV{DEBUG} > 0;

    $this->_time("nuke(gametree and parse)");
    my @to_nuke;

    push @to_nuke, (@{$this->{gametree}}) if ref($this->{gametree}) eq "ARRAY";
    push @to_nuke, $this->{parse}         if ref($this->{parse})    eq "HASH";

    while( @to_nuke ) {
        my $ref = shift @to_nuke;
        for my $k (qw(p c kids parent)) {
            if( my $v = $ref->{$k} ) {
                if( ref($v) eq "ARRAY" ) {
                    push @to_nuke, @$v;
                }

                delete $ref->{$k};
            }
        }
    }
    $this->_time("nuke(gametree and parse)");

    $this->_show_timings if $ENV{DEBUG} > 0;

    return $r;
}
# }}}
# freeze {{{
sub freeze {
    my $this = shift;

    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Purity = 1;

    my $fm = {};
    for my $k (qw(nodelist refdb)) {
        $fm->{$k} = $this->{$k};
    }

    $this->_time("freeze Dumper");
    my $buf = Dumper( $fm );
    $this->_time("freeze Dumper");

    return Compress::Zlib::memGzip( $buf );
}
# }}}
# thaw {{{
sub thaw {
    my $this = shift;
    my $frz  = shift;
    my ($VAR1);

    if( ref($frz) eq "GLOB" ) {
        $this->_time("gzreads");
        my $gz = gzopen($frz, "r");

        $frz = "";

        my $x;
        while( my $r = $gz->gzread($x, 32768) ) {
            $frz .= $x;
        }
        $gz->gzclose;

        $this->_time("gzreads");

        $this->_time("eval");
        eval $frz;
        $this->_time("eval");
    } else {
        $this->_time("memgunzip/eval");
        eval Compress::Zlib::memGunzip( $frz );
        $this->_time("memgunzip/eval");
        if( $@ ) {
            $this->{error} = $@;
            return 0;
        }
    }

    $this->_time("assign refs");
    for my $k (keys %$VAR1) {
        $this->{$k} = $VAR1->{$k};
    }
    $this->_time("assign refs");

    $this->_show_timings if $ENV{DEBUG} > 0;

    return 1;
}
# }}}
# errstr {{{
sub errstr {
    my $this = shift;

    $this->{error} =~ s/[\r\n\s]$//msg;

    return $this->{error};
}
# }}}

# tools -- can croak()!
# sgfco2numco {{{
sub sgfco2numco {
    my $this = shift;
    my $gref = shift;
    my $co   = shift;

    my ($sz, $ff);
    if( ref($gref) eq "HASH" and ref($gref->{game_properties}) eq "HASH" ) {
        $sz = $gref->{game_properties}{SZ};
        $ff = $gref->{game_properties}{FF};

        unless( $sz and $ff ) {
            croak "Error: sgfco2numco needs FF and SZ properties to function, sorry.\n";
        }
    } else {
        croak "Syntax Error: You must pass a game reference to sgfco2numco because it needs the FF and SZ properties.\n";
    }

    if( $co =~ m/\w{2}\:\w{2}/ ) {
        croak "Parsed Stupidly: SGF2misc.pm doesn't handle compressed co-ordinates ($co) yet... *sigh*\n";
    }

    my $inty = sub {
        my $x = -1;

        $x = int(hex(unpack("H*", $_[0]))) - 97 if $_[0] =~ m/[a-z]/;
        $x = int(hex(unpack("H*", $_[0]))) - 65 if $_[0] =~ m/[A-Z]/;

        die "unexpected error reading column identifier" unless $x > -1;

        return $x;
    };

    if( not $co or ($co eq "tt" and ($ff == 3 or $sz<=19)) ) {
        return (wantarray ? (qw(PASS PASS)) : [qw(PASS PASS)]);
    }

    if( $co =~ m/^([a-zA-Z])([a-zA-Z])$/ ) {
        my ($row, $col) = ($1, $2);

        return (wantarray ? ($inty->($col), $inty->($row)) : [ $inty->($col), $inty->($row) ]);
    }

    croak "Parse Error: co-ordinate not understood ($co)\n";
}
# }}}

# outputers
# parse_hash {{{
sub parse_hash {
    my $this = shift;

    return $this->{parse};
}
# }}}
# nodelist {{{
sub nodelist {
    my $this  = shift;

    return $this->{nodelist};
}
# }}}
# is_node {{{
sub is_node {
    my $this = shift;
    my $node = shift;

    return ($this->{refdb}{$node} ? 1:0);
}
# }}}
# as_perl {{{
sub as_perl {
    my $this = shift;
    my $node = shift;
    my $soft = shift;

    if( $node ) {
        if( my $ref = $this->{refdb}{$node} ) {
            return $ref;
        }
    }

    $this->{error} = "no such node: $node";
    return 0 if $soft;

    croak $this->{error};
}
# }}}
# as_text {{{
sub as_text {
    my $this = shift;
    my $node = shift;

    $node = $this->as_perl( $node, 1 ) or croak $this->errstr;

    my $board = $node->{board};

    my $x = "";
    for my $i (0..$#{ $board }) {
        for my $j (0..$#{ $board->[$i] }) {
            $x .= " " . { ' '=>'.', 'W'=>'O', 'B'=>'X' }->{$board->[$i][$j]};
        }
        $x .= "\n";
    }

    return $x;
}
# }}}
# _mark_alg {{{
sub _mark_alg {
    my $this = shift;
    my ($mark, $img) = @_;

    return "bt.gif" if $mark eq "TR" and $img eq "b.gif";
    return "wt.gif" if $mark eq "TR" and $img eq "w.gif";
    return "bc.gif" if $mark eq "CR" and $img eq "b.gif";
    return "wc.gif" if $mark eq "CR" and $img eq "w.gif";
    return "bq.gif" if $mark eq "SQ" and $img eq "b.gif";
    return "wq.gif" if $mark eq "SQ" and $img eq "w.gif";

    if( ($mark = int($mark)) > 0 and $mark <= 100 ) {
        return "b$mark.gif" if $img =~ "b[tcq]?.gif";
        return "w$mark.gif"
    }

    return $img;
}
# }}}
# _crazy_moku_alg {{{
sub _crazy_moku_alg {
    my $this = shift;
    my ($i, $j, $size) = @_;

    our $cma_size;
    our $hoshi;

    if( $size != $cma_size or not $hoshi ) {
        $hoshi = {};
        if( $size == 19 ) {
            $hoshi = { "3 3" => 1, "3 15" => 1, "15 3" => 1, "15 15" => 1,
                "9 3" => 1, "9 15" => 1, "3 9" => 1, "15 9" => 1, "9 9" => 1, };
        } elsif( $size == 13 ) {
            $hoshi = { "3 3" => 1, "9 9" => 1, "3 9" => 1, "9 3" => 1,
                "6 3" => 1, "3 6" => 1, "9 6" => 1, "6 9" => 1, "6 6" => 1, };
        } elsif( $size == 9 ) {
            $hoshi = { "2 2" => 1, "2 6" => 1, "6 6" => 1, "6 2" => 1, "4 4" => 1, };
        }
    }

    return "ulc.gif" if $i == 0     and $j == 0;
    return "urc.gif" if $i == 0     and $j == $size;
    return "llc.gif" if $i == $size and $j == 0;
    return "lrc.gif" if $i == $size and $j == $size;
    return "ts.gif"  if $i == 0     and $j != 0 and $j != $size;
    return "bs.gif"  if $i == $size and $j != 0 and $j != $size;
    return "ls.gif"  if $j == 0     and $i != 0 and $i != $size;
    return "rs.gif"  if $j == $size and $i != 0 and $i != $size;

    return "h.gif" if $hoshi->{"$i $j"};
    return "p.gif",
}
# }}}
# as_html {{{
sub as_html {
    my $this  = shift;
    my $node  = shift;
    my $dir   = shift;
       $dir   = "./img" unless $dir;
    my $id    = shift;
    my $onode = $node;

    $node = $this->as_perl( $node, 1 ) or croak $this->errstr;

    # use Data::Dumper; $Data::Dumper::Indent = 0;
    # warn Dumper( $node );

    my $gref      = $this->as_perl(1);
    my $game_info = $gref->{game_properties};

=cut
game_properties' => {'FF' => 4,'PB' => 'Orien Vandenbergh
(nichus)','GM' => 1,'KM' => '6.5','SZ' => 19,'PC' => 'Dragon Go Server: http://www.dragongoserver.net','RE' => 'W+29.5','RU' =>
'Japanese','BR' => '13 kyu','GN' => 'jettero-nichus-20041229.sgf','GC' => 'Game ID: 85389','DT' => '2004-10-29,2004-12-29','PW' =>
'Jettero Heller (jettero)','WR' => '13 kyu','OT' => '30 days + 1 day/10 periods Japanese byoyomi'}
=cut

    my $board = $node->{board};
    my $size  = @{$board->[0]}; # inaccurate?
       $size--;

    my %marks = ();
    for my $m (@{ $node->{marks} }) {
        $marks{"$m->[1] $m->[2]"} = ($m->[0] eq "LB" ? $m->[4] : $m->[0]);
    }

    my @letters = qw(A B C D E F G H J K L M N O P Q R S T);
    my $arow = "

    my $x = "$arow\n"; W.Caps: $node->{captures}->{W}\  \ B.Caps: $node->{captures}->{B}"; 
W($tw t + $cw c + $km k), B($tb t + $cb c): $f"; 





487




 





 





 





 





 





 



   




488




 





 





 





 





 





 



     for my $i (0..$#{ $board }) { 




489




 





 





 





 





 





 



         $x .= "". (($size+1)-$i); 




490




 





 





 





 





 





 



         for my $j (0 .. $#{ $board->[$i] }) { 




491




 





 





 





 





 





 



             my $iid = ""; 




492




 





 





 





 





 





 



                $iid = " id='$id.$i.$j'" if $id; 




493




 





 





 





 





 





 



   




494




 





 





 





 





 





 



             my $c = {  




495




 





 





 





 





 





 



                 'B' => "b.gif", 




496




 





 





 





 





 





 



                 'W' => "w.gif", 




497




 





 





 





 





 





 



             }->{$board->[$i][$j]}; 




498




 





 





 





 





 





 



   




499




 





 





 





 





 





 



             $c = "wc.gif" if $c eq "w.gif" and $node->{moves}[0][1] == $i and $node->{moves}[0][2] == $j; 




500




 





 





 





 





 





 



             $c = "bc.gif" if $c eq "b.gif" and $node->{moves}[0][1] == $i and $node->{moves}[0][2] == $j; 




501




 





 





 





 





 





 



   




502




 





 





 





 





 





 



             $c = $this->_crazy_moku_alg($i, $j, $size) unless $c; 




503




 





 





 





 





 





 



             $c = $this->_mark_alg($marks{"$i $j"}, $c); 




504




 





 





 





 





 





 



   




505




 





 





 





 





 





 



             $c  = "$dir/$c";  




506




 





 





 





 





 





 



             $x .= ""; 




507




 





 





 





 





 





 



         } 




508




 





 





 





 





 





 



         $x .= "". (($size+1)-$i) . "\n"; 




509




 





 





 





 





 





 



     } 




510




 





 





 





 





 





 



   




511




 





 





 





 





 





 



     my $cpid = ""; 




512




 





 





 





 





 





 



        $cpid = " id='$id.state'" if $id; 




513




 





 





 





 





 





 



   




514




 





 





 





 





 





 



     my $p = "



515




 





 





 





 





 





 



   




516




 





 





 





 





 





 



     if( $node->{other} ) { 




517




 





 





 





 





 





 



         my $TB = $node->{other}->{TB}; 




518




 





 





 





 





 





 



         my $TW = $node->{other}->{TW}; 




519




 





 





 





 





 





 



   




520




 





 





 





 





 





 



         if ($TB and $TW) { 




521




 





 





 





 





 





 



             my $cb = $node->{captures}->{B}; 




522




 





 





 





 





 





 



             my $cw = $node->{captures}->{W}; 




523




 





 





 





 





 





 



             my $km = $game_info->{KM}; 




524




 





 





 





 





 





 



   




525




 





 





 





 





 





 



             my ($tb, $tw) = (0, 0); 




526




 





 





 





 





 





 



             for my $r (@$TB) { 




527




 





 





 





 





 





 



                 my @a = $this->sgfco2numco($gref, $r); 




528




 





 





 





 





 





 



   




529




 





 





 





 





 





 



                 $tb ++; 




530




 





 





 





 





 





 



                 $cb ++ if $board->[$a[0]][$a[1]] eq "W"; 




531




 





 





 





 





 





 



             } 




532




 





 





 





 





 





 



   




533




 





 





 





 





 





 



             for my $r (@$TW) { 




534




 





 





 





 





 





 



                 my @a = $this->sgfco2numco($gref, $r); 




535




 





 





 





 





 





 



   




536




 





 





 





 





 





 



                 $tw ++; 




537




 





 





 





 





 





 



                 $cw ++ if $board->[$a[0]][$a[1]] eq "B"; 




538




 





 





 





 





 





 



             } 




539




 





 





 





 





 





 



   




540




 





 





 





 





 





 



             my $f = ($tw + $cw + $km) - ($tb + $cb); 




541




 





 





 





 





 





 



                $f = ($f<0 ? "B+".abs($f) : "W+$f"); 




542




 





 





 





 





 





 



   




543




 





 





 





 





 





 



             $p = "



544




 





 





 





 





 





 



         } 




545




 





 





 





 





 





 



     } 




546




 





 





 





 





 





 



   




547




 





 





 





 





 





 



     my $cmid = ""; 




548




 





 





 





 





 





 



        $cmid = " id='$id.comment'" if $id; 




549




 





 





 





 





 





 



   




550




 





 





 





 





 





 



     my $comments = ""; 




551




 





 





 





 





 





 



        $comments .= escapeHTML($_) for @{$node->{comments}}; 




552




 





 





 





 





 





 



        $comments =~ s/[\r\n]//sg; 




553




 





 





 





 





 





 



   




554




 





 





 





 





 





 



     return "$x$arow$p$comments";

    for my $i (0..$#{ $board }) {
        $x .= "
        for my $j (0 .. $#{ $board->[$i] }) {
            my $iid = "";
               $iid = " id='$id.$i.$j'" if $id;

            my $c = {
                'B' => "b.gif",
                'W' => "w.gif",
            }->{$board->[$i][$j]};

            $c = "wc.gif" if $c eq "w.gif" and $node->{moves}[0][1] == $i and $node->{moves}[0][2] == $j;
            $c = "bc.gif" if $c eq "b.gif" and $node->{moves}[0][1] == $i and $node->{moves}[0][2] == $j;

            $c = $this->_crazy_moku_alg($i, $j, $size) unless $c;
            $c = $this->_mark_alg($marks{"$i $j"}, $c);

            $c  = "$dir/$c";
            $x .= "
        }
        $x .= "
    }

    my $cpid = "";
       $cpid = " id='$id.state'" if $id;

    my $p = "

    if( $node->{other} ) {
        my $TB = $node->{other}->{TB};
        my $TW = $node->{other}->{TW};

        if ($TB and $TW) {
            my $cb = $node->{captures}->{B};
            my $cw = $node->{captures}->{W};
            my $km = $game_info->{KM};

            my ($tb, $tw) = (0, 0);
            for my $r (@$TB) {
                my @a = $this->sgfco2numco($gref, $r);

                $tb ++;
                $cb ++ if $board->[$a[0]][$a[1]] eq "W";
            }

            for my $r (@$TW) {
                my @a = $this->sgfco2numco($gref, $r);

                $tw ++;
                $cw ++ if $board->[$a[0]][$a[1]] eq "B";
            }

            my $f = ($tw + $cw + $km) - ($tb + $cb);
               $f = ($f<0 ? "B+".abs($f) : "W+$f");

            $p = "
        }
    }

    my $cmid = "";
       $cmid = " id='$id.comment'" if $id;

    my $comments = "";
       $comments .= escapeHTML($_) for @{$node->{comments}};
       $comments =~ s/[\r\n]//sg;

    return "$x$arow$p
}
# }}}
# as_js {{{
sub as_js {
    my $this  = shift;
    my $node  = shift;

    $node = $this->as_perl( $node, 1 ) or croak $this->errstr;

    my $gref      = $this->as_perl(1);
    my $game_info = $gref->{game_properties};

    my $board = $node->{board};
    my $size  = @{$board->[0]}; # inaccurate?
       $size--;

    my %marks = ();
    for my $m (@{ $node->{marks} }) {
        $marks{"$m->[1] $m->[2]"} = ($m->[0] eq "LB" ? $m->[4] : $m->[0]);
    }

    my @board  = ();
    for my $i (0..$#{ $board }) {
        my $row = [];
        for my $j (0 .. $#{ $board->[$i] }) {
            my $c = {
                'B' => "b.gif",
                'W' => "w.gif",
            }->{$board->[$i][$j]};

            $c = "wc.gif" if $c eq "w.gif" and $node->{moves}[0][1] == $i and $node->{moves}[0][2] == $j;
            $c = "bc.gif" if $c eq "b.gif" and $node->{moves}[0][1] == $i and $node->{moves}[0][2] == $j;

            $c = $this->_crazy_moku_alg($i, $j, $size) unless $c;
            $c = $this->_mark_alg($marks{"$i $j"}, $c);

            push @$row, $c;
        }

        push @board, $row;
    }

    local $Data::Dumper::Indent = 0;
    my $board = Dumper(\@board);
       $board =~ s/^\$VAR1\s*=\s*//s;
       $board =~ s/\s*\;\s*$//s;
       $board =~ s/\.gif//sg;

    my $p = "W.Caps: $node->{captures}->{W}\  \ B.Caps: $node->{captures}->{B}";

    if( $node->{other} ) {
        my $TB = $node->{other}->{TB};
        my $TW = $node->{other}->{TW};

        if ($TB and $TW) {
            my $cb = $node->{captures}->{B};
            my $cw = $node->{captures}->{W};
            my $km = $game_info->{KM};

            my ($tb, $tw) = (0, 0);
            for my $r (@$TB) {
                my @a = $this->sgfco2numco($gref, $r);

                $tb ++;
                $cb ++ if $board->[$a[0]][$a[1]] eq "W";
            }

            for my $r (@$TW) {
                my @a = $this->sgfco2numco($gref, $r);

                $tw ++;
                $cw ++ if $board->[$a[0]][$a[1]] eq "B";
            }

            my $f = ($tw + $cw + $km) - ($tb + $cb);
               $f = ($f<0 ? "B+".abs($f) : "W+$f");

            $p = "W($tw t + $cw c + $km k), B($tb t + $cb c): $f";
        }
    }

    my $comments = "";
       $comments .= escapeHTML($_) for @{$node->{comments}};
       $comments =~ s/[\r\n]//sg;

           $p =~ s/"/\\"/sg;
    $comments =~ s/"/\\"/sg;

    return "{ board: $board, status: \"$p\", comment: \"$comments\" }";
}
# }}}
# as_image {{{
sub as_image {
    my $this = shift;
    my $node = shift; my $nm = $node;
    my $argu = shift;
    my %opts = (imagesize=>256, antialias=>0);

    $node = $this->as_perl( $node, 1 ) or croak $this->errstr;

    my $board = $node->{board};
    my $size  = @{$board->[0]}; # inaccurate?

    if( ref($argu) ne "HASH" ) {
        croak
        "as_image() takes a hashref argument... e.g., {imagesize=>256, etc=>1} or nothing at all.";
    }

    my $package = $argu->{'use'} || 'Games::Go::SGF2misc::GD';
    if ($package =~ /svg/i) {
        $opts{'imagesize'} = '256px';
    }

    @opts{keys %$argu}  = (values %$argu);
    $opts{boardsize}    = $size;
    $opts{filename}     = "$nm.png" unless $opts{filename};

    my $image;
    eval qq( use $package; \$image = $package->new(%opts); );

    $image->drawGoban();

    # draw moves
    for my $i (0..$#{ $board }) {
        for my $j (0..$#{ $board->[$i] }) {
            if( $board->[$i][$j] =~ m/([WB])/ ) {
                if( $ENV{DEBUG} > 0 ) {
                    print STDERR "placeStone($1, [$i, $j])\n";
                }

                # SGFs are $y, $x, the matrix is $x, $y ...
                $image->placeStone(lc($1), [reverse( $i, $j )]);
            }
        }
    }

    my $marks = 0;
    # draw marks
    for my $m (@{ $node->{marks} }) {
        $image->addCircle($m->[3])   if $m->[0] eq "CR";
        $image->addSquare($m->[3])   if $m->[0] eq "SQ";
        $image->addTriangle($m->[3]) if $m->[0] eq "TR";

        $image->addLetter($m->[3], 'X', "./times.ttf") if $m->[0] eq "MA";
        $image->addLetter($m->[3], $m->[4], "./times.ttf") if $m->[0] eq "LB";
        $marks++;
    }

    if ($argu->{'automark'}) {
        unless ($marks) {
            my $moves = $node->{moves};
            foreach my $m (@$moves) {
                $image->addCircle($m->[3]) unless $m->[3];
            }
        }
    }

    if ($package =~ /svg/i) {
        if( $opts{filename} =~ m/.png$/ ) {
            $image->export($opts{'filename'});
        } else {
            $image->save($opts{filename});
        }
    } else {
        if( $opts{filename} =~ m/^\-\.(\w+)$/ ) {
            return $image->dump($1);
        }

        $image->save($opts{filename});
    }
}
# }}}
# as_freezerbag {{{
sub as_freezerbag {
    my $this = shift;
    my $file = shift or croak "You must name your freezerbag.";
    my $code = shift;
       $code = "# your code here\n" unless $code;
    my $perl = shift;

    if( not $perl ) {
        for my $try (qw{ /usr/bin/perl /usr/local/bin/perl }) {
            $perl = $try if -x $try;
        }
        croak "couldn't find perl" unless -x $perl;
    }

    open  OUTMF, ">$file" or croak "Couldn't open freezerbag ($file) for output: $!";
    print OUTMF "#!$perl\n# vi:fdm=marker fdl=0:\n\nuse strict;\nno warnings;\nuse Games::Go::SGF2misc;\n\n";
    print OUTMF "my \$sgf = new Games::Go::SGF2misc;\n";
    print OUTMF "   \$sgf->thaw(\\*DATA);\n\n$code\n\n# freezer DATA {\{\{\n__DATA__\n";

    $this->_time("print freeze");
    print OUTMF $this->freeze;
    $this->_time("print freeze");

    close OUTMF;

    $this->_show_timings if $ENV{DEBUG} > 0;
}
# }}}

# internals
# _show_timings {{{
sub _show_timings {
    my $this = shift;

    my @times = ();
    for my $k (keys %{ $this->{Time} }) {
        my $x   = $this->{Time}{$k}{diffs};  next unless ref($x) eq "ARRAY";
        my $n   = int @$x;
        my $sum = 0;
           $sum += $_ for @$x;

        push @times, [ $k, $sum, $n, ($sum/$n) ];
    }

    for my $x (sort {$b->[1] <=> $a->[1]} @times) {
        printf('%-35s: sum=%3.4fs cardinality=%5d avg=%3.2fs%s', @$x, "\n");
    }

    delete $this->{Time};
}
# }}}
# _time {{{
sub _time {
    return unless $ENV{DEBUG} > 0;

    my $this = shift;
    my $tag  = shift;

    if( $ENV{DEBUG} == 1.2 ) {
        my @a;

        for (sort keys %{ $this->{Time} }) {
           push @a, $_ if $this->{Time}{$_}{start};
        }

        print STDERR "clocks: @a\n";
    }

    if( defined $this->{Time}{$tag}{start} ) {
        push @{ $this->{Time}{$tag}{diffs} }, (time - $this->{Time}{$tag}{start});
        delete $this->{Time}{$tag}{start};
    } else {
        $this->{Time}{$tag}{start} = time;
    }
}
# }}}
# _nodelist {{{
sub _nodelist {
    my $this = shift;
    my $list = shift;
    my $cur  = shift;

    # $this->{nodelist} = { map {$this->_ref2id($_) => $this->_nodelist([], $_)} @{$this->{gametree}} };

    for my $kid (@{ $cur->{kids} }) {
        my $id = $this->_ref2id( $kid );

        die "problem parsing node id" unless $id =~ m/(\d+)\.(\d+)\-(.+)/;

        my ($g, $v, $m) = ($1, $2, $3);

        if( $v > @{ $list } ) {
            my $x = [];
            push @$list, $x;
            for (1..$m) {
                push @$x, undef;
            }
        }

        push @{ $list->[$v-1] }, $id;

        $this->_nodelist($list, $kid);
    }

    return $list;
}
# }}}
# _parse (aka, the internal parse) {{{
sub _parse {
    my $this   = shift;
    my $level  = shift;
    my $pref   = shift;
    my $gref   = shift;
    my $parent = shift;

    if( $ENV{DEBUG} > 1 ) {
        print STDERR "\t_parse($level)";
        print STDERR " ... variation = $gref->{variations} " if ref($gref) and defined $gref->{variations};
        print STDERR "\n";
    }

    my $gm_pr_reg = qr{^(?:GM|SZ|CA|AP|RU|KM|HA|FF|PW|PB|RE|TM|OT|BR|WR|DT|PC|AN|BT|CP|EV|GN|GC|ON|RO|SO|US)$};

    if( $level == 0 ) {
        # The file level... $gref is most certainly undefined...
        # We're also starting the gametree from scratch here

        $this->{gametree} = [];

        if( int(@{ $this->{parse}{n} }) ) {
            $this->{error} = "Parse Error: nodes found at top level... very strange.";
            return 0;
        }

        for my $c (@{ $this->{parse}{c} }) {
            $this->_parse($level+1, $c, undef) or return 0;
        }

        return 1;

    } elsif( $level == 1 ) {
        # Every collection should be a new game
        # At this $level, all we do is make a game and look for game properties.
        # Then we re _parse() at our current position

        $gref = { variations=>1, kids=>[] }; push @{ $this->{gametree} }, $gref;
        $gref->{gnum} = int @{ $this->{gametree} };

        my $pnode = $pref->{n}[0];
        for my $p (@$pnode) {
            if( $p->{P} =~ m/$gm_pr_reg/ ) {
                $gref->{game_properties}{$p->{P}} = $p->{V};
            }
            if( $p->{P} eq "CoPyright" ) {
                $gref->{game_properties}{FF} = 4;
            }
        }

        unless( $gref->{game_properties}{GM} == 1 ) {
            $this->{error} = "Parse Error: Need GM[1] property in the first node of the game... not found.";
            return 0;
        }

        unless( $gref->{game_properties}{FF} == 3 or $gref->{game_properties}{FF} == 4 ) {
            unless( $ENV{ALLOW_STRANGE_FFs} ) {
                $this->{error} = "Parse Error: Need FF[3] or FF[4] property in the first node of the game... not found.";
                return 0;
            }
        }

        if( $gref->{game_properties}{SZ} < 3 ) {
            $this->{error} = "Parse Error: SZ must be set and be greater than 2 (SZ was $gref->{game_properties}{SZ})";
            return 0;
        }

        if( $gref->{game_properties}{FF} == 3 and $gref->{game_properties}{SZ} > 19 ) {
            $this->{error} = "Parse Error: In FF[3] a move of B[tt] is a pass and therefore, SZ must be less than 20 " .
                "(SZ was $gref->{game_properties}{SZ}).";
            return 0;
        }

        if( $gref->{game_properties}{FF} == 4 and $gref->{game_properties}{SZ} > 52 ) {
            $this->{error} = "Parse Error: In FF[4] the size of the board must be no greater than 52" .
                "(SZ was $gref->{game_properties}{SZ})";
            return 0;
        }

        $this->_parse($level+1, $pref, $gref) or return 0;

        return 1;

    } elsif( defined $gref ) {
        # OK, now we're getting into some serious parsing.

        my $gnode;  # this has the effect of forking the variations off the last node in the collection.
                    # is that correct?

        for my $i (0..$#{ $pref->{n} }) {
            my $pnode = $pref->{n}[$i];

            $parent = ($gnode ? $gnode : $parent ? $parent : $gref);

            $gnode = { variation=>$gref->{variations}, kids=>[] };
            push @{ $parent->{kids} }, $gnode;

            $gnode->{board} = $this->_copy_board_matrix( $parent->{board} ) if $parent->{board};
            $gnode->{board} = $this->_new_board_matrix( $gref ) unless $gnode->{board};

            $gnode->{captures} = { B=>0, W=>0 };
            if( ref($parent) and ref(my $pc = $parent->{captures}) ) {
                $gnode->{captures}{B} += $pc->{B};
                $gnode->{captures}{W} += $pc->{W};
            }

            for my $p (@$pnode) {
                if( $p->{P} =~ m/^([BW])$/) {
                    my $c = $1;
                    my @c = $this->sgfco2numco($gref, $p->{V});

                    print STDERR "\t\tmove: $c($p->{V}) == [@c]\n" if $ENV{DEBUG} >= 4;

                    push @{ $gnode->{moves} }, [ $c, @c, $p->{V} ];

                    unless( $c[0] eq "PASS" ) {
                        # fix up board
                        $gnode->{board}[$c[0]][$c[1]] = $c;

                        # check for captures
                        $this->_check_for_captures($gref->{game_properties}{SZ}, $gnode, @c );
                    }

                } elsif( $p->{P} =~ m/^A([WBE])$/ ) {
                    my $c = $1;
                    my @c = $this->sgfco2numco($gref, $p->{V});

                    push @{ $gnode->{edits} }, [ $c, @c, $p->{V} ];

                    # fix up board
                    # do NOT check for captures
                    if( $c eq "E" ) {
                        $gnode->{board}[$c[0]][$c[1]] = ' ';
                    } else {
                        $gnode->{board}[$c[0]][$c[1]] = $c;
                    }
                } elsif( $p->{P} =~ m/^C$/ ) {
                    push @{ $gnode->{comments} }, $p->{V};

                } elsif( $p->{P} =~ m/^(?:CR|TR|SQ)$/ ) {
                    my @c = $this->sgfco2numco($gref, $p->{V});

                    push @{ $gnode->{marks} }, [ $p->{P}, @c, $p->{V} ];

                    # It's tempting to put the marks ON THE BOARD Do not do
                    # this.  They'd need to get handled in _copy, and also,
                    # whosoever get's the $board out of the $gnode, can
                    # also get the $marks!

                } elsif( $p->{P} =~ m/^(?:LB)$/ and $p->{V} =~ m/^(..)\:(.+)$/ ) {
                    push @{ $gnode->{marks} }, [ "LB", $this->sgfco2numco($gref, $1), $1, $2 ];

                } elsif( not $p->{P} =~ m/$gm_pr_reg/ ) {
                    push @{ $gnode->{other}{$p->{P}} }, $p->{V};
                }
            }

            $gnode->{gnum}    = $parent->{gnum};
            $gnode->{move_no} =
                  (ref($gnode->{moves}) ? int(@{ $gnode->{moves} }) : 0)
                + (ref($parent) and defined $parent->{move_no} ? $parent->{move_no} : 0);
        }

        my $j = @{ $pref->{c} };
        if( $j > 1 ) {
            # pretend we're in the node with move #12

            # The first fork is still this variation, and contains move #13
            $this->_parse($level+1, $pref->{c}[0], $gref, $gnode) or return 0;

            # Every other fork is an alternate move #13
            for my $i (1..$#{ $pref->{c} }) {
                $gref->{variations}++;
                $this->_parse($level+1, $pref->{c}[$i], $gref, $gnode) or return 0;
            }
        } elsif( $j == 1 ) {
            $this->{error} = "Parse Error: the author didn't think this condition could come up ... ";
            return 0;
        }

        return 1;
    }

    $this->{error} = "Parse Error: unknown parse depth ($level) or broken reference(s) ($pref, $gref)... error unknown";
    return 0;
}
# }}}
# _ref2id {{{
sub _ref2id {
    my $this = shift;
    my $ref  = shift;

    croak "invalid ref given to _ref2id()" unless ref($ref) eq "HASH";

    unless( defined $this->{refdb2}{$ref} ) {
        my $id;
        my $c = 2;
        if( defined($ref->{variation}) and defined($ref->{move_no}) ) {
            $id = "$ref->{gnum}." .
                   $ref->{variation} . "-" . ($ref->{move_no} ? $ref->{move_no} : "root");
            my $cur = $id;
            while( defined $this->{refdb}{$cur} ) {
                $cur = $id . "-" . $c++;
            }
            $id = $cur;
        } else {
            $id = ++$this->{games};
        }

        print STDERR "$ref 2 id: $id\n" if $ENV{DEBUG} >= 10;

        $this->{refdb2}{$ref} = $id;

        for my $k (qw(comments board marks moves other captures game_properties variations)) {
            $this->{refdb}{$id}{$k} = $ref->{$k} if defined $ref->{$k};
        }

        for my $k (qw(gnum kids)) {
            delete $this->{refdb}{$id}{$k};
        }

        if( $ENV{DEBUG} > 20 ) {
            print STDERR "\$this\->\{refdb\}\{\$ref($ref)\} = $this->{refdb2}{$ref} ",
                        "/ \$this\-\>\{refdb\}\{\$id($id)\} = $this->{refdb}{$id}\n";
        }
    }

    return $this->{refdb2}{$ref};
}
# }}}
# _new_board_matrix {{{
sub _new_board_matrix {
    my $this = shift;
    my $gref = shift;

    $this->_time("_new_board_matrix");

    my $board = [];

    my $size = $gref->{game_properties}{SZ};
    croak "Syntax Error: You must pass a game reference to sgfco2numco because it needs the FF and SZ properties.\n" unless $size;

    for my $i (1..$size) {
        my $row = [];
        for my $j (1..$size) {
            push @$row, ' ';
        }
        push @$board, $row;
    }

    $this->_time("_new_board_matrix");

    return $board;
}
# }}}
# _copy_board_matrix {{{
sub _copy_board_matrix {
    my $this = shift;
    my $tocp = shift;

    $this->_time("_copy_board_matrix");

    my $board = [];

    my $double_check = int @$tocp;
    for (@$tocp) {
        my @a = @{ $_ };
        push @$board, \@a;

        die "Problem copying board (" . (int @a) . " vs $double_check)!" unless int @a == $double_check;
    }

    $this->_time("_copy_board_matrix");

    return $board;
}
# }}}

# _check_for_captures {{{
sub _check_for_captures {
    my ($this, $SZ, $node, @p) = @_;
    my $board = $node->{board};
    my $caps  = $node->{captures};

    $this->_time("_check_for_captures");

    my $tc = $board->[$p[0]][$p[1]];

    croak "crazy unexpected error: checking for caps, and current pos doesn't have a stone.  Two times double odd, and fatal"
        unless $tc =~ m/^[WB]$/;

    my $oc = ($tc eq "W" ? "B" : "W");

    # 1. Find groups for all adjacent stones.

    $this->_time("for(_find_group)");

    my %checked = ();
    my @groups  = ();
    for my $p ( [$p[0]-1, $p[1]+0], [$p[0]+1, $p[1]+0], [$p[0]+0, $p[1]-1], [$p[0]+0, $p[1]+1] ) {
        my @g = $this->_find_group( \%checked, $SZ, $oc, $board, @$p );

        push @groups, [ @g ] if @g;
    }

    $this->_time("for(_find_group)");
    $this->_time("for(\@groups), _count_liberties");

    if( @groups ) {
        # 2. Any groups without liberties are toast!
        print STDERR "_check_for_captures() found ", int(@groups), " neighboring groups:" if $ENV{DEBUG} > 3 and int(@groups);

        for my $group (@groups) {
            my $l = $this->_count_liberties( $SZ, $board, @$group );

            print STDERR " liberties($l)" if $ENV{DEBUG}>3;
            if( $l < 1 ) {
                print STDERR "-killed! " if $ENV{DEBUG}>3;
                for my $p (@$group) {
                    $caps->{$tc}++;
                    $board->[$p->[0]][$p->[1]] = ' ';
                }
            }
        }

        print STDERR "\n" if $ENV{DEBUG} > 3;
    }

    $this->_time("for(\@groups), _count_liberties");
    $this->_time("_find_group/_count_liberties of me");

    # 3. Check my own liberties, I may be toast
    %checked = ();
    my @me_group = $this->_find_group( \%checked, $SZ, $tc, $board, @p );
    my $me_lifec = $this->_count_liberties( $SZ, $board, @me_group );
    print STDERR "_check_for_captures() me_group ", int(@me_group), " stones: " if $ENV{DEBUG} > 3;
    print STDERR " me liberties($me_lifec)" if $ENV{DEBUG}>3;
    if( $me_lifec < 1 ) {
        print STDERR "-killed! " if $ENV{DEBUG}>3;
        for my $p (@me_group) {
            $caps->{$oc}++;
            $board->[$p->[0]][$p->[1]] = ' ';
        }
    }
    print STDERR "\n" if $ENV{DEBUG}>3;

    $this->_time("_find_group/_count_liberties of me");
    $this->_time("_check_for_captures");
}
# }}}
# _count_liberties {{{
sub _count_liberties {
    my ($this, $SZ, $board, @group) = @_;

    $this->_time("_count_liberties");

    my %checked = ();
    my $count   = 0;

    for my $g (@group) {
        for my $p ( [$g->[0]-1, $g->[1]+0], [$g->[0]+1, $g->[1]+0], [$g->[0]+0, $g->[1]-1], [$g->[0]+0, $g->[1]+1] ) {
            if( not $checked{"@$p"} ) {
                $checked{"@$p"} = 1;
                unless( ($p->[0] < 0 or $p->[0] > ($SZ-1)) or ($p->[1] < 0 or $p->[1] > ($SZ-1)) ) {
                    if( $board->[$p->[0]][$p->[1]] eq ' ' ) {
                        $count++;
                    }
                }
            }
        }
    }

    $this->_time("_count_liberties");

    return $count;
}
# }}}
# _find_group {{{
sub _find_group {
    my ($this, $checked, $SZ, $oc, $board, @p) = @_;

    $this->_time("_find_group");

    print STDERR "\t_find_group(@p)" if $ENV{DEBUG}>12;
    my @g;

    if( not $checked->{"@p"} ) {
        $checked->{"@p"} = 1;
        print STDERR "." if $ENV{DEBUG}>12;
        unless( ($p[0] < 0 or $p[0] > ($SZ-1)) or ($p[1] < 0 or $p[1] > ($SZ-1)) ) {
            print STDERR ".." if $ENV{DEBUG}>12;
            if( $board->[$p[0]][$p[1]] eq $oc ) {
                print STDERR " !" if $ENV{DEBUG}>12;
                push @g, [ @p ];
                for my $p ( [$p[0]-1, $p[1]+0], [$p[0]+1, $p[1]+0], [$p[0]+0, $p[1]-1], [$p[0]+0, $p[1]+1] ) {
                    push @g, $this->_find_group( $checked, $SZ, $oc, $board, @$p );
                }
            }
        }
    }
    print STDERR "\n" if $ENV{DEBUG}>12;

    $this->_time("_find_group");

    return @g;
}
# }}}