1package Starlink::AST::Tk; 2 3=head1 NAME 4 5Starlink::AST::Tk - AST wrapper to the Tk library 6 7=head1 SYNOPSIS 8 9 use Starlink::AST::Tk 10 11The main methods which need to be registered with the AST package 12are shown below, 13 14 $status = _GFlush( $w ); 15 $status = _GLine( $w, \@x, \@y ); 16 $status = _GMark( $w, \@x, \@y, $type ); 17 $status = _GText( $w, $text, $x, $y, $just, $upx, $upy ); 18 ( $status, $xb, $yb ) = _GTxtExt( $w, $text, $x, $y, $just, $upx, $upy ); 19 ( $status, $chv, $chh ) = _GQch( $w ); 20 ( $status, $old_value ) = _GAttr( $w, $attr, $value, $prim ); 21 22The following helper methods are also provided, 23 24 my ( $status, $alpha, $beta ) = _GScales( $w ) 25 26=head1 DESCRIPTION 27 28This file implements the low level graphics functions required by the 29rest of AST, by calling suitable Tk::Canvas or Tk::Zinc functions. In 30all the routines $w is a reference to the Tk::Canvas or Tk::Zinc 31object on which we're plotting. 32 33=head1 NOTES 34 35All the functions in this module are private, and are intended to be called 36from the AST module. None of these functions should be considered to be part 37of the packages public interface. 38 39=head1 REVISION 40 41$Id$ 42 43=cut 44 45use strict; 46use vars qw/ $VERSION /; 47use constant R2D => 57.29578; # Radians to degrees factor 48use constant FLT_MAX => 3.40282347e+38; # Maximum float on ix86 platform 49 50use Tk; 51use Tk::Font; 52use Starlink::AST; 53use Carp; 54use Data::Dumper; 55 56$VERSION = '2.00'; 57 58# Constants describing locations in the external array 59use constant EXT_ATTR => 9; 60 61# reference height for characters as a fraction of the 62# full height/width of the display 63use constant DEFAULT_CHAR_HEIGHT => 1 / 40; 64 65# Tk::Zinc drawing objects need a group number. Not sure if we need to 66# get complicated with groups, so, for now, use the root group, which 67# is 1. 68use constant TK_ZINC_GROUP => 1; 69 70# Static look up tables mapping AST index to Tk equivalent 71# Note that the "black" and "white" entries are really default 72# background + foreground 73# They should be obtained from the canvas itself 74my @COLOURS = qw( black 75 white 76 red 77 green 78 blue 79 cyan 80 magenta 81 yellow 82 orange 83 chartreuse 84 springgreen 85 skyblue 86 purple 87 pink 88 darkgrey 89 grey 90 ); 91 92# Line style specification depends on whether the canvas is a 93# Tk::Canvas widget or a Tk::Zinc widget. 94my %LINE_STYLES = ( 95# Line styles for Tk::Canvas are 96# solid, long dashes, dash-dot-dash-dot, dotted and dash-dot-dot-dot. 97 'Tk::Canvas' => [undef, 98 undef, # default is solid 99 '-', 100 '-.', 101 '..', 102 '-...'], 103# Line styles for Tk::Zinc are simple (solid), dashed, mixed 104# (dash-dot-dash-dot), and dotted. Tk::Zinc does not support 105# dash-dot-dot-dot, so just use mixed for that case. 106 'Tk::Zinc' => [undef, 107 undef, # default is solid 108 'dashed', 109 'mixed', 110 'dotted', 111 'mixed'] 112 ); 113 114# Look up from AST attribute number to Attribute hash key 115my %GRF_PRIM = ( 116 &Starlink::AST::Grf::GRF__LINE() => 'LINE', 117 &Starlink::AST::Grf::GRF__MARK() => 'MARK', 118 &Starlink::AST::Grf::GRF__TEXT() => 'TEXT', 119 ); 120 121# Similarly for style 122my %GRF_STYLE = ( 123 &Starlink::AST::Grf::GRF__STYLE() => 'STYLE', 124 &Starlink::AST::Grf::GRF__WIDTH() => 'WIDTH', 125 &Starlink::AST::Grf::GRF__SIZE() => 'SIZE', 126 &Starlink::AST::Grf::GRF__FONT() => 'FONT', 127 &Starlink::AST::Grf::GRF__COLOUR() => 'COLOUR', 128 ); 129 130# Text Anchors 131# points on a compass except no rotation is allowed 132my @AnchorPoints = qw/ n ne e se s sw w ne /; 133my @AnchorAng = qw/ 0 45 90 135 180 225 270 315 /; 134my %Text_Anchors = ( 135 'CC' => 'center', 136 'CL' => 'w', 137 'CR' => 'e', 138 139 'TC' => 'n', 140 'TL' => 'nw', 141 'TR' => 'ne', 142 143 'BC' => 's', 144 'BL' => 'sw', 145 'BR' => 'se', 146 ); 147 148 149=head1 METHODS 150 151=over 4 152 153=item B<_GFlush> 154 155This function ensures that the display device is up-to-date, by flushing 156any pending graphics to the output device. 157 158 my $status = _GFlush( $w ); 159 160=cut 161 162sub _GFlush { 163 my $external = shift; 164 my $canvas = $$external[0]; 165 $canvas->update(); 166 return 1; 167} 168 169=item B<_GLine> 170 171This function displays lines joining the given positions. 172 173 my $status = _GLine( $w, \@x, \@y ); 174 175=cut 176 177sub _GLine { 178 my ( $external, $xf, $yf ) = @_; 179 my $canvas = $$external[0]; 180 181 #use Data::Dumper; 182 #print "\n# _GLine()\n"; 183 #print Dumper( $xf ) . "\n"; 184 #print Dumper( $yf ) . "\n"; 185 186 if( scalar(@$xf) > 1 && scalar(@$xf) == scalar(@$yf) ) { 187 188 # convert GRAPHICS coordinates to pixel coordinates 189 my @points = map { 190 _CooTranslate( $external, $xf->[$_], $yf->[$_]); 191 } ( 0.. $#$xf ); 192 193 # modifiers 194 my %opts; 195 196 # Now add additional style information 197 # colour 198 %opts = _attr_to_colour( $canvas, $external->[EXT_ATTR], 'LINE' ); 199 200 # line style 201 my $lindex = $external->[EXT_ATTR]->{LINE}->{STYLE}; 202 # For now, put a -lindex key in the %opts hash, if $lindex is 203 # defined. The _create_line function will translate the -lindex 204 # value into the correct option as required by Tk::Canvas or 205 # Tk::Zinc, depending on which type of widget we are working 206 # with. 207 $opts{'-lindex'} = $lindex if defined $lindex; 208 209 # a line width is in units of 1/200 in according to the PGPLOT 210 # standard 211 my $astwid = $external->[EXT_ATTR]->{LINE}->{WIDTH}; 212 my $width; 213 $width = ( $astwid / 200 ) . 'i' if defined $astwid; 214 $opts{'-width'} = $width if defined $width; 215 216 # and draw the line 217 my $t = _create_line( $canvas, $external, \@points, %opts ); 218 $canvas->addtag( 'ASTGLine', 'withtag', $t); 219 220 } 221 return 1; 222} 223 224=item B<_GMark> 225 226This function displays markers at the given positions. 227 228 my $status = _GMark( $w, \@x, \@y, $type ); 229 230where $type is an integer used to indicate the type of marker required. 231 232=cut 233 234sub _GMark { 235 my ($external, $xf, $yf, $type) = @_; 236 my $canvas = $$external[0]; 237 my $width = $canvas->cget( '-width' ); 238 239 #use Data::Dumper; 240 #print "\n# _GMark()\n"; 241 #print Dumper( $xf ) . "\n"; 242 #print Dumper( $yf ) . "\n"; 243 244 if( scalar(@$xf) && scalar(@$xf) == scalar(@$yf) ) { 245 246 my %opts; 247 %opts = _attr_to_colour( $canvas, $external->[EXT_ATTR], 'MARK'); 248 249 # Get the symbol size in pixels 250 my $size = _char_height( $canvas, $external->[EXT_ATTR], 'MARK'); 251 252 # and work out how the symbol should be displayed 253 254 # scale factor for some of the types 255 my $scale = 1; 256 257 my $prim; 258 my $fill = 0; 259 260 # Set parameters for duplicated symbols 261 if ($type == 0 || $type == 6 || $type == 19 || $type == 16) { 262 # squares of all types 263 $prim = 'square'; 264 if ($type == 19) { 265 $scale = 1.5; 266 } elsif ($type == 16) { 267 $scale = 0.5; 268 $fill = 1; 269 } 270 } elsif ($type == 1 || $type == 4 || $type == 17 || 271 ( $type >= 20 && $type <= 27)) { 272 $prim = 'circle'; 273 274 if ( $type == 1 ) { 275 $scale = 0.1; 276 } elsif ($type == 4 || $type == 23) { 277 $scale = 1; 278 } elsif ($type == 17) { 279 $scale = 0.75; 280 $fill = 1; 281 } elsif ($type == 20) { 282 $scale = 0.25; 283 } elsif ($type == 21) { 284 $scale = 0.5; 285 } elsif ($type == 22) { 286 $scale = 0.75; 287 } elsif ($type == 24) { 288 $scale = 1.5; 289 } elsif ($type == 25) { 290 $scale = 1.75; 291 } elsif ($type == 26) { 292 $scale = 2.0; 293 } elsif ($type == 27) { 294 $scale = 3.0; 295 } 296 297 } elsif ($type == 2 ) { 298 # cross 299 $prim = 'cross'; 300 } else { 301 # do not yet know how to render this. Default 302 $prim = 'circle'; 303 $scale = 1; 304 $fill = 1; 305 } 306 307 # Configure the fill color 308 if (!$fill) { 309 # by default the color to opt code uses -fill 310 # but we need to use -outline if fill is not specified 311 if (exists $opts{'-fill'}) { 312 $opts{'-outline'} = $opts{'-fill'}; 313 delete $opts{'-fill'}; 314 } 315 } 316 317 foreach my $i ( 0 ... $#$xf ) { 318 319 # convert to canvas coordinates 320 my ( $x, $y ) = _CooTranslate( $external, $xf->[$i], $yf->[$i]); 321 322 # now draw them 323 my $item; 324 if ($prim eq 'square') { 325 326 my $dist = $size * $scale / 2; 327 my $x1 = $x - $dist; 328 my $x2 = $x + $dist; 329 my $y1 = $y - $dist; 330 my $y2 = $y + $dist; 331 332 $item = _create_rectangle( $canvas, $external, $x1, $y1, $x2, $y2, %opts ); 333 334 } elsif ($prim eq 'circle') { 335 336 my $dist = $size * $scale / 2; 337 my $x1 = $x - $dist; 338 my $x2 = $x + $dist; 339 my $y1 = $y - $dist; 340 my $y2 = $y + $dist; 341 $item = _create_oval( $canvas, $external, $x1, $y1, $x2, $y2, %opts ); 342 343 344 } elsif ($prim eq 'cross') { 345 346 # we may have to respect line widths 347 my $dist = $size * $scale / 2; 348 my $x1 = $x - $dist; 349 my $x2 = $x + $dist; 350 my $y1 = $y - $dist; 351 my $y2 = $y + $dist; 352 353 $item = _create_line( $canvas, $external, [$x, $y1, $x, $y2], %opts ); 354 355 $canvas->addtag( 'ASTGMark', 'withtag', $item); 356 357 $item = _create_line( $canvas, $external, [$x1, $y, $x1, $y], %opts ); 358 359 360 361 } else { 362 # should not happen 363 ReportGrfError("_GMark: Bizarre inability to determine symbol type"); 364 return (0); 365 } 366 367 $canvas->addtag( 'ASTGMark', 'withtag', $item); 368 } 369 } 370 return 1; 371} 372 373=item B<_GText> 374 375This function displays a character string $text at a given position using 376a specified justification and up-vector. 377 378 my $status = _GText( $text, $x, $y, $just, $upx, $upy ); 379 380where $x is the reference x coordinate, $y is the reference y coordinate, 381and where $just is a character string which specifies the location within 382the text string which is to be placed at the reference position given by x 383and y. The first character may be 'T' for "top", 'C' for "centre", or 'B' 384for "bottom", and specifies the vertical location of the reference position. 385Note, "bottom" corresponds to the base-line of normal text. Some characters 386(eg "y", "g", "p", etc) descend below the base-line. The second character 387may be 'L' for "left", 'C' for "centre", or 'R' for "right", and specifies 388the horizontal location of the reference position. If the string has less 389than 2 characters then 'C' is used for the missing characters. 390 391And $upx is the x component of the up-vector for the text, in graphics 392world coordinates. If necessary the supplied value should be negated to 393ensure that positive values always refer to displacements from left to 394right on the screen. 395 396While $upy is the y component of the up-vector for the text, in graphics 397world coordinates. If necessary the supplied value should be negated to 398ensure that positive values always refer to displacements from bottom to 399top on the screen. 400 401Note that we match the PGPLOT definition of default character height. 402ie the default character height one-fortieth of the height or width of 403the view surface (whichever is less). 404 405An optional argument can be provided at the end of the argument list 406(AST will not do this). This should be a ref to a scalar. On return, 407it will contain the object that was just plotted. 408 409=cut 410 411sub _GText { 412 my ( $external, $text, $xf, $yf, $just, $upx, $upy, $ref ) = @_; 413 my $canvas = $$external[0]; 414 #print "# _GText: Placeholder routine called\n"; 415 416 #use Data::Dumper; 417 #print "\n# _GText( $text )\n"; 418 #print Dumper( $xf ) . "\n"; 419 #print Dumper( $yf ) . "\n"; 420 421 print "$text : $just \n" if $text =~ /decl/i; 422 423 if( defined $text && length($text) != 0 ) { 424 425 # work out the X and Y anchoring 426 my $xa = substr($just,1,1) || 'C'; 427 my $ya = substr($just,0,1) || 'C'; 428 429 # and reconstruct it 430 $just = $ya. $xa; 431 432 # option handling 433 my %opts; 434 %opts = _attr_to_colour( $canvas, $external->[EXT_ATTR], 'TEXT'); 435 436 # translate to the pixel coordinates 437 my ( $x, $y ) = _CooTranslate($external, $xf, $yf); 438 439 # Specify text anchor 440 $opts{'-anchor'} = ( exists $Text_Anchors{$just} ? 441 $Text_Anchors{$just} : $Text_Anchors{CC}); 442 443 444 # apply scaling 445 my $charh = _char_height( $canvas, $external->[EXT_ATTR], 'TEXT'); 446 447 # select the font object 448 my $fi = $external->[EXT_ATTR]->{TEXT}->{FONT}; 449 450 my %fontparams; 451 if ( exists $external->[EXT_ATTR]->{FONTS}->[$fi] ) { 452 %fontparams = %{ $external->[EXT_ATTR]->{FONTS}->[$fi] }; 453 } 454 455 # size in pixels is specified as negative number 456 my $font = $canvas->Font( %fontparams, '-size' => (-1 * $charh ) ); 457 458 # Add the font to the %opts hash 459 $opts{'-font'} = $font; 460 461 # draw text 462 my $item = _create_text( $canvas, $external, $text, $x, $y, $upx, $upy, %opts ); 463 464 $canvas->addtag( 'ASTGText', 'withtag', $item); 465 466 # if we have a scalar ref 467 $$ref = $item if defined $ref; 468 469 } 470 471 # Return, all is well strangely 472 return 1; 473} 474 475 476=item B<_GScales> 477 478This function returns two values (one for each axis) which scale 479increments on the corresponding axis into a "normal" coordinate system in 480which: The axes have equal scale in terms of (for instance) millimetres 481per unit distance, X values increase from left to right and the Y values 482increase from bottom to top. 483 484 my ( $status, $alpha, $beta ) = _GScales( $w ) 485 486=cut 487 488sub _GScales { 489 my ( $external, $alpha, $beta ) = @_; 490 #print "# _GScales: Placeholder routine called\n"; 491 my $canvas = $$external[0]; 492 my ($xglo,$xghi,$yglo,$yghi) = @$external[1 .. 4]; 493 my ($xplo,$xphi,$yplo,$yphi) = @$external[5 .. 8]; 494 my ($xmin,$xmax,$ymin,$ymax) = _CooBox($external); 495 496 my ($nx1, $nx2, $ny1, $ny2); 497 my ($wx1, $wx2, $wy1, $wy2); 498 499 $nx1 = $xmin; 500 $nx2 = $xmax; 501 $ny1 = $ymax; 502 $ny2 = $ymin; 503 504 $wx1 = $xglo; 505 $wx2 = $xghi; 506 $wy1 = $yghi; 507 $wy2 = $yglo; 508 509 if( $wx2 != $wx1 && $wy2 != $wy1 && $nx2 != $nx1 && $ny2 != $ny1 ) { 510 $alpha = ( $nx2 - $nx1 ) / ( $wx2 - $wx1 ); 511 $beta = ( $ny2 - $ny1 ) / ( $wy2 - $wy1 ); 512 } else { 513 ReportGrfError("_GScales: The graphics window has zero size"); 514 return (0); 515 } 516 return ( 1, $alpha, $beta ); 517} 518 519 520=item B<_GTxExt> 521 522This function returns the corners of a box which would enclose the 523supplied character string if it were displayed using astGText. The 524returned box INCLUDES any leading or trailing spaces. 525 526 my ( $status, $xb, $yb ) = _GTxExt( $w, $text, $x, $y, $just, $upx, $upy); 527 528where $x is the reference x coordinate, $y is the reference y coordinate, 529and where $justification is a character string which specifies the 530location within the text string which is to be placed at the reference 531position given by x and y. The first character may be 'T' for "top", 'C' 532for "centre", or 'B' for "bottom", and specifies the vertical location of 533the reference position. Note, "bottom" corresponds to the base-line of 534normal text. Some characters (eg "y", "g", "p", etc) descend below the 535base-line. The second character may be 'L' for "left", 'C' for "centre", 536or 'R' for "right", and specifies the horizontal location of the 537reference position. If the string has less than 2 characters then 'C' is 538used for the missing characters. 539 540And $upx is the x component of the up-vector for the text, in graphics 541world coordinates. If necessary the supplied value should be negated to 542ensure that positive values always refer to displacements from left to 543right on the screen. 544 545While $upy is the y component of the up-vector for the text, in graphics 546world coordinates. If necessary the supplied value should be negated to 547ensure that positive values always refer to displacements from bottom to 548top on the screen. 549 550Finally $xb is a refernce to an array of 4 elements in which to return the 551x coordinate of each corner of the bounding box, and $yb is a reference to 552an array of 4 elements in which to return the y coordinate of each corner 553of the bounding box. 554 555Notes: 556 - The order of the corners is anti-clockwise (in world coordinates) 557 starting at the bottom left. 558 - A NULL value for "just" causes a value of "CC" to be used. 559 - Both "upx" and "upy" being zero causes an error. 560 - Any unrecognised character in "just" causes an error. 561 - Zero is returned for all bounds of the box if an error occurs. 562 563=cut 564 565sub _GTxExt { 566 my $external = shift; 567 my $canvas = $external->[0]; 568 569 # The easy plan is to: 570 # get GText to plot the text 571 # Attach a new tag to it 572 # read the bounding box 573 # delete the item from the canvas 574 my $item; 575 _GText( $external, @_, \$item ); 576 577 # add a unique tag 578 $canvas->addtag('ASTGTxExt_TEMP', 'withtag', $item); 579 580 # read the bounding box 581 my @bbox = $canvas->bbox( 'ASTGTxExt_TEMP' ); 582 583 # delete the text 584 if ($external->[EXT_ATTR]->{ISA_CANVAS}) { 585 $canvas->delete( 'ASTGTxExt_TEMP' ); 586 } elsif ($external->[EXT_ATTR]->{ISA_ZINC}) { 587 $canvas->remove( 'ASTGTxExt_TEMP' ); 588 } 589 590 # to convert these coordinates back to the correct units 591 # we need the width and height of the canvas 592 my $width = $canvas->cget( '-width' ); 593 my $height = $canvas->cget( '-height' ); 594 595 # convert to AST form 596 my @xb = @bbox[0,2,2,0]; 597 my @yb = @bbox[1,1,3,3]; 598 599 @xb = map { $_ / $width } @xb; 600 @yb = map { 1 - $_ / $height } @yb; 601 602 #use Data::Dumper; 603 #print Dumper([$_[0], \@xb, \@yb]); 604 605 # Return 606 return (1, \@xb, \@yb); 607} 608 609=item B<_GQch> 610 611This function returns the heights of characters drawn vertically and 612horizontally in world coordinates. 613 614 my ( $status, $chv, $chh ) = _GQch( $w ); 615 616Where $chv is the height of characters drawn with a vertical 617baseline. This will be an increment in the X axis. Where $chh is the 618height of characters drawn with a horizontal baseline. This will be an 619increment in the Y axis. 620 621 622=cut 623 624sub _GQch { 625 my $external = shift; 626 my $canvas = $$external[0]; 627 #print "# _GQch: Placeholder routine called\n"; 628 629 # the Tk definition of world coordinates (from AST viewpoint) 630 # is fraction of viewport 631 my $charh = _char_height( $canvas, $external->[EXT_ATTR], 'TEXT' ); 632 my $chv = $charh / $canvas->cget( '-width' ); 633 my $chh = $charh / $canvas->cget( '-height' ); 634 return (1, $chv, $chh ); 635} 636 637 638=item B<_GAttr> 639 640This function returns the current value of a specified graphics 641attribute, and optionally establishes a new value. The supplied 642value is converted to an integer value if necessary before use. 643 644 645 my ( $status, $old_value ) = _GAttr( $w, $attr, $value, $prim ); 646 647Where $attr is an integer value identifying the required attribute. 648The following symbolic values are defined in the AST grf.h: 649 650 GRF__STYLE - Line style. 651 GRF__WIDTH - Line width. 652 GRF__SIZE - Character and marker size scale factor. 653 GRF__FONT - Character font. 654 GRF__COLOUR - Colour index. 655 656$value is a new value to store for the attribute. If this is 657AST__BAD no value is stored, and $old_value is a scalar containing 658the old attribute value, if this is NULL no value is returned. 659 660Finally $prim is the sort of graphics primitive to be drawn with 661the new attribute. Identified by the following values defined in 662AST's grf.h: 663 664 GRF__LINE 665 GRF__MARK 666 GRF__TEXT 667 668=cut 669 670sub _GAttr { 671 my ( $external, $att, $val, $prim ) = @_; 672 673 # Get the attribute hash 674 my $attr = $external->[EXT_ATTR]; 675 676 # possible return value 677 my $old_value = undef; 678 679 # determine which primitive we are dealing with 680 my $PRIM = $GRF_PRIM{$prim}; 681 if (!defined $PRIM) { 682 ReportGrfError("_GAttr: Unknown primitive: $prim\n"); 683 return ( 0 ); 684 } 685 686 # and which style 687 my $STYLE = $GRF_STYLE{$att}; 688 if (!defined $STYLE) { 689 ReportGrfError("_GAttr: Unknown style: $att\n"); 690 return ( 0 ); 691 } 692 693 # Now process the style request, relying on each plotting system 694 # to be able to work out what these numbers mean 695 $old_value = $attr->{$PRIM}->{$STYLE}; 696 $attr->{$PRIM}->{$STYLE} = $val if $val != &Starlink::AST::AST__BAD(); 697 698 # map to bad value if appropriate 699 $old_value = &Starlink::AST::AST__BAD() if !defined $old_value; 700 701 return (1, $old_value); 702} 703 704 705=item B<_GCap> 706 707This function is called by the AST Plot class to determine if the 708grf module has a given capability, as indicated by the "cap" 709argument. 710 711 $has_cap = _GCap( $cap, $value ); 712 713The capability string should be one of the following constants 714provided in the Starlink::AST::Grf namespace: 715 716GRF__SCALES: This function should return a non-zero value if 717it implements the astGScales function, and zero otherwise. The 718supplied "value" argument should be ignored. 719 720GRF__MJUST: This function should return a non-zero value if 721the astGText and astGTxExt functions recognise "M" as a 722character in the justification string. If the first character of 723a justification string is "M", then the text should be justified 724with the given reference point at the bottom of the bounding box. 725This is different to "B" justification, which requests that the 726reference point be put on the baseline of the text, since some 727characters hang down below the baseline. If the astGText or 728astGTxExt function cannot differentiate between "M" and "B", 729then this function should return zero, in which case "M" 730justification will never be requested by Plot. The supplied 731"value" argument should be ignored. 732 733GRF__ESC: This function should return a non-zero value if the 734astGText and astGTxExt functions can recognise and interpret 735graphics escape sequences within the supplied string. These 736escape sequences are described below. Zero should be returned 737if escape sequences cannot be interpreted (in which case the 738Plot class will interpret them itself if needed). The supplied 739"value" argument should be ignored only if escape sequences cannot 740be interpreted by astGText and astGTxExt. Otherwise, "value" 741indicates whether astGText and astGTxExt should interpret escape 742sequences in subsequent calls. If "value" is non-zero then 743escape sequences should be interpreted by astGText and 744astGTxExt. Otherwise, they should be drawn as literal text. 745 746Zero should be returned if the supplied capability is not recognised. 747 748=cut 749 750sub _GCap { 751 my $cap = shift; 752 my $value = shift; 753 #print "# _GCap: Placeholder routine called [assume lack capability]\n"; 754 return 0; 755} 756 757# Internal error setting routine 758sub ReportGrfError { 759 my $text = shift; 760 warn "Generated AST error in perl Tk callback: $text\n"; 761 Starlink::AST::_Error( &Starlink::AST::Status::AST__GRFER(), $text); 762} 763 764 765sub _CooBox { 766 my $external = shift; 767 my $canvas = $$external[0]; 768 my ($xglo,$xghi,$yglo,$yghi) = @$external[1 .. 4]; 769 my ($xplo,$xphi,$yplo,$yphi) = @$external[5 .. 8]; 770 771 my $width = $canvas->cget( '-width' ); 772 my $height = $canvas->cget( '-height' ); 773 774 my $xleft = $xglo*$width; 775 my $xright = $xglo*$width + $xphi; 776 my $ybottom = $yghi*$height; 777 my $ytop = $yghi*$height - $yphi; 778 779 #print "# width = $width, height = $height\n"; 780 #print "# Gbox $xglo,$xghi,$yglo,$yghi\n"; 781 #print "# Pbox $xplo,$xphi,$yplo,$yphi\n"; 782 #print "# xleft = $xleft, xright = $xright\n"; 783 #print "# ytop = $ytop, ybottom = $ybottom\n"; 784 785 return ($xleft,$xright,$ybottom,$ytop); 786} 787 788# convert GRAPHICS coordinates (0,1) 789# to canvas pixel coordinates 790 791sub _CooTranslate { 792 my ($external, $xf, $yf) = @_; 793 my $canvas = $$external[0]; 794 my ($xglo,$xghi,$yglo,$yghi) = @$external[1 .. 4]; 795 my ($xplo,$xphi,$yplo,$yphi) = @$external[5 .. 8]; 796 my ($xmin,$xmax,$ymin,$ymax) = _CooBox($external); 797 798 my $width = $canvas->cget( '-width' ); 799 my $height = $canvas->cget( '-height' ); 800 801 my $x = $xf*$width; 802 my $y = (1 - $yf)*$height; 803 804 #print "# _CooTranslate( $xf, $yf )\n"; 805 #print "# width = $width, height = $height\n"; 806 #print "# Gbox $xglo,$xghi,$yglo,$yghi\n"; 807 #print "# Pbox $xplo,$xphi,$yplo,$yphi\n"; 808 #print "# X $xf -> $x\n# Y $yf -> $y\n\n"; 809 return ( $x, $y ); 810} 811 812 813# Given the attributes hash and the primitive type, 814# return a hash with the correct arguments for the canvas 815# color settings 816 817sub _attr_to_colour { 818 my ($canvas, $external, $PRIM) = @_; 819 820 my %opts; 821 822 # depends on Tk::Zinc vs Canvas 823 # -fill will be translated by the _create routines. 824 my $bgkey; 825 if ($external->{ISA_CANVAS}) { 826 $bgkey = "-background"; 827 } elsif ($external->{ISA_ZINC}) { 828 $bgkey = "-backcolor"; 829 } 830 my $ci = $external->{$PRIM}->{COLOUR}; 831 if (defined $ci && $ci >= 0 && $ci <= $#COLOURS) { 832 # background color 833 if ($ci == 0) { 834 $opts{'-fill'} = $canvas->cget($bgkey); 835 } elsif ($ci == 1) { 836 # foreground color 837 my $bg = $canvas->cget($bgkey); 838 my $fg = $COLOURS[$ci]; 839 840 if ($bg eq $fg) { 841 # need to choose something else 842 $fg = $COLOURS[0]; 843 }; 844 845 $opts{'-fill'} = $fg; 846 } else { 847 $opts{'-fill'} = $COLOURS[$ci] 848 } 849 } 850 return %opts; 851} 852 853# Calculate the default character height 854 855# To match PGPLOT we define the default character height one-fortieth 856# of the height or width of the view surface (whichever is less). 857 858# Size specifications are then relative to this unit 859 860# this height is returned in pixels 861 862sub _def_char_height { 863 my $canvas = shift; 864 my $width = $canvas->cget('-width'); 865 my $height = $canvas->cget('-height'); 866 867 my $wh = $width * DEFAULT_CHAR_HEIGHT; 868 my $hh = $height * DEFAULT_CHAR_HEIGHT; 869 870 return ( $wh < $hh ? $wh : $hh ); 871} 872 873# Return the character height in pixels for this particular primitive 874# type. 875# Requires the canvas, attr hash and the primitive name (TEXT,MARK,LINE) 876 877sub _char_height { 878 my ($canvas, $attr, $prim) = @_; 879 880 my $dch = _def_char_height( $canvas ); 881 my $scale = $attr->{$prim}->{SIZE}; 882 $scale = 1 unless defined $scale; 883 return ($dch * $scale); 884} 885 886# Create a line composed of segments from (x1,y1) to (x2,y2) to ... to 887# (xn,yn) with options in %opt. The points variable is a reference to 888# an array with the end points of the line segments, i.e. (x1, y1, x2, 889# y2, ..., xn, yn). Returns the id of the line. 890 891sub _create_line { 892 893 my ($canvas, $external, $points, %opts) = @_; 894 895 my $item; # id of the item created 896 897 # If the canvas is a Tk::Canvas widget, use the createLine 898 # method. Tk::Zinc widgets require a little more work. 899 if ($external->[EXT_ATTR]->{ISA_CANVAS}) { 900 # Translate the linestyle index into the proper string for the 901 # Tk::Canvas -dash option. 902 if (exists $opts{-lindex}) { 903 my $lstyle = $LINE_STYLES{'Tk::Canvas'}->[ $opts{-lindex} ]; 904 $opts{'-dash'} = $lstyle if defined $lstyle; 905 delete $opts{-lindex}; 906 } 907 $item = $canvas->createLine( @$points, %opts ); 908 } elsif ($external->[EXT_ATTR]->{ISA_ZINC}) { 909 # Translate the linestyle index into the proper string for the 910 # Tk::Zinc -linestyle option. 911 if (exists $opts{-lindex}) { 912 my $lstyle = $LINE_STYLES{'Tk::Zinc'}->[ $opts{-lindex} ]; 913 $opts{'-linestyle'} = $lstyle if defined $lstyle; 914 delete $opts{-lindex}; 915 } 916 # Tk::Zinc uses the linecolor option, rather than the fill 917 # option used by Tk::Canvas. 918 if (exists $opts{'-fill'}) { 919 $opts{'-linecolor'} = $opts{'-fill'}; 920 delete $opts{'-fill'}; 921 } 922 # Tk::Zinc uses the linewidth option, rather than the width option 923 # used by Tk::Canvas. Also, Tk::Zinc requires the linewidth to be 924 # in pixels rather than inches, so we use fpixels to convert. 925 if (exists $opts{'-width'}) { 926 $opts{'-linewidth'} = $canvas->fpixels($opts{'-width'}); 927 delete $opts{'-width'}; 928 } 929 # Add the curve to the canvas 930 $item = $canvas->add( 'curve', TK_ZINC_GROUP, $points, %opts ); 931 } 932 return $item; 933} 934 935# Create a rectangle with corners at (x1,y1) and (x2,y2) with options in 936# %opt. Returns the id of the rectangle. 937 938sub _create_rectangle { 939 940 my ($canvas, $external, $x1, $y1, $x2, $y2, %opts) = @_; 941 942 my $item; # id of the item created 943 944 # If the canvas is a Tk::Canvas widget, use the createRectangle 945 # method. Tk::Zinc widgets require a little more work. 946 if ($external->[EXT_ATTR]->{ISA_CANVAS}) { 947 $item = $canvas->createRectangle( $x1, $y1, $x2, $y2, %opts ); 948 } elsif ($external->[EXT_ATTR]->{ISA_ZINC}) { 949 # Tk::Zinc uses the linecolor option, rather than the outline 950 # option used by Tk::Canvas. 951 if (exists $opts{'-outline'}) { 952 $opts{'-linecolor'} = $opts{'-outline'}; 953 delete $opts{'-outline'}; 954 } 955 # Tk::Zinc uses the fillcolor and filled (boolean) options, rather 956 # than the fill (string) option used by Tk::Canvas. 957 if (exists $opts{'-fill'}) { 958 $opts{'-fillcolor'} = $opts{'-fill'}; 959 $opts{'-filled'} = 1; 960 delete $opts{-fill}; 961 } 962 # Add the rectangle to the canvas 963 $item = $canvas->add( 'rectangle', TK_ZINC_GROUP, [$x1, $y1, $x2, $y2], %opts ); 964 } 965 return $item; 966} 967 968# Create an oval inside the rectangle with corners at (x1,y1) and 969# (x2,y2) with options in %opt. Returns the id of the oval. 970 971sub _create_oval { 972 973 my ($canvas, $external, $x1, $y1, $x2, $y2, %opts) = @_; 974 975 my $item; # id of the item created 976 977 # If the canvas is a Tk::Canvas widget, use the createRectangle 978 # method. Tk::Zinc widgets require a little more work. 979 if ($external->[EXT_ATTR]->{ISA_CANVAS}) { 980 $item = $canvas->createOval( $x1, $y1, $x2, $y2, %opts ); 981 } elsif ($external->[EXT_ATTR]->{ISA_ZINC}) { 982 # Tk::Zinc uses the linecolor option, rather than the outline 983 # option used by Tk::Canvas. 984 if (exists $opts{'-outline'}) { 985 $opts{'-linecolor'} = $opts{'-outline'}; 986 delete $opts{'-outline'}; 987 } 988 # Tk::Zinc uses the fillcolor and filled (boolean) options, rather 989 # than the fill (string) option used by Tk::Canvas. 990 if (exists $opts{'-fill'}) { 991 $opts{'-fillcolor'} = $opts{'-fill'}; 992 $opts{'-filled'} = 1; 993 delete $opts{-fill}; 994 } 995 # Add the oval to the canvas 996 $item = $canvas->add( 'arc', TK_ZINC_GROUP, [$x1, $y1, $x2, $y2], %opts ); 997 } 998 return $item; 999} 1000 1001# Create text at position (x, y) with options in %opt. Up-direction of 1002# the text specified by (upx, upy) vector. Returns the id of the text. 1003 1004sub _create_text { 1005 1006 my ($canvas, $external, $text, $x, $y, $upx, $upy, %opts) = @_; 1007 1008 my $item; # id of the item created 1009 1010 # For Tk::Canvas widgets, which don't support rotated text, try to 1011 # fudge the most common rotation. For Tk::Zinc widgets, text can be 1012 # at any angle, so we compute the angle from the specified up 1013 # vector. To be consistent with what Tk::Zinc wants, we are 1014 # measuring the angle as positve clockwise from the positive y-axis, 1015 # which AST considers to point upward on the screen. 1016 my $rotAngle; 1017 if ($external->[EXT_ATTR]->{ISA_CANVAS}) { 1018 if ($upx == 1 && $upy == 0 ) { 1019 # massage to attempt vertical text 1020 $text = join("\n", split(//, $text)); 1021 } elsif ($upx == -1 && $upy == 0 ) { 1022 # massage to attempt vertical text 1023 $text = join("\n", reverse split(//, $text)); 1024 } 1025 } elsif ($external->[EXT_ATTR]->{ISA_ZINC}) { 1026 $rotAngle = atan2($upx, $upy); 1027 } 1028 1029 # If the canvas is a Tk::Canvas widget, use the createText 1030 # method. Tk::Zinc widgets require a little more work. 1031 if ($external->[EXT_ATTR]->{ISA_CANVAS}) { 1032 $item = $canvas->createText( $x, $y, -text => $text, %opts); 1033 } elsif ($external->[EXT_ATTR]->{ISA_ZINC}) { 1034 # Tk::Zinc uses the color option, rather than the fill option used 1035 # by Tk::Canvas. 1036 if (exists $opts{'-fill'}) { 1037 $opts{'-color'} = $opts{'-fill'}; 1038 delete $opts{'-fill'}; 1039 } 1040 # Add the text to the canvas 1041 $item = $canvas->add( 'text', TK_ZINC_GROUP, -position => [$x, $y], 1042 -text => $text, %opts 1043 ); 1044 # Rotate the text 1045 $canvas->rotate( $item, $rotAngle); 1046 } 1047 return $item; 1048} 1049 1050# Routine to initialise the attributes. This includes the creation 1051# of Font objects that match the desired PGPLOT types 1052 1053sub _init_canvas_attrs { 1054 my ($canvas, $attr) = @_; 1055 1056 # prefill size attr to 1 since that is what PGPLOT does 1057 $attr->{TEXT}->{SIZE} = 1; 1058 $attr->{TEXT}->{FONT} = 1; 1059 $attr->{MARK}->{SIZE} = 1; 1060 1061 # This will be a lookup just like the Colour array except that 1062 # it has to be per-widget rather than global 1063 my @fonts; 1064 1065 # Simple font - can not cache the font itself since size and colour 1066 # control may not be respected if many changes are made between refreshes 1067 $fonts[1] = { -family => 'Courier', 1068 -slant => 'roman', 1069 -size => 12, 1070 }; 1071 1072 # roman font 1073 $fonts[2] = { -family => 'Times', 1074 -slant => 'roman', 1075 -size => 12, 1076 }; 1077 1078 # italic 1079 $fonts[3] = { -family => 'Time', 1080 -slant => 'italic', 1081 -size => 12, 1082 }; 1083 1084 # script 1085 $fonts[4] = { -family => 'Helvetica', 1086 -slant => 'italic', 1087 -size => 12, 1088 }; 1089 1090 $attr->{FONTS} = \@fonts; 1091 1092 # The canvas widget is allowed to be either a Tk::Canvas or a 1093 # Tk::Zinc widget. The ISA_CANVAS attribute is set to true if the 1094 # canvas is a Tk::Canvas widget. The ISA_ZINC attribute is set to 1095 # true if the canvas is a Tk::Zinc widget. There are slight 1096 # differences in the Tk::Canvas and Tk::Zinc methods, so we use the 1097 # ISA_CANVAS and ISA_ZINC attributes in the _create_line and related 1098 # methods to make sure we are calling the correct widget methods. 1099 $attr->{ISA_CANVAS} = UNIVERSAL::isa($canvas, 'Tk::Canvas'); 1100 $attr->{ISA_ZINC} = UNIVERSAL::isa($canvas, 'Tk::Zinc'); 1101} 1102 1103=back 1104 1105=head1 COPYRIGHT 1106 1107Copyright (C) 2010 Science and Technology Facilities Council. 1108Copyright (C) 2004 University of Exeter. 1109Copyright (C) 2005,2006 Particle Physics and Astronomy Research Council. 1110All Rights Reserved. 1111 1112This program is free software; you can redistribute it and/or modify it under 1113the terms of the GNU General Public License as published by the Free Software 1114Foundation; either version 2 of the License, or (at your option) any later 1115version. 1116 1117This program is distributed in the hope that it will be useful,but WITHOUT ANY 1118WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A 1119PARTICULAR PURPOSE. See the GNU General Public License for more details. 1120 1121You should have received a copy of the GNU General Public License along with 1122this program; if not, write to the Free Software Foundation, Inc., 59 Temple 1123Place,Suite 330, Boston, MA 02111-1307, USA 1124 1125=head1 AUTHORS 1126 1127Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> 1128Alasdair Allan E<lt>aa@astro.ex.ac.ukE<gt>, 1129Russell Kackley E<lt>r.kackley@jach.hawaii.eduE<gt> 1130 1131 1132=cut 1133 1134package Starlink::AST::Plot; 1135 1136use strict; 1137use vars qw/ $VERSION /; 1138 1139use Starlink::AST::Tk; 1140 1141sub tk { 1142 my $self = shift; 1143 my $canvas = shift; 1144 1145 # Store the information we need to pass to the plot functions 1146 my @external; 1147 push @external, $canvas; 1148 push @external, $self->GBox(); 1149 push @external, $self->PBox(); 1150 1151 my $attr = {}; 1152 push @external, $attr; # hash for attributes 1153 1154 # initialise the attribute hash 1155 Starlink::AST::Tk::_init_canvas_attrs( $canvas, $attr ); 1156 1157 # register callbacks 1158 $self->GExternal( \@external ); 1159 $self->GFlush(\&Starlink::AST::Tk::_GFlush); 1160 $self->GLine(\&Starlink::AST::Tk::_GLine); 1161 $self->GMark(\&Starlink::AST::Tk::_GMark); 1162 $self->GText(\&Starlink::AST::Tk::_GText); 1163 $self->GTxExt(\&Starlink::AST::Tk::_GTxExt); 1164 $self->GQch(\&Starlink::AST::Tk::_GQch); 1165 $self->GAttr(\&Starlink::AST::Tk::_GAttr); 1166 $self->GScales(\&Starlink::AST::Tk::_GScales); 1167 $self->GCap(\&Starlink::AST::Tk::_GCap); 1168 1169 1170 return 1; 1171} 1172 11731; 1174