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