[sgk-go] / interface / GoImage / Stone.pm

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# 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 "$_:&nbsp;<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;
Commit	Line	Data
7eeb782e AT	1	# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
	2	# This program is distributed with GNU Go, a Go program. #
	3	# #
	4	# Write gnugo@gnu.org or see http://www.gnu.org/software/gnugo/ #
	5	# for more information. #
	6	# #
	7	# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 and 2007 #
	8	# by the Free Software Foundation. #
	9	# #
	10	# This program is free software; you can redistribute it and/or #
	11	# modify it under the terms of the GNU General Public License #
	12	# as published by the Free Software Foundation - version 3, #
	13	# or (at your option) any later version. #
	14	# #
	15	# This program is distributed in the hope that it will be #
	16	# useful, but WITHOUT ANY WARRANTY; without even the implied #
	17	# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR #
	18	# PURPOSE. See the GNU General Public License in file COPYING #
	19	# for more details. #
	20	# #
	21	# You should have received a copy of the GNU General Public #
	22	# License along with this program; if not, write to the Free #
	23	# Software Foundation, Inc., 51 Franklin Street, Fifth Floor, #
	24	# Boston, MA 02111, USA. #
	25	# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
	26	#
	27	# Uses Perl GB package to create mini-PNG files used by the
	28	# regression html views.
	29	#
	30
	31	package GoImage::Stone;
	32
	33	if (0) {
	34	require GD;
	35	}
	36
	37	use GD;
	38	use strict;
	39	use warnings;
	40
	41	BEGIN {
	42	use Exporter ();
	43	our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
	44	# set the version for version checking
	45	$VERSION = 0.01;
	46	# if using RCS/CVS, this may be preferred (???-tm)
	47	$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
	48	@ISA = qw(Exporter);
	49	@EXPORT = qw(&createPngFile &parseFileName);
	50	%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
	51	# your exported package globals go here,
	52	# as well as any optionally exported functions
	53	@EXPORT_OK = (); #qw($Var1 %Hashit &func3);
	54	}
	55	our @EXPORT_OK;
	56	# exported package globals go here
	57	#our $Var1;
	58	#our %Hashit;
	59	# non-exported package globals go here
	60	#our @more;
	61	#our $stuff;
	62	# initialize package globals, first exported ones
	63	#$Var1 = '';
	64	#%Hashit = ();
