Games::Go::Dg2ASCII - Perl extension to convert Games::Go::Diagrams to ASCII diagrams

 my $dg2ascii = B<Games::Go::Dg2ASCII-E<gt>new> (options);
 my $ascii = $dg2ascii->convertDiagram($diagram);

    my $int = $diagram->get($dg2mp->diaCoords(3, 4));

# $Id: Dg2ASCII.pm 201 2007-06-11 00:38:40Z reid $

#   Dg2ASCII
#
#   Copyright (C) 2005 Reid Augustin reid@hellosix.com
#                      1000 San Mateo Dr.
#                      Menlo Park, CA 94025 USA
#
#   This library is free software; you can redistribute it and/or modify it
#   under the same terms as Perl itself, either Perl version 5.8.5 or, at your
#   option, any later version of Perl 5 you may have available.
#
#   This program is distributed in the hope that it will be useful, but
#   WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
#   or FITNESS FOR A PARTICULAR PURPOSE.
#

use strict;
require 5.001;

package Games::Go::Dg2ASCII;
use Carp;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration       use PackageName ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
);

BEGIN {
    our $VERSION = sprintf "1.%03d", '$Revision: 201 $' =~ /(\d+)/;
}

######################################################
#
#       Class Variables
#
#####################################################

use constant TOPLEFT     => ' +--';
use constant TOPRIGHT    => '-+  ';
use constant TOP         => '----';
use constant BOTTOMLEFT  => ' +--';
use constant BOTTOMRIGHT => '-+  ';
use constant BOTTOM      => '----';
use constant LEFT        => ' |  ';
use constant RIGHT       => ' |  ';
use constant MIDDLE      => ' +  ';
use constant HOSHI       => ' *  ';
use constant WHITE       => " O  ";    # numberless white stone
use constant BLACK       => " X  ";    # numberless black stone
use constant MARKEDWHITE => " @  ";    # marked white stone
use constant MARKEDBLACK => " #  ";    # marked black stone
use constant MARKEDEMPTY => " ?  ";    # marked empty intersection
use constant WHITE1      => "O"   ;    # numberless white stone
use constant BLACK1      => "X"   ;    # numberless black stone

our %options = (
    boardSizeX      => 19,
    boardSizeY      => 19,
    doubleDigits    => 0,
    coords          => 0,
    topLine         => 1,
    bottomLine      => 19,
    leftLine        => 1,
    rightLine       => 19,
    diaCoords       => sub { my ($x, $y) = @_;
                             $x = chr($x - 1 + ord('a'));
                             $y = chr($y - 1 + ord('a'));
                             return("$x$y"); },
    file            => undef,
    filename        => 'unknown',
    print           => sub { return; }, # Hmph...
    );

######################################################
#
#       Public methods
#
#####################################################

sub new {
    my ($proto, %args) = @_;

    my $my = {};
    bless($my, ref($proto) || $proto);
    $my->{converted} = '';
    foreach (keys(%options)) {
        $my->{$_} = $options{$_};  # transfer default options
    }
    # transfer user args
    $my->configure(%args);
    return($my);
}

