# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# 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 #
# for more details. #
# #
# 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
# regression html views.
#
package GoImage::Stone;
if (0) {
require GD;
}
use GD;
use strict;
use warnings;
BEGIN {
use Exporter ();
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
# set the version for version checking
$VERSION = 0.01;
# 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
@ISA = qw(Exporter);
@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);
}
our @EXPORT_OK;
# exported package globals go here
#our $Var1;
#our %Hashit;
# non-exported package globals go here
#our @more;
#our $stuff;
# initialize package globals, first exported ones
#$Var1 = '';
#%Hashit = ();
# then the others (which are still accessible as $Some::Module::stuff)
#$stuff = '';
#@more = ();
# all file-scoped lexicals must be created before
# the functions below that use them.
# file-private lexicals go here
#my $priv_var = '';
#my %secret_hash = ();
# here's a file-private function as a closure,
# callable as &$priv_func; it cannot be prototyped.
#my $priv_func = sub {
# stuff goes here.
#};
# 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 $overwrite = "";
my $image_dir = "html/images";
sub parseFileName {
#FIXME: !!!!!!!!!!!!!!!!!!!!!!!
# Need to support text2 & text2_color attributes correctly.
my $fn = shift;
$fn =~ s/(.png)?\s*$//mg;
# print "$fn\n";
$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 = ""; }
if ($text) {
my $new_text="";
while ($text =~ s/(...)//) {
$new_text .= chr(hex("0$1"));
}
$text = $new_text;
}
my $out = createPngFile($color, $pixels, $position, $text, $text_color, $text2, $text2_color, $square_color);
if ("$fn.png" ne $out) {
print "IN:$fn\tOUT:$out\n";
}
}
#createStone:
#Does: Creates an appropriate PNG file if it doesn't exist, and...
#Returns: name of the image file to use
#Parameters:
# color - stone color: "black", "white", ""
# pixels - default 15.
# 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
#
#Details:
# 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.
# For example:
# W25.png - large white stone;
# B10.png - smaller black stone;
# B14x61x6d_R - black stone w/ red 'am' text.
sub createPngFile {
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 = ""};
my $image_name;
if ($color eq "black") { $image_name = "B"; }
elsif ($color eq "white") { $image_name = "W"; }
else {$image_name = "E"}
$image_name .= $pixels;
$image_name .= $position;
if ($text) {
foreach (split(//,$text)) {
$image_name .= "x" . (sprintf "%x", ord($_));
}
$image_name .= "_" . $text_color;
}
if ($text2) {
$image_name .= '__';
foreach (split(//,$text2)) {
$image_name .= "x" . (sprintf "%x", ord($_));
}
$image_name .= "_" . $text2_color;
}
if ($square_color) {
$image_name .= "-s" . $square_color;
}
#gdGiantFont, gdLargeFont, gdMediumBoldFont, gdSmallFont and gdTinyFont
$image_name .= ".png";
#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") {
return $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"});
if ($color) {
$im->arc($pixels/2, $pixels/2, $pixels+1, $pixels+1, 0, 360, $colors{$color});
$im->fill($pixels/2, $pixels/2, $colors{$color});
} else {
$im->line($pixels/2,0,$pixels/2,$pixels, $colors{"black"});
$im->line(0,$pixels/2,$pixels,$pixels/2, $colors{"black"});
}
if ($text || $text2) {
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});
}
if ($square_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";
binmode IMAGE;
print IMAGE $im->png;
close IMAGE;
return $image_name;
}
sub createTestHtml {
opendir(IMAGES, $image_dir);
foreach (sort readdir(IMAGES)) {
if (/\.png$/) {
print "$_: <IMG SRC=\"$image_dir/$_\"><HR>\n";
}
}
}
1;
END { }
if (!-e "html") { #Wher's perl's mkdir -p ????
mkdir "html";
}
if (!(-e $image_dir)) {
mkdir ($image_dir) || die "Couldn't create directory: $image_dir\n";
}
1;