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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3