sub configure {
    my ($my, %args) = @_;

    if (exists($args{file})) {
        $my->{file} = delete($args{file});
        if (ref($my->{file}) eq 'SCALAR') {
            $my->{filename} = $my->{file};
            $my->{print} = sub { ${$_[0]->{file}} .= $_[1]; };
        } elsif (ref($my->{file}) eq 'ARRAY') {
            $my->{filename} = 'ARRAY';
            $my->{print} = sub { push @{$_[0]->{file}}, split("\n", $_[1]); };
        } elsif (ref($my->{file}) eq 'GLOB') {
            $my->{filename} = 'GLOB';
            $my->{print} = sub { $_[0]->{file}->print($_[1]) or
                                        die "Error writing to output file:$!\n"; };
        } elsif (ref($my->{file}) =~ m/^IO::/) {
            $my->{filename} = 'IO';
            $my->{print} = sub { $_[0]->{file}->print($_[1]) or
                                        die "Error writing to output file:$!\n"; };
        } else {
            require IO::File;
            $my->{filename} = $my->{file};
            $my->{file} = IO::File->new($my->{filename}) or
                die("Error opening $my->{filename}: $!\n");
            $my->{print} = sub { $_[0]->{file}->print($_[1]) or
                                        die "Error writing to $_[0]->{filename}:$!\n"; };
        }
    }
    foreach (keys(%args)) {
        croak("I don't understand option $_\n") unless(exists($options{$_}));
        $my->{$_} = $args{$_};  # transfer user option
    }
    # make sure edges of the board don't exceed boardSize
    $my->{topLine}    = 1 if ($my->{topLine} < 1);
    $my->{leftLine}   = 1 if ($my->{leftLine} < 1);
    $my->{rightLine}  = $my->{boardSizeX} if ($my->{rightLine} > $my->{boardSizeX});
    $my->{bottomLine} = $my->{boardSizeY} if ($my->{bottomLine} > $my->{boardSizeY});
}

sub diaCoords {
    my ($my, $x, $y) = @_;

    return &{$my->{diaCoords}}($x, $y);
}

sub print {
    my ($my, @args) = @_;

    foreach my $arg (@args) {
        $my->{converted} .= $arg;
        &{$my->{print}} ($my, $arg);
    }
}

sub converted {
    my ($my, $text) = @_;

    $my->{converted} = $text if (defined($text));
    return ($my->{converted});
}

sub comment {
    my ($my, @comments) = @_;

    foreach my $c (@comments) {
        while ($c =~ s/([^\n]*)\n//) {
            $my->print("$1\n");
        }
        $my->print("$c\n") if ($c ne '');
    }
}