65	# then the others (which are still accessible as $Some::Module::stuff)
66	#$stuff = '';
67	#@more = ();
68	# all file-scoped lexicals must be created before
69	# the functions below that use them.
70	# file-private lexicals go here
71	#my $priv_var = '';
72	#my %secret_hash = ();
73	# here's a file-private function as a closure,
74	# callable as &$priv_func; it cannot be prototyped.
75	#my $priv_func = sub {
76	# stuff goes here.
77	#};
78	# make all your functions, whether exported or not;
79	# remember to put something interesting in the {} stubs
80	#sub createPngFile {} # no prototype
81	#sub func2() {} # proto'd void
82	#sub func3($$) {} # proto'd to 2 scalars
83	# this one isn't exported, but could be called!
84	#sub func4(\%) {} # proto'd to 1 hash ref
85
86	my $overwrite = "";
87
88	my $image_dir = "html/images";
89
90	sub parseFileName {
91
92	#FIXME: !!!!!!!!!!!!!!!!!!!!!!!
93	# Need to support text2 & text2_color attributes correctly.
94	my $fn = shift;
95	$fn =~ s/(.png)?\s*$//mg;
96	# print "$fn\n";
97	$fn =~ /([WBE])([1-9][0-9])([NSEWH]{0,2})((?:x[0-9a-fA-F]{2}))_?([a-z])(?:-s([a-z]))?/;
98	my ($color, $pixels, $position, $text, $text_color, $square_color) = ($1,$2,$3,$4,$5,$6);
99	my ($text2, $text2_color);
100	#print "$1:$2:$3:$4:$5\n";
101	if ($color eq "B") { $color = "black"; }
102	elsif ($color eq "W") { $color = "white"; }
103	elsif ($color =~ /^E/ \|\| die "bad color in: $fn;$color;") { $color = ""; }
104	if ($text) {
105	my $new_text="";
106	while ($text =~ s/(...)//) {
107	$new_text .= chr(hex("0$1"));
108	}
109	$text = $new_text;
110	}
111
112
113
114	my $out = createPngFile($color, $pixels, $position, $text, $text_color, $text2, $text2_color, $square_color);
115	if ("$fn.png" ne $out) {
116	print "IN:$fn\tOUT:$out\n";
117	}
118	}
119
120
121	#createStone:
122	#Does: Creates an appropriate PNG file if it doesn't exist, and...
123	#Returns: name of the image file to use
124	#Parameters:
125	# color - stone color: "black", "white", ""
126	# pixels - default 15.
127	# position - "H", "N", "S", "E", "W", "NE", "SW", "SE", "NW", "" (H == hoshi)
128	# : edge or star point location.
129	# text - stone label: "3 char max recommended."
130	# text_color - "white", "black", "green","cyan","red","yellow","magenta","blue", ""
131	# text2 - appended t text...;
132	# text2_color - ...but in this color.
133	# square_color - same choices as text_color
134	#
135	#Details:
136	# creates file named like:
137	# COLORLIST := white\|black\|green\|cyan\|red\|blue\|yellow\|magenta\|grey
138	# [WBE]$pixels[NSEWH]{0,2}(${text}_(COLORLIST))?(__?${text}$(_COLORLIST))?(-s(COLORLIST))?
139	# Note that $text is written with each character converted to it's ord value
140	# in hex preceeded by an underscore to avoid bogus file names. Also allows
141	# upper & lower case easily on case-insensitive file systems, like Windows.
142	# For example:
143	# W25.png - large white stone;
144	# B10.png - smaller black stone;
145	# B14x61x6d_R - black stone w/ red 'am' text.
146
147
148	sub createPngFile {
149	my ($color, $pixels, $position, $text, $text_color, $text2, $text2_color, $square_color)= @_;
150	if (!$color) {$color = "";}
151	elsif (!($color eq "black" \|\| $color eq "white")) { die "invalid color: $color"; }
152	if (!$text) {$text = "";}
153	if (!$text_color) {$text_color = "blue";}
154	if (!$text2) {$text2 = "";}
155	if (!$text2_color) {$text2_color = "blue";}
156	if (!$position) {$position = ""};
157	if (!$pixels) {$pixels = 15};
158	if (!$square_color) {$square_color = ""};
159
160	my $image_name;
161	if ($color eq "black") { $image_name = "B"; }
162	elsif ($color eq "white") { $image_name = "W"; }
163	else {$image_name = "E"}
164
165	$image_name .= $pixels;
166	$image_name .= $position;
167	if ($text) {
168	foreach (split(//,$text)) {
169	$image_name .= "x" . (sprintf "%x", ord($_));
170	}
171	$image_name .= "_" . $text_color;
172	}
173	if ($text2) {
174	$image_name .= '__';
175	foreach (split(//,$text2)) {
176	$image_name .= "x" . (sprintf "%x", ord($_));
177	}
178	$image_name .= "_" . $text2_color;
179	}
180
181	if ($square_color) {
182	$image_name .= "-s" . $square_color;
183	}
184
185
186	#gdGiantFont, gdLargeFont, gdMediumBoldFont, gdSmallFont and gdTinyFont
187	$image_name .= ".png";
188
189	#Note: Create image name first; don't re-create if it already exists.
190	#The caller now caches the images names, so they're regenerated every
191	#time. Maybe make this a package-level option?
192	if ((!$overwrite) && -e "$image_dir/$image_name") {
193	return $image_name;
194	}
195
196	my $im = new GD::Image($pixels,$pixels);
197	my %colors = ("white", $im->colorAllocate(255,255,255),
198	"black", $im->colorAllocate(0,0,0),
199	"red", $im->colorAllocate(255,0,0),
200	"blue", $im->colorAllocate(0,0,255),
201	"green", $im->colorAllocate(0,255,0),
202	"grey", $im->colorAllocate(127,127,127),
203	"dkgrey", $im->colorAllocate(63,63,63),
204	"ltgrey", $im->colorAllocate(190,190,190),
205	"brown", $im->colorAllocate(170,140,70),
206	"cyan", $im->colorAllocate(0,255,255),
207	"yellow",$im->colorAllocate(255,255,0),
208	"magenta",$im->colorAllocate(255,0,255),
209	);
210
211	$im->fill(1,1, $colors{"brown"});
212	if ($color) {
213	$im->arc($pixels/2, $pixels/2, $pixels+1, $pixels+1, 0, 360, $colors{$color});
214	$im->fill($pixels/2, $pixels/2, $colors{$color});
215	} else {
216	$im->line($pixels/2,0,$pixels/2,$pixels, $colors{"black"});
217	$im->line(0,$pixels/2,$pixels,$pixels/2, $colors{"black"});
218	}
219
220	if ($text \|\| $text2) {
221	my $f = gdSmallFont;#gdLargeFont;#gdMediumBoldFont;#
222	my $ftext = $text.$text2;
223	my ($fw, $fh) = ($f->width,$f->height);
224	my ($tw, $th) = ($fw * length($ftext), $fh); #TODO: Allow multi-line text.
225	my ($ulx, $uly) = ($pixels/2 - $tw/2 + 1, $pixels/2 - $th/2);
226	my ($lrx, $lry) = ($ulx + $tw, $uly + $th);
227	if (!$color or $text_color eq "blue" or $text2_color eq "blue"
228	or ($color eq "white" and $text_color eq "yellow" and $text2_color eq "yellow")) {
229	$im->filledRectangle($ulx-2, $uly, $lrx, $lry, $colors{"ltgrey"});
230	}
231	$im->string($f, $ulx, $uly, $text, $colors{$text_color});
232	$im->string($f, $ulx+ length($text) * $fw, $uly, $text2, $colors{$text2_color});
233	}
234
235	if ($square_color) {
236	$im->rectangle(1,1,$pixels-2, $pixels-2, $colors{$square_color});
237	$im->rectangle(2,2,$pixels-3, $pixels-3, $colors{$square_color});
238	}
239
240
241
242	open(IMAGE, ">$image_dir/$image_name") \|\| die "Couldn't create file: $image_dir/$image_name";
243	binmode IMAGE;
244	print IMAGE $im->png;
245	close IMAGE;
246	return $image_name;
247	}
248
249	sub createTestHtml {
250	opendir(IMAGES, $image_dir);
251	foreach (sort readdir(IMAGES)) {
252	if (/\.png$/) {
253	print "$_: <IMG SRC=\"$image_dir/$_\"><HR>\n";
254	}
255	}
256	}
257
258	1;
259
260	END { }
261
262	if (!-e "html") { #Wher's perl's mkdir -p ????
263	mkdir "html";
264	}
265
266	if (!(-e $image_dir)) {
267	mkdir ($image_dir) \|\| die "Couldn't create directory: $image_dir\n";
268	}
269
270	1;