[Bio] / FigKernelPackages / gd_tree_0.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/gd_tree_0.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (view) (download) (as text)

1 : golsen 1.1 # -*- perl -*-
2 :     ########################################################################
3 :     # Copyright (c) 2003-2009 University of Chicago and Fellowship
4 :     # for Interpretations of Genomes. All Rights Reserved.
5 :     #
6 :     # This file is part of the SEED Toolkit.
7 :     #
8 :     # The SEED Toolkit is free software. You can redistribute
9 :     # it and/or modify it under the terms of the SEED Toolkit
10 :     # Public License.
11 :     #
12 :     # You should have received a copy of the SEED Toolkit Public License
13 :     # along with this program; if not write to the University of Chicago
14 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
15 :     # Genomes at veronika@thefig.info or download a copy from
16 :     # http://www.theseed.org/LICENSE.TXT.
17 :     ########################################################################
18 :    
19 :     package gd_tree;
20 :    
21 :     # use Data::Dumper;
22 :     # use Carp;
23 :    
24 :     use GD;
25 :     use gjonewicklib;
26 :     use strict;
27 :    
28 : golsen 1.3 # $string = '((A:1,B:2):3,(C:2,M:4):2);';
29 :     # $tree = parse_newick_tree_str( $string );
30 :     #
31 :     # $gd_image = gd_tree::gd_plot_newick( $tree, { bkg_color => [255,255,0] } );
32 :     # print $gd_image->png;
33 :     # print $gd_image->jpg;
34 :     #
35 :     # gd_tree::newick_gd_png( $tree, { bkg_color => [255,255,0] } ); # \*STDOUT
36 :     # gd_tree::newick_gd_jpg( $tree, { bkg_color => [255,255,0] } );
37 :     #
38 :     # $bool = gd_tree::gd_has_png()
39 :     # $bool = gd_tree::gd_has_jpg()
40 :     # \%fmt = gd_tree::gd_formats() # hash keys: gd, jpg and png
41 :    
42 :     {
43 :     my $has_png;
44 :     my $has_jpg;
45 :     my %has = ();
46 :    
47 :     sub gd_has_png
48 :     {
49 :     return $has_png if defined $has_png;
50 :     return $has_png = $has{ png } if keys %has;
51 :     my $image = new GD::Image( 1, 1 );
52 :     $image->colorAllocate( 255, 255, 255 );
53 :     $has_png = 0;
54 :     eval { $image->png; $has_png = 1; };
55 :     $has_png;
56 :     }
57 :    
58 :     sub gd_has_jpg
59 :     {
60 : golsen 1.4 return 1;
61 : golsen 1.3 return $has_jpg if defined $has_jpg;
62 :     return $has_jpg = $has{ jpg } if keys %has;
63 :     my $image = new GD::Image( 1, 1 );
64 :     $image->colorAllocate( 255, 255, 255 );
65 :     $has_jpg = 0;
66 : golsen 1.4 eval { $image->jpeg; $has_jpg = 1; };
67 : golsen 1.3 $has_jpg;
68 :     }
69 :    
70 :     sub gd_formats
71 :     {
72 :     if ( ! keys %has )
73 :     {
74 :     my $image = new GD::Image( 1, 1 );
75 :     $image->colorAllocate( 255, 255, 255 );
76 :     foreach my $fmt ( qw( jpg png gd ) )
77 :     {
78 :     $has{$fmt} = 0;
79 :     eval { $image->$fmt; $has{$fmt} = 1; };
80 :     }
81 :     }
82 :     \%has;
83 :     }
84 :     }
85 :    
86 : golsen 1.1
87 :     #===============================================================================
88 : golsen 1.3 # newick_gd_png( $tree, \%options )
89 : golsen 1.1 #===============================================================================
90 :     sub newick_gd_png
91 :     {
92 :     my ( $tree, $options ) = @_;
93 :    
94 : golsen 1.2 $options ||= {};
95 :     my $file = $options->{ file };
96 :     my $fh;
97 :     if ( ! $file ) { $fh = \*STDOUT }
98 :     elsif ( ref( $file ) eq 'GLOB' ) { $fh = $file }
99 :     else
100 :     {
101 :     open( $fh, ">$file" )
102 :     or print STERR "Could not open $file.\n" and return 0;
103 :     }
104 :    
105 : golsen 1.1 my $image = gd_plot_newick( $tree, $options );
106 :    
107 : golsen 1.2 print $fh $image->png;
108 :    
109 :     close( $fh ) if $file && ! ref( $file );
110 :     return 1;
111 : golsen 1.1 }
112 :    
113 :    
114 :     #===============================================================================
115 : golsen 1.3 # newick_gd_jpg( $tree, \%options )
116 :     #===============================================================================
117 :     sub newick_gd_jpg
118 :     {
119 :     my ( $tree, $options ) = @_;
120 :    
121 :     $options ||= {};
122 :     my $file = $options->{ file };
123 :     my $fh;
124 :     if ( ! $file ) { $fh = \*STDOUT }
125 :     elsif ( ref( $file ) eq 'GLOB' ) { $fh = $file }
126 :     else
127 :     {
128 :     open( $fh, ">$file" )
129 :     or print STERR "Could not open $file.\n" and return 0;
130 :     }
131 :    
132 :     my $image = gd_plot_newick( $tree, $options );
133 :    
134 :     print $fh $image->jpg;
135 :    
136 :     close( $fh ) if $file && ! ref( $file );
137 :     return 1;
138 :     }
139 :    
140 :    
141 :     #===============================================================================
142 : golsen 1.1 # Make a GD plot of a tree:
143 :     #
144 :     # $gd_image = gd_plot_newick( $node, \%options );
145 :     # ( $gd_image, $hash ) = gd_plot_newick( $node, \%options );
146 :     #
147 :     # $node newick tree root node
148 :     #
149 :     # Options:
150 :     #
151 :     # bar_position => position # D = ll (lower_left)
152 :     # bkg_color => [ @RGB ] # D = transparent
153 :     # dy => pixels # vertical spacing (D = 12)
154 :     # font => gb_font_name # D depends size
155 :     # font_size => pixels # synonym for text_size
156 :     # line_color => [ @RGB ] # D = black
157 :     # min_dx => min_node_spacing # D = 0
158 :     # scale_bar => length # D is based on drawing size
159 :     # text_bkg_color => [ @RGB ] # D = none
160 :     # text_color => [ @RGB ] # D = black
161 :     # text_size => pixels # D = 0.8 * dy
162 :     # thickness => pixels # tree line thickness (D = 1)
163 :     # width => pixels # width of tree w/o labels (D = 540)
164 :     # x_scale => pixels_per_unit_x # D is scaled to fit width
165 :     #
166 :     # All color RGB values are on 0-255 color intensity range
167 :     #
168 :     # $hash is a reference to a hash of data about the tree and its layout.
169 :     #
170 :     # $hash->{ $node }->{ lbl_rect } is the coordinates (ul, lr) of the label
171 :     # of node refered to my $node. These can be used to build an image map.
172 :     #
173 :     #===============================================================================
174 :     sub gd_plot_newick
175 :     {
176 :     my ( $node, $options ) = @_;
177 :     array_ref( $node ) || die "Bad node passed to text_plot_newick\n";
178 :    
179 :     # colors will all be [r,g,b] in 0 - 255 range;
180 :     # sizes will all be in pixels
181 : golsen 1.5 # work on a local copy of options, so I can write to it
182 : golsen 1.1
183 :     my %options = ref( $options ) eq 'HASH' ? %$options : ();
184 :    
185 :     # Vertical size adjustments:
186 :    
187 :     my ( $dy_key ) = grep { /^dy/i } keys %options;
188 :     $options{ dy } = $dy_key ? $options{ $dy_key } : undef;
189 :    
190 :     # Allow font_size or text_size
191 :    
192 :     my ( $font_size_key ) = grep { /^fo?nt.*si?z/i || /^te?xt.*si?z/i } keys %options;
193 :     $options{ font_size } = $font_size_key ? $options{ $font_size_key } : undef;
194 :    
195 :     adjust_font( \%options ); # This adds options
196 :    
197 :     # Horizontal size adjustments:
198 :    
199 :     my ( $wid_key ) = grep { /^wid/i } keys %options;
200 :     my $width = $options{ width } = $wid_key ? $options{ $wid_key } : 72 * 7.5;
201 :    
202 :     my ( $min_dx_key ) = grep { /dx/i && ! /la?be?l/i } keys %options;
203 :     $options{ min_dx } = $min_dx_key ? $options{ $min_dx_key } : 0;
204 :    
205 :     my $max_x = newick_max_X( $node );
206 :     my ( $x_scale_key ) = grep { /x_?scale/i } keys %options;
207 :     my $x_scale = $options{ $x_scale_key }
208 :     || $width / ( $max_x || 1 );
209 :     $options{ x_scale } = $x_scale;
210 :    
211 :     # Scale bar:
212 :    
213 :     my ( $bar_key ) = grep { /bar/i && ! /pos/i } keys %options;
214 :     my $bar_len = $options{ $bar_key };
215 :     $bar_len = bar_length( $max_x ) if ! defined( $bar_len );
216 :     $options{ bar_len } = $bar_len;
217 :    
218 :     my $bar_pos;
219 :     if ( $bar_len > 0 )
220 :     {
221 :     my ( $bar_pos_key ) = grep { /bar.*pos/i } keys %options;
222 :     my $bar_val = $options{ $bar_pos_key };
223 :     $bar_pos = $bar_val =~ /up.*rig/i ? 'ur' :
224 :     $bar_val =~ /low.*rig/i ? 'lr' :
225 :     $bar_val =~ /up/i ? 'ul' :
226 :     $bar_val =~ /low/i ? 'll' :
227 :     $bar_val =~ /^(ur|ul|lr|ll)$/i ? $bar_val :
228 :     'll';
229 :     $options{ bar_pos } = $bar_pos;
230 :     $options{ bar_font } = $options{ font } || 'gdSmallFont';
231 :     }
232 :    
233 :     # Line adjustment:
234 :    
235 :     my ( $thickness_key ) = grep { /thick/i } keys %options;
236 :     my $thickness = $thickness_key ? $options{ $thickness_key } : 1;
237 :     $thickness = int( $thickness + 0.5 );
238 :     $options{ thickness } = $thickness || 1;
239 :    
240 :     my ( $line_color_key ) = grep { /^lin.*co?lo?r/i } keys %options;
241 :     my $line_color = $line_color_key ? $options{ $line_color_key } : [0,0,0];
242 :     $options{ line_color } = $line_color;
243 :    
244 :     # Other colors:
245 :    
246 :     my ( $bkg_color_key ) = grep { /^b.*k.*g.*co?lo?r/i } keys %options;
247 :     my $bkg_color = $bkg_color_key ? $options{ $bkg_color_key } : undef;
248 :     $options{ bkg_color } = $bkg_color;
249 :    
250 :     my ( $text_color_key ) = grep { /^te?xt.*co?lo?r/i && ! /bkg/ } keys %options;
251 :     my $text_color = $text_color_key ? $options{ $text_color_key } : [0,0,0];
252 :     $options{ text_color } = $text_color;
253 :    
254 :     my ( $text_bkg_color_key ) = grep { /^te?xt.*bkg.*co?lo?r/i } keys %options;
255 :     my $text_bkg_color = $text_bkg_color_key ? $options{ $text_bkg_color_key } : undef;
256 :     $options{ text_bkg_color } = $text_bkg_color;
257 :    
258 :     my $hash = {};
259 :     my $dy = $options{ dy };
260 :     layout_gd_tree( $node, $hash, \%options,
261 :     int( 2*$thickness + 0.4999 ), int( 0.5*$dy + 0.4999 )
262 :     );
263 :    
264 :     render_gd_tree( $node, $hash, \%options );
265 :     }
266 :    
267 :    
268 :     sub bar_length
269 :     {
270 :     my ( $max_x ) = @_;
271 :     my $target = 0.4 * $max_x;
272 :     my $e = 10**( int( log($target)/log(10) + 100 ) -100 );
273 :     my $f = $target / $e;
274 :     ( $f >= 10 ? 10 : $f >= 5 ? 5 : $f >= 2 ? 2 : 1 ) * $e;
275 :     }
276 :    
277 :    
278 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
279 :     # ( $root_y, $xmax, $yn ) = layout_gd_tree( $node, $hash, $options, $x0, $y0, $parent )
280 :     #
281 :     # GD coordinate 0,0 is upper left corner
282 :     #
283 :     # $hash->{ $node } = { x0 => $x0, x => $x, y => $y, y1 => $y1, y2 => $y2,
284 :     # xmax => $xmax, y0 => $y0, yn => $yn
285 :     # }
286 :     #
287 :     # y0 _ _ _ _ _ _ _ _ _ _ _ _ _ _
288 :     # +----------+ label_1
289 :     # y1 - - - - +---+
290 :     # | +----+ label_2
291 :     # y - - +----+
292 :     # | +------+ label_3
293 :     # y2 - -|- - +----+
294 :     # | | +--------+ label_4
295 :     # | | +---+ |
296 :     # yn _ _|_ _ |_ _ _ _ +---+ label_5
297 :     # | | |
298 :     # x0 x xmax
299 :     #
300 :     #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
301 :     sub layout_gd_tree
302 :     {
303 :     my ( $node, $hash, $options, $x0, $y0, $parent ) = @_;
304 :     array_ref( $node ) || die "Bad node ref passed to layout_printer_plot\n";
305 :     hash_ref( $hash ) || die "Bad hash ref passed to layout_printer_plot\n";
306 :    
307 :     my $x_scale = $options->{ x_scale };
308 :     my $min_dx = $options->{ min_dx };
309 :     my $dy = $options->{ dy };
310 :    
311 :     my $dx = gjonewicklib::newick_x( $node );
312 :     if ( defined( $dx ) )
313 :     {
314 :     $dx *= $x_scale;
315 :     $dx >= $min_dx or $dx = $min_dx;
316 :     }
317 :     else
318 :     {
319 :     $dx = $parent ? $min_dx : 0;
320 :     }
321 :     $dx = int( $dx + 0.4999 );
322 :    
323 :     my ( $x, $y, $y1, $y2, $xmax, $yn );
324 :    
325 :     $x = $x0 + $dx;
326 :     my @dl = gjonewicklib::newick_desc_list( $node );
327 :    
328 :     if ( ! @dl ) # A tip
329 :     {
330 :     $xmax = $x;
331 :     $y = $y1 = $y2 = int( $y0 + 0.5 * $dy + 0.4999 );
332 :     $yn = $y0 + $dy;
333 :     }
334 :     else # A subtree
335 :     {
336 :     $xmax = -1e100;
337 :     my $xmaxi;
338 :     my $yi;
339 :     my @nodelist = ();
340 :     $yn = $y0;
341 :    
342 :     foreach ( @dl )
343 :     {
344 :     push @nodelist, $_;
345 :     ( $yi, $xmaxi, $yn ) = layout_gd_tree( $_, $hash, $options, $x, $yn, $node );
346 :     if ( $xmaxi > $xmax ) { $xmax = $xmaxi }
347 :     }
348 :    
349 :     # Use of nodelist is overkill for saving first and last values,
350 :     # but eases implimentation of alternative y-value calculations.
351 :    
352 :     $y1 = $hash->{ $nodelist[ 0] }->{ y };
353 :     $y2 = $hash->{ $nodelist[-1] }->{ y };
354 :     $y = int( 0.5 * ( $y1 + $y2 ) + 0.4999 );
355 :     }
356 :    
357 :     $hash->{ $node } = { x0 => $x0, x => $x, y => $y, y1 => $y1, y2 => $y2,
358 :     xmax => $xmax, y0 => $y0, yn => $yn,
359 :     parent => $parent
360 :     };
361 :    
362 :     # Scan comment 1 for embedded format information:
363 :    
364 :     my $c1 = gjonewicklib::newick_c1( $node );
365 :     my %c1 = ();
366 :     foreach ( grep { s/^&&gdTree:\s*// || s/^&&treeLayout:\s*// }
367 :     ( ref $c1 eq 'ARRAY' ? @$c1 : ( $c1 ) ) # $c1 should be an array ref, but allow a string
368 :     )
369 :     {
370 :     my @data = map { /(\S+)\s*=>?\s*\[\s*(\d+)\s*,\s*(\d+)\s*,\s*(\d+)\s*\]/ ? [ $1, [$2,$3,$4] ] : # color
371 :     /(\S+)\s*=>?\s*(\S+)/ ? [ $1, $2 ] : # other key=value
372 :     ()
373 :     } split /\s*;\s*/, $_;
374 :     foreach ( @data ) { $c1{ $_->[0] } = $_->[1] }
375 :     }
376 :    
377 :     $hash->{ $node }->{ inherit } = \%c1 if keys %c1;
378 :    
379 :     ( $y, $xmax, $yn );
380 :     }
381 :    
382 :    
383 :     #
384 :     # $image = render_gd_tree( $node, $hash, $options )
385 :     #
386 :     sub render_gd_tree
387 :     {
388 :     my ( $node, $hash, $options ) = @_;
389 :    
390 :     my $nodeinfo = $hash->{ $node };
391 :     my $xmax = pict_width( $node, $hash, $options );
392 :     $options->{ xmax } = $xmax;
393 :    
394 :     # Start a new image
395 :    
396 :     my $ymax = int( $nodeinfo->{ yn } + 0.5 * $options->{ dy } + 0.4999 );
397 :     $options->{ ymax } = $ymax;
398 :     my @size = ( $xmax + 1, $ymax + 1 );
399 : golsen 1.5 my $image = myNewImage( @size ); # trueColor is false
400 : golsen 1.1
401 : golsen 1.5 # Background is done outside of my color management:
402 : golsen 1.1
403 :     my $bkg;
404 :     if ( $options->{ bkg_color } )
405 :     {
406 :     $bkg = $image->colorAllocate( @{ $options->{ bkg_color } } );
407 :     }
408 :     else
409 :     {
410 : golsen 1.5 # Lets us use white on a transparent background (evil).
411 :     $bkg = $image->colorAllocate( 254, 254, 254 );
412 : golsen 1.1 $image->transparent( $bkg );
413 :     }
414 : golsen 1.5 $options->{ bkg_index } = $bkg;
415 : golsen 1.1
416 :     # Draw the tree
417 :    
418 :     render_gd_tree2( $image, $node, $hash, $options );
419 :    
420 :     # Scale bar; oh bother:
421 :    
422 :     if ( $options->{ bar_pos } && $options->{ bar_font } )
423 :     {
424 :     my $bar_pos = $options->{ bar_pos };
425 :     my $bar_len = int( $options->{ bar_len } * $options->{ x_scale } + 0.5 );
426 :     my ( $x1, $x2, $y, $lo );
427 :     if ( $bar_pos =~ /^.l$/i )
428 :     {
429 :     $x1 = $nodeinfo->{ x0 };
430 :     $x2 = $x1 + $bar_len;
431 :     }
432 :     else
433 :     {
434 :     $x1 = $nodeinfo->{ xmax } - 2 * $options->{ thickness };
435 :     $x2 = $x1 - $bar_len;
436 :     }
437 :     my $lbl_x = int( 0.5*($x1+$x2+1) );
438 :     if ( $bar_pos =~ /^u.$/i )
439 :     {
440 :     $y = $nodeinfo->{ y0 };
441 :     $lo = 16;
442 :     }
443 :     else
444 :     {
445 :     $y = $nodeinfo->{ yn };
446 :     $lo = 14;
447 :     }
448 :    
449 :     $image->setThickness( $options->{ thickness } );
450 :     my $line_color = myGetColor( $image, $options->{ line_color } );
451 :     $image->line( $x1, $y, $x2, $y, $line_color );
452 :    
453 :     my $text_color = myGetColor( $image, $options->{ text_color } );
454 :     my $opt = { text_color => $text_color,
455 :     label_origin => $lo
456 :     };
457 :     gdPlacedText( $image, "$options->{bar_len}", $options->{ bar_font }, $lbl_x, $y, $opt );
458 :     }
459 :    
460 :     wantarray ? ( $image, $hash ) : $image;
461 :     }
462 :    
463 :    
464 :     #
465 :     # $image = render_gd_tree2( $image, $node, $hash, $options )
466 :     #
467 :     sub render_gd_tree2
468 :     {
469 :     my ( $image, $node, $hash, $options ) = @_;
470 :    
471 :     my $nodeinfo = $hash->{ $node };
472 :    
473 :     # Are there localized options?
474 :    
475 :     if ( ref $nodeinfo->{ inherit } eq 'HASH' )
476 :     {
477 :     $options = { %$options };
478 :     foreach ( keys %{ $nodeinfo->{ inherit } } )
479 :     {
480 :     $options->{ $_ } = $nodeinfo->{ inherit }->{ $_ };
481 :     }
482 :     }
483 :    
484 :     my $x0 = $nodeinfo->{ x0 };
485 :     my $x = $nodeinfo->{ x };
486 :     my $y = $nodeinfo->{ y };
487 :    
488 :     if ( $nodeinfo->{ inherit }->{ bkg_color } )
489 :     {
490 :     my $x1 = max( int( 0.5*($x0+$x+1)), $x0+1 );
491 :     my $xmax = $options->{ xmax };
492 :     my $y0 = $nodeinfo->{ y0 };
493 :     my $yn = $nodeinfo->{ yn };
494 :     my $bkg_color = myGetColor( $image, $nodeinfo->{ inherit }->{ bkg_color } );
495 :     $image->setThickness( 1 );
496 :     $image->filledRectangle( $x1, $y0, $xmax, $yn, $bkg_color );
497 :     }
498 :    
499 :     $image->setThickness( $options->{ thickness } );
500 :     my $line_color = myGetColor( $image, $options->{ line_color } );
501 :    
502 :     my @dl = gjonewicklib::newick_desc_list( $node );
503 :     if ( ! @dl ) # A tip
504 :     {
505 :     $image->line( $x0, $y, $x, $y, $line_color );
506 :     my $lbl = gjonewicklib::newick_lbl( $node );
507 :     my $font_size = $options->{ font_size };
508 :     if ( $lbl && $font_size )
509 :     {
510 :     my $lbl_x = $x + $options->{ lbl_dx };
511 :     my $font = $options->{ font };
512 :     my $text_color = myGetColor( $image, $options->{ text_color } );
513 :     my $text_bkg = $options->{ text_bkg_color };
514 :     my $text_bkg_color = $text_bkg ? myGetColor( $image, $text_bkg ) : undef;
515 :     my @rectangle = ();
516 :     if ( $font )
517 :     {
518 :     my $opt = { text_color => $text_color,
519 :     ( $text_bkg_color ? ( text_bkg_color => $text_bkg_color ) : () ),
520 :     # text_border => 1,
521 :     label_origin => 2
522 :     };
523 :     @rectangle = gdPlacedText( $image, $lbl, $font, $lbl_x, $y, $opt );
524 :     }
525 :     else
526 :     {
527 :     my $len = int( 0.5 * $font_size * length( $lbl ) + 0.5 );
528 :     my $thick = $options->{ lbl_line };
529 :     @rectangle = ( $lbl_x, int( $y - 0.5*$thick ),
530 :     $lbl_x + $len, int( $y + 0.5*$thick )
531 :     );
532 :     $image->setThickness( $thick );
533 :     $image->line( $lbl_x, $y, $lbl_x+$len, $y, $text_bkg_color || $text_color );
534 :     }
535 :     $nodeinfo->{ lbl_rect } = \@rectangle;
536 :     }
537 :     }
538 :     else
539 :     {
540 :     $image->line( $nodeinfo->{ x0 }, $y, $x, $y, $line_color );
541 :     $image->line( $x, $nodeinfo->{ y1 }, $x, $nodeinfo->{ y2 }, $line_color );
542 :    
543 :     foreach ( @dl ) { render_gd_tree2( $image, $_, $hash, $options ) }
544 :     }
545 :    
546 :     $image
547 :     }
548 :    
549 :    
550 :     sub pict_width
551 :     {
552 :     my ( $node, $hash, $options ) = @_;
553 :     return $hash->{ xmax } if ( $options->{ font_size } < 1 );
554 :    
555 :     my $xmax;
556 :     my @dl = gjonewicklib::newick_desc_list( $node );
557 :     if ( ! @dl )
558 :     {
559 :     $xmax = $hash->{ $node }->{ x };
560 :     my $lbl = gjonewicklib::newick_lbl( $node );
561 :     if ( $lbl )
562 :     {
563 :     $xmax += $options->{ lbl_dx } + 2;
564 :     my $font = $options->{ font };
565 :     if ( $font )
566 :     {
567 :     $xmax += textWidth( $lbl, $font );
568 :     }
569 :     else
570 :     {
571 :     $xmax += int( 0.5 * $options->{ font_size } * length( $lbl ) + 0.9999 );
572 :     }
573 :     }
574 :     }
575 :     else
576 :     {
577 :     $xmax = -1e100;
578 :     foreach ( @dl )
579 :     {
580 :     my $x = pict_width( $_, $hash, $options );
581 :     $xmax = $x if $x > $xmax;
582 :     }
583 :    
584 :     }
585 :    
586 :     $xmax
587 :     }
588 :    
589 :    
590 :     #===============================================================================
591 :     # A subroutine to simplify the placing of text strings in the GD environment.
592 :     # The model is based upon label origin (LO) in HPGL.
593 :     #
594 :     # 13 16 19
595 :     #
596 :     #
597 :     # 3TTTTTTTTT EEEEEEEEEE 6XX XX TTTTTTTTT9
598 :     # TT EE XX XX TT
599 :     # TT EE XX XX TT
600 :     # 12 2 TT EEEEEEEE 5 X TT 8 18
601 :     # TT EE XX XX TT
602 :     # TT EE XX XX TT
603 :     # 1 TT EEEEEEEEEE 4XX XX TT 7
604 :     #
605 :     #
606 :     # 11 14 17
607 :     #
608 :     #
609 :     # GD has an odd font position model. For example, for gdSmallFont:
610 :     # __________________________________________________________________________
611 :     # |O <- string origin point ^ ^
612 :     # | top lead = 3 |
613 :     # | _______________v_______________ |
614 :     # | XX XXXXXX ^ |
615 :     # | XX XX XX XX _________ | |
616 :     # | XXXXXX XXXX XX XX XXXX XX ^ upper font
617 :     # |XX XX XX XXXX XXXX XX XX XX lower case height
618 :     # |XX XX XX XX XX XX XX XX case rise = 13
619 :     # | XXXXXX XX XX XX XX XX XX rise = 8 |
620 :     # |XX XX XXXX XX XX XX XX XX = 6 | |
621 :     # | XXXXXX | XXXX XX XXXXXX XX XX_____v________v____ |
622 :     # |XX XX | descent = 2 |
623 :     # |_ XXXXXX __|___________________________________________v_____________v___
624 :     # | |
625 :     # |<- width ->|
626 :     # | = 6 |
627 :     #
628 :     #-------------------------------------------------------------------------------
629 :     # Block to ensure that font description hash is loaded
630 :     #-------------------------------------------------------------------------------
631 :    
632 :     BEGIN {
633 :    
634 :     my %fontData =
635 :     # font font cell cell top uc lc des-
636 :     # name object width height lead rise rise cent
637 :     ( gdTinyFont => [ gdTinyFont, 5, 8, 1, 6, 4, 1 ],
638 :     gdSmallFont => [ gdSmallFont, 6, 13, 3, 8, 6, 2 ],
639 :     gdLargeFont => [ gdLargeFont, 8, 16, 3, 10, 7, 3 ],
640 :     gdMediumBoldFont => [ gdMediumBoldFont, 7, 13, 2, 9, 6, 2 ],
641 :     gdGiantFont => [ gdGiantFont, 9, 15, 3, 10, 7, 2 ]
642 :     );
643 :    
644 :    
645 :     sub adjust_font
646 :     {
647 :     my ( $options ) = @_;
648 :    
649 :     my $dy = $options->{ dy };
650 :     my $font_size = $options->{ font_size };
651 :    
652 :     my ( $font_key ) = grep { /^font/i && ! ( /si?ze/i ) && ! ( /co?lo?r/i ) } keys %$options;
653 :     my $font = $fontData{ $options->{ $font_key } } ? $options->{ $font_key }
654 :     : undef;
655 :    
656 :     if ( ! defined( $dy ) )
657 :     {
658 :     if ( ! $font )
659 :     {
660 :     $font = defined( $font_size ) ? fontFromSize( $font_size )
661 :     : 'gdSmallFont';
662 :     }
663 :     $font_size = $fontData{$font}->[4] + $fontData{$font}->[6] if $font;
664 :     $dy = max( int( 1.2 * $font_size + 0.5 ), 2 );
665 :     }
666 :     else
667 :     {
668 :     $dy = max( int( $dy + 0.5 ), 2 );
669 :     if ( $font )
670 :     {
671 :     $font_size = $fontData{$font}->[4] + $fontData{$font}->[6];
672 :     }
673 :     else
674 :     {
675 :     $font_size = int( 0.85 * $dy ) if ! defined( $font_size );
676 :     $font = fontFromSize( $font_size );
677 :     $font_size = $fontData{$font}->[4] + $fontData{$font}->[6] if $font;
678 :     }
679 :     }
680 :     $options->{ dy } = $dy;
681 :     $options->{ font_size } = $font_size;
682 :     $options->{ font } = $font;
683 :    
684 :     my $char_width;
685 :     if ( $font )
686 :     {
687 :     $char_width = $fontData{$font}->[1];
688 :     $options->{ lbl_dx } = int( 1.5 * $char_width );
689 :     }
690 :     else
691 :     {
692 :     $char_width = 0.5 * $font_size;
693 :     $options->{ lbl_dx } = int( $font_size + 1 );
694 :     $options->{ lbl_line } = int( 0.6 * $font_size + 0.5 );
695 :     }
696 :     $options->{ char_width } = $char_width;
697 :    
698 :     ( $dy, $font_size, $font )
699 :     }
700 :    
701 :    
702 :     sub fontFromSize
703 :     {
704 :     my ( $font_size ) = @_;
705 :    
706 :     return $font_size < 6 ? undef
707 :     : $font_size < 10 ? 'gdTinyFont'
708 :     : $font_size < 13 ? 'gdSmallFont'
709 :     : 'gdLargeFont';
710 :     }
711 :    
712 :    
713 :     sub textWidth
714 :     {
715 :     my ( $text, $fontname, $extra_chr ) = @_;
716 :     $text && $fontname && $fontData{ $fontname }
717 :     or return undef;
718 :     $fontData{ $fontname }->[1] * ( length( $text ) + ( $extra_chr || 0 ) );
719 :     }
720 :    
721 :    
722 :     sub gdPlacedText
723 :     {
724 :     my ( $image, $text, $fontname, $x0, $y0, $options ) = @_;
725 :     $image && $text && $fontname && $fontData{ $fontname }
726 :     && defined $x0 && defined $y0
727 :     or return undef;
728 :     $options = {} unless hash_ref( $options );
729 :     my ( $text_color );
730 :     if ( $options->{ text_color } )
731 :     {
732 :     $text_color = $options->{ text_color }
733 :     }
734 :     else
735 :     {
736 :     $text_color = $image->colorAllocate( 0, 0, 0 );
737 :     }
738 :     my $text_bkg_color = $options->{ text_bkg_color };
739 :     my $textBorder = $options->{ text_border };
740 :     $textBorder = 1 unless defined $textBorder;
741 :    
742 :     my ( $font, $fWidth, $fHeight, $fLead, $ucRise, $lcRise, $fDescent )
743 :     = @{ $fontData{ $fontname } };
744 :    
745 :     my $label_origin = int( $options->{ label_origin } || 1 );
746 :     return if $label_origin < 1 || $label_origin > 19 || $label_origin == 10;
747 :    
748 :     # Adjust vertical position:
749 :    
750 :     my @v_offset = ( undef, 2, 1, 0, 2, 1, 0, 2, 1, 0,
751 :     undef, 3, 1, -1, 3, 1, -1, 3, 1, -1 );
752 :     $y0 -= $fLead + int( 0.5 * $v_offset[ $label_origin ] * $ucRise );
753 :    
754 :     # Adjust horizontal position:
755 :    
756 :     my $textWidth = length( $text ) * $fWidth;
757 :     my @h_offset = ( undef, 0, 0, 0, 0, 0, 0, 0, 0, 0,
758 :     undef, -1, -1, -1, 0, 0, 0, 1, 1, 1 );
759 :     $x0 -= int( 0.5 * $h_offset[ $label_origin ] * $ucRise
760 :     + ( $label_origin >= 17 ? $textWidth :
761 :     $label_origin >= 14 ? $textWidth / 2 :
762 :     0
763 :     )
764 :     );
765 :     my @rect = ( $x0-$textBorder, $y0+$fLead-$textBorder,
766 :     $x0+$textWidth+$textBorder-2, $y0+$fHeight+$textBorder-1 );
767 :     if ( $text_bkg_color )
768 :     {
769 :     $image->filledRectangle( @rect, $text_bkg_color );
770 :     }
771 :     $image->string( $font, $x0, $y0, $text, $text_color);
772 :    
773 :     @rect; # Return the rectangle
774 :     }
775 :     } # End of BEGIN block
776 :    
777 :    
778 :     # We can pretty quickly manage colors without worrying about the GD limits.
779 :     # Generally the idea is to not free any colors. Just let automatic recycling
780 :     # take over if necessary.
781 : golsen 1.5 #
782 :     # This is a fallback:
783 :    
784 :     sub myGetColor_alt
785 :     {
786 :     my $image = shift;
787 :     my ( @RGB ) = map { $_ || 0 } ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
788 :     $image->colorAllocate( @RGB );
789 :     }
790 :    
791 : golsen 1.1
792 :     BEGIN
793 :     {
794 : golsen 1.5 my %colorSet; # We allow concurrent images. I don't know if GD does.
795 :     my $n_stable = 64;
796 :    
797 :     sub myNewImage
798 :     {
799 :     my $image = new GD::Image( @_ ); # width, height
800 :     $image->trueColor( 0 );
801 :     # $image->trueColor( 1 ); # GD has a very bad color saved state issue
802 :    
803 :     # Associate a color mapping to the image
804 :     $colorSet{ $image } = { colorIndex => {},
805 :     indexColor => {},
806 :     recycleStack => [],
807 :     n_allo => 0,
808 :     is_stable => {}
809 :     };
810 :    
811 :     $image;
812 :     }
813 :    
814 : golsen 1.1
815 :     sub myGetColor
816 :     {
817 :     my $image = shift;
818 : golsen 1.5
819 :     my $colorSetH = $colorSet{ $image };
820 :     my $colorIndexH = $colorSetH->{ colorIndex };
821 :     my $indexColorH = $colorSetH->{ indexColor };
822 :     my $recycleStackA = $colorSetH->{ recycleStack };
823 :    
824 : golsen 1.1 my ( @RGB ) = map { $_ || 0 } ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
825 :     my $name = sprintf '%03d.%03d.%03d', @RGB;
826 : golsen 1.5 return $colorIndexH->{ $name } if $colorIndexH->{ $name };
827 :     if ( $colorSetH->{ n_allo } > 250 )
828 : golsen 1.1 {
829 : golsen 1.5 my ( $del_name, $free_index ) = @{ shift @$recycleStackA };
830 : golsen 1.1 $image->colorDeallocate( $free_index );
831 : golsen 1.5 delete $colorIndexH->{ $del_name };
832 :     delete $indexColorH->{ $free_index };
833 :     $colorSetH->{ n_allo }--;
834 : golsen 1.1 }
835 :     my $index = $image->colorAllocate( @RGB );
836 : golsen 1.5 $colorIndexH->{ $name } = $index;
837 :     $indexColorH->{ $index } = $name;
838 :     if ( ++$colorSetH->{ n_allo } > $n_stable )
839 : golsen 1.1 {
840 : golsen 1.5 push @$recycleStackA, [ $name, $index ];
841 : golsen 1.1 }
842 :     else
843 :     {
844 : golsen 1.5 $colorSetH->{ is_stable }->{ $index } = 1;
845 : golsen 1.1 }
846 :    
847 :     $index;
848 :     }
849 :    
850 :     sub myFreeColor
851 :     {
852 :     my ( $image, $index ) = @_;
853 : golsen 1.5
854 :     my $colorSetH = $colorSet{ $image };
855 :     my $colorIndexH = $colorSetH->{ colorIndex };
856 :     my $indexColorH = $colorSetH->{ indexColor };
857 :     my $recycleStackA = $colorSetH->{ recycleStack };
858 :    
859 :     my $name = $indexColorH->{ $index };
860 : golsen 1.1 return unless $name;
861 :    
862 : golsen 1.5 if ( $colorSetH->{ is_stable }->{ $index } )
863 : golsen 1.1 {
864 : golsen 1.5 delete $colorSetH->{ is_stable }->{ $index };
865 :     if ( @$recycleStackA )
866 : golsen 1.1 {
867 : golsen 1.5 $colorSetH->{ is_stable }->{ $recycleStackA->[0]->[1] } = 1;
868 :     shift @$recycleStackA;
869 : golsen 1.1 }
870 :     }
871 :     else
872 :     {
873 : golsen 1.5 @$recycleStackA = grep { $_->[1] != $index } @$recycleStackA;
874 : golsen 1.1 }
875 :    
876 :     $image->colorDeallocate( $index );
877 : golsen 1.5 delete $colorIndexH->{ $name };
878 :     delete $indexColorH->{ $index };
879 :     $colorSetH->{ n_allo }--;
880 : golsen 1.1 }
881 :    
882 :     }
883 :    
884 :    
885 :     sub min { $_[0] < $_[1] ? $_[0] : $_[1] }
886 :     sub max { $_[0] > $_[1] ? $_[0] : $_[1] }
887 :     sub array_ref { ref $_[0] eq 'ARRAY' }
888 :     sub hash_ref { ref $_[0] eq 'HASH' }
889 :    
890 :    
891 :     1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3