sub convertDiagram {
    my ($my, $diagram) = @_;

    unless($my->{firstDone}) {
        $my->print("
Black -> X   Marked black -> #   Labeled black -> Xa, Xb
White -> O   Marked white -> @   Labeled white -> Oa, Ob
                          Marked empty -> ?   Labeled empty ->  a,  b\n");
        $my->{firstDone} = 1;
    }
    my @name = $diagram->name;
    $name[0] = 'Unknown Diagram' unless(defined($name[0]));
    my $propRef = $diagram->property;           # get property list for the diagram
    $my->{VW} = exists($propRef->{0}{VW});      # view control?
    my $first = $diagram->first_number;
    my $last = $diagram->last_number;
    $my->{offset} = $diagram->offset;
    $my->{stoneOffset} = $diagram->offset;
    if ($my->{doubleDigits}) {
        while ($first - $my->{stoneOffset} >= 100) {
            $my->{stoneOffset} += 100;      # first to last is not supposed to cross 101
        }
    }
    my $range = '';
    if ($first) {
        $range = ': ' . ($first - $my->{offset});
        if ($last != $first) {
            $range .= '-' . ($last - $my->{offset});
        }
    } else {
        # carp("Hmmm! No numbered moves in $name[0]");
    }

    # get some measurements based on font size
    my ($diaHeight, $diaWidth) = (($my->{bottomLine} - $my->{topLine} + 1), ($my->{rightLine} - $my->{leftLine} + 1));
    if ($my->{coords}) {
        $diaWidth += 4;
        $diaHeight += 2;
    }
    unless(exists($my->{titleDone})) {      # first diagram only:
        $my->{titleDone} = 1;
        my @title_lines = $diagram->gameProps_to_title();
        my $title = '';
        foreach (@title_lines) {
            $title .= "$_\n";
        }
        if($title ne '') {
            $my->print("\n\n$title\n");
        }
    }
    $my->_preamble($diaHeight, $diaWidth);
    if (defined($diagram->var_on_move) and
        defined($diagram->parent)) {
        my $varOnMove = $diagram->var_on_move;
        my $parentOffset = $diagram->parent->offset;
        my $parentName = $diagram->parent->name->[0];
        if (defined($parentOffset) and
            defined($parentName)) {
            $name[0] .= ' at move ' .
                        ($varOnMove - $parentOffset) .
                        ' in ' .
                        $parentName;
        }
    }

    # print the diagram title
    $my->print(join('', @name, $range, "\n"));
    foreach my $y ($my->{topLine} .. $my->{bottomLine}) {
        foreach my $x ($my->{leftLine} ..  $my->{rightLine}) {
            $my->_convertIntersection($diagram, $x, $y);
        }
        if ($my->{coords}) {    # right-side coords
            $my->print($diagram->ycoord($y));
        }
        $my->print("\n");
        if ($y < $my->{bottomLine}) {
            if ($my->{rightLine} - $my->{leftLine} > 1) {
                $my->print(($my->{leftLine} == 1) ? LEFT : '    ',
                           '    ' x ($my->{rightLine} - $my->{leftLine} - 1),
                           ($my->{rightLine} == $my->{boardSizeY}) ? RIGHT : '',
                           "\n");
            } else {
                $my->print(LEFT, "\n");       # doesn't seem very likely!
            }
        }
    }
    # print coordinates along the bottom
    if ($my->{coords}) {
        my ($l, $r) = ($my->{leftLine}, $my->{rightLine});
        $my->print(' ');
        for ($my->{leftLine} .. $my->{rightLine}) {
            $my->print($diagram->xcoord($_), '   ');
        }
    }

    # deal with the over-lay stones
    $my->_convertOverstones($diagram);
    $my->print("\n");
    # print the game comments for this diagram
    foreach my $n (sort { $a <=> $b } keys(%{$propRef})) {
        my @comment;
        if (exists($propRef->{$n}{B}) and
            ($propRef->{$n}{B}[0] eq 'pass')) {
            push(@comment, "Black Pass\n\n");
        }
        if (exists($propRef->{$n}{W}) and
             ($propRef->{$n}{W}[0] eq 'pass')) {
            push(@comment, "White Pass\n\n");
        }
        if (exists($propRef->{$n}{N})) {
            push(@comment, "$propRef->{$n}{N}[0]\n"); # node name
        }
        if (exists($propRef->{$n}{C})) {
            push(@comment, @{$propRef->{$n}{C}});
        }
        if (@comment) {
            my $c = '';
            my $n_off = $n - $my->{offset};
            $c = "$n_off: " if (($n > 0) and
                                ($n >= $first) and
                                ($n <= $last));
            $c .= join("\n", @comment);
            $my->print($my->convertText("$c\n"));
        }
    }
    $my->_postamble();
}

sub convertText {
    my ($my, $text) = @_;

    return $text;
}

sub close {
    my ($my) = @_;

    if (defined($my->{file}) and
        ((ref($my->{file}) eq 'GLOB') or
         (ref($my->{file}) eq 'IO::File'))) {
        $my->{file}->close;
    }
}

######################################################
#
#       Private methods
#
#####################################################

sub _convertOverstones {
    my ($my, $diagram) = @_;

    my @converted;

    foreach my $int (@{$diagram->getoverlist()}) {
        my $overStones = '';
        for(my $ii = 0; $ii < @{$int->{overstones}}; $ii += 2) {
            # all the overstones that were put on this understone:
            my $overColor = $int->{overstones}[$ii];
            my $overNumber = $int->{overstones}[$ii+1];
            $overStones .= ", " if ($overStones ne '');
            local $my->{stoneOffset} = $my->{offset};
            $overStones .= $my->_checkStoneNumber($overNumber);
        }
        my $atStone = '';
        if (exists($int->{number})) {
            # numbered stone in text
            $atStone = $my->_checkStoneNumber($int->{number});
        } else {
            unless (exists($int->{mark})) {
                my $mv = '';
                $mv .= " black node=$int->{black}" if (exists($int->{black}));
                $mv .= " white node=$int->{white}" if (exists($int->{white}));
                carp("Oops: understone$mv is not numbered or marked? " .
                     "This isn't supposed to be possible!");
            }
            if (exists($int->{black})) {
                $atStone = '#';        # marked black stone in text
            }elsif (exists($int->{white})) {
                $atStone = '@';        # marked white stone in text
            } else {
                carp("Oops: understone is not black or white? " .
                     "This isn't supposed to be possible!");
            }
        }
        # collect all the overstones in the diagram
        push(@converted, "$overStones at $atStone");
    }
    return '' unless(@converted);
    $my->print("\n", join(",\n", @converted), "\n");
}

sub _checkStoneNumber {
    my ($my, $number) = @_;

    if ($number - $my->{stoneOffset} > 0) {
        return $number - $my->{stoneOffset};
    }
    if ($number < 1) {
        carp "Yikes: stone number $number is less than 1.  Intersection/stone will be missing!";
    } else {
        carp "Stone number $number and offset $my->{stoneOffset} makes less than 1 - not using offset";
    }
    return $number;
}


sub _formatNumber {
    my ($my, $number) = @_;

    return " $number  " if ($number < 10);
    return  "$number  " if ($number < 100);
    return   "$number ";
}

# get text for intersection hash from $diagram.
sub _convertIntersection {
    my ($my, $diagram, $x, $y) = @_;

    my $int = $diagram->get($my->diaCoords($x, $y));
    if ($my->{VW} and               # view control AND
        not exists($int->{VW})) {   # no view on this intersection
        $my->print('    ');
        return;
    }
    my $stone;
    if (exists($int->{number})) {
        $stone = $my->_formatNumber($my->_checkStoneNumber($int->{number})); # numbered stone
    } elsif (exists($int->{mark})) {
        if (exists($int->{black})) {
            $stone = MARKEDBLACK;                       # marked black stone
        }elsif (exists($int->{white})) {
            $stone = MARKEDWHITE;                       # marked white stone
        } else {
            $stone = MARKEDEMPTY;                       # marked empty intersection
        }
    } elsif (exists($int->{label})) {
        if (exists($int->{black})) {
            $stone = ' ' . BLACK1 . substr($int->{label}, 0, 1) . ' ';     # labeled black stone
        } elsif (exists($int->{white})) {
            $stone = ' ' . WHITE1 . substr($int->{label}, 0, 1) . ' ';     # labeled white stone
        } else {
            $stone = ' ' . substr($int->{label}, 0, 1) . '  ';               # labeled intersection
        }
    } elsif (exists($int->{white})) {
        $stone = WHITE;       # numberless white stone
    } elsif (exists($int->{black})) {
        $stone = BLACK;        # numberless black stone
    }

    unless (defined($stone)) {
        if (exists($int->{hoshi})) {
            $stone = HOSHI;
        } else {
            $stone = $my->_underneath($x, $y);
        }
    }
    $my->print($stone);
}

# return the appropriate font char for the intersection
sub _underneath {
    my ($my, $x, $y) = @_;

    if ($y <= 1) {
        return TOPLEFT if ($x <= 1);            # upper left corner
        return TOPRIGHT if ($x >= $my->{boardSizeX}); # upper right corner
        return TOP;                             # upper side
    } elsif ($y >= $my->{boardSizeY}) {
        return BOTTOMLEFT if ($x <= 1);         # lower left corner
        return BOTTOMRIGHT if ($x >= $my->{boardSizeX}); # lower right corner
        return BOTTOM;                          # lower side
    }
    return LEFT if ($x <= 1);                   # left side
    return RIGHT if ($x >= $my->{boardSizeX});   # right side
    return MIDDLE;                              # somewhere in the middle
}

# don't need any preamble for text diagrams
sub _preamble {
    my ($my, $diaHeight, $diaWidth) = @_;

    return;
}

# this one's pretty easy too
sub _postamble {
    my ($my) = @_;

    $my->print("\n\n");
}

1;

__END__