# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# This program is distributed with GNU Go, a Go program. #
# Write gnugo@gnu.org or see http://www.gnu.org/software/gnugo/ #
# for more information. #
# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 and 2007 #
# by the Free Software Foundation. #
# This program is free software; you can redistribute it and/or #
# modify it under the terms of the GNU General Public License #
# as published by the Free Software Foundation - version 3, #
# or (at your option) any later version. #
# 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. See the GNU General Public License in file COPYING #
# You should have received a copy of the GNU General Public #
# License along with this program; if not, write to the Free #
# Software Foundation, Inc., 51 Franklin Street, Fifth Floor, #
# Boston, MA 02111, USA. #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# Uses Perl GB package to create mini-PNG files used by the
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
# set the version for version checking
# if using RCS/CVS, this may be preferred (???-tm)
$VERSION = do { my @r = (q
$Revision: 1.1.1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x
$#r, @r }; # must be all one line, for MakeMaker
@EXPORT = qw(&createPngFile &parseFileName);
%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
# your exported package globals go here,
# as well as any optionally exported functions
@EXPORT_OK = (); #qw($Var1 %Hashit &func3);
# exported package globals go here
# non-exported package globals go here
# initialize package globals, first exported ones
# then the others (which are still accessible as $Some::Module::stuff)
# all file-scoped lexicals must be created before
# the functions below that use them.
# file-private lexicals go here
# here's a file-private function as a closure,
# callable as &$priv_func; it cannot be prototyped.
# make all your functions, whether exported or not;
# remember to put something interesting in the {} stubs
#sub createPngFile {} # no prototype
#sub func2() {} # proto'd void
#sub func3($$) {} # proto'd to 2 scalars
# this one isn't exported, but could be called!
#sub func4(\%) {} # proto'd to 1 hash ref
my $image_dir = "html/images";
#FIXME: !!!!!!!!!!!!!!!!!!!!!!!
# Need to support text2 & text2_color attributes correctly.
$fn =~ s/(.png)?\s*$//mg;
$fn =~ /([WBE])([1-9][0-9]*)([NSEWH]{0,2})((?:x[0-9a-fA-F]{2})*)_?([a-z]*)(?:-s([a-z]*))?/;
my ($color, $pixels, $position, $text, $text_color, $square_color) = ($1,$2,$3,$4,$5,$6);
my ($text2, $text2_color);
#print "$1:$2:$3:$4:$5\n";
if ($color eq "B") { $color = "black"; }
elsif ($color eq "W") { $color = "white"; }
elsif ($color =~ /^E/ || die "bad color in: $fn;$color;") { $color = ""; }
while ($text =~ s/(...)//) {
$new_text .= chr(hex("0$1"));
my $out = createPngFile
($color, $pixels, $position, $text, $text_color, $text2, $text2_color, $square_color);
print "IN:$fn\tOUT:$out\n";
#Does: Creates an appropriate PNG file if it doesn't exist, and...
#Returns: name of the image file to use
# color - stone color: "black", "white", ""
# position - "H", "N", "S", "E", "W", "NE", "SW", "SE", "NW", "" (H == hoshi)
# : edge or star point location.
# text - stone label: "3 char max recommended."
# text_color - "white", "black", "green","cyan","red","yellow","magenta","blue", ""
# text2 - appended t text...;
# text2_color - ...but in this color.
# square_color - same choices as text_color
# creates file named like:
# COLORLIST := white|black|green|cyan|red|blue|yellow|magenta|grey
# [WBE]$pixels[NSEWH]{0,2}(${text}_(COLORLIST))?(__?${text}$(_COLORLIST))?(-s(COLORLIST))?
# Note that $text is written with each character converted to it's ord value
# in hex preceeded by an underscore to avoid bogus file names. Also allows
# upper & lower case easily on case-insensitive file systems, like Windows.
# W25.png - large white stone;
# B10.png - smaller black stone;
# B14x61x6d_R - black stone w/ red 'am' text.
my ($color, $pixels, $position, $text, $text_color, $text2, $text2_color, $square_color)= @_;
if (!$color) {$color = "";}
elsif (!($color eq "black" || $color eq "white")) { die "invalid color: $color"; }
if (!$text) {$text = "";}
if (!$text_color) {$text_color = "blue";}
if (!$text2) {$text2 = "";}
if (!$text2_color) {$text2_color = "blue";}
if (!$position) {$position = ""};
if (!$pixels) {$pixels = 15};
if (!$square_color) {$square_color = ""};
if ($color eq "black") { $image_name = "B"; }
elsif ($color eq "white") { $image_name = "W"; }
$image_name .= $position;
foreach (split(//,$text)) {
$image_name .= "x" . (sprintf "%x", ord($_));
$image_name .= "_" . $text_color;
foreach (split(//,$text2)) {
$image_name .= "x" . (sprintf "%x", ord($_));
$image_name .= "_" . $text2_color;
$image_name .= "-s" . $square_color;
#gdGiantFont, gdLargeFont, gdMediumBoldFont, gdSmallFont and gdTinyFont
#Note: Create image name first; don't re-create if it already exists.
#The caller now caches the images names, so they're regenerated every
#time. Maybe make this a package-level option?
if ((!$overwrite) && -e
"$image_dir/$image_name") {
my $im = new GD
::Image
($pixels,$pixels);
my %colors = ("white", $im->colorAllocate(255,255,255),
"black", $im->colorAllocate(0,0,0),
"red", $im->colorAllocate(255,0,0),
"blue", $im->colorAllocate(0,0,255),
"green", $im->colorAllocate(0,255,0),
"grey", $im->colorAllocate(127,127,127),
"dkgrey", $im->colorAllocate(63,63,63),
"ltgrey", $im->colorAllocate(190,190,190),
"brown", $im->colorAllocate(170,140,70),
"cyan", $im->colorAllocate(0,255,255),
"yellow",$im->colorAllocate(255,255,0),
"magenta",$im->colorAllocate(255,0,255),
$im->fill(1,1, $colors{"brown"});
$im->arc($pixels/2, $pixels/2, $pixels+1, $pixels+1, 0, 360, $colors{$color});
$im->fill($pixels/2, $pixels/2, $colors{$color});
$im->line($pixels/2,0,$pixels/2,$pixels, $colors{"black"});
$im->line(0,$pixels/2,$pixels,$pixels/2, $colors{"black"});
my $f = gdSmallFont
;#gdLargeFont;#gdMediumBoldFont;#
my $ftext = $text.$text2;
my ($fw, $fh) = ($f->width,$f->height);
my ($tw, $th) = ($fw * length($ftext), $fh); #TODO: Allow multi-line text.
my ($ulx, $uly) = ($pixels/2 - $tw/2 + 1, $pixels/2 - $th/2);
my ($lrx, $lry) = ($ulx + $tw, $uly + $th);
if (!$color or $text_color eq "blue" or $text2_color eq "blue"
or ($color eq "white" and $text_color eq "yellow" and $text2_color eq "yellow")) {
$im->filledRectangle($ulx-2, $uly, $lrx, $lry, $colors{"ltgrey"});
$im->string($f, $ulx, $uly, $text, $colors{$text_color});
$im->string($f, $ulx+ length($text) * $fw, $uly, $text2, $colors{$text2_color});
$im->rectangle(1,1,$pixels-2, $pixels-2, $colors{$square_color});
$im->rectangle(2,2,$pixels-3, $pixels-3, $colors{$square_color});
open(IMAGE
, ">$image_dir/$image_name") || die "Couldn't create file: $image_dir/$image_name";
opendir(IMAGES
, $image_dir);
foreach (sort readdir(IMAGES
)) {
print "$_: <IMG SRC=\"$image_dir/$_\"><HR>\n";
if (!-e
"html") { #Wher's perl's mkdir -p ????
mkdir ($image_dir) || die "Couldn't create directory: $image_dir\n";