Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # items.pl |
2 | ||
3 | use subs qw/items_button_press items_drag items_enter items_leave items_mark | |
4 | items_start_drag items_stroke items_under_area/; | |
5 | use vars qw/$TOP/; | |
6 | ||
7 | sub items { | |
8 | ||
9 | # Create a top-level window containing a canvas that displays the various | |
10 | # item types and allows them to be selected and moved. | |
11 | ||
12 | my($demo) = @_; | |
13 | $TOP = $MW->WidgetDemo( | |
14 | -name => $demo, | |
15 | -text => ["This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tdisplays items under area.", qw/-wraplength 5i/], | |
16 | -title => 'Canvas Item Demonstration', | |
17 | -iconname => 'items', | |
18 | ); | |
19 | ||
20 | my $c = $TOP->Scrolled(qw/Canvas -width 15c -height 10c -relief sunken | |
21 | -borderwidth 2 -scrollbars se -scrollregion/ => | |
22 | [qw/0c 0c 30c 24c/]); | |
23 | $c->pack(qw/-expand yes -fill both/); | |
24 | ||
25 | my %iinfo = (); # item information hash | |
26 | $iinfo{areaX1} = 0; | |
27 | $iinfo{areaY1} = 0; | |
28 | $iinfo{areaX2} = 0; | |
29 | $iinfo{areaY2} = 0; | |
30 | $iinfo{restore_cmd} = ''; | |
31 | ||
32 | ||
33 | if ($Tk::VERSION cmp '800.015') { | |
34 | # Display a 3x3 rectangular grid (800.016 or greater). | |
35 | $c->createGrid(qw/0c 0c 10c 8c -width 2 -lines 1/); | |
36 | $c->createGrid(qw/0c 0c 5c 4c -lines 1 -dash ./); | |
37 | $c->createGrid(qw/0c 0c 10m 8m -width 1/); | |
38 | } else { | |
39 | # Display a 3x3 rectangular grid. | |
40 | $c->createRectangle(qw/ 0c 0c 30c 24c -width 2/); | |
41 | $c->createLine (qw/ 0c 8c 30c 8c -width 2/); | |
42 | $c->createLine (qw/ 0c 16c 30c 16c -width 2/); | |
43 | $c->createLine (qw/10c 0c 10c 24c -width 2/); | |
44 | $c->createLine (qw/20c 0c 20c 24c -width 2/); | |
45 | } | |
46 | ||
47 | my $font1 = '-*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*'; | |
48 | my $font2 = '-*-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*'; | |
49 | my($blue, $red, $bisque, $green); | |
50 | if ($TOP->depth > 1) { | |
51 | $blue = 'DeepSkyBlue3'; | |
52 | $red = 'red'; | |
53 | $bisque = 'bisque3'; | |
54 | $green = 'SeaGreen3'; | |
55 | } else { | |
56 | $blue = 'black'; | |
57 | $red = 'black'; | |
58 | $bisque = 'black'; | |
59 | $green = 'black'; | |
60 | } | |
61 | ||
62 | # Set up demos within each of the areas of the grid. | |
63 | ||
64 | $c->createText(qw/5c .2c -text Lines -anchor n/); | |
65 | $c->createLine(qw/1c 1c 3c 1c 1c 4c 3c 4c -width 2m/, -fill => $blue, | |
66 | qw/-cap butt -join miter -tags item/); | |
67 | $c->createLine(qw/4.67c 1c 4.67c 4c -arrow last -activedash - -tags item/); | |
68 | $c->createLine(qw/6.33c 1c 6.33c 4c -arrow both -activedash . -tags item/); | |
69 | $c->createLine(qw/5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c | |
70 | 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c | |
71 | 8.4c 4.4c -width 3 -tags item -fill/ => $red); | |
72 | $c->createLine(qw/1c 5c 7c 5c 7c 7c 9c 7c -width .5c/, | |
73 | -stipple => '@'.Tk->findINC('demos/images/grey.25'), | |
74 | qw/-arrow both -tags item -arrowshape/ => [15, 15, 7]); | |
75 | $c->createLine(qw/1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c | |
76 | -cap round -join round -tags item/); | |
77 | ||
78 | $c->createText(qw/15c .2c -anchor n -text/ => 'Curves (smoothed lines)'); | |
79 | $c->createLine(qw/11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on/, | |
80 | -fill =>$blue, qw/-tags item/); | |
81 | $c->createLine(qw/15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on | |
82 | -arrow both -width 3 -tags item/); | |
83 | $c->createLine(qw/12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c 16.5c 4.5c 13.5c | |
84 | 7.5c 12c 6c -smooth on -width 3m -cap round -tags item/, | |
85 | -stipple => '@'.Tk->findINC('demos/images/grey.25'), | |
86 | -fill => $red); | |
87 | ||
88 | $c->createText(qw/25c .2c -text Polygons -anchor n/); | |
89 | $c->createPolygon(qw/21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c 24c 4.0c | |
90 | 22.5c 3.25c 21c 4.0c 21.75c 2.5c -tags item/, | |
91 | -fill => $green); | |
92 | $c->createPolygon(qw/25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c 29c 1c | |
93 | 29c 4c 29c 4c -smooth on -tags item/, -fill => $red); | |
94 | $c->createPolygon(qw/22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c 28c 5.25c 24c | |
95 | 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c -tags item/, | |
96 | -stipple => '@'.Tk->findINC('demos/images/grey.25')); | |
97 | ||
98 | $c->createText(qw/5c 8.2c -text Rectangles -anchor n/); | |
99 | $c->createRectangle(qw/1c 9.5c 4c 12.5c/, -outline => $red, | |
100 | qw/-width 3m -tags item/); | |
101 | $c->createRectangle(qw/0.5c 13.5c 4.5c 15.5c/, -fill => $green, | |
102 | qw/-tags item/); | |
103 | $c->createRectangle(qw/6c 10c 9c 15c -tags item/, -outline => undef, | |
104 | -stipple => '@'.Tk->findINC('demos/images/grey.25'), | |
105 | -fill => $blue); | |
106 | ||
107 | $c->createText(qw/15c 8.2c -text Ovals -anchor n/); | |
108 | $c->createOval(qw/11c 9.5c 14c 12.5c/, -outline => $red, | |
109 | qw/-width 3m -tags item/); | |
110 | $c->createOval(qw/10.5c 13.5c 14.5c 15.5c/, -fill => $green, | |
111 | qw/-tags item/); | |
112 | $c->createOval(qw/16c 10c 19c 15c -tags item/, -outline => undef, | |
113 | -stipple => '@'.Tk->findINC('demos/images/grey.25'), | |
114 | -fill => $blue); | |
115 | ||
116 | $c->createText(qw/25c 8.2c -text Text -anchor n/); | |
117 | $c->createRectangle(qw/22.4c 8.9c 22.6c 9.1c/); | |
118 | $c->createText(qw/22.5c 9c -anchor n -width 4c/, -font => $font1, | |
119 | -text => 'A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text.', qw/-tags item/); | |
120 | $c->createRectangle(qw/25.4c 10.9c 25.6c 11.1c/); | |
121 | $c->createText(qw/25.5c 11c -anchor w/, -font => $font1, -fill => $blue, | |
122 | -text => "Several lines,\n each centered\n" . | |
123 | "individually,\nand all anchored\nat the left edge.", | |
124 | qw/-justify center -tags item/); | |
125 | $c->createRectangle(qw/24.9c 13.9c 25.1c 14.1c/); | |
126 | $c->createText(qw/25c 14c -anchor c/, -font => $font2, -fill => $red, | |
127 | -stipple => 'gray50', | |
128 | -text => 'Stippled characters', qw/-tags item/); | |
129 | ||
130 | $c->createText(qw/5c 16.2c -text Arcs -anchor n/); | |
131 | $c->createArc(qw/0.5c 17c 7c 20c/, -fill => $green, qw/-outline black/, | |
132 | -stipple => '@'.Tk->findINC('demos/images/grey.25'), | |
133 | qw/-start 45 -extent 270 -style pieslice -tags item/); | |
134 | $c->createArc(qw/6.5c 17c 9.5c 20c -width 4m -style arc/, -fill => $blue, | |
135 | qw/-start -135 -extent 270 -tags item/); | |
136 | $c->createArc(qw/0.5c 20c 9.5c 24c -width 4m -style pieslice/, | |
137 | -fill => undef, -outline => $red, | |
138 | qw/-start 225 -extent -90 -tags item/); | |
139 | $c->createArc(qw/5.5c 20.5c 9.5c 23.5c -width 4m -style chord/, | |
140 | -fill => $blue, -outline => undef, | |
141 | qw/-start 45 -extent 270 -tags item/); | |
142 | ||
143 | $c->createText(qw/15c 16.2c -text Bitmaps -anchor n/); | |
144 | $c->createBitmap(qw/13c 20c -bitmap/ => | |
145 | '@'.Tk->findINC('demos/images/face'), qw/-tags item/); | |
146 | $c->createBitmap(qw/17c 18.5c/, | |
147 | -bitmap => '@'.Tk->findINC('demos/images/noletters'), | |
148 | qw/-tags item/); | |
149 | $c->createBitmap(qw/17c 21.5c/, | |
150 | -bitmap => '@'.Tk->findINC('demos/images/letters'), | |
151 | qw/-tags item/); | |
152 | ||
153 | $c->createText(qw/25c 16.2c -text Windows -anchor n/); | |
154 | my $c_button = $c->Button(-text => 'Press Me', | |
155 | -command => [\&items_button_press, $c, $red], | |
156 | ); | |
157 | $c->createWindow(qw/21c 18c/, -window => $c_button, | |
158 | qw/-anchor nw -tags item/); | |
159 | my $c_entry = $c->Entry(-width => '20', -relief => 'sunken', | |
160 | -validate => 'all', | |
161 | -validatecommand => sub {$n++ ? 1 : 0}, | |
162 | -invalidcommand => sub {$TOP->bell}); | |
163 | $c_entry->insert('end' => 'Edit this text'); | |
164 | $c->createWindow(qw/21c 21c/, -window => $c_entry, | |
165 | qw/-anchor nw -tags item/); | |
166 | my $c_scale = $c->Scale(qw/-from 0 -to 100 -length 6c -sliderlength .4c | |
167 | -width .5c -tickinterval 0/); | |
168 | $c->createWindow(qw/28.5c 17.5c/, -window => $c_scale, | |
169 | qw/-anchor n -tags item/); | |
170 | $c->createText(qw/21c 17.9c -text Button: -anchor sw/); | |
171 | $c->createText(qw/21c 20.9c -text Entry: -anchor sw/); | |
172 | $c->createText(qw/28.5c 17.4c -text Scale: -anchor s/); | |
173 | ||
174 | # Set up event bindings for canvas. | |
175 | ||
176 | $c->bind('item', '<Any-Enter>' => [\&items_enter, \%iinfo]); | |
177 | $c->bind('item', '<Any-Leave>' => [\&items_leave, \%iinfo]); | |
178 | ||
179 | # Get real canvas widget reference to apply bind() commands to: the | |
180 | # Canvas widget is a subwidget of the Scrolled composite widget. To | |
181 | # reference the X event structure, either use the XEvent() method or | |
182 | # read the specially localized variable $Tk::event. We'll use XEvent | |
183 | # first, and the variable from then on. | |
184 | ||
185 | $c->CanvasBind('<<Copy>>',sub { print "Do Copy\n" }); | |
186 | ||
187 | $c->CanvasBind('<1>' => sub { | |
188 | my($c) = @_; | |
189 | my $e = $c->XEvent; | |
190 | items_start_drag $c, $e->x, $e->y, \%iinfo; | |
191 | }); | |
192 | $c->CanvasBind('<B1-Motion>' => | |
193 | sub {items_drag shift, $Tk::event->x, $Tk::event->y, \%iinfo}); | |
194 | $c->CanvasBind('<2>' => | |
195 | sub {shift->scan('mark', $Tk::event->x, $Tk::event->y)}); | |
196 | $c->CanvasBind('<B2-Motion>' => | |
197 | sub {shift->scan('dragto', $Tk::event->x, $Tk::event->y)}); | |
198 | $c->CanvasBind('<3>' => | |
199 | sub {items_mark shift, $Tk::event->x, $Tk::event->y, \%iinfo}); | |
200 | $c->CanvasBind('<B3-Motion>' => | |
201 | sub {items_stroke shift, $Tk::event->x, $Tk::event->y, \%iinfo}); | |
202 | $c->CanvasBind('<Control-f>' => [sub { | |
203 | my($c, $iinfo) = @_; | |
204 | my $e = $c->XEvent; | |
205 | items_under_area $c, $iinfo; | |
206 | }, \%iinfo]); | |
207 | $c->CanvasBind('<Any-Enter>' => sub {$_[0]->CanvasFocus}); | |
208 | ||
209 | } # end items | |
210 | ||
211 | # Utility procedures for highlighting the item under the pointer: | |
212 | ||
213 | sub items_button_press { | |
214 | ||
215 | # Procedure that's invoked when the button embedded in the canvas | |
216 | # is invoked. | |
217 | ||
218 | my($w, $color) = @_; | |
219 | ||
220 | my $i = $w->createText(qw/25c 18.1c -anchor n/, -text => 'Ouch!!', | |
221 | -fill => $color); | |
222 | $w->after(500, sub { $w->delete($i) }); | |
223 | ||
224 | } # end items_button_press | |
225 | ||
226 | sub items_drag { | |
227 | ||
228 | my($c, $x, $y, $iinfo) = @_; | |
229 | ||
230 | $x = $c->canvasx($x); | |
231 | $y = $c->canvasy($y); | |
232 | $c->move('current', $x-$iinfo->{lastX}, $y-$iinfo->{lastY}); | |
233 | $iinfo->{lastX} = $x; | |
234 | $iinfo->{lastY} = $y; | |
235 | ||
236 | } # end items_drag | |
237 | ||
238 | sub items_enter { | |
239 | ||
240 | my($c, $iinfo) = @_; | |
241 | ||
242 | $iinfo->{restore_cmd} = ''; | |
243 | ||
244 | if ($TOP->depth == 1) { | |
245 | $iinfo->{restore_cmd} = ''; | |
246 | return; | |
247 | } | |
248 | my $type = $c->type('current'); | |
249 | if ($type eq 'window') { | |
250 | $iinfo->{restore_cmd} = ''; | |
251 | return; | |
252 | } | |
253 | ||
254 | if ($type eq 'bitmap') { | |
255 | my $bg = ($c->itemconfigure(qw/current -background/))[4]; | |
256 | if (defined $bg) { | |
257 | $iinfo->{restore_cmd} = "\$c->itemconfigure('current', | |
258 | -background => '$bg');"; | |
259 | } else { | |
260 | $iinfo->{restore_cmd} = "\$c->itemconfigure('current', | |
261 | -background => undef);"; | |
262 | } | |
263 | $c->itemconfigure(qw/current -background SteelBlue2/); | |
264 | return; | |
265 | } | |
266 | my $fill = ($c->itemconfigure(qw/current -fill/))[4]; | |
267 | my $stipple = ($c->itemconfigure(qw/current -stipple/))[4]; | |
268 | if (defined $stipple) { | |
269 | $iinfo->{restore_cmd} = "\$c->itemconfigure('current', | |
270 | -stipple => '$stipple')"; | |
271 | $c->itemconfigure(qw/current -stipple /,''); | |
272 | } elsif (($type eq 'rectangle' or $type eq 'oval' or $type eq 'arc') | |
273 | and not defined $fill) { | |
274 | my $outline = ($c->itemconfigure(qw/current -outline/))[4]; | |
275 | $iinfo->{restore_cmd} = "\$c->itemconfigure('current', | |
276 | -outline => '$outline')"; | |
277 | $c->itemconfigure(qw/current -outline SteelBlue2/); | |
278 | } else { | |
279 | $iinfo->{restore_cmd} = "\$c->itemconfigure('current', | |
280 | -fill => '$fill')"; | |
281 | $c->itemconfigure(qw/current -fill SteelBlue2/); | |
282 | } | |
283 | ||
284 | } # end items_enter | |
285 | ||
286 | sub items_leave { | |
287 | ||
288 | my($c, $iinfo) = @_; | |
289 | ||
290 | eval $iinfo->{restore_cmd}; | |
291 | ||
292 | } # end items_leave | |
293 | ||
294 | sub items_mark { | |
295 | ||
296 | my($c, $x, $y, $iinfo) = @_; | |
297 | ||
298 | $iinfo->{areaX1} = $c->canvasx($x); | |
299 | $iinfo->{areaY1} = $c->canvasy($y); | |
300 | $c->delete('area'); | |
301 | ||
302 | } # end items_mark | |
303 | ||
304 | sub items_start_drag { | |
305 | ||
306 | my($c, $x, $y, $iinfo) = @_; | |
307 | ||
308 | $iinfo->{lastX} = $c->canvasx($x); | |
309 | $iinfo->{lastY} = $c->canvasy($y); | |
310 | ||
311 | } # end items_start_drag | |
312 | ||
313 | sub items_stroke { | |
314 | ||
315 | my($c, $x, $y, $iinfo) = @_; | |
316 | ||
317 | $x = $c->canvasx($x); | |
318 | $y = $c->canvasy($y); | |
319 | if (($iinfo->{areaX1} != $x) and ($iinfo->{areaY1} != $y)) { | |
320 | $c->delete('area'); | |
321 | $c->addtag('area', 'withtag', $c->create('rectangle', | |
322 | $iinfo->{areaX1}, $iinfo->{areaY1}, $x, $y, -outline => 'black')); | |
323 | $iinfo->{areaX2} = $x; | |
324 | $iinfo->{areaY2} = $y; | |
325 | } | |
326 | ||
327 | } # end items_stroke | |
328 | ||
329 | sub items_under_area { | |
330 | ||
331 | my($c, $iinfo) = @_; | |
332 | ||
333 | my $area = $c->find('withtag', 'area'); | |
334 | my @items = (); | |
335 | my $i; | |
336 | foreach $i ($c->find('enclosed', $iinfo->{areaX1}, | |
337 | $iinfo->{areaY1}, $iinfo->{areaX2}, $iinfo->{areaY2})) { | |
338 | my @tags = $c->gettags($i); | |
339 | if (defined($tags[0]) and grep $_ eq 'item', @tags) { | |
340 | push @items, $i; | |
341 | } | |
342 | } | |
343 | @items = 'None' unless @items; | |
344 | print STDOUT 'Items enclosed by area: ', join(' ', @items), ".\n"; | |
345 | @items = (); | |
346 | foreach $i ($c->find('overlapping', $iinfo->{areaX1}, $iinfo->{areaY1}, | |
347 | $iinfo->{areaX2}, $iinfo->{areaY2})) { | |
348 | my @tags = $c->gettags($i); | |
349 | if (defined($tags[0]) and grep $_ eq 'item', @tags) { | |
350 | push @items, $i; | |
351 | } | |
352 | } | |
353 | @items = 'None' unless @items; | |
354 | print STDOUT 'Items overlapping area: ', join(' ', @items), ".\n"; | |
355 | ||
356 | } # end items_under_area | |
357 | ||
358 | 1; |