Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | |
2 | package Plot; | |
3 | ||
4 | # Class "Plot": constructor, methods, destructor, global class data, | |
5 | # etcetera. | |
6 | # | |
7 | # Because a Plot object is a composite widget all the Composite base | |
8 | # class methods and advertised widgets are available to you. | |
9 | # | |
10 | # Advertised Plot widgets: canvas, entry, PostScript_button, view_button. | |
11 | ||
12 | require 5.002; | |
13 | ||
14 | use vars qw/$VERSION @ISA/; | |
15 | $VERSION = '3.013'; # $Id: //depot/Tk8/demos/demos/widget_lib/Plot.pm#13 $ | |
16 | ||
17 | use Tk::Frame; | |
18 | use base qw(Tk::Frame); | |
19 | Construct Tk::Widget 'Plot'; | |
20 | use strict; | |
21 | ||
22 | # Plot Virtual Methods | |
23 | # | |
24 | # $plot = $MW->Plot( | |
25 | # -title_color => 'Brown', | |
26 | # -inactive_highlight => 'Skyblue2', | |
27 | # -active_highlight => 'red', | |
28 | # ); | |
29 | ||
30 | sub Populate { | |
31 | ||
32 | # Plot composite widget constructor. | |
33 | ||
34 | my($cw, $args) = @_; | |
35 | ||
36 | $cw->SUPER::Populate($args); | |
37 | my($tc, $ih, $ah) = ( | |
38 | delete $args->{-title_color}, | |
39 | delete $args->{-inactive_highlight}, | |
40 | delete $args->{-active_highlight}, | |
41 | ); | |
42 | ||
43 | my %pinfo; # plot information hash | |
44 | $pinfo{'lastX'} = 0; | |
45 | $pinfo{'lastY'} = 0; | |
46 | $pinfo{'areaX2'} = -1; | |
47 | $pinfo{'prcmd'} = 'lpr'; | |
48 | ||
49 | my $plot_font = '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*'; | |
50 | ||
51 | my $c = $cw->Canvas( | |
52 | -relief => 'raised', | |
53 | -width => '450', | |
54 | -height => '300', | |
55 | -cursor => 'top_left_arrow', | |
56 | ); | |
57 | $cw->Advertise('canvas' => $c); | |
58 | $c->pack(-side => 'top', -fill => 'x'); | |
59 | ||
60 | $c->createLine(100, 250, 400, 250, -width => 2); | |
61 | $c->createLine(100, 250, 100, 50, -width => 2); | |
62 | $c->createText(225, 20, -text => 'A Simple Plot', -font => $plot_font, | |
63 | -fill => $tc); | |
64 | ||
65 | my($i, $x, $y, $point, $item); | |
66 | for($i = 0; $i <= 10; $i++) { | |
67 | $x = 100 + ($i * 30); | |
68 | $c->createLine($x, 250, $x, 245, -width => 2); | |
69 | $c->createText($x, 254, -text => 10 * $i, -anchor => 'n', | |
70 | -font => $plot_font); | |
71 | } # forend | |
72 | for ($i = 0; $i <= 5; $i++) { | |
73 | $y = 250 - ($i * 40); | |
74 | $c->createLine(100, $y, 105, $y, -width => 2); | |
75 | $c->createText(96, $y, -text => $i * 50.0, -anchor => 'e', | |
76 | -font => $plot_font); | |
77 | } # forend | |
78 | ||
79 | foreach $point ([12, 56], [20, 94], [33, 98], [32, 120], [61, 180], | |
80 | [75, 160], [98, 223]) { | |
81 | $x = 100 + (3 * ${$point}[0]); | |
82 | $y = 250 - (4 * ${$point}[1]) / 5; | |
83 | $item = $c->createOval($x-6, $y-6, $x+6, $y+6, -width => 1, | |
84 | -outline => 'black', -fill => $ih); | |
85 | $c->addtag('point', 'withtag', $item); | |
86 | } | |
87 | ||
88 | $c->bind('point', '<Any-Enter>' => [sub{shift->itemconfigure(@_)}, | |
89 | 'current', -fill => $ah]); | |
90 | $c->bind('point', '<Any-Leave>' => [sub{shift->itemconfigure(@_)}, | |
91 | 'current', -fill => $ih]); | |
92 | $c->bind('point', '<1>' => [sub {plot_down(@_)}, \%pinfo]); | |
93 | $c->bind('point', '<ButtonRelease-1>' => sub {shift->dtag('selected')}); | |
94 | $c->CanvasBind('<B1-Motion>' => [sub {plot_move(@_)}, \%pinfo]); | |
95 | $c->CanvasBind('<2>' => [sub {area_down(@_)}, \%pinfo]); | |
96 | $c->CanvasBind('<B2-Motion>' => [sub {area_move(@_)}, \%pinfo]); | |
97 | ||
98 | my $w_prcmd = $cw->Entry( | |
99 | -textvariable => \$pinfo{'prcmd'}, | |
100 | ); | |
101 | $cw->Advertise('entry' => $w_prcmd); | |
102 | $w_prcmd->pack; | |
103 | ||
104 | my $w_print = $cw->Button( | |
105 | -text => 'Print in PostScript Format', | |
106 | -command => [\&area_save, $c, \%pinfo], | |
107 | ); | |
108 | $cw->Advertise('PostScript_button' => $w_print); | |
109 | $w_print->pack; | |
110 | $w_prcmd->bind('<Return>' => [$w_print => 'invoke']); | |
111 | ||
112 | my $w_view = $cw->Button( | |
113 | -text => 'View Composite Plot Widget', | |
114 | -command => [\&::view_widget_code, | |
115 | Tk->findINC('demos/widget_lib/Plot.pm'), | |
116 | ], | |
117 | ); | |
118 | $cw->Advertise('view_button' => $w_view); | |
119 | $w_view->pack; | |
120 | ||
121 | return $cw; | |
122 | ||
123 | } # end Populate, Plot constructor | |
124 | ||
125 | # Private methods. | |
126 | ||
127 | sub area_down { | |
128 | ||
129 | my($w, $pinfo) = @_; | |
130 | ||
131 | my $e = $w->XEvent; | |
132 | my($x, $y) = ($e->x, $e->y); | |
133 | $pinfo->{'areaX1'} = $x; | |
134 | $pinfo->{'areaY1'} = $y; | |
135 | $pinfo->{'areaX2'} = -1; | |
136 | $pinfo->{'areaY2'} = -1; | |
137 | eval {local $SIG{'__DIE__'}; $w->delete('area');}; | |
138 | ||
139 | } # end area_down | |
140 | ||
141 | sub area_move { | |
142 | ||
143 | my($w, $pinfo) = @_; | |
144 | ||
145 | my $e = $w->XEvent; | |
146 | my($x, $y) = ($e->x, $e->y); | |
147 | if($x != $pinfo->{'areaX1'} && $y != $pinfo->{'areaY1'}) { | |
148 | eval {local $SIG{'__DIE__'}; $w->delete('area');}; | |
149 | $w->addtag('area','withtag',$w->createRectangle($pinfo->{'areaX1'}, | |
150 | $pinfo->{'areaY1'},$x,$y)); | |
151 | $pinfo->{'areaX2'} = $x; | |
152 | $pinfo->{'areaY2'} = $y; | |
153 | } | |
154 | } # end area_move | |
155 | ||
156 | sub area_save { | |
157 | ||
158 | my($w, $pinfo) = @_; | |
159 | ||
160 | my($x1, $x2, $y1, $y2, $a); | |
161 | ||
162 | if($pinfo->{'areaX2'} != -1) { | |
163 | ($x1, $x2, $y1, $y2) = | |
164 | @$pinfo{'areaX1', 'areaX2', 'areaY1', 'areaY2'}; # slice ! | |
165 | ($x1, $x2) = @$pinfo{'areaX2', 'areaX1'} if $x2 <= $x1; | |
166 | ($y1, $y2) = @$pinfo{'areaY2', 'areaY1'} if $y2 <= $y1; | |
167 | $a = $w->postscript('-x' => $x1, '-y' => $y1, | |
168 | -width => $x2 - $x1, -height => $y2 - $y1); | |
169 | } else { | |
170 | $a = $w->postscript; | |
171 | } | |
172 | ||
173 | $SIG{'PIPE'} = sub {}; | |
174 | open(LPR, "| $pinfo->{'prcmd'}"); | |
175 | print LPR $a; | |
176 | close(LPR); | |
177 | ||
178 | } # end area_save | |
179 | ||
180 | sub plot_down { | |
181 | ||
182 | my($w, $pinfo) = @_; | |
183 | ||
184 | my $e = $w->XEvent; | |
185 | my($x, $y) = ($e->x, $e->y); | |
186 | $w->dtag('selected'); | |
187 | $w->addtag('selected', 'withtag', 'current'); | |
188 | $w->raise('current'); | |
189 | $pinfo->{'lastX'} = $x; | |
190 | $pinfo->{'lastY'} = $y; | |
191 | ||
192 | } # end plot_down | |
193 | ||
194 | sub plot_move { | |
195 | ||
196 | my($w, $pinfo) = @_; | |
197 | ||
198 | my $e = $w->XEvent; | |
199 | my($x, $y) = ($e->x, $e->y); | |
200 | $w->move('selected', $x-$pinfo->{'lastX'}, $y-$pinfo->{'lastY'}); | |
201 | $pinfo->{'lastX'} = $x; | |
202 | $pinfo->{'lastY'} = $y; | |
203 | ||
204 | } # end plot_move | |
205 | ||
206 | 1; |