| Games-Go-Sgf2Dg documentation | Contained in the Games-Go-Sgf2Dg distribution. |
Games::Go::Dg2PDF - Perl extension to convert Games::Go::Diagrams to PDF (Portable Document Format).
use Games::Go::Dg2PDF
my $dg2pdf = B<Games::Go::Dg2PDF-E<gt>new> (options); $dg2pdf->convertDiagram($diagram);
A Games::Go::Dg2PDF object converts a Games::Go::Diagram object into a PDF file.
A new Games::Go::Dg2PDF takes the following options:
Sets the size of the board.
Default: 19
Numbers on stones are wrapped back to 1 after they reach 100. Numbers associated with comments and diagram titles are not affected.
Default: false
Generates a coordinate grid.
Default: false
The edges of the board that should be displayed. Any portion of the board that extends beyond these numbers is not included in the output.
This callback defines a subroutine to convert coordinates from $x, $y to whatever coordinates are used in the Games::Go::Diagram object. The default diaCoords converts 1-based $x, $y to the same coordinates used in SGF format files. You only need to define this if you're using a different coordinate system in the Diagram.
Default: sub { my ($x, $y) = @_; $x = chr($x - 1 + ord('a')); # convert 1 to 'a', etc $y = chr($y - 1 + ord('a')); return("$x$y"); }, # concatenate two letters
See also the diaCoords method below.
A user defined subroutine to replace the default printing method. This callback is called from the print method (below) with the reference to the Dg2TeX object and a list of lines that are part of the TeX diagram source.
May be one of:
Default: 'letter'
Margins are set in PDF 'user space units' which are approximately equivilent to points (1/72 of an inch).
Default for all margins: 72 * .70 (7/10s of an inch)
Text and stone fonts names may be one of these (case sensitive):
The point size for the comment text. Diagram titles use this size plus 4, and the game title uses this size plus 6.
Default: 11
The stone_fontSize determines the size of the text inside stones, and may also determine the size of the stones and diagrams (see lineHeight and lineWidth below).
Default: 5
The lineWidth and lineHeight determine the size of the stones and diagrams.
If lineWidth is not explicitly set, it is calculated from the stone_fontSize to allow up to three digits on a stone . The default stone_fontSize allows for three diagrams (with -coords) per 'letter' page if comments don't take up extra space below diagrams. If doubleDigits is specified, the stones and board are slightly smaller (stone 100 may look a bit cramped).
If lineHeight is not explicitly set, it will be 1.05 * lineWidth, creating a slightly rectangular diagram.
Default: undef - determined from stone_fontSize
Change Dg2PDF options from values passed at new time.
Provides access to the diaCoords option (see above). Returns coordinates in the converter's coordinate system for board coordinates ($x, $y). For example, to get a specific intersection structure:
my $int = $diagram->get($dg2mp->diaCoords(3, 4));
prints raw PDF code to file as defined at new time. Whether or not file was defined, print accumulates the PDF code for later retrieval with converted.
Adds $text to the diagram comments.
Inserts the PDF comment character ('%') in front of each line of each comment and prints it to file.
Note that this is not the same as the printComment method.
Converts a Games::Go::Diagram into PDF.
Converts $text into text for display.
Returns the converted text.
convertGameProps takes a reference to a hash of properties as extracted from an SGF file. Each hash key is a property ID and the hash value is a reference to an array of property values: $hash->{propertyId}->[values]. The following SGF properties are recognized:
Both long and short property names are recognized, and all unrecognized properties are ignored with no warnings. Note that these properties are all intended as game-level notations.
prints some final PDF code to the diagram and closes the pdf object (file).
Script to convert SGF format files to Go diagrams
You think I'd admit it?
Reid Augustin, <reid@hellosix.com>
Copyright (C) 2005 by Reid Augustin
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.
| Games-Go-Sgf2Dg documentation | Contained in the Games-Go-Sgf2Dg distribution. |
# $Id: Dg2PDF.pm 171 2007-04-14 04:31:46Z reid $ # Dg2PDF # # 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::Dg2PDF; eval { require PDF::Create; }; # is this module available? if ($@) { die (" Dg2PDF needs the PDF::Create module, but it is not available. You can find PDF::Create in the same repository where you found Games::Go::Sgf2Dg, or from http://search.cpan.org/\n\n"); } 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: 171 $' =~ /(\d+)/; } { my $v = ($PDF::Create::VERSION =~ m/(^\d*\.\d*)/)[0]; if (not defined($v)) { carp("Hmm, can't extract PDF::Create package version from $PDF::Create::VERSION. There may be a " . "more recent version from http://www.sourceforge.net/projects/perl-pdf.\n"); } elsif ($v < 0.06) { carp("Note: your PDF::Create package is version $PDF::Create::VERSION. You might want to pick up a " . "more recent version from http://www.sourceforge.net/projects/perl-pdf.\n"); } # from Slaven on comp.lang.perl.modules: # Modify PDF::Create to add changing font/stroke colors package PDF::Create; sub my_get_data { if (defined(&get_data)) { return shift->get_data(); # only in newer versions, apparently } return shift->{'data'}; } sub my_get_page_size { my $self = shift; if (defined(&get_page_size)) { return $self->get_page_size(@_); # only in newer versions, alas } my $name = lc(shift); my %pagesizes = ( 'a0' => [ 0, 0, 2380, 3368 ], 'a1' => [ 0, 0, 1684, 2380 ], 'a2' => [ 0, 0, 1190, 1684 ], 'a3' => [ 0, 0, 842, 1190 ], 'a4' => [ 0, 0, 595, 842 ], 'a5' => [ 0, 0, 421, 595 ], 'a6' => [ 0, 0, 297, 421 ], 'letter' => [ 0, 0, 612, 792 ], 'broadsheet' => [ 0, 0, 1296, 1584 ], 'ledger' => [ 0, 0, 1224, 792 ], 'tabloid' => [ 0, 0, 792, 1224 ], 'legal' => [ 0, 0, 612, 1008 ], 'executive' => [ 0, 0, 522, 756 ], '36x36' => [ 0, 0, 2592, 2592 ], ); if (!$pagesizes{$name}) { $name = "a4"; } $pagesizes{$name}; } package PDF::Create::Page; # set colors for drawing commands sub set_stroke_color { my($page, $r, $g, $b) = @_; return if (defined $page->{'current_stroke_color'} && $page->{'current_stroke_color'} eq join(",", $r, $g, $b)); $page->{'pdf'}->page_stream($page); $page->{'pdf'}->add("$r $g $b RG"); $page->{'current_stroke_color'} = join(",", $r, $g, $b); } # set colors for fonts sub set_fill_color { my($page, $r, $g, $b) = @_; return if (defined $page->{'current_fill_color'} && $page->{'current_fill_color'} eq join(",", $r, $g, $b)); $page->{'pdf'}->page_stream($page); if ($r == 0 and $b == 0 and $g == 0) { $page->{'pdf'}->add("0 g "); } elsif ($r == 1 and $b == 1 and $g == 1) { $page->{'pdf'}->add("1 g "); } else { $page->{'pdf'}->add("$r $g $b rg "); } $page->{'current_fill_color'} = join(",", $r, $g, $b); } # b: closes, fills and strokes the path using the non-zero winding number rule sub close_fill_stroke { my $self = shift; $self->{'pdf'}->page_stream($self); $self->{'pdf'}->add("b"); } # b*: closes, fills and strokes the path using the even-odd rule sub close_fill_stroke2 { my $self = shift; $self->{'pdf'}->page_stream($self); $self->{'pdf'}->add("b*"); } # raw print - dump directly to PDF page stream sub print { my $self = shift; $self->{'pdf'}->page_stream($self); while(@_) { $self->{'pdf'}->add(shift); } } package PDF::Create; # kludge in some more flexible filename handling sub filehandle { my ($self, $fh, $filename) = @_; $self->{fh} = $fh if (defined($fh)); $self->{filename} = $filename if (defined($fh)); return $self->{fh}; } } ###################################################### # # Class Variables # ##################################################### 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 => '', filename => 'unknown', print => sub { return; }, # Hmph... # PDF=specific options: pageSize => 'letter', topMargin => 72 * .70, bottomMargin => 72 * .70, leftMargin => 72 * .70, rightMargin => 72 * .70, text_fontName => 'Times-Roman', text_fontSize => 9, stone_fontName => 'Courier-Bold', stone_fontSize => 5, lineWidth => undef, lineHeight => undef, ); use constant TEXT_Y_OFFSET => 1.3; use constant BLACK => 'black'; use constant WHITE => 'white'; use constant NORMAL_PEN => 1; use constant BOARD_EDGE_PEN => NORMAL_PEN * 2; use constant MARK_PEN => NORMAL_PEN * 3; ###################################################### # # Public methods # #####################################################
sub new { my ($proto, %args) = @_; my $my = {}; bless($my, ref($proto) || $proto); # $my->{lineWidth} = 1; # $my->{lineHeight} = 1; $my->{diagram_box_right} = 1; $my->{diagram_box_bottom} = 0; $my->{text_box_y_last} = 0; $my->{curr_set_width} = -1; 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]->{currentPage}->add($_[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]->{pdf}->add($_[1]) or die "Error writing to $_[0]->{filename}:$!\n"; }; } } foreach (keys(%args)) { if (exists($options{$_})) { $my->{$_} = $args{$_}; # transfer user option } else { carp("Unknown 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) = @_; unless(exists($my->{pdf})) { push(@{$my->{pre_init_print}}, @args); return; # we'll get around to it eventually... } foreach my $arg (@args) { &{$my->{print}} ($my, $arg); } }
sub printComment { my ($my, @args) = @_; foreach(@args) { $my->_flow_text($_); } }
sub comment { my ($my, @comments) = @_; $my->print("\n"); 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) = @_; my @name = $diagram->name; $name[0] = 'Unknown Diagram' unless(defined($name[0])); unless(exists($my->{root})) { $my->_createPDF; $my->{pdf}->add(@{$my->{pre_init_print}}); } $my->comment("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"); $my->comment(" Start of $name[0]"); $my->comment("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"); $my->{diagram_width} = $my->{lineWidth} * (1 + $my->{rightLine} - $my->{leftLine}); $my->{diagram_height} = $my->{lineHeight} * (1 + $my->{bottomLine} - $my->{topLine}); if ($my->{coords}) { $my->{diagram_width} += $my->{lineWidth}; $my->{diagram_height} += $my->{lineHeight}; } $my->_next_diagram_box; # get location for next diagram # BUGBUG table of contents? 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]"); } 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; } } if ($my->{VW}) { # view control $my->{draw_underneath} = 1; # draw each intersection individually } else { # draw the underneath part (the board) $my->_board; } 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->_createText( $my->_boardX($my->{rightLine} + 1), $my->_boardY($y) + TEXT_Y_OFFSET, -font => $my->{stone_font}, -fontSize => $my->{stone_fontSize} + 2, -text => $diagram->ycoord($y)); } } # print bottom coordinates if ($my->{coords}) { for ($my->{leftLine} .. $my->{rightLine}) { $my->_createText( $my->_boardX($_), $my->_boardY($my->{bottomLine} + 1) + TEXT_Y_OFFSET, -font => $my->{stone_font}, -fontSize => $my->{stone_fontSize} + 2, -text => $diagram->xcoord($_)); } } # now handle text associated with this diagram { local $my->{text_fontSize} = $my->{text_fontSize} + 4; 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->printComment("$title\n"); } my $pw = $propRef->{0}{PW}[0] || '(unknown)'; my $pb = $propRef->{0}{PB}[0] || '(unknown)'; $my->{toc} = $my->{pdf}->new_outline( # the Table of Contents 'Title' => "$pw vs. $pb", 'Destination' => $my->{currentPage}); } $my->{text_fontSize} -= 2; # print the diagram title $my->printComment($my->convertText(join('', @name, $range, "\n"))); } # the over-lay stones $my->_convertOverstones($diagram); $my->printComment("\n"); $my->{toc}->new_outline( # add diagram to table of contents 'Title' => join('', @name, $range)); # 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->printComment($my->convertText("$c\n")); } } }
sub convertText { my ($my, $text) = @_; # turn single \n into single space. multiple \n's are broken during _flow_text # $text =~ s/([^\n])\n([^\n])/$1 $2/gs; return $text; }
sub convertGameProps { my ($my, $hashRef) = @_; return unless(defined($hashRef)); my %hash; foreach my $key (keys(%{$hashRef})) { my $short = $key; $short =~ s/[^A-Z]//g; # delete everything but upper case letters my $text = join('', @{$hashRef->{$key}}); $text =~ s/\n//gm; $text =~ s/0*$// if ($short eq 'KM'); # remove ugly trailing zeros on komi supplied by IGS $hash{$short} = $my->convertText($text); } if (exists($hash{WR})) { if (exists($hash{PW})) { $hash{PW} = "$hash{PW} $hash{WR}"; # join name and rank } else { $hash{PW} = $hash{WR}; # rank only? } } if (exists($hash{BR})) { if (exists($hash{PB})) { $hash{PB} = "$hash{PB} $hash{BR}"; # join name and rank } else { $hash{PB} = $hash{BR}; # rank only? } } if (exists($hash{RO})) { if (exists($hash{EV})) { $hash{EV} = "$hash{EV} - $hash{RO}"; # join event and round } else { $hash{EV} = $hash{RO}; # round only? } } my @lines; push(@lines, $hash{GN}) if(exists($hash{GN})); # GameName push(@lines, $hash{EV}) if(exists($hash{EV})); # Event and Round number push(@lines, $hash{DT}) if (exists($hash{DT})); # DaTe push(@lines, "{\\bf White:} $hash{PW}") if (exists($hash{PW})); # PlayerWhite push(@lines, "{\\bf Black:} $hash{PB}") if (exists($hash{PB})); # PlayerBlack push(@lines, "{\\bf Place:} $hash{PC}") if (exists($hash{PC})); # PlaCe push(@lines, "{\\bf Komi:} $hash{KM}") if (exists($hash{KM})); # komi push(@lines, "{\\bf Rules} $hash{RU}") if (exists($hash{RU})); # rules push(@lines, "{\\bf Time:} $hash{TM}") if (exists($hash{TM})); # time constraints push(@lines, "{\\bf Byo-yomi} $hash{OT}") if (exists($hash{OT})); # overtime push(@lines, "{\\bf Result:} $hash{RE}") if (exists($hash{RE})); # result push(@lines, "{\\bf Annotated by:} $hash{AN}") if (exists($hash{AN})); # annotater push(@lines, "{\\bf Source:} $hash{SO}") if (exists($hash{SO})); # source? push(@lines, "{\\bf Entered by:} $hash{US}") if (exists($hash{US})); # user push(@lines, "$hash{CP}") if (exists($hash{CP})); # Copyright push(@lines, $hash{GC}) if (exists($hash{GC})); # GameComment my ($title)=''; foreach my $line (@lines) { next unless (defined($line)); $my->printComment($my->convertText($line)); } }
sub close { my ($my) = @_; $my->{pdf}->close; my $pdf = $my->{pdf}->my_get_data; if (ref($my->{file}) eq 'SCALAR') { ${$my->{file}} .= $pdf; } elsif (ref($my->{file}) eq 'ARRAY') { push(@{$my->{file}}, split("\n", $pdf)); } return $pdf; } ###################################################### # # Private methods # ##################################################### sub _convertOverstones { my ($my, $diagram) = @_; return unless (@{$diagram->getoverlist}); my ($color, $number, $otherColor); for (my $ii = 0; $ii < @{$diagram->getoverlist}; $ii++) { my $int = $diagram->getoverlist->[$ii]; $my->{text_box_y} += $my->{text_fontSize}; # un-adjust for text line height $my->{text_box_y} -= $my->{lineHeight} * 1.2;# adjust for stone height my $x = $my->{text_box_left}; # all the overstones that were put on this understone: my $comma = 0; for (my $jj = 0; $jj < @{$int->{overstones}}; $jj += 2) { if ($comma ) { $my->_createText( $x, $my->{text_box_y}, -anchor => 'sw', -font => $my->{text_font}, -fontSize => $my->{text_fontSize}, -text => ','); $x += $my->{text_fontSize} * $my->{currentPage}->string_width($my->{text_font}, ', '); } if ($my->{text_box_right} - $x < 3 * $my->{lineWidth}) { $my->{text_box_y} -= $my->{lineHeight} * 1.2; # drop to next line $x = $my->{text_box_left}; $jj -= 2; $comma = 0; next; # try again } $color = $int->{overstones}[$jj]; $otherColor = ($color eq BLACK) ? WHITE : BLACK; local $my->{stoneOffset} = $my->{offset}; # turn off doubleDigits $number = $my->_checkStoneNumber($int->{overstones}[$jj+1]); # draw the overstone my $left = $x; my $right = $x + $my->{lineWidth}; my $top = $my->{text_box_y} + $my->{lineHeight}; my $bottom = $my->{text_box_y}; $my->_createOval( $left, $top, $right, $bottom, -outline => BLACK, -fill => $color); # put the number on it $my->_createText( $x + $my->{lineWidth} / 2, $my->{text_box_y} + TEXT_Y_OFFSET + $my->{lineHeight} / 2, -fill => $otherColor, -fontSize => $my->{stone_fontSize} + ((length($number) > 2) ? 0 : 2), -text => $number); $x += $my->{lineWidth}; $comma = 1; } # the 'at' stone if (exists($int->{black})) { $color = BLACK; $otherColor = WHITE; } elsif (exists($int->{white})) { $color = WHITE; $otherColor = BLACK; } else { carp("Oops: understone is not black or white? " . "This isn't supposed to be possible!"); next; } # at $my->_createText( $x, $my->{text_box_y} + TEXT_Y_OFFSET, -anchor => 'sw', -font => $my->{text_font}, -fontSize => $my->{text_fontSize}, -text => ' at '); $x += $my->{text_fontSize} * $my->{currentPage}->string_width($my->{text_font}, ' at '); # draw the at-stone my $left = $x; my $right = $x + $my->{lineWidth}; my $top = $my->{text_box_y} + $my->{lineHeight}; my $bottom = $my->{text_box_y}; $my->_createOval( $left, $top, $right, $bottom, -outline => BLACK, -fill => $color); if (exists($int->{number})) { # put the number on it $my->_createText( $x + $my->{lineWidth} / 2, $my->{text_box_y} + TEXT_Y_OFFSET + $my->{lineHeight} / 2, -fill => $otherColor, -fontSize => $my->{stone_fontSize} + ((length($int->{number}) > 2) ? 0 : 2), -text => $my->_checkStoneNumber($int->{number})); } elsif (exists($int->{mark})) { # draw the mark on it $my->_drawMark($int->{mark}, $otherColor, ($left + $right) / 2, ($top + $bottom) / 2); } else { 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!"); } $x += $my->{lineWidth}; if ($ii < @{$diagram->getoverlist} - 1) { $my->_createText( $x, $my->{text_box_y}, -anchor => 'sw', -font => $my->{text_font}, -fontSize => $my->{text_fontSize}, -text => ','); } $my->{text_box_y} -= $my->{text_fontSize}; # re-adjust for text line height $my->{text_box_y_last} = $my->{text_box_y}; $my->{text_box_used} = 1; } } 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 _stone { my ($my, $x, $y, $color) = @_; $my->_createOval( $x - $my->{lineWidth} / 2, # left $y - $my->{lineHeight} / 2, # top $x + $my->{lineWidth} / 2, # right $y + $my->{lineHeight} / 2, # bottom -fill => $color, -outline => BLACK); } sub _blank { my ($my, $x, $y, $color) = @_; # create some whitespace to draw label on $my->_createOval( $x - $my->{lineWidth} / 3, # left $y - $my->{lineHeight} / 3, # top $x + $my->{lineWidth} / 3, # right $y + $my->{lineHeight} / 3, # bottom -fill => WHITE, -outline => WHITE); } sub _label { my ($my, $x, $y, $label, $color) = @_; $my->_createText( $x, $y + TEXT_Y_OFFSET, -fill => $color, -fontSize => $my->{stone_fontSize} + ((length($label) > 2) ? 0 : 2), -text => $label ); } # convert intersection hash from $diagram. sub _convertIntersection { my ($my, $diagram, $x, $y) = @_; my $int = $diagram->get($my->diaCoords($x, $y)); return if ($my->{VW} and # view control AND not exists($int->{VW})); # no view on this intersection my $color = BLACK; my $otherColor = BLACK; my $xx = $my->_boardX($x); my $yy = $my->_boardY($y); if (exists($int->{black})) { $otherColor = WHITE; $my->_stone($xx, $yy, $color); } elsif (exists($int->{white})) { $color = WHITE; $my->_stone($xx, $yy, $color); } else { if ($my->{draw_underneath}) { # draw the appropriate intersection $my->_draw_underneath($int, $x, $y); } # else the whole board underneath has already been drawn for us if (exists($int->{hoshi})) { $my->_drawHoshi($xx, $yy); } if (exists($int->{label}) or exists($int->{number})) { # clear some space at intersection for the number/label $my->_blank($xx, $yy); } } if (exists($int->{number})) { my $label = $my->_checkStoneNumber($int->{number}); # numbered stone $my->_label($xx, $yy, $label, $otherColor); } elsif (exists($int->{mark})) { $my->_drawMark($int->{mark}, $otherColor, $xx, $yy); } elsif (exists($int->{label})) { $my->_label($xx, $yy, $int->{label}, $otherColor); } } sub _board { my ($my, $width, $x, $y) = @_; foreach my $y ($my->{topLine} .. $my->{bottomLine}) { my $width = NORMAL_PEN; my $l = $my->_boardX($my->{leftLine}); my $r = $my->_boardX($my->{rightLine}); $width = BOARD_EDGE_PEN if ($y <= 1 or $y >= $my->{boardSizeY}); my $yy = $my->_boardY($y); $my->_createLine($l, $yy, $r, $yy, -width => $width); } foreach my $x ($my->{leftLine} .. $my->{rightLine}) { my $width = NORMAL_PEN; $width = BOARD_EDGE_PEN if ($x <= 1 or $x >= $my->{boardSizeX}); my $t = $my->_boardY($my->{topLine}); my $b = $my->_boardY($my->{bottomLine}); my $xx = $my->_boardX($x); $my->_createLine($xx, $t, $xx, $b, -width => $width); } } sub _draw_left { my ($my, $width, $x, $y) = @_; $my->_createLine( $x, $y, $x - ($my->{lineWidth} / 2), $y, -width => $width); } sub _draw_right { my ($my, $width, $x, $y) = @_; $my->_createLine( $x, $y, $x + ($my->{lineWidth} / 2) + 1, $y, -width => $width); } sub _draw_up { my ($my, $width, $x, $y) = @_; $my->_createLine( $x, $y, $x, $y + ($my->{lineWidth} / 2), -width => $width); } sub _draw_down { my ($my, $width, $x, $y) = @_; $my->_createLine( $x, $y, $x, $y - ($my->{lineWidth} / 2) - 1, -width => $width); } sub _draw_underneath { my ($my, $int, $xx, $yy) = @_; my $x = $my->_boardX($xx); my $y = $my->_boardY($yy); if ($yy <= 1) { if ($xx <= 1) { # upper left corner $my->_draw_right(BOARD_EDGE_PEN, $x, $y); $my->_draw_down(BOARD_EDGE_PEN, $x, $y); } elsif ($xx >= $my->{boardSizeX}) {# upper right corner $my->_draw_left(BOARD_EDGE_PEN, $x, $y); $my->_draw_down(BOARD_EDGE_PEN, $x, $y); } else { # upper side $my->_draw_left(BOARD_EDGE_PEN, $x, $y); $my->_draw_right(BOARD_EDGE_PEN, $x, $y); $my->_draw_down(NORMAL_PEN, $x, $y); } } elsif ($yy >= $my->{boardSizeY}) { if ($xx <= 1) { # lower left corner $my->_draw_right(BOARD_EDGE_PEN, $x, $y); $my->_draw_up(BOARD_EDGE_PEN, $x, $y); } elsif ($xx >= $my->{boardSizeX}) {# lower right corner $my->_draw_left(BOARD_EDGE_PEN, $x, $y); $my->_draw_up(BOARD_EDGE_PEN, $x, $y); } else { # lower side $my->_draw_left(BOARD_EDGE_PEN, $x, $y); $my->_draw_right(BOARD_EDGE_PEN, $x, $y); $my->_draw_up(NORMAL_PEN, $x, $y); } } else { if ($xx <= 1) { # left side $my->_draw_up(BOARD_EDGE_PEN, $x, $y); $my->_draw_down(BOARD_EDGE_PEN, $x, $y); $my->_draw_right(NORMAL_PEN, $x, $y); } elsif ($xx >= $my->{boardSizeX}) {# right side $my->_draw_up(BOARD_EDGE_PEN, $x, $y); $my->_draw_down(BOARD_EDGE_PEN, $x, $y); $my->_draw_left(NORMAL_PEN, $x, $y); } else { # somewhere in the middle $my->_draw_up(NORMAL_PEN, $x, $y); $my->_draw_down(NORMAL_PEN, $x, $y); $my->_draw_left(NORMAL_PEN, $x, $y); $my->_draw_right(NORMAL_PEN, $x, $y); } } } sub _drawMark { my ($my, $mark, $color, $x, $y) = @_; if ($mark eq 'TR') { # TR[pt] triangle # triangle has top Y; left, right X; and bottom Y my $left = $x - (.3 * $my->{lineWidth}); # cos(30) = .866 my $right = $x + (.3 * $my->{lineWidth}); # cos(30) = .866 my $top = $y + ($my->{lineHeight} / 3); my $bottom = $y - ($my->{lineHeight} / 6); # sin(30) = .5 $my->_createLine( $x, $top, $right, $bottom, $left, $bottom, $x, $top, -fill => $color, -width => MARK_PEN ); } else { # circle, square, and X mark is centered at X, Y, 50% of usual stone size my $left = $x - (.25 * $my->{lineWidth}); my $right = $x + (.25 * $my->{lineWidth}); my $top = $y - (.25 * $my->{lineHeight}); my $bottom = $y + (.25 * $my->{lineHeight}); if ($mark eq 'CR') { # CR[pt] circle $my->_createOval( $left, $top, $right, $bottom, -outline => $color, -width => MARK_PEN ); } elsif ($mark eq 'SQ') { # SQ[pt] square $my->_createLine( $left, $top, $right, $top, $right, $bottom, $left, $bottom, $left, $top, -fill => $color, -width => MARK_PEN ); } else { # MA[pt] mark (X) $my->_createLine( $left, $top, $right, $bottom, -fill => $color, -width => MARK_PEN ); $my->_createLine( $right, $top, $left, $bottom, -fill => $color, -width => MARK_PEN ); } } } sub _drawHoshi { my ($my, $x, $y) = @_; my $size = $my->{lineWidth} * 0.08; # 8% size of a stone $size = 1 if $size <= 0; $my->_createOval( $x - $size, $y + $size, $x + $size, $y - $size, -fill => BLACK); } sub _boardX { my ($my, $x) = @_; return $my->{diagram_box_left} + ($x - $my->{leftLine} + 0.5) * $my->{lineWidth}; } sub _boardY { my ($my, $y) = @_; return $my->{diagram_box_top} - ($y - $my->{topLine} + 0.5) * $my->{lineHeight}; } # imitate a Tk::Canvas createText call # Note: default font is $my->{stone_font} and fontSize is $my->{stone_fontSize} sub _createText { my ($my, $x, $y, %args) = @_; my $page = $my->{currentPage}; $page->set_fill_color($my->_get_rgb(delete($args{-fill}))); my $text = delete($args{-text}); my $font = delete($args{-font}) || $my->{stone_font}; my $fontSize = delete($args{-fontSize}) || $my->{stone_fontSize}; if (exists($args{-anchor})) { if ($args{-anchor} eq 'sw') { } else { carp ("Unknown anchor in _createText: $args{-anchor}"); } delete ($args{-anchor}); } else { # put anchor at center of text $x -= $fontSize * $page->string_width($font, $text) / 2; $y -= $fontSize / 2; } foreach (keys(%args)) { carp ("Unknown args key in _createText: $_"); } $page->stringl( $font, $fontSize, $x, $y, $text); } # imitate a Tk::Canvas createOval call use constant SQRT2 => sqrt(2); use constant BZEL8 => (8 - SQRT2) / 6; use constant BZEL7 => ((7 * SQRT2) - 8) / 6; sub _createOval { my ($my, $x1, $y1, $x2, $y2, %args) = @_; my $page = $my->{currentPage}; my $fill = exists($args{-fill}); $page->set_fill_color($my->_get_rgb(delete($args{-fill}))); my $outline = exists($args{-outline}); $page->set_stroke_color($my->_get_rgb(delete($args{-outline}))); $my->_set_width(delete($args{-width})); foreach (keys(%args)) { carp ("Unknown args key in _createOval: $_"); } # From: "David Hart" <d...@xxxserif.com> # Newsgroups: comp.graphics.algorithms # Subject: Re: Using bezier curves to approx an ellipse # Date: Wed, 3 Jun 1998 12:08:07 +0100 # # for an ellipse defined by: # # (x^2 / a^2) + (y^2 / b^2) = 1 # # the Bezier control points for one quarter of the ellipse are: # # [+a/sqrt(2), +b/sqrt(2)] # [+a*(8-sqrt(2))/6, +b*(7*sqrt(2)-8)/6] # [+a*(8-sqrt(2))/6, -b*(7*sqrt(2)-8)/6] # [+a/sqrt(2), -b/sqrt(2)] # # repeat four times to get the full ellipse my $a = ($x2 - $x1) / 2; my $x = $x1 + $a; my $b = ($y2 - $y1) / 2; my $y = $y1 + $b; $page->moveto ($x + ($a / SQRT2), $y + ($b / SQRT2)); $page->curveto($x + ($a * BZEL8), $y + ($b * BZEL7), # right quarter of ellipse $x + ($a * BZEL8), $y - ($b * BZEL7), $x + ($a / SQRT2), $y - ($b / SQRT2)); $page->curveto($x + ($a * BZEL7), $y - ($b * BZEL8), # bottom quarter of ellipse $x - ($a * BZEL7), $y - ($b * BZEL8), $x - ($a / SQRT2), $y - ($b / SQRT2)); $page->curveto($x - ($a * BZEL8), $y - ($b * BZEL7), # left quarter of ellipse $x - ($a * BZEL8), $y + ($b * BZEL7), $x - ($a / SQRT2), $y + ($b / SQRT2)); $page->curveto($x - ($a * BZEL7), $y + ($b * BZEL8), # top quarter of ellipse $x + ($a * BZEL7), $y + ($b * BZEL8), $x + ($a / SQRT2), $y + ($b / SQRT2)); if ($outline and $fill) { $page->close_fill_stroke; } elsif ($fill) { $page->closepath; $page->fill; } elsif ($outline) { $page->closestroke; } else { $page->closepath; } } # imitate a Tk::Canvas createLine call sub _createLine { my ($my, $x1, $y1, @args) = @_; my $page = $my->{currentPage}; my @points; while (@args) { last if ($args[0] =~ m/[^-\d\.]/); push(@points, shift(@args), shift(@args)); } my %args = @args; $page->set_stroke_color($my->_get_rgb(delete($args{-fill}))); $my->_set_width(delete($args{-width})); foreach (keys(%args)) { carp ("Unknown args key in _createLine: $_"); } $page->moveto($x1, $y1); while (@points) { $page->lineto(shift(@points), shift(@points)); } $page->closestroke; } sub _get_rgb { my ($my, $color) = @_; return (0, 0, 0) unless(defined($color)); $color = lc($color); return (1, 1, 1) if ($color eq WHITE); return (1, 0, 0) if ($color eq 'red'); return (0, 1, 0) if ($color eq 'green'); return (0, 0, 1) if ($color eq 'blue'); return (0, 0, 0) if ($color eq BLACK); carp ("unknown color $color in _get_rgb"); return (0, 0, 0); } sub _set_width { my ($my, $width) = @_; $width = 1 unless defined($width); if ($width != $my->{curr_set_width}) { $my->{currentPage}->set_width($width / 4); $my->{curr_set_width} = $width; } } sub _createPDF { my ($my) = @_; my $pdf; my %opts = ( Version => 1.2, PageMode => 'UseOutlines', Creator => 'sgf2dg', CreationDate => [ localtime ],); if (defined($my->{file})) { if ((ref($my->{file}) eq 'GLOB') or (ref($my->{file}) eq 'IO::File')) { $pdf = $my->{pdf} = new PDF::Create( %opts); $pdf->filehandle($my->{file}, 'sgf2pdf.pdf'); $my->{file}->print($pdf->my_get_data); } elsif ((ref($my->{file}) eq 'SCALAR') or (ref($my->{file}) eq 'ARRAY')) { $pdf = $my->{pdf} = new PDF::Create( 'filename' => "", # to /dev/null %opts); } else { $my->{file} =~ s/^>//; $pdf = $my->{pdf} = new PDF::Create( 'filename' => $my->{file}, %opts); } } else { $pdf = $my->{pdf} = new PDF::Create( %opts); } my $pageCoords = $pdf->my_get_page_size(lc($my->{pageSize})); my $root = $my->{currentPage} = $my->{root} = $pdf->new_page( 'MediaBox' => $pageCoords); $my->{page_left} = $pageCoords->[0] + $my->{leftMargin}; $my->{page_right} = $pageCoords->[2] - $my->{rightMargin}; $my->{page_top} = $pageCoords->[3] - $my->{topMargin}; $my->{page_bottom} = $pageCoords->[1] + $my->{bottomMargin}; # Prepare fonts $my->{font_helv} = $pdf->font( 'Subtype' => 'Type1', 'Encoding' => 'WinAnsiEncoding', 'BaseFont' => 'Helvetica'); $my->{text_font} = $pdf->font( 'Subtype' => 'Type1', 'Encoding' => 'WinAnsiEncoding', 'BaseFont' => $my->{text_fontName}); $my->{stone_font} = $pdf->font( 'Subtype' => 'Type1', 'Encoding' => 'WinAnsiEncoding', 'BaseFont' => $my->{stone_fontName}); # figure out the font and line width and height my $fontWidth = $my->{stone_fontSize} * ($root->string_width($my->{stone_font}, '0123456789')) / 10; unless(defined($my->{lineWidth})) { $my->{lineWidth} = $my->{doubleDigits} ? $fontWidth * 3.0 : # need space for two digits (and 100) $fontWidth * 3.5; # need space for three digits } my $hLines = (1 + $my->{rightLine} - $my->{leftLine}); my $vLines = (1 + $my->{bottomLine} - $my->{topLine}); my $pageH = ($my->{page_top} - $my->{page_bottom}); my $pageW = ($my->{page_right} - $my->{page_left}); if ($my->{lineWidth} * $hLines > $pageW) { my $newW = $pageW / $hLines; carp "lineWidth of $my->{lineWidth} won't fit on the page. I'm setting it to $newW\n"; $my->{lineWidth} = $newW; } unless(defined($my->{lineHeight})) { $my->{lineHeight} = $my->{lineWidth} * 1.05; # 95% aspect ratio } if ($my->{lineHeight} * $vLines > $pageH) { my $newH = $pageH / $vLines; carp "lineHeight of $my->{lineHeight} won't fit on the page. I'm setting it to $newH\n"; $my->{lineHeight} = $newH; } } # handle text reflow sub _flow_text { my ($my, $text) = @_; my $width = 0; my @line = (); my $token = my $space = ''; until (($text eq '') and ($token eq '')) { if ($token eq '') { $text =~ s/^(\s*)(\S*)//s; # whitespace, then non-whitespace $space = $1; $token = $2; $space =~ s/ +/ /gs; # turn multiple spaces into single space $space =~ s/ \n/\n/gs; # remove preceding and intervening blanks $space =~ s/\n /\n/gs; # and trailing blanks } my $tokenWidth = $my->{text_fontSize} * $my->{currentPage}->string_width($my->{text_font}, "$space$token"); if (($space =~ m/\n/) or ($width + $tokenWidth > $my->{text_box_width})) { if ($width) { # put collected tokens on current line $my->_flow_text_lf(join('', @line)); $width = 0; @line = (); $space =~ s/\n//; # remove one LF (if there's one here) } elsif ($width + $tokenWidth > $my->{text_box_width}) { # no @line, but token is too long # put first part of token on current line: $token = $my->_flow_force_break($token); } while ($space =~ s/\n//) { $my->_flow_text_lf(''); # extra LFs? } $space = ''; # no preceding space on next line } else { push(@line, "$space$token"); $width += $tokenWidth; $token = ''; } } $my->_flow_text_lf(join('', @line)) if (@line); } # force a break in a chunk that's too wide for the box, return the remainder sub _flow_force_break { my ($my, $text) = @_; my $idx = 0; my $width = 0; while ($width < $my->{text_box_width}) { my $c = substr($text, $idx, 1); $width += $my->{text_fontSize} * $my->{currentPage}->string_width($my->{text_font}, $c); $idx++; if ($idx >= length($text)) { return $text; # fits - force break shouldn't have been called } } $my->_flow_text_lf(substr($text, 0, $idx - 1)); return substr($text, $idx) } # print a line, then update box data to reflect a line-feed sub _flow_text_lf { my ($my, $text) = @_; # print " flow $text\n"; $my->_createText($my->{text_box_left}, $my->{text_box_y}, -anchor => 'sw', -font => $my->{text_font}, -fontSize => $my->{text_fontSize}, -text => $text); if ($text =~ m/\S/) { # non-whitespace here $my->{text_box_y_last} = $my->{text_box_y}; $my->{text_box_used} = 1; } $my->{text_box_y} -= 1.2 * $my->{text_fontSize}; if ($my->{text_box_y} <= $my->{text_box_bottom}) { $my->_next_text_box(); } } # figure out where the next diagram box should be. sub _next_diagram_box { my ($my) = @_; # print "next diagram box\n"; $my->{text_box_state} = 0; # next text box should be to right of diagram # is there enough space under the latest text? my $prev_bottom = $my->{diagram_box_bottom}; if ($my->{text_box_used} and ($my->{text_box_y_last} < $prev_bottom)) { $prev_bottom = $my->{text_box_y_last}; # text is below bottom of diagram $prev_bottom -= $my->{lineHeight}; # extra space between text and next diagram } # some space between diagrams $prev_bottom -= $my->{lineHeight} unless ($prev_bottom == $my->{page_top}); my $need = $my->{diagram_height} - $my->{lineHeight} + $my->{page_bottom}; if ($prev_bottom > $need) { # enough space on this page still $my->{diagram_box_top} = $prev_bottom; } else { # need a new page $my->_next_page; $my->{diagram_box_top} = $my->{page_top}; } $my->{diagram_box_left} = $my->{page_left}; $my->{diagram_box_right} = $my->{diagram_box_left} + $my->{diagram_width}; $my->{diagram_box_bottom} = $my->{diagram_box_top} - $my->{diagram_height}; $my->_next_text_box; # need a new text box for this diagram } # figure out where the next text box should be. box may be to the right of a # diagram, underneath a diagram, or it may be a new page. sub _next_text_box { my ($my) = @_; # print "next text box: "; $my->{text_box_state}++; if ($my->{text_box_state} == 1) { # try for the area to the right of the diagram my $min_text = 'revive his dead stones'; # at least this wide... my $min_width = $my->{text_fontSize} * $my->{currentPage}->string_width($my->{text_font}, $min_text); my $dia_right = $my->{diagram_box_right} + $my->{lineWidth}; if ($my->{page_right} - ($dia_right + 10) < $min_width) { $my->{text_box_bottom} = $my->{diagram_box_bottom}; $my->_next_text_box; # not enough room, try next box } else { $my->{text_box_left} = $dia_right; $my->{text_box_right} = $my->{page_right} - 10; $my->{text_box_top} = $my->{diagram_box_top} - $my->{lineHeight}; $my->{text_box_bottom} = $my->{diagram_box_bottom} - $my->{text_fontSize} * 1.2;; $my->{text_box_bottom} = $my->{page_bottom} if ($my->{text_box_bottom} < $my->{page_bottom}); # print "right\n"; } } elsif ($my->{text_box_state} == 2) { # try for the area under the diagram $my->{text_box_left} = $my->{page_left} + 10; $my->{text_box_right} = $my->{page_right} - 10; $my->{text_box_top} = $my->{text_box_y}; while ($my->{text_box_top} > $my->{text_box_bottom}) { $my->{text_box_top} -= $my->{text_fontSize} * 1.2; } $my->{text_box_bottom} = $my->{page_bottom}; if ($my->{text_box_top} < $my->{page_bottom}) { $my->_next_text_box; # not enough space, try next } # print "under\n"; } else { # gotta start a new page... # print "new page\n"; $my->_next_page; $my->{text_box_left} = $my->{page_left} + 10; $my->{text_box_right} = $my->{page_right} - 10; $my->{text_box_top} = $my->{page_top} - $my->{lineHeight}; $my->{text_box_bottom} = $my->{page_bottom}; $my->{diagram_box_bottom} = $my->{page_top}; # no diagram on this page } $my->{text_box_width} = $my->{text_box_right} - $my->{text_box_left}; $my->{text_box_y} = $my->{text_box_top}; $my->{text_box_used} = 0; } # Add a new page which inherits its attributes from $root my $page = 0; sub _next_page { my ($my) = @_; $page++; # print "next page($page)\n"; $my->{currentPage} = $my->{root}->new_page; $my->{currentPage}->print(".3 w 1 j\n"); # set width to .3 points, line join mode to rounded corners $my->{text_box_y} = $my->{text_box_y_last} = $my->{page_top} - $my->{lineHeight}; } 1; __END__