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

Annotation of /FigKernelPackages/GenoGraphics.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.20 # This is a SAS component.
2 :    
3 : olson 1.13 #
4 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
5 :     # for Interpretations of Genomes. All Rights Reserved.
6 :     #
7 :     # This file is part of the SEED Toolkit.
8 :     #
9 :     # The SEED Toolkit is free software. You can redistribute
10 :     # it and/or modify it under the terms of the SEED Toolkit
11 :     # Public License.
12 :     #
13 :     # You should have received a copy of the SEED Toolkit Public License
14 :     # along with this program; if not write to the University of Chicago
15 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
16 :     # Genomes at veronika@thefig.info or download a copy from
17 :     # http://www.theseed.org/LICENSE.TXT.
18 :     #
19 :    
20 : efrank 1.1 package GenoGraphics;
21 :    
22 :     use GD;
23 :     use Data::Dumper;
24 :     use Carp;
25 : overbeek 1.16 use constant MINPIX => 5;
26 : heiko 1.7
27 : olson 1.20 use SeedHTML;
28 :    
29 :     use vars qw($temp_dir $temp_url $image_type $image_suffix);
30 :    
31 : golsen 1.24 # #
32 :     # # Let's diagnose the working rendering options of GD:
33 :     # #
34 :     # # $bool = gd_has_png()
35 :     # # $bool = gd_has_jpg()
36 :     # # \%fmt = gd_formats() # hash keys: gd, jpg and png
37 :     # #
38 :     # # Cache the answers
39 :     # #
40 :     # my $has_png;
41 :     # my $has_jpg;
42 :     # my %has = ();
43 :     #
44 :     # sub gd_has_png
45 :     # {
46 :     # return $has_png if defined $has_png;
47 :     # return $has_png = $has{ png } if keys %has;
48 :     # my $image = new GD::Image( 1, 1 );
49 :     # $image->colorAllocate( 255, 255, 255 );
50 :     # $has_png = 0;
51 :     # eval { $image->png; $has_png = 1; };
52 :     # $has_png;
53 :     # }
54 :     #
55 :     # sub gd_has_jpg
56 :     # {
57 :     # return $has_jpg if defined $has_jpg;
58 :     # return $has_jpg = $has{ jpg } if keys %has;
59 :     # my $image = new GD::Image( 1, 1 );
60 :     # $image->colorAllocate( 255, 255, 255 );
61 :     # $has_jpg = 0;
62 :     # eval { $image->jpg; $has_jpg = 1; };
63 :     # $has_jpg;
64 :     # }
65 :     #
66 :     # sub gd_formats
67 :     # {
68 :     # if ( ! keys %has )
69 :     # {
70 :     # my $image = new GD::Image( 1, 1 );
71 :     # $image->colorAllocate( 255, 255, 255 );
72 :     # foreach my $fmt ( qw( jpg png gd ) )
73 :     # {
74 :     # $has{$fmt} = 0;
75 :     # eval { $image->$fmt; $has{$fmt} = 1; };
76 :     # }
77 :     # }
78 :     # \%has;
79 :     # }
80 : golsen 1.23
81 : olson 1.21 BEGIN {
82 :     $temp_dir = "/tmp";
83 :     $temp_url = "file://localhost/tmp";
84 :    
85 :     #
86 : golsen 1.23 # Default to png, fall back to jpeg. I'm still not sure why the assignment
87 :     # is in the begin block.
88 : olson 1.21 #
89 : golsen 1.24 # if ( gd_has_png() )
90 :     # {
91 :     # $image_type = "png";
92 :     # $image_suffix = "png";
93 :     # }
94 :     # elsif ( gd_has_jpg() )
95 :     # {
96 : golsen 1.23 $image_type = "jpeg";
97 :     $image_suffix = "jpg";
98 : golsen 1.24 # }
99 : olson 1.20
100 :     eval {
101 :     require FIG;
102 :     require FIG_Config;
103 :     $temp_dir = $FIG_Config::temp;
104 :     $temp_url = &FIG::temp_url;
105 :     };
106 :     eval {
107 :     require Tracer;
108 :     import Tracer;
109 :     };
110 :     if ($@)
111 :     {
112 :     sub T {}
113 :     }
114 :     }
115 :    
116 : efrank 1.1 use strict;
117 :    
118 :     #
119 :     # A GenoGraphics request is a data structure of the form:
120 :     #
121 :     # 1. $gg is a pointer to a list of "maps"
122 :     # 2. Each map is a 4-tuple of the form
123 : golsen 1.14 #
124 : parrello 1.18 # [ $text, $beg, $end, $objects ]
125 : golsen 1.14 #
126 :     # or
127 :     #
128 : parrello 1.18 # [ [ $text, $link, $popup_text, $menu, $popup_title ], $beg, $end, $objects ]
129 : golsen 1.14 #
130 : efrank 1.1 # 3. $objects is a pointer to a list. Each entry is of the form
131 : golsen 1.14 #
132 : overbeek 1.19 # [ $beg, $end, $shape, $color, ???, $url, $popup_text, $menu, $popup_title]
133 :     ###
134 :     # Whoever did the javascript stuff added fields, but I cannot figure out
135 :     # what the one marked with ??? is. I just set it to undef. (RAO 2009)
136 :     ###
137 : golsen 1.14 #
138 : efrank 1.1 # When $gg is rendered, each map may be split into a set of
139 :     # "submaps", each containing a set of non-overlapping objects.
140 :     #
141 :     # Thus, $ggR is a data structure in which maps become
142 :     #
143 :     # [$text, $beg, $end, $submaps]
144 :     #
145 :     # Where $submaps is a pointer to a list; each entry in the list
146 :     # is a pointer to a list of objects.
147 :    
148 :    
149 :     sub render {
150 : golsen 1.14 my( $gg, $width, $obj_half_heigth, $save, $img ) = @_;
151 : parrello 1.15 Trace("Rendering width = $width, OHH = $obj_half_heigth") if T(3);
152 : efrank 1.1 if (! $img) { $img = 1 }
153 :    
154 : golsen 1.14 # compute left margin based on text -- GJO
155 :    
156 :     # my $left_margin = (15 * gdSmallFont->width) + 5;
157 :     my $maxln = 0;
158 :     my ( $text, $ln );
159 :     foreach ( @$gg )
160 :     {
161 :     $text = ( ref( $_->[0] ) eq "ARRAY" ) ? $_->[0]->[0] : $_->[0];
162 :     $ln = length( $text );
163 :     $maxln = $ln if $ln > $maxln;
164 :     }
165 :     my $left_margin = ( ( $maxln + 1 ) * gdSmallFont->width ) + 5;
166 :     my $image_width = $width + $left_margin;
167 :    
168 :     my $ggR = &generate_submaps($gg); # introduces sublevels
169 :     my $gd = new GD::Image($image_width+5,&height($ggR,$obj_half_heigth));
170 :    
171 :     my $ismap = {};
172 : efrank 1.1 my $color_of = &choose_colors($gd,$ggR);
173 : golsen 1.14 &draw( $gd, $ismap, $ggR, $color_of, $width, $obj_half_heigth, $left_margin );
174 : efrank 1.1 my($img_file,$img_url);
175 :     if ($save)
176 :     {
177 : olson 1.20 &SeedUtils::verify_dir("$temp_dir/Save");
178 :     $img_file = "$temp_dir/Save/GenoGraphics_$$.$img.$image_suffix";
179 :     $img_url = "$temp_url/Save/GenoGraphics_$$.$img.$image_suffix";
180 : efrank 1.1 }
181 :     else
182 :     {
183 : olson 1.20 $img_file = "$temp_dir/GenoGraphics_$$.$img.$image_suffix";
184 :     $img_url = "$temp_url/GenoGraphics_$$.$img.$image_suffix";
185 : efrank 1.1 }
186 :     &write_image($gd,$img_file);
187 :     return &generate_html($ismap,$img_url,$ggR,$img);
188 :     }
189 :    
190 : golsen 1.14
191 : efrank 1.1 sub draw {
192 : golsen 1.14 my( $gd, $ismap, $ggR, $colors, $width, $obj_half_heigth, $left_margin ) = @_;
193 :     my( $y, $map, $text, $beg, $end, $submaps, $submap, $object );
194 :    
195 : efrank 1.1 my $map_incr = 3 * $obj_half_heigth;
196 :     my $submap_incr = (4 * $obj_half_heigth) + int(1.1 * gdSmallFont->height);
197 : golsen 1.14 my $text_color = $colors->{"text"};
198 :     my $char_height = gdSmallFont->height;
199 :     my $char_width = gdSmallFont->width;
200 : efrank 1.1
201 :     $y = (2 * $obj_half_heigth) + gdSmallFont->height;
202 :     foreach $map (@$ggR)
203 :     {
204 : parrello 1.18 ( $text, $beg, $end, $submaps ) = @$map;
205 : golsen 1.14
206 :     # draw the text label
207 :    
208 : parrello 1.18 $text = $text->[0] if ref( $text ) eq "ARRAY";
209 :     if ( $text =~ /\S/ )
210 :     {
211 :     $gd->string( gdSmallFont, 5, int($y - (0.5 * $char_height)), $text, $text_color );
212 : golsen 1.14 $ismap->{ $map } = [ [ 5, $y - $obj_half_heigth ],
213 :     [ 5 + length($text)*$char_width, $y + $obj_half_heigth ]
214 :     ];
215 :     }
216 : efrank 1.1
217 : golsen 1.14 # draw map line + ticks at ends
218 : efrank 1.1
219 : parrello 1.18 my $begP = &get_pos_of_pixel( $gd, $beg, $beg, $end, $width, $left_margin );
220 :     my $endP = &get_pos_of_pixel( $gd, $end, $beg, $end, $width, $left_margin );
221 :     $gd->line( $begP, $y, $endP, $y, $text_color );
222 :     $gd->line( $begP, $y-$obj_half_heigth, $begP, $y+$obj_half_heigth, $text_color );
223 :     $gd->line( $endP, $y-$obj_half_heigth, $endP, $y+$obj_half_heigth, $text_color );
224 :    
225 :     foreach $submap ( @$submaps )
226 :     {
227 :     foreach $object ( @$submap )
228 :     {
229 :     my( $begO, $endO, $shapeO, $colorO ) = @$object;
230 :     my $begOP = &get_pos_of_pixel( $gd, $begO, $beg, $end, $width, $left_margin );
231 :     my $endOP = &get_pos_of_pixel( $gd, $endO, $beg, $end, $width, $left_margin );
232 :     if (($endOP - $begOP) < MINPIX)
233 :     {
234 :     if (0 < int($begOP - (MINPIX/2)))
235 :     {
236 :     $begOP = int($begOP - (MINPIX/2));
237 :     }
238 :     if ($width > int($endOP + (MINPIX/2)))
239 :     {
240 :     $endOP = int($endOP + (MINPIX/2));
241 :     }
242 :     }
243 :     Trace("Shape $shapeO from $begOP to $endOP in color $colorO.") if T(4);
244 :    
245 :     my $tmp = [];
246 :     my $rtn = \&{$shapeO};
247 :     &$rtn( $gd, $tmp, $y, $begOP, $endOP, $colors->{$colorO}, $obj_half_heigth );
248 : golsen 1.14 $ismap->{ $object } = pop @$tmp;
249 : efrank 1.1 }
250 : parrello 1.18 &text( $gd, $text_color, $submap, $y, $beg, $end, $begP, $endP, $width, $obj_half_heigth, $left_margin );
251 : efrank 1.1 $y += $submap_incr;
252 :     }
253 :     $y += $map_incr;
254 :     }
255 :     }
256 :    
257 : golsen 1.14
258 : efrank 1.1 sub text {
259 : golsen 1.14 my( $gd, $color, $submap, $y, $beg, $end, $begP, $endP, $width, $obj_half_heigth, $left_margin ) = @_;
260 : efrank 1.1 my($object);
261 :    
262 : golsen 1.14 my $font_sz = gdSmallFont->width;
263 :     my $text_y = int($y - ((2 * $obj_half_heigth) + gdSmallFont->height));
264 : efrank 1.1
265 :     foreach $object (@$submap)
266 :     {
267 : parrello 1.18 my($begO,$endO,undef,undef,$textO) = @$object;
268 :     my $begOP = &get_pos_of_pixel( $gd, $begO, $beg, $end, $width, $left_margin );
269 :     my $endOP = &get_pos_of_pixel( $gd, $endO, $beg, $end, $width, $left_margin );
270 :     my $text_start = int((($begOP + $endOP) / 2) - ((length($textO) * $font_sz)/2));
271 :     if ($text_start < $begP)
272 :     {
273 :     $text_start = $begP;
274 :     }
275 :     else
276 :     {
277 :     my $adj_left = $endP - (length($textO) * $font_sz);
278 :     if ($text_start > $adj_left)
279 :     {
280 :     $text_start = $adj_left;
281 :     }
282 :     }
283 :     if ($text_start >= $begOP)
284 :     {
285 :     $gd->string( gdSmallFont, $text_start, $text_y, $textO, $color );
286 :     }
287 : efrank 1.1 }
288 :     }
289 :    
290 :     sub generate_submaps {
291 :     my($gg) = @_;
292 :     my($ggR,$map,$text,$beg,$end,$objects);
293 :    
294 :     $ggR = [];
295 :     foreach $map (@$gg)
296 :     {
297 :     ($text,$beg,$end,$objects) = @$map;
298 : parrello 1.18 push(@$ggR,[$text,$beg,$end,&split_overlaps($objects)]);
299 : efrank 1.1 }
300 :     return $ggR;
301 :     }
302 :    
303 :     sub split_overlaps {
304 :     my($objects) = @_;
305 :     my($submaps,$object,$i);
306 :    
307 :     $submaps = [];
308 :     foreach $object (@$objects)
309 :     {
310 : parrello 1.18 for ($i=0; ($i < @$submaps) && &will_not_fit($object,$submaps->[$i]); $i++) {}
311 :     if ($i < @$submaps)
312 :     {
313 :     push(@{$submaps->[$i]},$object);
314 :     }
315 :     else
316 :     {
317 :     push(@$submaps,[$object]);
318 :     }
319 : efrank 1.1 }
320 :     return $submaps;
321 :     }
322 :    
323 :     sub will_not_fit {
324 :     my($object,$submap) = @_;
325 :     my($i);
326 :    
327 :     for ($i=0; ($i < @$submap) && (! &overlaps($object,$submap->[$i])); $i++) {}
328 :     return ($i < @$submap);
329 :     }
330 :    
331 :     sub overlaps {
332 :     my($obj1,$obj2) = @_;
333 :    
334 : olson 1.20 return &SeedUtils::between($obj1->[0],$obj2->[0],$obj1->[1]) ||
335 :     &SeedUtils::between($obj2->[0],$obj1->[0],$obj2->[1]);
336 : efrank 1.1 }
337 :    
338 :     sub height {
339 :     my($ggR,$obj_half_heigth) = @_;
340 :     my($sz,$map,$sub);
341 :    
342 :     my $map_incr = 3 * $obj_half_heigth;
343 :     my $submap_incr = (4 * $obj_half_heigth) + int(1.1 * gdSmallFont->height);
344 :    
345 :     $sz = (2 * $obj_half_heigth) + gdSmallFont->height;
346 :     foreach $map (@$ggR)
347 :     {
348 : parrello 1.18 $sub = $map->[3];
349 :     $sz += ($map_incr + ($submap_incr * @$sub));
350 : efrank 1.1 }
351 : parrello 1.15 Trace("Height = $sz.") if T(4);
352 : efrank 1.1 return $sz;
353 :     }
354 :    
355 :     sub choose_colors {
356 :     my($gd,$ggR) = @_;
357 :    
358 :     my $color_of = {};
359 : golsen 1.10 my $colors =
360 : efrank 1.1 [
361 : golsen 1.10 '255-255-255', # white
362 :     '0-0-0', # black
363 :     '192-192-192', # ltgray
364 :     '128-128-128', # gray
365 :     '64-64-64', # dkgray
366 :     '255-0-0', # red
367 :     '0-255-0', # green
368 :     '0-0-255', # blue
369 : efrank 1.1 '255-64-192',
370 :     '255-128-64',
371 :     '255-0-128',
372 :     '255-192-64',
373 :     '64-192-255',
374 :     '64-255-192',
375 :     '192-128-128',
376 :     '192-255-0',
377 :     '0-255-128',
378 :     '0-192-64',
379 :     '128-0-0',
380 :     '255-0-192',
381 :     '64-0-128',
382 :     '128-64-64',
383 :     '64-255-0',
384 :     '128-0-64',
385 :     '128-192-255',
386 :     '128-192-0',
387 :     '64-0-0',
388 :     '128-128-0',
389 :     '255-192-255',
390 :     '128-64-255',
391 :     '64-0-192',
392 :     '0-64-64',
393 :     '64-0-255',
394 :     '192-64-255',
395 :     '128-0-128',
396 :     '192-255-64',
397 :     '64-128-255',
398 :     '255-128-192',
399 :     '64-192-64',
400 :     '0-128-128',
401 :     '255-0-64',
402 :     '128-64-0',
403 :     '128-255-128',
404 :     '255-64-128',
405 :     '128-192-64',
406 :     '128-128-64',
407 :     '255-255-192',
408 :     '192-192-128',
409 :     '192-64-128',
410 :     '64-128-192',
411 :     '192-192-64',
412 :     '192-0-128',
413 :     '64-64-192',
414 :     '0-128-192',
415 :     '0-128-64',
416 :     '255-192-128',
417 :     '192-128-0',
418 :     '64-255-255',
419 :     '255-0-255',
420 :     '128-255-255',
421 :     '255-255-64',
422 :     '0-128-0',
423 :     '192-255-192',
424 :     '0-192-0',
425 :     '0-64-192',
426 :     '0-64-128',
427 :     '192-0-255',
428 :     '192-192-255',
429 :     '64-255-128',
430 :     '0-0-128',
431 :     '255-64-64',
432 :     '192-192-0',
433 :     '192-128-192',
434 :     '128-64-192',
435 :     '0-192-255',
436 :     '128-192-192',
437 :     '192-0-64',
438 :     '192-255-255',
439 :     '255-192-0',
440 :     '255-255-128',
441 :     '192-0-0',
442 :     '64-64-0',
443 :     '192-64-192',
444 :     '192-128-255',
445 :     '128-255-192',
446 :     '64-64-255',
447 :     '0-64-255',
448 :     '128-64-128',
449 :     '255-64-255',
450 :     '192-128-64',
451 :     '64-64-128',
452 :     '0-128-255',
453 :     '64-0-64',
454 :     '128-0-192',
455 :     '255-128-255',
456 :     '64-128-0',
457 :     '255-64-0',
458 :     '64-192-192',
459 :     '255-128-0',
460 :     '0-0-64',
461 :     '128-128-192',
462 :     '128-128-255',
463 :     '0-192-192',
464 :     '0-255-192',
465 :     '128-192-128',
466 :     '192-0-192',
467 :     '0-255-64',
468 :     '64-192-0',
469 :     '0-192-128',
470 :     '128-255-64',
471 :     '255-255-0',
472 :     '64-255-64',
473 :     '192-64-64',
474 :     '192-64-0',
475 :     '255-192-192',
476 :     '192-255-128',
477 :     '0-64-0',
478 :     '0-0-192',
479 :     '128-0-255',
480 :     '64-128-64',
481 :     '64-192-128',
482 :     '0-255-255',
483 :     '255-128-128',
484 :     '64-128-128',
485 :     '128-255-0'
486 :     ];
487 :    
488 : golsen 1.10 $color_of->{"background"} = $color_of->{"white"} = &take_color($gd,$colors);
489 :     $color_of->{"text"} = $color_of->{"black"} = &take_color($gd,$colors);
490 :     $color_of->{"ltgray"} = $color_of->{"ltgrey"} = &take_color($gd,$colors);
491 :     $color_of->{"gray"} = $color_of->{"grey"} = &take_color($gd,$colors);
492 :     $color_of->{"dkgray"} = $color_of->{"dkgrey"} = &take_color($gd,$colors);
493 :     $color_of->{'color0'} = $color_of->{"red"} = &take_color($gd,$colors);
494 :     $color_of->{'color1'} = $color_of->{"green"} = &take_color($gd,$colors);
495 :     $color_of->{'color2'} = $color_of->{"blue"} = &take_color($gd,$colors);
496 :     $color_of->{'color3'} = &take_color($gd,$colors);
497 :     $color_of->{'color4'} = &take_color($gd,$colors);
498 :     $color_of->{'color5'} = &take_color($gd,$colors);
499 :     $color_of->{'color6'} = &take_color($gd,$colors);
500 :     $color_of->{'color7'} = &take_color($gd,$colors);
501 :     $color_of->{'color8'} = &take_color($gd,$colors);
502 :     $color_of->{'color9'} = &take_color($gd,$colors);
503 :     $color_of->{'color10'} = &take_color($gd,$colors);
504 :     $color_of->{'color11'} = &take_color($gd,$colors);
505 :     $color_of->{'color12'} = &take_color($gd,$colors);
506 :     $color_of->{'color13'} = &take_color($gd,$colors);
507 :     $color_of->{'color14'} = &take_color($gd,$colors);
508 :     $color_of->{'color15'} = &take_color($gd,$colors);
509 :     $color_of->{'color16'} = &take_color($gd,$colors);
510 :     $color_of->{'color17'} = &take_color($gd,$colors);
511 :     $color_of->{'color18'} = &take_color($gd,$colors);
512 :     $color_of->{'color19'} = &take_color($gd,$colors);
513 :     $color_of->{'color20'} = &take_color($gd,$colors);
514 : efrank 1.1
515 :     my ($map,$submap,$object,$rgb,$color);
516 :     my %how_many;
517 :     foreach $map (@$ggR)
518 :     {
519 : parrello 1.18 foreach $submap (@{$map->[3]})
520 :     {
521 :     foreach $object (@$submap)
522 :     {
523 :     $color = $object->[3];
524 :     $how_many{$color}++;
525 :     }
526 :     }
527 : efrank 1.1 }
528 :    
529 :     foreach $color (sort { $how_many{$b} <=> $how_many{$a} } keys(%how_many))
530 :     {
531 : parrello 1.18 if ((! $color_of->{$color}) &&
532 :     ($rgb = &take_color($gd,$colors)))
533 :     {
534 :     $color_of->{$color} = $rgb;
535 :     }
536 : efrank 1.1 }
537 : parrello 1.18 my $tooFew = 0;
538 : efrank 1.1 foreach $map (@$ggR)
539 :     {
540 : parrello 1.18 foreach $submap (@{$map->[3]})
541 :     {
542 :     foreach $object (@$submap)
543 :     {
544 :     $color = $object->[3];
545 :     if (! $color_of->{$color})
546 :     {
547 :     $tooFew = 1;
548 :     $color_of->{$color} = $color_of->{"grey"};
549 :     }
550 :     }
551 :     }
552 : efrank 1.1 }
553 : parrello 1.18 Trace("Could not allocate enough colors in choose_colors.") if $tooFew && T(1);
554 : efrank 1.1 return $color_of;
555 :     }
556 :    
557 :     sub take_color {
558 :     my($gd,$colors) = @_;
559 :     my($color);
560 :    
561 :     if (@$colors > 0)
562 :     {
563 : parrello 1.18 $color = shift @$colors;
564 :     # print STDERR "allocating $color: ", scalar @$colors, " left\n";
565 :     return $gd->colorAllocate(split(/-/,$color));
566 : efrank 1.1 }
567 :     return undef;
568 :     }
569 :    
570 :    
571 : golsen 1.14 # Left margin was hard coded, making adaptation hard.
572 : olson 1.9
573 : golsen 1.14 sub get_pos_of_pixel {
574 :     my( $gd, $pos, $beg, $end, $width, $left_margin ) = @_;
575 : olson 1.9 if (($end - $beg) == 0)
576 :     {
577 : parrello 1.18 confess "Zero-length segment";
578 : olson 1.9 }
579 : efrank 1.1
580 : golsen 1.14 # Margin should be an arg, if not provide previous behavior:
581 :    
582 :     $left_margin ||= ( 15 * gdSmallFont->width ) + 5;
583 :    
584 : efrank 1.1 return int($left_margin + ($width * (($pos - $beg) / ($end - $beg))));
585 :     }
586 :    
587 : golsen 1.17
588 :     sub filledRectangle {
589 :     my( $gd, $ismap, $y, $begOP, $endOP, $color, $obj_half_heigth ) = @_;
590 :     Trace("filledRectangle begOP = $begOP, endOP = $endOP, color = $color, OHH = $obj_half_heigth.") if T(4);
591 :    
592 :     my $y1 = $y - $obj_half_heigth;
593 :     my $y2 = $y + $obj_half_heigth;
594 :     $gd->filledRectangle( $begOP, $y1, $begOP, $y2, $color );
595 :     push( @$ismap, [ [ $begOP, $y1 ], [$endOP, $y2 ] ] );
596 :     }
597 :    
598 :    
599 : overbeek 1.16 sub Rectangle {
600 :     my($gd,$ismap,$y,$begOP,$endOP,$color,$obj_half_heigth) = @_;
601 : golsen 1.17 Trace("Rectangle begOP = $begOP, endOP = $endOP, color = $color, OHH = $obj_half_heigth.") if T(4);
602 : overbeek 1.16 my @poly = ();
603 :    
604 :     push(@poly,[$endOP,$y-(2 * $obj_half_heigth)]);
605 :     push(@poly,[$endOP,$y+(2 * $obj_half_heigth)]);
606 :     push(@poly,[$begOP,$y+(2 * $obj_half_heigth)]);
607 :     push(@poly,[$begOP,$y-(2 * $obj_half_heigth)]);
608 :     &render_poly($gd,$y,\@poly,$color);
609 :     push(@$ismap,[[$begOP,$y-(2 * $obj_half_heigth)],[$endOP,$y+(2 * $obj_half_heigth)]]);
610 :     }
611 :    
612 : golsen 1.17
613 : efrank 1.1 sub rightArrow {
614 :     my($gd,$ismap,$y,$begOP,$endOP,$color,$obj_half_heigth) = @_;
615 : parrello 1.15 Trace("Right Arrow begOP = $begOP, endOP = $endOP, color = $color, OHH = $obj_half_heigth.") if T(4);
616 : efrank 1.1 my @poly = ();
617 :    
618 :     if (($endOP - $begOP) <= (2 * $obj_half_heigth))
619 :     {
620 : parrello 1.18 push(@poly,[$endOP,$y]);
621 :     push(@poly,[$begOP,$y+(2 * $obj_half_heigth)]);
622 :     push(@poly,[$begOP,$y-(2 * $obj_half_heigth)]);
623 : efrank 1.1 }
624 :     else
625 :     {
626 : parrello 1.18 push(@poly,[$endOP,$y]);
627 :     push(@poly,[$endOP-(2 * $obj_half_heigth),$y+(2 * $obj_half_heigth)]);
628 :     push(@poly,[$endOP-(2 * $obj_half_heigth),$y+$obj_half_heigth]);
629 :     push(@poly,[$begOP,$y+$obj_half_heigth]);
630 :     push(@poly,[$begOP,$y-$obj_half_heigth]);
631 :     push(@poly,[$endOP-(2 * $obj_half_heigth),$y-$obj_half_heigth]);
632 :     push(@poly,[$endOP-(2 * $obj_half_heigth),$y-(2 * $obj_half_heigth)]);
633 : efrank 1.1 }
634 :     &render_poly($gd,$y,\@poly,$color);
635 :     push(@$ismap,[[$begOP,$y-$obj_half_heigth],[$endOP,$y+$obj_half_heigth]]);
636 :     }
637 :    
638 :     sub leftArrow {
639 :     my($gd,$ismap,$y,$begOP,$endOP,$color,$obj_half_heigth) = @_;
640 : parrello 1.15 Trace("Left Arrow begOP = $begOP, endOP = $endOP, color = $color, OHH = $obj_half_heigth.") if T(4);
641 : efrank 1.1 my @poly;
642 :    
643 :     if (($endOP - $begOP) <= (2 * $obj_half_heigth))
644 :     {
645 : parrello 1.18 push(@poly,[$begOP,$y]);
646 :     push(@poly,[$endOP,$y+(2 * $obj_half_heigth)]);
647 :     push(@poly,[$endOP,$y-(2 * $obj_half_heigth)]);
648 : efrank 1.1 }
649 :     else
650 :     {
651 : parrello 1.18 push(@poly,[$begOP,$y]);
652 :     push(@poly,[$begOP+(2 * $obj_half_heigth),$y+(2 * $obj_half_heigth)]);
653 :     push(@poly,[$begOP+(2 * $obj_half_heigth),$y+$obj_half_heigth]);
654 :     push(@poly,[$endOP,$y+$obj_half_heigth]);
655 :     push(@poly,[$endOP,$y-$obj_half_heigth]);
656 :     push(@poly,[$begOP+(2 * $obj_half_heigth),$y-$obj_half_heigth]);
657 :     push(@poly,[$begOP+(2 * $obj_half_heigth),$y-(2 * $obj_half_heigth)]);
658 : efrank 1.1 }
659 :     &render_poly($gd,$y,\@poly,$color);
660 :     push(@$ismap,[[$begOP,$y-$obj_half_heigth],[$endOP,$y+$obj_half_heigth]]);
661 :     }
662 :    
663 :     sub render_poly {
664 :     my($gd,$y,$poly,$color) = @_;
665 :     my($pt);
666 :    
667 :     my $GDpoly = new GD::Polygon;
668 :    
669 :     foreach $pt (@$poly)
670 :     {
671 : parrello 1.18 my($x,$y) = @$pt;
672 :     $GDpoly->addPt($x,$y);
673 : efrank 1.1 }
674 :    
675 :     $gd->filledPolygon($GDpoly,$color);
676 :     }
677 :    
678 :    
679 :     sub write_image {
680 :     my($gd,$file) = @_;
681 : parrello 1.15 open(TMPXXJPEG,">$file")
682 : parrello 1.18 || die "could not open $file";
683 : parrello 1.15 binmode(TMPXXJPEG);
684 : olson 1.20 print TMPXXJPEG $gd->$image_type;
685 : parrello 1.15 close(TMPXXJPEG);
686 : olson 1.4 chmod 0777,$file;
687 : efrank 1.1 }
688 :    
689 : golsen 1.12
690 : efrank 1.1 sub generate_html {
691 : golsen 1.12 my( $ismap, $gif, $ggR, $img ) = @_;
692 :     my( $map, $i, $submap, $object, $link, $tip, $menu, $coords, $title, $java, $tag );
693 : efrank 1.1
694 :     my $html = [];
695 :     my $map_name = "map_table_$$" . "_$img";
696 : golsen 1.12
697 :     push @$html, qq(<img src="$gif" usemap="#$map_name" border=0>\n),
698 :     qq(<map name="$map_name">\n);
699 : efrank 1.1
700 : golsen 1.12 foreach $map ( @$ggR )
701 : efrank 1.1 {
702 : parrello 1.18 # Allow links to the text titles -- GJO
703 : golsen 1.14
704 :     my $text = $map->[0];
705 : parrello 1.18 if ( ref( $text ) eq "ARRAY" && ( $coords = $ismap->{$map} ) )
706 :     {
707 :     ( $text, $link, $tip, $menu, $title ) = @$text;
708 :     if ( ( $text =~ /\S/ ) && ( $link || $tip || $menu ) )
709 :     {
710 :     $coords = join( ",", map {@$_} @{$coords} );
711 :     $title ||= "Info";
712 : olson 1.20 $java = ( $tip || $menu ) ? &SeedHTML::mouseover( $title, $tip, $menu )
713 : parrello 1.18 : undef;
714 :    
715 :     $tag = qq(<area shape="rect" coords="$coords")
716 :     . ( $link ? qq( href="$link") : () )
717 :     . ( $java ? qq( $java) : () )
718 :     . qq(>\n);
719 :     push @$html, $tag;
720 :     }
721 :     }
722 :    
723 :     foreach $submap ( @{$map->[3]} )
724 :     {
725 :     foreach $object ( @$submap )
726 :     {
727 :     $link = $object->[5]; # Usual html link
728 :     $tip = $object->[6]; # html text that is displayed on mouseover
729 :     $menu = $object->[7]; # Context menu. Do not follow the href on
730 :     # click, put $object->[7] html in a box
731 :     $title = $object->[8]; # Alternative to "Peg info" title text
732 :     # (not everything is a Peg!)
733 :    
734 :     if ( ( $link || $tip || $menu ) && ( $coords = $ismap->{$object} ) )
735 :     {
736 :     $coords = join( ",", map {@$_} @{$coords} );
737 :     $title ||= "Peg info";
738 : olson 1.20 $java = ( $tip || $menu ) ? &SeedHTML::mouseover( $title, $tip, $menu )
739 : parrello 1.18 : undef;
740 :    
741 :     $tag = qq(<area shape="rect" coords="$coords")
742 :     . ( $link ? qq( href="$link") : () )
743 :     . ( $java ? qq( $java) : () )
744 :     . qq(>\n);
745 :     push @$html, $tag;
746 :     }
747 :     }
748 :     }
749 : efrank 1.1 }
750 : golsen 1.12
751 :     push @$html, "</map>\n";
752 : efrank 1.1 return $html;
753 :     }
754 :    
755 : golsen 1.12
756 : overbeek 1.8 sub disambiguate_maps {
757 :     my($gg) = @_;
758 :     my($map,$id,%seen);
759 :    
760 :     foreach $map (@$gg)
761 :     {
762 : parrello 1.18 $id = ref( $map->[0] ) ? $map->[0]->[0] : $map->[0];
763 :     while ($seen{$id})
764 :     {
765 :     if ($id =~ /^(.*)\*(\d+)$/)
766 :     {
767 :     $id = $1 . "*" . ($2 + 1);
768 :     }
769 :     else
770 :     {
771 :     substr($id,-2) = "*0";
772 :     }
773 :     }
774 :     $seen{$id} = 1;
775 :     if ( ref( $map->[0] ) ) { $map->[0]->[0] = $id } else { $map->[0] = $id }
776 : overbeek 1.8 }
777 :     }
778 :    
779 : efrank 1.1 1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3