diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/Plot.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/Plot.pm | 198 |
1 files changed, 198 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/Plot.pm b/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/Plot.pm new file mode 100644 index 00000000000..c5416b0e535 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/Plot.pm @@ -0,0 +1,198 @@ + +package Plot; + +# Class "Plot": constructor, methods, destructor, global class data, +# etcetera. +# +# Because a Plot object is a composite widget all the Composite base +# class methods and advertised widgets are available to you. +# +# Advertised Plot widgets: canvas, entry, PostScript_button, view_button. + +require 5.005_03; + +use vars qw/$VERSION @ISA/; +$VERSION = '4.008'; # sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; + +use Tk::Frame; +use base qw/Tk::Frame/; +Construct Tk::Widget 'Plot'; +use strict; + +sub Populate { + + # Plot composite widget constructor. + + my($cw, $args) = @_; + + $cw->SUPER::Populate($args); + my($tc, $ih, $ah) = ( + delete $args->{-title_color}, + delete $args->{-inactive_highlight}, + delete $args->{-active_highlight}, + ); + + my %pinfo; # plot information hash + $pinfo{'lastX'} = 0; + $pinfo{'lastY'} = 0; + $pinfo{'areaX2'} = -1; + $pinfo{'prcmd'} = 'lpr'; + + my $plot_font = '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*'; + + my $c = $cw->Canvas( + -relief => 'raised', + -width => '450', + -height => '300', + -cursor => 'top_left_arrow', + ); + $cw->Advertise('canvas' => $c); + $c->pack(-side => 'top', -fill => 'x'); + + $c->createLine(100, 250, 400, 250, -width => 2); + $c->createLine(100, 250, 100, 50, -width => 2); + $c->createText(225, 20, -text => 'A Simple Plot', -font => $plot_font, + -fill => $tc); + + my($i, $x, $y, $point, $item); + for($i = 0; $i <= 10; $i++) { + $x = 100 + ($i * 30); + $c->createLine($x, 250, $x, 245, -width => 2); + $c->createText($x, 254, -text => 10 * $i, -anchor => 'n', + -font => $plot_font); + } # forend + for ($i = 0; $i <= 5; $i++) { + $y = 250 - ($i * 40); + $c->createLine(100, $y, 105, $y, -width => 2); + $c->createText(96, $y, -text => $i * 50.0, -anchor => 'e', + -font => $plot_font); + } # forend + + foreach $point ([12, 56], [20, 94], [33, 98], [32, 120], [61, 180], + [75, 160], [98, 223]) { + $x = 100 + (3 * ${$point}[0]); + $y = 250 - (4 * ${$point}[1]) / 5; + $item = $c->createOval($x-6, $y-6, $x+6, $y+6, -width => 1, + -outline => 'black', -fill => $ih); + $c->addtag('point', 'withtag', $item); + } + + $c->bind('point', '<Any-Enter>' => [sub{shift->itemconfigure(@_)}, + 'current', -fill => $ah]); + $c->bind('point', '<Any-Leave>' => [sub{shift->itemconfigure(@_)}, + 'current', -fill => $ih]); + $c->bind('point', '<1>' => [sub {plot_down(@_)}, \%pinfo]); + $c->bind('point', '<ButtonRelease-1>' => sub {shift->dtag('selected')}); + $c->CanvasBind('<B1-Motion>' => [sub {plot_move(@_)}, \%pinfo]); + $c->CanvasBind('<2>' => [sub {area_down(@_)}, \%pinfo]); + $c->CanvasBind('<B2-Motion>' => [sub {area_move(@_)}, \%pinfo]); + + my $w_prcmd = $cw->Entry( + -textvariable => \$pinfo{'prcmd'}, + ); + $cw->Advertise('entry' => $w_prcmd); + $w_prcmd->pack; + + my $w_print = $cw->Button( + -text => 'Print in PostScript Format', + -command => [\&area_save, $c, \%pinfo], + ); + $cw->Advertise('PostScript_button' => $w_print); + $w_print->pack; + $w_prcmd->bind('<Return>' => [$w_print => 'invoke']); + + my $w_view = $cw->Button( + -text => 'View Composite Plot Widget', + -command => [\&::view_widget, + Tk->findINC('demos/widget_lib/Plot.pm'), + ], + ); + $cw->Advertise('view_button' => $w_view); + $w_view->pack; + + return $cw; + +} # end Populate, Plot constructor + +# Private methods. + +sub area_down { + + my($w, $pinfo) = @_; + + my $e = $w->XEvent; + my($x, $y) = ($e->x, $e->y); + $pinfo->{'areaX1'} = $x; + $pinfo->{'areaY1'} = $y; + $pinfo->{'areaX2'} = -1; + $pinfo->{'areaY2'} = -1; + eval {local $SIG{'__DIE__'}; $w->delete('area');}; + +} # end area_down + +sub area_move { + + my($w, $pinfo) = @_; + + my $e = $w->XEvent; + my($x, $y) = ($e->x, $e->y); + if($x != $pinfo->{'areaX1'} && $y != $pinfo->{'areaY1'}) { + eval {local $SIG{'__DIE__'}; $w->delete('area');}; + $w->addtag('area','withtag',$w->createRectangle($pinfo->{'areaX1'}, + $pinfo->{'areaY1'},$x,$y)); + $pinfo->{'areaX2'} = $x; + $pinfo->{'areaY2'} = $y; + } +} # end area_move + +sub area_save { + + my($w, $pinfo) = @_; + + my($x1, $x2, $y1, $y2, $a); + + if($pinfo->{'areaX2'} != -1) { + ($x1, $x2, $y1, $y2) = + @$pinfo{'areaX1', 'areaX2', 'areaY1', 'areaY2'}; # slice ! + ($x1, $x2) = @$pinfo{'areaX2', 'areaX1'} if $x2 <= $x1; + ($y1, $y2) = @$pinfo{'areaY2', 'areaY1'} if $y2 <= $y1; + $a = $w->postscript('-x' => $x1, '-y' => $y1, + -width => $x2 - $x1, -height => $y2 - $y1); + } else { + $a = $w->postscript; + } + + $SIG{'PIPE'} = sub {}; + open(LPR, "| $pinfo->{'prcmd'}"); + print LPR $a; + close(LPR); + +} # end area_save + +sub plot_down { + + my($w, $pinfo) = @_; + + my $e = $w->XEvent; + my($x, $y) = ($e->x, $e->y); + $w->dtag('selected'); + $w->addtag('selected', 'withtag', 'current'); + $w->raise('current'); + $pinfo->{'lastX'} = $x; + $pinfo->{'lastY'} = $y; + +} # end plot_down + +sub plot_move { + + my($w, $pinfo) = @_; + + my $e = $w->XEvent; + my($x, $y) = ($e->x, $e->y); + $w->move('selected', $x-$pinfo->{'lastX'}, $y-$pinfo->{'lastY'}); + $pinfo->{'lastX'} = $x; + $pinfo->{'lastY'} = $y; + +} # end plot_move + +1; |