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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3