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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3