Parent Directory
| 
Revision Log
cosmetic change -- brings this in line with gage_dev
1 2 # this module holds the graph. Several functions 3 # and labels may be plotted on 4 # the graph. 5 6 # constructor new WWPlot(300,400) constructs an image of width 300 by height 400 pixels 7 # plot->imageName gives the image's name 8 9 10 =head1 NAME 11 12 WWPlot 13 14 =head1 SYNPOSIS 15 16 17 $graph = new WWPlot(400,400); # creates a graph 400 pixels by 400 pixels 18 $graph->fn($fun1, $fun2); # installs functions $fun1 and $fun2 in $graph 19 $image_binary = $graph->draw(); # creates the gif/png image of the functions installed in the graph 20 21 =head1 DESCRIPTION 22 23 This module creates a graph object -- a canvas on which to draw functions, labels, and other symbols. 24 The graph can be drawn with an axis, with a grid, and/or with an axis with tick marks. 25 The position of the axes and the granularity of the grid and tick marks can be specified. 26 27 =head2 new 28 29 $graph = new WWPlot(400,400); 30 31 Creates a graph object 400 pixels by 400 pixels. The size is required. 32 33 34 35 36 =head2 Methods and properties 37 38 =over 4 39 40 =item xmin, xmax, ymin, ymax 41 42 These determine the world co-ordinates of the graph. The constructions 43 44 $new_xmin = $graph->xmin($new_xmin); 45 and 46 $current_xmin = $graph->xmin(); 47 48 set and read the values. 49 50 =item fn, lb, stamps 51 52 These arrays contain references to the functions (fn), the labels (lb) and the stamped images (stamps) such 53 as open or closed circles which will drawn when the graph is asked to draw itself. Since each of these 54 objects is expected to draw itself, there is not a strong difference between the different arrays of objects. 55 The principle difference is the order in which they are drawn. The axis and grids are drawn first, followed 56 by the functions, then the labels, then the stamps. 57 58 You can add a function with either of the commands 59 60 @fn = $graph->fn($new_fun_ref1, $new_fun_ref2); 61 @fn = $graph->install($new_fun_ref1, $new_fun_ref2); 62 63 the constructions for labels and stamps are respectively: 64 65 @labels = $graph->lb($new_label); 66 @stamps = $graph->stamps($new_stamp); 67 68 while 69 70 @functions = $graph->fn(); 71 72 will give a list of the current functions (similary for labels and stamps). 73 74 Either of the commands 75 76 $graph->fn('reset'); 77 $graph->fn('erase'); 78 79 will erase the array containing the functions and similary for the label and stamps arrays. 80 81 82 =item h_axis, v_axis 83 84 $h_axis_coordinate = $graph -> h_axis(); 85 $new_axis = $grpah -> h_axis($new_axis); 86 87 Respectively read and set the vertical coordinate value in real world coordinates where the 88 horizontal axis intersects the vertical one. The same construction reads and sets the coordinate 89 value for the vertical axis. The axis is drawn more darkly than the grids. 90 91 =item h_ticks, v_ticks 92 93 @h_ticks = $graph -> h_ticks(); 94 @h_ticks = $graph -> h_ticks( $tick1, $tick2, $tick3, $tick4 ); 95 96 reads and sets the coordinates for the tick marks along the horizontal axis. The values 97 $tick1, etc are the real world coordinate values for each of the tick marks. 98 99 =item h_grid, v_grid 100 101 @h_grid = $graph -> h_grid(); 102 @h_grid = $graph -> h_grid( $grid1, $grid2, $grid3, $grid4 ); 103 104 reads and sets the verical coordinates for the horizontal grid lines. The values 105 $grid1, etc are the real world coordinate values where the horizontal grid meets the 106 vertical axis. 107 108 =item draw 109 110 $image = $graph ->draw(); 111 112 Draws the image of the graph. 113 114 =item size 115 116 ($horizontal_pixels, $vertical_pixels) = @{$graph ->size()}; 117 118 Reads the size of the graph image in pixels. This cannot be reset. It is defined by 119 the new constructor and cannot be changed. 120 121 =item colors 122 123 %colors =$graph->colors(); 124 125 Returns the hash containing the colors known to the graph. The keys are the names of the 126 colors and the values are the color indices used by the graph. 127 128 =item new_color 129 130 $graph->new_color('white', 255,255,255); 131 132 defines a new color named white with red, green and blue densities 255. 133 134 =item im 135 136 $GD_image = $graph->im(); 137 138 Allows access to the GD image object contained in the graph object. You can use this 139 to access methods defined in GD but not supported directly by WWPlot. (See the documentation 140 for GD.) 141 142 =item moveTo, lineTo, arrowTo 143 144 $graph->moveTo($x,$y); 145 $graph->lineTo($x,$y,$color); 146 $graph->lineTo($x,$y,$color,$thickness); 147 $graph->lineTo($x,$y,$color,$thickness,'dashed'); 148 $graph->arrowTo($x,$y,$color); 149 $graph->arrowTo($x,$y,$color,$thickness); 150 $graph->arrowTo($x,$y,$color,$thickness,'dashed'); 151 152 Moves to the point ($x, $y) (defined in real world coordinates) or draws a line or arrow 153 from the current position to the specified point ($x, $y) using the color $color. $color 154 is the name, e.g. 'white', of the color, not an index value or RGB specification. 155 $thickness gives the thickness of the line or arrow to draw. If 'dashed' is specified, 156 the line or arrow is rendered with a dashed line. These are low level call 157 back routines used by the function, label and stamp objects to draw themselves. 158 159 =item ii, jj 160 161 These functions translate from real world to pixel coordinates. 162 163 $pixels_down_from_top = $graph -> jj($y); 164 165 166 =back 167 168 =cut 169 170 BEGIN { 171 be_strict(); # an alias for use strict. This means that all global variable must contain main:: as a prefix. 172 173 } 174 package WWPlot; 175 176 177 #use Exporter; 178 #use DynaLoader; 179 #use GD; 180 181 @WWPlot::ISA=undef; 182 $WWPlot::AUTOLOAD = undef; 183 @WWPlot::ISA = qw(GD PGcore); 184 185 186 if ( $GD::VERSION > '1.20' ) { 187 $WWPlot::use_png = 1; # in version 1.20 and later of GD, gif's are not supported by png files are 188 # This only affects the draw method. 189 } else { 190 $WWPlot::use_png = 0; 191 } 192 193 my $last_image_number=0; #class variable. Keeps track of how many images have been made. 194 195 196 197 my %fields = ( # initialization only!!! 198 xmin => -1, 199 xmax => 1, 200 ymin => -1, 201 ymax => 1, 202 imageName => undef, 203 position => undef, #used internally in the draw routine lineTo 204 ); 205 206 207 208 sub new { 209 my $class =shift; 210 my @size = @_; # the dimensions in pixels of the image 211 my $self = { im => new GD::Image(@size), 212 %fields, 213 size => [@size], 214 fn => [], 215 fillRegion => [], 216 lb => [], 217 stamps => [], 218 colors => {}, 219 hticks => [], 220 vticks => [], 221 hgrid => [], 222 vgrid => [], 223 haxis => [], 224 vaxis => [], 225 226 227 }; 228 229 bless $self, $class; 230 $self -> _initialize; 231 return $self; 232 } 233 234 # access methods for function list, label list and image 235 sub fn { 236 my $self = shift; 237 238 if (@_ == 0) { 239 # do nothing if input is empty 240 } elsif ($_[0] eq 'reset' or $_[0] eq 'erase' ) { 241 $self->{fn} = []; 242 } else { 243 push(@{$self->{fn}},@_) if @_; 244 } 245 @{$self->{fn}}; 246 } 247 # access methods for fillRegion list, label list and image 248 sub fillRegion { 249 my $self = shift; 250 251 if (@_ == 0) { 252 # do nothing if input is empty 253 } elsif ($_[0] eq 'reset' or $_[0] eq 'erase' ) { 254 $self->{fillRegion} = []; 255 } else { 256 push(@{$self->{fillRegion}},@_) if @_; 257 } 258 @{$self->{fillRegion}}; 259 } 260 261 sub install { # synonym for installing a function 262 fn(@_); 263 } 264 265 sub lb { 266 my $self = shift; 267 if (@_ == 0) { 268 # do nothing if input is empty 269 } elsif ($_[0] eq 'reset' or $_[0] eq 'erase' ) { 270 $self->{lb} = []; 271 } else { 272 push(@{$self->{lb}},@_) if @_; 273 } 274 275 @{$self->{lb}}; 276 } 277 278 sub stamps { 279 my $self = shift; 280 if (@_ == 0) { 281 # do nothing if input is empty 282 } elsif ($_[0] eq 'reset' or $_[0] eq 'erase' ) { 283 $self->{stamps} = []; 284 } else { 285 push(@{$self->{stamps}},@_) if @_; 286 } 287 288 @{$self->{stamps}}; 289 } 290 sub colors { 291 my $self = shift; 292 $self -> {colors} ; 293 } 294 295 sub new_color { 296 my $self = shift; 297 my ($color,$r,$g,$b) = @_; 298 $self->{'colors'}{$color} = $self->im->colorAllocate($r, $g, $b); 299 } 300 sub im { 301 my $self = shift; 302 $self->{im}; 303 } 304 sub gifName { # This is yields backwards compatibility. 305 my $self = shift; 306 $self->imageName(@_); 307 } 308 sub pngName { # It is better to use the method imageName. 309 my $self = shift; 310 $self->imageName(@_); 311 } 312 sub size { 313 my $self = shift; 314 $self ->{size}; 315 } 316 317 sub _initialize { 318 my $self = shift; 319 $self->{position} = [0,0]; 320 # $self->{width} = $self->{'size'}[0]; # original height and width tags match pixel dimensions 321 # $self->{height} = $self->{'size'}[1]; # of the image 322 # allocate some colors 323 $self->{'colors'}{'background_color'} = $self->im->colorAllocate(255,255,255); 324 $self->{'colors'}{'default_color'} = $self->im->colorAllocate(0,0,0); 325 $self->{'colors'}{'white'} = $self->im->colorAllocate(255,255,255); 326 $self->{'colors'}{'black'} = $self->im->colorAllocate(0,0,0); 327 $self->{'colors'}{'red'} = $self->im->colorAllocate(255,0,0); 328 $self->{'colors'}{'green'} = $self->im->colorAllocate(0,255,0); 329 $self->{'colors'}{'blue'} = $self->im->colorAllocate(0,0,255); 330 $self->{'colors'}{'yellow'} = $self->im->colorAllocate(255,255,0); 331 $self->{'colors'}{'orange'} = $self->im->colorAllocate(255,100,0); 332 $self->{'colors'}{'gray'} = $self->im->colorAllocate(180,180,180); 333 $self->{'colors'}{'nearwhite'} = $self->im->colorAllocate(254,254,254); 334 # obtain a new imageNumber; 335 $self->{imageNumber} = ++$last_image_number; 336 } 337 338 # reference shapes 339 # closed circle 340 # open circle 341 342 # The translation subroutines. 343 344 sub ii { 345 my $self = shift; 346 my $x = shift; 347 return undef unless defined($x); 348 my $xmax = $self-> xmax ; 349 my $xmin = $self-> xmin ; 350 int( ($x - $xmin)*(@{$self->size}[0]) / ($xmax - $xmin) ); 351 } 352 353 sub jj { 354 my $self = shift; 355 my $y = shift; 356 return undef unless defined($y); 357 my $ymax = $self->ymax; 358 my $ymin = $self->ymin; 359 #print "ymax=$ymax y=$y ymin=$ymin size=",${$self->size}[1],"<BR><BR><BR><BR>"; 360 int( ($ymax - $y)*${$self->size}[1]/($ymax-$ymin) ); 361 } 362 363 # The move and draw subroutines. Arguments are in real world coordinates. 364 365 sub lineTo { 366 my $self = shift; 367 my ($x,$y,$color, $w, $d) = @_; 368 $w = 1 if ! defined( $w ); 369 $d = 0 if ! defined( $d ); ## draw a dashed line? 370 371 $x=$self->ii($x); 372 $y=$self->jj($y); 373 $color = $self->{'colors'}{$color} if $color=~/[A-Za-z]+/ && defined($self->{'colors'}{$color}) ; # colors referenced by name works here. 374 $color = $self->{'colors'}{'default_color'} unless defined($color); 375 376 $self->im->setThickness( $w ); 377 if ( $d ) { 378 my @dashing = ( $color )x(4*$w*$w); 379 my @spacing = ( GD::gdTransparent )x(3*$w*$w); 380 $self->im->setStyle( @dashing, @spacing ); 381 $self->im->line(@{$self->position},$x,$y,GD::gdStyled); 382 } else { 383 $self->im->line(@{$self->position},$x,$y,$color); 384 } 385 $self->im->setThickness( 1 ); 386 #warn "color is $color"; 387 @{$self->position} = ($x,$y); 388 } 389 390 sub moveTo { 391 my $self = shift; 392 my $x=shift; 393 my $y=shift; 394 $x=$self->ii($x); 395 $y=$self->jj($y); 396 #print "moving to $x,$y<BR>"; 397 @{$self->position} = ( $x,$y ); 398 } 399 400 sub arrowTo { 401 my $self = shift; 402 my ( $x1, $y1, $color, $w, $d ) = @_; 403 $w = 1 if ! defined( $w ); 404 $d = 0 if ! defined( $d ); 405 my $width = ( $w == 1 ) ? 2 : $w; 406 407 $x1 = $self->ii($x1); 408 $y1 = $self->jj($y1); 409 $color = $self->{'colors'}{$color} if $color=~/[A-Za-z]+/ && defined($self->{'colors'}{$color}) ; 410 $color = $self->{'colors'}{'default_color'} unless defined($color); 411 412 ## set thickness 413 $self->im->setThickness($w); 414 415 my ($x0, $y0) = @{$self->position}; 416 my $dx = $x1 - $x0; 417 my $dy = $y1 - $y0; 418 my $len = sqrt($dx*$dx + $dy*$dy); 419 my $ux = $dx/$len; ## a unit vector in the direction of the arrow 420 my $uy = $dy/$len; 421 my $px = -1*$uy; ## a unit vector perpendicular 422 my $py = $ux; 423 my $hbx = $x1 - 5*$width*$ux; ## the base of the arrowhead 424 my $hby = $y1 - 5*$width*$uy; 425 my $head = new GD::Polygon; 426 $head->addPt($x1,$y1); 427 $head->addPt($hbx + 2*$width*$px, $hby + 2*$width*$py); 428 $head->addPt($hbx - 2*$width*$px, $hby - 2*$width*$py); 429 $self->im->filledPolygon( $head, $color ); 430 if ( $d ) { 431 my @dashing = ( $color )x(4*$w*$w); 432 my @spacing = ( GD::gdTransparent )x(3*$w*$w); 433 $self->im->setStyle( @dashing, @spacing ); 434 $self->im->line( $x0,$y0,$x1,$y1,GD::gdStyled); 435 } else { 436 $self->im->line( $x0,$y0,$x1,$y1,$color ); 437 } 438 439 @{$self->position} = ( $x1, $y1 ); 440 441 ## reset thickness 442 $self->im->setThickness(1); 443 } 444 445 446 sub v_axis { 447 my $self = shift; 448 @{$self->{vaxis}}=@_; # y_value, color 449 } 450 sub h_axis { 451 my $self = shift; 452 @{$self->{haxis}}=@_; # x_value, color 453 } 454 sub h_ticks { 455 my $self = shift; 456 my $nudge =2; 457 push(@{$self->{hticks}},$nudge,@_); # y-value, color, tick x-values. see save_image subroutine 458 459 } 460 sub v_ticks { 461 my $self = shift; 462 my $nudge =2; 463 push(@{$self->{vticks}},$nudge,@_); # x-value, color, tick y-values. see save_image subroutine 464 465 } 466 sub h_grid { 467 my $self = shift; 468 push(@{$self->{hgrid}}, @_ ); #color, grid y values 469 } 470 sub v_grid { 471 my $self = shift; 472 push(@{$self->{vgrid}},@_ ); #color, grid x values 473 } 474 475 476 477 sub draw { 478 my $self = shift; 479 my $im =$self->{'im'}; 480 my @size = @{$self->size}; 481 my %colors =%{$self->colors}; 482 483 # make the background transparent and interlaced 484 # $im->transparent($colors{'white'}); 485 $im->interlaced('true'); 486 487 # Put a black frame around the picture 488 $im->rectangle(0,0,$size[0]-1,$size[1]-1,$colors{'black'}); 489 490 # draw functions 491 492 foreach my $f ($self->fn) { 493 #$self->draw_function($f); 494 $f->draw($self); # the graph is passed to the function so that the label can call back as needed. 495 } 496 # and fill the regions 497 foreach my $r ($self->fillRegion) { 498 my ($x,$y,$color_name) = @{$r}; 499 my $color = ${$self->colors}{$color_name}; 500 $self->im->fill($self->ii($x),$self->jj($y),$color); 501 } 502 503 #draw hticks 504 my $tk; 505 my @ticks = @{$self->{hticks}}; 506 if (@ticks) { 507 my $nudge = shift(@ticks); 508 my $j = $self->jj(shift(@ticks)); 509 my $tk_clr= $self->{'colors'}{shift(@ticks)}; 510 511 foreach $tk (@ticks) { 512 $tk = $self->ii($tk); 513 # print "tk=$tk\n"; 514 $self->im->line($tk,$j+int($nudge),$tk,$j-int($nudge),$tk_clr); 515 } 516 } 517 #draw vticks 518 @ticks = @{$self->{vticks}}; 519 if (@ticks) { 520 my $nudge = shift(@ticks); 521 my $i = $self->ii(shift(@ticks)); 522 my $tk_clr= $self->{'colors'}{shift(@ticks)}; 523 524 foreach $tk (@ticks) { 525 $tk = $self->jj($tk); 526 # print "tk=$tk\n"; 527 $self->im->line($i+int($nudge),$tk,$i-int($nudge),$tk,$tk_clr); 528 } 529 } 530 #draw vgrid 531 532 my @grid = @{$self->{vgrid}}; 533 if (@grid) { 534 my $x_value; 535 my $grid_clr= $self->{'colors'}{shift(@grid)}; 536 537 foreach $x_value (@grid) { 538 $x_value = $self->ii($x_value); # scale 539 #print "grid_line=$grid_line\n"; 540 $self->im->dashedLine($x_value,0,$x_value,$self->{'size'}[1],$grid_clr); 541 } 542 } 543 #draw hgrid 544 @grid = @{$self->{hgrid}}; 545 if (@grid) { 546 my $grid_clr= $self->{'colors'}{shift(@grid)}; 547 my $y_value; 548 foreach $y_value (@grid) { 549 $y_value = $self->jj($y_value); 550 #print "y_value=$y_value\n"; 551 #print "width= $self->{width}\n"; 552 $self->im->dashedLine(0,$y_value,$self->{'size'}[0],$y_value,$grid_clr); 553 } 554 } 555 # draw axes 556 if (defined ${$self->{vaxis}}[0]) { 557 my ($x, $color_name) = @{$self->{vaxis}}; 558 my $color = ${$self->colors}{$color_name}; 559 $self->moveTo($x,$self->ymin); 560 $self->lineTo($x,$self->ymax,$color); 561 #print "draw vaxis", @{$self->{vaxis}},"\n"; 562 #$self->im->line(0,0,300,300,$color); 563 } 564 if (defined $self->{haxis}[0]) { 565 my ($y, $color_name) = @{$self->{haxis}}; 566 my $color = ${$self->colors}{$color_name}; 567 $self->moveTo($self->xmin,$y); 568 $self->lineTo($self->xmax,$y,$color); 569 #print "draw haxis", @{$self->{haxis}},"\n"; 570 } 571 # draw functions again 572 573 foreach my $f ($self->fn) { 574 #$self->draw_function($f); 575 $f->draw($self); # the graph is passed to the function so that the label can call back as needed. 576 } 577 578 579 #draw labels 580 my $lb; 581 foreach $lb ($self->lb) { 582 $lb->draw($self); # the graph is passed to the label so that the label can call back as needed. 583 } 584 #draw stamps 585 my $stamp; 586 foreach $stamp ($self->stamps) { 587 $stamp->draw($self); # the graph is passed to the label so that the label can call back as needed. 588 } 589 my $out; 590 if ($WWPlot::use_png) { 591 $out = $im->png; 592 } else { 593 $out = $im->gif; 594 } 595 $out; 596 597 } 598 599 600 601 # sub AUTOLOAD { 602 # my $self = shift; 603 # my $type = ref($self) || die "$self is not an object"; 604 # my $name = $WWPlot::AUTOLOAD; 605 # $name =~ s/.*://; # strip fully-qualified portion 606 # unless (exists $self->{'_permitted'}->{$name} ) { 607 # die "Can't find '$name' field in object of class $type"; 608 # } 609 # if (@_) { 610 # return $self->{$name} = shift; 611 # } else { 612 # return $self->{$name}; 613 # } 614 # 615 # } 616 ########################## 617 # Access methods 618 ########################## 619 sub ymin { 620 my $self = shift; 621 my $type = ref($self) || die "$self is not an object"; 622 unless (exists $self->{ymin} ) { 623 die "Can't find ymin field in object of class $type"; 624 } 625 626 if (@_) { 627 return $self->{ymin} = shift; 628 } else { 629 return $self->{ymin} 630 } 631 } 632 633 sub xmin { 634 my $self = shift; 635 my $type = ref($self) || die "$self is not an object"; 636 unless (exists $self->{xmin} ) { 637 die "Can't find xmin field in object of class $type"; 638 } 639 640 if (@_) { 641 return $self->{xmin} = shift; 642 } else { 643 return $self->{xmin} 644 } 645 } 646 647 sub xmax { 648 my $self = shift; 649 my $type = ref($self) || die "$self is not an object"; 650 unless (exists $self->{xmax} ) { 651 die "Can't find xmax field in object of class $type"; 652 } 653 654 if (@_) { 655 return $self->{xmax} = shift; 656 } else { 657 return $self->{xmax} 658 } 659 } 660 661 sub ymin { 662 my $self = shift; 663 my $type = ref($self) || die "$self is not an object"; 664 unless (exists $self->{ymin} ) { 665 die "Can't find ymin field in object of class $type"; 666 } 667 668 if (@_) { 669 return $self->{ymin} = shift; 670 } else { 671 return $self->{ymin} 672 } 673 } 674 675 sub ymax { 676 my $self = shift; 677 my $type = ref($self) || die "$self is not an object"; 678 unless (exists $self->{ymax} ) { 679 die "Can't find ymax field in object of class $type"; 680 } 681 682 if (@_) { 683 return $self->{ymax} = shift; 684 } else { 685 return $self->{ymax} 686 } 687 } 688 689 sub imageName { 690 my $self = shift; 691 my $type = ref($self) || die "$self is not an object"; 692 unless (exists $self->{imageName} ) { 693 die "Can't find imageName field in object of class $type"; 694 } 695 696 if (@_) { 697 return $self->{imageName} = shift; 698 } else { 699 return $self->{imageName} 700 } 701 } 702 703 sub position { 704 my $self = shift; 705 my $type = ref($self) || die "$self is not an object"; 706 unless (exists $self->{position} ) { 707 die "Can't find position field in object of class $type"; 708 } 709 710 if (@_) { 711 return $self->{position} = shift; 712 } else { 713 return $self->{position} 714 } 715 } 716 sub DESTROY { 717 # doing nothing about destruction, hope that isn't dangerous 718 } 719 720 sub save_image { 721 my $self = shift; 722 warn "The method save_image is no longer supported. Use insertGraph(\$graph)"; 723 "The method save_image is no longer supported. Use insertGraph(\$graph)"; 724 } 725 726 727 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |