| 1 | package Tk::WorldCanvas; |
| 2 | require Tk::Canvas; |
| 3 | require Tk::Derived; |
| 4 | use strict; |
| 5 | use Tk; |
| 6 | |
| 7 | use vars qw($VERSION); |
| 8 | $VERSION = '1.2.7'; |
| 9 | |
| 10 | #Version |
| 11 | #1.0.0 -- Sept 20, 2001 -- Initial release. |
| 12 | #1.1.0 -- Oct 29, 2001 -- Added '-changeView' callback option |
| 13 | #1.2.0 -- Jan 29, 2002 -- Added 'getView' method, |
| 14 | # better error handleing in 'bbox', |
| 15 | # cleaned up syntax |
| 16 | #1.2.1 -- May 17, 2002 -- changed package name to Tk::WorldCanvas |
| 17 | #1.2.2 -- June 28, 2002 -- Fixed bug in 'coords' |
| 18 | #1.2.3 -- July 31, 2002 -- Fixed another bug in 'coords', and an agrument passing bug. |
| 19 | #1.2.4 -- Sept 5, 2002 -- Added to POD |
| 20 | #1.2.5 -- Sept 6, 2002 -- Enhanced view window scaleing on canvas resize |
| 21 | #1.2.6 -- Nov 1, 2002 -- Fixed _view_area_canvas bug. |
| 22 | #1.2.7 -- Nov 19, 2002 -- handle fractional arguments to canvas(x|y) |
| 23 | |
| 24 | @Tk::WorldCanvas::ISA = qw(Tk::Derived Tk::Canvas); |
| 25 | |
| 26 | Construct Tk::Widget 'WorldCanvas'; |
| 27 | |
| 28 | sub ClassInit { |
| 29 | my ($worldcanvas, $mw) = @_; |
| 30 | |
| 31 | $worldcanvas->SUPER::ClassInit($mw); |
| 32 | } |
| 33 | |
| 34 | sub InitObject { |
| 35 | my ($worldcanvas, $args) = @_; |
| 36 | |
| 37 | my $pData = $worldcanvas->privateData; |
| 38 | $pData->{'bbox'} = [0, 0, -1, -1]; |
| 39 | $pData->{'scale'} = 1; |
| 40 | $pData->{'movex'} = 0; |
| 41 | $pData->{'movey'} = 0; |
| 42 | $pData->{'bboxvalid'} = 1; |
| 43 | $pData->{'width'} = $worldcanvas->width; |
| 44 | $pData->{'height'} = $worldcanvas->height; |
| 45 | |
| 46 | $worldcanvas->configure(-confine => 0); |
| 47 | |
| 48 | $worldcanvas->ConfigSpecs('-bandColor' => ['PASSIVE', 'bandColor', 'BandColor', 'red'], |
| 49 | '-bandcolor' => '-bandColor', |
| 50 | '-changeView' => ['CALLBACK', 'changeView', 'ChangeView', undef], |
| 51 | '-changeview' => '-changeView'); |
| 52 | |
| 53 | $worldcanvas->CanvasBind('<Configure>' => |
| 54 | sub { |
| 55 | my $w = $worldcanvas->width; |
| 56 | my $h = $worldcanvas->height; |
| 57 | my $ow = $pData->{'width'}; |
| 58 | my $oh = $pData->{'height'}; |
| 59 | if ($w != $ow or $h != $oh) { |
| 60 | my $b = $worldcanvas->cget('-borderwidth'); |
| 61 | _view_area_canvas($worldcanvas, $b, $b, $ow - $b, $oh - $b); |
| 62 | $pData->{'width'} = $w; |
| 63 | $pData->{'height'} = $h; |
| 64 | |
| 65 | my $bbox = $pData->{'bbox'}; |
| 66 | my $le = $worldcanvas->canvasx($b); |
| 67 | my $re = $worldcanvas->canvasx($w - $b); |
| 68 | my $te = $worldcanvas->canvasy($b); |
| 69 | my $be = $worldcanvas->canvasy($h - $b); |
| 70 | if (_inside(@$bbox, $le, $te, $re, $be)) { |
| 71 | $worldcanvas->viewAll; |
| 72 | } |
| 73 | } |
| 74 | } |
| 75 | ); |
| 76 | |
| 77 | $worldcanvas->SUPER::InitObject($args); |
| 78 | } |
| 79 | |
| 80 | sub getView { |
| 81 | my ($canvas) = @_; |
| 82 | |
| 83 | my $borderwidth = $canvas->cget('-borderwidth'); |
| 84 | my $right_edge = $canvas->width - $borderwidth; |
| 85 | my $left_edge = $borderwidth; |
| 86 | my $bot_edge = $canvas->height - $borderwidth; |
| 87 | my $top_edge = $borderwidth; |
| 88 | |
| 89 | return (worldxy($canvas, $left_edge, $bot_edge), worldxy($canvas, $right_edge, $top_edge)); |
| 90 | } |
| 91 | |
| 92 | sub xview { |
| 93 | my $canvas = shift; |
| 94 | _new_bbox($canvas) unless $canvas->privateData->{'bboxvalid'}; |
| 95 | $canvas->SUPER::xview(@_); |
| 96 | $canvas->Callback(-changeView, getView($canvas)) if defined($canvas->cget('-changeView')); |
| 97 | } |
| 98 | |
| 99 | sub yview { |
| 100 | my $canvas = shift; |
| 101 | _new_bbox($canvas) unless $canvas->privateData->{'bboxvalid'}; |
| 102 | $canvas->SUPER::yview(@_); |
| 103 | $canvas->Callback(-changeView, getView($canvas)) if defined($canvas->cget('-changeView')); |
| 104 | } |
| 105 | |
| 106 | sub delete { |
| 107 | my ($canvas, @tags) = @_; |
| 108 | |
| 109 | my $recreate = _killBand($canvas); |
| 110 | |
| 111 | my $found = 0; |
| 112 | foreach my $tag (@tags) { |
| 113 | if ($canvas->type($tag)) { |
| 114 | $found = 1; |
| 115 | last; |
| 116 | } |
| 117 | } |
| 118 | if (!$found) { # can't find anything! |
| 119 | _makeBand($canvas) if $recreate; |
| 120 | return; |
| 121 | } |
| 122 | |
| 123 | my $pData = $canvas->privateData; |
| 124 | my ($cx1, $cy1, $cx2, $cy2) = @{$pData->{'bbox'}}; |
| 125 | my ($x1, $y1, $x2, $y2) = _superBbox($canvas, @tags); |
| 126 | $canvas->SUPER::delete(@tags); |
| 127 | |
| 128 | if (!$canvas->type('all')) { # deleted last object |
| 129 | $pData->{'bbox'} = [0, 0, -1, -1]; |
| 130 | $pData->{'scale'} = 1; |
| 131 | $pData->{'movex'} = 0; |
| 132 | $pData->{'movey'} = 0; |
| 133 | } elsif (!_inside($x1, $y1, $x2, $y2, $cx1, $cy1, $cx2, $cy2)) { |
| 134 | $pData->{'bboxvalid'} = 0; |
| 135 | } |
| 136 | _makeBand($canvas) if $recreate; |
| 137 | } |
| 138 | |
| 139 | sub _inside { |
| 140 | my ($ix1, $iy1, $ix2, $iy2, $ox1, $oy1, $ox2, $oy2) = @_; |
| 141 | |
| 142 | my $wmargin = 0.01 * ($ox2 - $ox1); |
| 143 | my $hmargin = 0.01 * ($oy2 - $oy1); |
| 144 | |
| 145 | $wmargin = 3 if $wmargin < 3; |
| 146 | $hmargin = 3 if $hmargin < 3; |
| 147 | |
| 148 | return ($ix1 - $wmargin > $ox1 and $iy1 - $hmargin > $oy1 and |
| 149 | $ix2 + $wmargin < $ox2 and $iy2 + $hmargin < $oy2); |
| 150 | } |
| 151 | |
| 152 | sub _new_bbox { |
| 153 | my ($canvas) = @_; |
| 154 | |
| 155 | my $borderwidth = $canvas->cget('-borderwidth'); |
| 156 | my $vwidth = $canvas->width - 2 * $borderwidth; |
| 157 | my $vheight = $canvas->height - 2 * $borderwidth; |
| 158 | |
| 159 | my $pData = $canvas->privateData; |
| 160 | my ($cx1, $cy1, $cx2, $cy2) = @{$pData->{'bbox'}}; |
| 161 | |
| 162 | $cx2 += 1 if $cx2 == $cx1; |
| 163 | $cy2 += 1 if $cy2 == $cy1; |
| 164 | my $zoomx = $vwidth / abs($cx2 - $cx1); |
| 165 | my $zoomy = $vheight / abs($cy2 - $cy1); |
| 166 | my $zoom = ($zoomx > $zoomy) ? $zoomx : $zoomy; |
| 167 | |
| 168 | if ($zoom > 1.01) { |
| 169 | _scale($canvas, $canvas->width / 2, $canvas->height / 2, $zoom * 100); |
| 170 | } |
| 171 | |
| 172 | my ($x1, $y1, $x2, $y2) = _superBbox($canvas, 'all'); |
| 173 | $pData->{'bbox'} = [$x1, $y1, $x2, $y2]; |
| 174 | $canvas->configure(-scrollregion => [$x1, $y1, $x2, $y2]); |
| 175 | |
| 176 | if ($zoom > 1.01) { |
| 177 | _scale($canvas, $canvas->width / 2, $canvas->height / 2, 1 / ($zoom * 100)); |
| 178 | } |
| 179 | |
| 180 | $pData->{'bboxvalid'} = 1; |
| 181 | } |
| 182 | |
| 183 | sub _find_box { |
| 184 | die "Error: the number of args to _find_box must be positive and even\n" if @_ % 2 or !@_; |
| 185 | my $x1 = $_[0]; |
| 186 | my $x2 = $_[0]; |
| 187 | my $y1 = $_[1]; |
| 188 | my $y2 = $_[1]; |
| 189 | for (my $i = 2; $i < @_; $i += 2) { |
| 190 | if ($_[$i] < $x1) {$x1 = $_[$i];} |
| 191 | if ($_[$i] > $x2) {$x2 = $_[$i];} |
| 192 | if ($_[$i + 1] < $y1) {$y1 = $_[$i + 1];} |
| 193 | if ($_[$i + 1] > $y2) {$y2 = $_[$i + 1];} |
| 194 | } |
| 195 | return ($x1, $y1, $x2, $y2); |
| 196 | } |
| 197 | |
| 198 | sub zoom { |
| 199 | my ($canvas, $zoom) = @_; |
| 200 | _new_bbox($canvas) unless $canvas->privateData->{'bboxvalid'}; |
| 201 | _scale($canvas, $canvas->width / 2, $canvas->height / 2, $zoom); |
| 202 | $canvas->Callback(-changeView, getView($canvas)) if defined($canvas->cget('-changeView')); |
| 203 | } |
| 204 | |
| 205 | sub _scale { |
| 206 | my ($canvas, $xo, $yo, $scale) = @_; |
| 207 | |
| 208 | $scale = abs($scale); |
| 209 | |
| 210 | my $x = $canvas->canvasx(0) + $xo; |
| 211 | my $y = $canvas->canvasy(0) + $yo; |
| 212 | |
| 213 | if (!$canvas->type('all')) {return;} # can't find it |
| 214 | |
| 215 | my $pData = $canvas->privateData; |
| 216 | $pData->{'movex'} = ($pData->{'movex'} - $x) * $scale + $x; |
| 217 | $pData->{'movey'} = ($pData->{'movey'} - $y) * $scale + $y; |
| 218 | $pData->{'scale'} *= $scale; |
| 219 | |
| 220 | $canvas->SUPER::scale('all', $x, $y, $scale, $scale); |
| 221 | |
| 222 | my ($x1, $y1, $x2, $y2) = @{$pData->{'bbox'}}; |
| 223 | $x1 = ($x1 - $x) * $scale + $x; |
| 224 | $x2 = ($x2 - $x) * $scale + $x; |
| 225 | $y1 = ($y1 - $y) * $scale + $y; |
| 226 | $y2 = ($y2 - $y) * $scale + $y; |
| 227 | $pData->{'bbox'} = [$x1, $y1, $x2, $y2]; |
| 228 | $canvas->configure(-scrollregion => [$x1, $y1, $x2, $y2]); |
| 229 | } |
| 230 | |
| 231 | sub center { |
| 232 | my ($canvas, $x, $y) = @_; |
| 233 | |
| 234 | if (!$canvas->type('all')) {return;} # can't find anything! |
| 235 | |
| 236 | my $pData = $canvas->privateData; |
| 237 | _new_bbox($canvas) unless $pData->{'bboxvalid'}; |
| 238 | |
| 239 | $x = $x * $pData->{'scale'} + $pData->{'movex'}; |
| 240 | $y = $y * -$pData->{'scale'} + $pData->{'movey'}; |
| 241 | |
| 242 | my $dx = $canvas->canvasx(0) + $canvas->width / 2 - $x; |
| 243 | my $dy = $canvas->canvasy(0) + $canvas->height / 2 - $y; |
| 244 | |
| 245 | $pData->{'movex'} += $dx; |
| 246 | $pData->{'movey'} += $dy; |
| 247 | $canvas->SUPER::move('all', $dx, $dy); |
| 248 | |
| 249 | my ($x1, $y1, $x2, $y2) = @{$pData->{'bbox'}}; |
| 250 | $x1 += $dx; |
| 251 | $x2 += $dx; |
| 252 | $y1 += $dy; |
| 253 | $y2 += $dy; |
| 254 | $pData->{'bbox'} = [$x1, $y1, $x2, $y2]; |
| 255 | $canvas->configure(-scrollregion => [$x1, $y1, $x2, $y2]); |
| 256 | $canvas->Callback(-changeView, getView($canvas)) if defined($canvas->cget('-changeView')); |
| 257 | } |
| 258 | |
| 259 | sub centerTags { |
| 260 | my ($canvas, @args) = @_; |
| 261 | |
| 262 | my ($x1, $y1, $x2, $y2) = bbox($canvas, @args); |
| 263 | return unless defined($y2); |
| 264 | center($canvas, ($x1 + $x2) / 2.0, ($y1 + $y2) / 2.0); |
| 265 | } |
| 266 | |
| 267 | sub panWorld { |
| 268 | my ($canvas, $x, $y) = @_; |
| 269 | |
| 270 | my $cx = worldx($canvas, $canvas->width / 2) + $x; |
| 271 | my $cy = worldy($canvas, $canvas->height / 2) + $y; |
| 272 | center($canvas, $cx, $cy); |
| 273 | } |
| 274 | |
| 275 | sub viewAll { |
| 276 | my $canvas = shift; |
| 277 | |
| 278 | if (!$canvas->type('all')) {return;} # can't find anything! |
| 279 | |
| 280 | my %switches = (-border => 0.02, @_); |
| 281 | $switches{-border} = 0 if $switches{-border} < 0; |
| 282 | |
| 283 | my $pData = $canvas->privateData; |
| 284 | _new_bbox($canvas) unless $pData->{'bboxvalid'}; |
| 285 | |
| 286 | my ($x1, $y1, $x2, $y2) = @{$pData->{'bbox'}}; |
| 287 | my $scale = $pData->{'scale'}; |
| 288 | my $movex = $pData->{'movex'}; |
| 289 | my $movey = $pData->{'movey'}; |
| 290 | my $wx1 = ($x1 - $movex) / $scale; |
| 291 | my $wx2 = ($x2 - $movex) / $scale; |
| 292 | my $wy1 = ($y1 - $movey) / $scale; |
| 293 | my $wy2 = ($y2 - $movey) / $scale; |
| 294 | |
| 295 | viewArea($canvas, $wx1, -$wy1, $wx2, -$wy2, -border => $switches{-border}); |
| 296 | } |
| 297 | |
| 298 | sub viewArea { |
| 299 | my ($canvas, $vx1, $vy1, $vx2, $vy2) = splice(@_, 0, 5); |
| 300 | |
| 301 | if (!defined($vy2) or !$canvas->type('all')) {return;} # can't find anything! |
| 302 | |
| 303 | my %switches = (-border => 0.02, @_); |
| 304 | $switches{-border} = 0 if $switches{-border} < 0; |
| 305 | |
| 306 | my $pData = $canvas->privateData; |
| 307 | _new_bbox($canvas) unless $pData->{'bboxvalid'}; |
| 308 | |
| 309 | $vy1 = -$vy1; |
| 310 | $vy2 = -$vy2; |
| 311 | |
| 312 | ($vx1, $vx2) = ($vx2, $vx1) if $vx1 > $vx2; |
| 313 | ($vy1, $vy2) = ($vy2, $vy1) if $vy1 > $vy2; |
| 314 | my $bw = $switches{-border} * ($vx2 - $vx1); |
| 315 | my $bh = $switches{-border} * ($vy2 - $vy1); |
| 316 | $vx1 -= $bw; |
| 317 | $vx2 += $bw; |
| 318 | $vy1 -= $bh; |
| 319 | $vy2 += $bh; |
| 320 | |
| 321 | my $scale = $pData->{'scale'}; |
| 322 | my $movex = $pData->{'movex'}; |
| 323 | my $movey = $pData->{'movey'}; |
| 324 | my $canvasx = $canvas->canvasx(0); |
| 325 | my $canvasy = $canvas->canvasy(0); |
| 326 | |
| 327 | my $cx1 = $vx1 * $scale + $movex - $canvasx; |
| 328 | my $cx2 = $vx2 * $scale + $movex - $canvasx; |
| 329 | my $cy1 = $vy1 * $scale + $movey - $canvasy; |
| 330 | my $cy2 = $vy2 * $scale + $movey - $canvasy; |
| 331 | |
| 332 | _view_area_canvas($canvas, $cx1, $cy1, $cx2, $cy2); |
| 333 | } |
| 334 | |
| 335 | sub _view_area_canvas { |
| 336 | my ($canvas, $vx1, $vy1, $vx2, $vy2) = @_; |
| 337 | |
| 338 | if (!$canvas->type('all')) {return;} # can't find anything! |
| 339 | my $pData = $canvas->privateData; |
| 340 | _new_bbox($canvas) unless $pData->{'bboxvalid'}; |
| 341 | |
| 342 | my $borderwidth = $canvas->cget('-borderwidth'); |
| 343 | my $cwidth = $canvas->width; |
| 344 | my $cheight = $canvas->height; |
| 345 | |
| 346 | my $dx = $cwidth / 2 - ($vx1 + $vx2) / 2; |
| 347 | my $dy = $cheight / 2 - ($vy1 + $vy2) / 2; |
| 348 | |
| 349 | my $midx = $canvas->canvasx(0) + $cwidth / 2; |
| 350 | my $midy = $canvas->canvasy(0) + $cheight / 2; |
| 351 | |
| 352 | $vx2 += 1 if $vx2 == $vx1; |
| 353 | $vy2 += 1 if $vy2 == $vy1; |
| 354 | my $zoomx = ($cwidth - 2 * $borderwidth) / abs($vx2 - $vx1); |
| 355 | my $zoomy = ($cheight - 2 * $borderwidth) / abs($vy2 - $vy1); |
| 356 | my $zoom = ($zoomx < $zoomy) ? $zoomx : $zoomy; |
| 357 | $zoom = abs($zoom); # This should never be needed. |
| 358 | |
| 359 | if ($zoom > 0.999 and $zoom < 1.001) { |
| 360 | $canvas->SUPER::move('all', $dx, $dy); |
| 361 | } else { |
| 362 | $canvas->SUPER::scale('all', $midx - $dx - $dx / ($zoom - 1), $midy - $dy - $dy / ($zoom - 1), $zoom, $zoom); |
| 363 | } |
| 364 | |
| 365 | $pData->{'movex'} = ($pData->{'movex'} + $dx - $midx) * $zoom + $midx; |
| 366 | $pData->{'movey'} = ($pData->{'movey'} + $dy - $midy) * $zoom + $midy; |
| 367 | $pData->{'scale'} *= $zoom; |
| 368 | |
| 369 | my ($x1, $y1, $x2, $y2) = @{$pData->{'bbox'}}; |
| 370 | $x1 = ($x1 + $dx - $midx) * $zoom + $midx; |
| 371 | $x2 = ($x2 + $dx - $midx) * $zoom + $midx; |
| 372 | $y1 = ($y1 + $dy - $midy) * $zoom + $midy; |
| 373 | $y2 = ($y2 + $dy - $midy) * $zoom + $midy; |
| 374 | $pData->{'bbox'} = [$x1, $y1, $x2, $y2]; |
| 375 | $canvas->configure(-scrollregion => [$x1, $y1, $x2, $y2]); |
| 376 | $canvas->Callback(-changeView, getView($canvas)) if defined($canvas->cget('-changeView')); |
| 377 | } |
| 378 | |
| 379 | sub _map_coords { |
| 380 | my $canvas = shift; |
| 381 | |
| 382 | my @coords = (); |
| 383 | my $pData = $canvas->privateData; |
| 384 | my $change_bbox = 0; |
| 385 | my ($x1, $y1, $x2, $y2) = @{$pData->{'bbox'}}; |
| 386 | |
| 387 | my $scale = $pData->{'scale'}; |
| 388 | my $movex = $pData->{'movex'}; |
| 389 | my $movey = $pData->{'movey'}; |
| 390 | |
| 391 | my $x = 1; |
| 392 | while (defined (my $arg = shift)) { |
| 393 | if ($arg !~ /^[+-.]*\d/) { |
| 394 | unshift @_, $arg; |
| 395 | last; |
| 396 | } else { |
| 397 | if ($x) { |
| 398 | $arg = $arg * $scale + $movex; |
| 399 | if ($x2 < $x1) {$x2 = $x1 = $arg; $change_bbox = 1;} |
| 400 | if ($arg < $x1) {$x1 = $arg; $change_bbox = 1;} |
| 401 | if ($arg > $x2) {$x2 = $arg; $change_bbox = 1;} |
| 402 | $x = 0; |
| 403 | } else { |
| 404 | $arg = -$arg * $scale + $movey; # invert y-coords |
| 405 | if ($y2 < $y1) {$y2 = $y1 = $arg; $change_bbox = 1;} |
| 406 | if ($arg < $y1) {$y1 = $arg; $change_bbox = 1;} |
| 407 | if ($arg > $y2) {$y2 = $arg; $change_bbox = 1;} |
| 408 | $x = 1; |
| 409 | } |
| 410 | push @coords, $arg; |
| 411 | } |
| 412 | } |
| 413 | if ($change_bbox) { |
| 414 | $pData->{'bbox'} = [$x1, $y1, $x2, $y2]; |
| 415 | $canvas->configure(-scrollregion => [$x1, $y1, $x2, $y2]); |
| 416 | } |
| 417 | |
| 418 | return (@coords, @_); |
| 419 | } |
| 420 | |
| 421 | sub find { |
| 422 | my ($canvas, @args) = @_; |
| 423 | |
| 424 | my $pData = $canvas->privateData; |
| 425 | if ($args[0] =~ m/^(closest|above|below)$/i) { |
| 426 | if ($args[0] =~ m/^closest$/i) { |
| 427 | return if @args < 3; |
| 428 | my $scale = $pData->{'scale'}; |
| 429 | $args[1] = $args[1] * $scale + $pData->{'movex'}; |
| 430 | $args[2] = -$args[2] * $scale + $pData->{'movey'}; |
| 431 | } |
| 432 | my $recreate = _killBand($canvas); |
| 433 | my $found = $canvas->SUPER::find(@args); |
| 434 | _makeBand($canvas) if $recreate; |
| 435 | return $found; |
| 436 | } else { |
| 437 | if ($args[0] =~ m/^(enclosed|overlapping)$/i) { |
| 438 | return if @args < 5; |
| 439 | my $scale = $pData->{'scale'}; |
| 440 | my $movex = $pData->{'movex'}; |
| 441 | my $movey = $pData->{'movey'}; |
| 442 | $args[1] = $args[1] * $scale + $movex; |
| 443 | $args[2] = -$args[2] * $scale + $movey; |
| 444 | $args[3] = $args[3] * $scale + $movex; |
| 445 | $args[4] = -$args[4] * $scale + $movey; |
| 446 | } |
| 447 | my $recreate = _killBand($canvas); |
| 448 | my @found = $canvas->SUPER::find(@args); |
| 449 | _makeBand($canvas) if $recreate; |
| 450 | return @found; |
| 451 | } |
| 452 | } |
| 453 | |
| 454 | sub coords { |
| 455 | my ($canvas, $tag, @w_coords) = @_; |
| 456 | |
| 457 | if (!$canvas->type($tag)) {return;} # can't find it |
| 458 | |
| 459 | my $pData = $canvas->privateData; |
| 460 | my $scale = $pData->{'scale'}; |
| 461 | my $movex = $pData->{'movex'}; |
| 462 | my $movey = $pData->{'movey'}; |
| 463 | |
| 464 | if (@w_coords) { |
| 465 | die "missing y coordinate in call to coords\n" if @w_coords % 2; |
| 466 | my ($x1, $y1, $x2, $y2) = _find_box($canvas->SUPER::coords($tag)); |
| 467 | |
| 468 | my @c_coords = @w_coords; |
| 469 | for (my $i = 0; $i < @c_coords; $i += 2) { |
| 470 | $c_coords[$i] = $c_coords[$i ] * $scale + $movex; |
| 471 | $c_coords[$i + 1] = -$c_coords[$i + 1] * $scale + $movey; |
| 472 | } |
| 473 | $canvas->SUPER::coords($tag, @c_coords); |
| 474 | |
| 475 | my ($nx1, $ny1, $nx2, $ny2) = _find_box(@c_coords); |
| 476 | _adjustBbox($canvas, $x1, $y1, $x2, $y2, $nx1, $ny1, $nx2, $ny2); |
| 477 | } else { |
| 478 | @w_coords = $canvas->SUPER::coords($tag); |
| 479 | die "missing y coordinate in return value from SUPER::coords\n" if @w_coords % 2; |
| 480 | for (my $i = 0; $i < @w_coords; $i += 2) { |
| 481 | $w_coords[$i] = ($w_coords[$i] - $movex) / $scale; |
| 482 | $w_coords[$i + 1] = 0 - ($w_coords[$i + 1] - $movey) / $scale; |
| 483 | } |
| 484 | if (@w_coords == 4 and ($w_coords[0] > $w_coords[2] or $w_coords[1] > $w_coords[3])) { |
| 485 | my $type = $canvas->type($tag); |
| 486 | if ($type =~ /^arc$|^oval$|^rectangle$/) { |
| 487 | ($w_coords[0], $w_coords[2]) = ($w_coords[2], $w_coords[0]) if $w_coords[0] > $w_coords[2]; |
| 488 | ($w_coords[1], $w_coords[3]) = ($w_coords[3], $w_coords[1]) if $w_coords[1] > $w_coords[3]; |
| 489 | } |
| 490 | } |
| 491 | return @w_coords; |
| 492 | } |
| 493 | return; |
| 494 | } |
| 495 | |
| 496 | sub scale { |
| 497 | my ($canvas, $tag, $xo, $yo, $xs, $ys) = @_; |
| 498 | |
| 499 | if (!$canvas->type($tag)) {return;} # can't find it |
| 500 | |
| 501 | my $pData = $canvas->privateData; |
| 502 | |
| 503 | my $cxo = $xo * $pData->{'scale'} + $pData->{'movex'}; |
| 504 | my $cyo = -$yo * $pData->{'scale'} + $pData->{'movey'}; |
| 505 | |
| 506 | if ($tag =~ m/^all$/i) { |
| 507 | $canvas->SUPER::scale($tag, $cxo, $cyo, $xs, $ys); |
| 508 | |
| 509 | my ($x1, $y1, $x2, $y2) = @{$pData->{'bbox'}}; |
| 510 | $x1 = ($x1 - $cxo) * $xs + $cxo; |
| 511 | $x2 = ($x2 - $cxo) * $xs + $cxo; |
| 512 | $y1 = ($y1 - $cyo) * $ys + $cyo; |
| 513 | $y2 = ($y2 - $cyo) * $ys + $cyo; |
| 514 | $pData->{'bbox'} = [$x1, $y1, $x2, $y2]; |
| 515 | $canvas->configure(-scrollregion => [$x1, $y1, $x2, $y2]); |
| 516 | } else { |
| 517 | my ($x1, $y1, $x2, $y2) = _find_box($canvas->SUPER::coords($tag)); |
| 518 | $canvas->SUPER::scale($tag, $cxo, $cyo, $xs, $ys); |
| 519 | my $nx1 = ($x1 - $cxo) * $xs + $cxo; |
| 520 | my $nx2 = ($x2 - $cxo) * $xs + $cxo; |
| 521 | my $ny1 = ($y1 - $cyo) * $ys + $cyo; |
| 522 | my $ny2 = ($y2 - $cyo) * $ys + $cyo; |
| 523 | |
| 524 | _adjustBbox($canvas, $x1, $y1, $x2, $y2, $nx1, $ny1, $nx2, $ny2); |
| 525 | } |
| 526 | } |
| 527 | |
| 528 | sub move { |
| 529 | my ($canvas, $tag, $x, $y) = @_; |
| 530 | |
| 531 | my ($x1, $y1, $x2, $y2) = _find_box($canvas->SUPER::coords($tag)); |
| 532 | |
| 533 | my $scale = $canvas->privateData->{'scale'}; |
| 534 | my $dx = $x * $scale; |
| 535 | my $dy = -$y * $scale; |
| 536 | $canvas->SUPER::move($tag, $dx, $dy); |
| 537 | |
| 538 | my ($nx1, $ny1, $nx2, $ny2) = ($x1 + $dx, $y1 + $dy, $x2 + $dx, $y2 + $dy); |
| 539 | _adjustBbox($canvas, $x1, $y1, $x2, $y2, $nx1, $ny1, $nx2, $ny2); |
| 540 | } |
| 541 | |
| 542 | sub _adjustBbox { |
| 543 | my ($canvas, $x1, $y1, $x2, $y2, $nx1, $ny1, $nx2, $ny2) = @_; |
| 544 | |
| 545 | my $pData = $canvas->privateData; |
| 546 | my ($cx1, $cy1, $cx2, $cy2) = @{$pData->{'bbox'}}; |
| 547 | |
| 548 | my $changeBbox = 0; |
| 549 | if ($nx1 < $cx1) {$cx1 = $nx1; $changeBbox = 1;} |
| 550 | if ($ny1 < $cy1) {$cy1 = $ny1; $changeBbox = 1;} |
| 551 | if ($nx2 > $cx2) {$cx2 = $nx2; $changeBbox = 1;} |
| 552 | if ($ny2 > $cy2) {$cy2 = $ny2; $changeBbox = 1;} |
| 553 | |
| 554 | #expanding the bounding box is easy. |
| 555 | if ($changeBbox) { |
| 556 | $pData->{'bbox'} = [$cx1, $cy1, $cx2, $cy2]; |
| 557 | $canvas->configure(-scrollregion => [$cx1, $cy1, $cx2, $cy2]); |
| 558 | } |
| 559 | |
| 560 | #shrinking the bounding box is not easy. |
| 561 | my $wmargin = 0.01 * ($cx2 - $cx1); |
| 562 | my $hmargin = 0.01 * ($cy2 - $cy1); |
| 563 | $wmargin = 3 if $wmargin < 3; |
| 564 | $hmargin = 3 if $hmargin < 3; |
| 565 | |
| 566 | if (($x1 - $wmargin < $cx1 and $x1 < $nx1) or |
| 567 | ($y1 - $hmargin < $cy1 and $y1 < $ny1) or |
| 568 | ($x2 + $wmargin > $cx2 and $x2 > $nx2) or |
| 569 | ($y2 + $hmargin > $cy2 and $y2 > $ny2)) { |
| 570 | $pData->{'bboxvalid'} = 0; |
| 571 | } |
| 572 | } |
| 573 | |
| 574 | sub bbox { |
| 575 | my $canvas = shift; |
| 576 | |
| 577 | my $exact = 0; |
| 578 | if ($_[0] =~ m/-exact/i) { |
| 579 | shift; |
| 580 | $exact = shift; |
| 581 | } |
| 582 | my @tags = @_; |
| 583 | |
| 584 | my $found = 0; |
| 585 | foreach my $tag (@tags) { |
| 586 | if ($canvas->type($tag)) { |
| 587 | $found = 1; |
| 588 | last; |
| 589 | } |
| 590 | } |
| 591 | return unless $found; |
| 592 | |
| 593 | my $pData = $canvas->privateData; |
| 594 | |
| 595 | if ($tags[0] =~ m/^all$/i) { |
| 596 | my ($x1, $y1, $x2, $y2) = @{$pData->{'bbox'}}; |
| 597 | my $scale = $pData->{'scale'}; |
| 598 | my $movex = $pData->{'movex'}; |
| 599 | my $movey = $pData->{'movey'}; |
| 600 | my $wx1 = ($x1 - $movex) / $scale; |
| 601 | my $wx2 = ($x2 - $movex) / $scale; |
| 602 | my $wy1 = ($y1 - $movey) / -$scale; |
| 603 | my $wy2 = ($y2 - $movey) / -$scale; |
| 604 | |
| 605 | ($wx1, $wx2) = ($wx2, $wx1) if ($wx2 < $wx1); |
| 606 | ($wy1, $wy2) = ($wy2, $wy1) if ($wy2 < $wy1); |
| 607 | return ($wx1, $wy1, $wx2, $wy2); |
| 608 | } else { |
| 609 | my $onePixel = 1.0 / $pData->{'scale'}; |
| 610 | my $zoom_fix = 0; |
| 611 | if ($exact and $onePixel > 0.001) { |
| 612 | zoom($canvas, $onePixel * 1000); |
| 613 | $zoom_fix = 1; |
| 614 | } |
| 615 | my ($x1, $y1, $x2, $y2) = _superBbox($canvas, @tags); |
| 616 | if (not defined $x1) { |
| 617 | # @tags exist but their bbox can not be |
| 618 | # expressed in integers (overflows). |
| 619 | zoom($canvas, 1 / ($onePixel * 1000)) if $zoom_fix; |
| 620 | return; |
| 621 | } |
| 622 | |
| 623 | # If the error looks to be greater than 15%, do exact anyway |
| 624 | if (!$exact and abs($x2 - $x1) < 27 and abs($y2 - $y1) < 27) { |
| 625 | zoom($canvas, $onePixel * 1000); |
| 626 | my ($nx1, $ny1, $nx2, $ny2) = _superBbox($canvas, @tags); |
| 627 | if (not defined $nx1) { |
| 628 | # overflows integers. Retreat to previous box. |
| 629 | zoom($canvas, 1 / ($onePixel * 1000)); |
| 630 | } else { |
| 631 | $zoom_fix = 1; |
| 632 | ($x1, $y1, $x2, $y2) = ($nx1, $ny1, $nx2, $ny2); |
| 633 | } |
| 634 | } |
| 635 | |
| 636 | my $scale = $pData->{'scale'}; |
| 637 | my $movex = $pData->{'movex'}; |
| 638 | my $movey = $pData->{'movey'}; |
| 639 | $x1 = ($x1 - $movex) / $scale; |
| 640 | $x2 = ($x2 - $movex) / $scale; |
| 641 | $y1 = ($y1 - $movey) / -$scale; |
| 642 | $y2 = ($y2 - $movey) / -$scale; |
| 643 | |
| 644 | if ($zoom_fix) { |
| 645 | zoom($canvas, 1 / ($onePixel * 1000)); |
| 646 | } |
| 647 | return ($x1, $y2, $x2, $y1); |
| 648 | } |
| 649 | } |
| 650 | |
| 651 | sub rubberBand { |
| 652 | die "Error: wrong number of args passed to rubberBand\n" unless @_ == 2; |
| 653 | my ($canvas, $step) = @_; |
| 654 | |
| 655 | my $pData = $canvas->privateData; |
| 656 | return if $step >= 1 and not defined $pData->{'RubberBand'}; |
| 657 | |
| 658 | my $ev = $canvas->XEvent; |
| 659 | my $x = worldx($canvas, $ev->x); |
| 660 | my $y = worldy($canvas, $ev->y); |
| 661 | |
| 662 | if ($step == 0) { |
| 663 | # create anchor for rubberband |
| 664 | _killBand($canvas); |
| 665 | $pData->{'RubberBand'} = [$x, $y, $x, $y]; |
| 666 | } elsif ($step == 1) { |
| 667 | # update end of rubber band and redraw |
| 668 | $pData->{'RubberBand'}[2] = $x; |
| 669 | $pData->{'RubberBand'}[3] = $y; |
| 670 | _killBand($canvas); |
| 671 | _makeBand($canvas); |
| 672 | } elsif ($step == 2) { |
| 673 | # step == 2: done |
| 674 | _killBand($canvas) or return; |
| 675 | |
| 676 | my ($x1, $y1, $x2, $y2) = @{$pData->{'RubberBand'}}; |
| 677 | undef($pData->{'RubberBand'}); |
| 678 | |
| 679 | ($x1, $x2) = ($x2, $x1) if ($x2 < $x1); |
| 680 | ($y1, $y2) = ($y2, $y1) if ($y2 < $y1); |
| 681 | return ($x1, $y1, $x2, $y2); |
| 682 | } |
| 683 | } |
| 684 | |
| 685 | sub _superBbox { |
| 686 | my ($canvas, @tags) = @_; |
| 687 | |
| 688 | my $recreate = _killBand($canvas); |
| 689 | my ($x1, $y1, $x2, $y2) = $canvas->SUPER::bbox(@tags); |
| 690 | _makeBand($canvas) if $recreate; |
| 691 | |
| 692 | return ($x1, $y1, $x2, $y2); |
| 693 | } |
| 694 | |
| 695 | sub _killBand { |
| 696 | my ($canvas) = @_; |
| 697 | |
| 698 | my $id = $canvas->privateData->{'RubberBandID'}; |
| 699 | return 0 if !defined($id); |
| 700 | |
| 701 | $canvas->SUPER::delete($id); |
| 702 | undef($canvas->privateData->{'RubberBandID'}); |
| 703 | |
| 704 | return 1; |
| 705 | } |
| 706 | |
| 707 | sub _makeBand { |
| 708 | my ($canvas) = @_; |
| 709 | |
| 710 | my $pData = $canvas->privateData; |
| 711 | my $rb = $pData->{'RubberBand'}; |
| 712 | die "Error: RubberBand is not defined" if !$rb; |
| 713 | die "Error: RubberBand does not have 4 values." if @$rb != 4; |
| 714 | |
| 715 | my $scale = $pData->{'scale'}; |
| 716 | my $movex = $pData->{'movex'}; |
| 717 | my $movey = $pData->{'movey'}; |
| 718 | my $crbx1 = $rb->[0] * $scale + $movex; |
| 719 | my $crbx2 = $rb->[2] * $scale + $movex; |
| 720 | my $crby1 = $rb->[1] * -$scale + $movey; |
| 721 | my $crby2 = $rb->[3] * -$scale + $movey; |
| 722 | |
| 723 | my $color = $canvas->cget('-bandColor'); |
| 724 | my $id = $canvas->SUPER::create('rectangle', $crbx1, $crby1, $crbx2, $crby2, -outline => $color); |
| 725 | $pData->{'RubberBandID'} = $id; |
| 726 | } |
| 727 | |
| 728 | sub eventLocation { |
| 729 | my ($canvas) = @_; |
| 730 | |
| 731 | my $ev = $canvas->XEvent; |
| 732 | return ($canvas->worldx($ev->x), $canvas->worldy($ev->y)) if defined $ev; |
| 733 | return; |
| 734 | } |
| 735 | |
| 736 | sub viewFit { |
| 737 | my $canvas = shift; |
| 738 | my $border = 0.02; |
| 739 | |
| 740 | if ($_[0] =~ m/-border/i) { |
| 741 | shift; |
| 742 | $border = shift if (@_); |
| 743 | $border = 0 if $border < 0; |
| 744 | } |
| 745 | my @tags = @_; |
| 746 | |
| 747 | my $found = 0; |
| 748 | foreach my $tag (@tags) { |
| 749 | if ($canvas->type($tag)) { |
| 750 | $found = 1; |
| 751 | last; |
| 752 | } |
| 753 | } |
| 754 | return unless $found; |
| 755 | |
| 756 | viewArea($canvas, bbox($canvas, @tags), -border => $border); |
| 757 | } |
| 758 | |
| 759 | sub pixelSize { |
| 760 | my ($canvas) = @_; |
| 761 | |
| 762 | return (1.0 / $canvas->privateData->{'scale'}); |
| 763 | } |
| 764 | |
| 765 | sub worldx { |
| 766 | my ($canvas, $x) = @_; |
| 767 | |
| 768 | my $pData = $canvas->privateData; |
| 769 | my $scale = $pData->{'scale'}; |
| 770 | return if !$scale; |
| 771 | return (($canvas->canvasx(0) + $x - $pData->{'movex'}) / $scale); |
| 772 | } |
| 773 | |
| 774 | sub worldy { |
| 775 | my ($canvas, $y) = @_; |
| 776 | |
| 777 | my $pData = $canvas->privateData; |
| 778 | my $scale = $pData->{'scale'}; |
| 779 | return if !$scale; |
| 780 | return (0 - ($canvas->canvasy(0) + $y - $pData->{'movey'}) / $scale); |
| 781 | } |
| 782 | |
| 783 | sub worldxy { |
| 784 | my ($canvas, $x, $y) = @_; |
| 785 | |
| 786 | my $pData = $canvas->privateData; |
| 787 | my $scale = $pData->{'scale'}; |
| 788 | return if !$scale; |
| 789 | return ( ($canvas->canvasx(0) + $x - $pData->{'movex'}) / $scale, |
| 790 | 0 - ($canvas->canvasy(0) + $y - $pData->{'movey'}) / $scale); |
| 791 | } |
| 792 | |
| 793 | sub widgetx { |
| 794 | my ($canvas, $x) = @_; |
| 795 | |
| 796 | my $pData = $canvas->privateData; |
| 797 | return ($x * $pData->{'scale'} + $pData->{'movex'} - $canvas->canvasx(0)); |
| 798 | } |
| 799 | |
| 800 | sub widgety { |
| 801 | my ($canvas, $y) = @_; |
| 802 | |
| 803 | my $pData = $canvas->privateData; |
| 804 | return (-$y * $pData->{'scale'} + $pData->{'movey'} - $canvas->canvasy(0)); |
| 805 | } |
| 806 | |
| 807 | sub widgetxy { |
| 808 | my ($canvas, $x, $y) = @_; |
| 809 | |
| 810 | my $pData = $canvas->privateData; |
| 811 | my $scale = $pData->{'scale'}; |
| 812 | return ( $x * $scale + $pData->{'movex'} - $canvas->canvasx(0), |
| 813 | -$y * $scale + $pData->{'movey'} - $canvas->canvasy(0)); |
| 814 | } |
| 815 | |
| 816 | # In older versions of Tk, createType calls create('type', ...) |
| 817 | # 'coords_mapped' is used to avoid calling _map_coords twice. |
| 818 | # I could have had the createType methods all call create, but |
| 819 | # that defeats the point of the new Tk optimization to avoid |
| 820 | # the case statement. |
| 821 | my $coords_mapped = 0; |
| 822 | |
| 823 | sub create { |
| 824 | my ($canvas, $type) = splice(@_, 0, 2); |
| 825 | my @new_args = ($coords_mapped) ? @_ : _map_coords($canvas, @_); |
| 826 | return ($canvas->SUPER::create($type, @new_args)); |
| 827 | } |
| 828 | |
| 829 | sub createPolygon { |
| 830 | my $canvas = shift; |
| 831 | my @new_args = _map_coords($canvas, @_); |
| 832 | $coords_mapped = 1; |
| 833 | my $id = $canvas->SUPER::createPolygon(@new_args); |
| 834 | $coords_mapped = 0; |
| 835 | return $id; |
| 836 | } |
| 837 | |
| 838 | sub createRectangle { |
| 839 | my $canvas = shift; |
| 840 | my @new_args = _map_coords($canvas, @_); |
| 841 | $coords_mapped = 1; |
| 842 | my $id = $canvas->SUPER::createRectangle(@new_args); |
| 843 | $coords_mapped = 0; |
| 844 | return $id; |
| 845 | } |
| 846 | |
| 847 | sub createArc { |
| 848 | my $canvas = shift; |
| 849 | my @new_args = _map_coords($canvas, @_); |
| 850 | $coords_mapped = 1; |
| 851 | my $id = $canvas->SUPER::createArc(@new_args); |
| 852 | $coords_mapped = 0; |
| 853 | return $id; |
| 854 | } |
| 855 | |
| 856 | sub createLine { |
| 857 | my $canvas = shift; |
| 858 | my @new_args = _map_coords($canvas, @_); |
| 859 | $coords_mapped = 1; |
| 860 | my $id = $canvas->SUPER::createLine(@new_args); |
| 861 | $coords_mapped = 0; |
| 862 | return $id; |
| 863 | } |
| 864 | |
| 865 | sub createOval { |
| 866 | my $canvas = shift; |
| 867 | my @new_args = _map_coords($canvas, @_); |
| 868 | $coords_mapped = 1; |
| 869 | my $id = $canvas->SUPER::createOval(@new_args); |
| 870 | $coords_mapped = 0; |
| 871 | return $id; |
| 872 | } |
| 873 | |
| 874 | sub createText { |
| 875 | my $canvas = shift; |
| 876 | my @new_args = _map_coords($canvas, @_); |
| 877 | $coords_mapped = 1; |
| 878 | my $id = $canvas->SUPER::createText(@new_args); |
| 879 | $coords_mapped = 0; |
| 880 | return $id; |
| 881 | } |
| 882 | |
| 883 | sub createWindow { |
| 884 | my $canvas = shift; |
| 885 | my @new_args = _map_coords($canvas, @_); |
| 886 | $coords_mapped = 1; |
| 887 | my $id = $canvas->SUPER::createWindow(@new_args); |
| 888 | $coords_mapped = 0; |
| 889 | return $id; |
| 890 | } |
| 891 | |
| 892 | sub createBitmap { |
| 893 | my $canvas = shift; |
| 894 | my @new_args = _map_coords($canvas, @_); |
| 895 | $coords_mapped = 1; |
| 896 | my $id = $canvas->SUPER::createBitmap(@new_args); |
| 897 | $coords_mapped = 0; |
| 898 | return $id; |
| 899 | } |
| 900 | |
| 901 | sub createImage { |
| 902 | my $canvas = shift; |
| 903 | my @new_args = _map_coords($canvas, @_); |
| 904 | $coords_mapped = 1; |
| 905 | my $id = $canvas->SUPER::createImage(@new_args); |
| 906 | $coords_mapped = 0; |
| 907 | return $id; |
| 908 | } |
| 909 | |
| 910 | 1; |
| 911 | |
| 912 | __END__ |
| 913 | |
| 914 | =head1 NAME |
| 915 | |
| 916 | Tk::WorldCanvas - Autoscaling Canvas widget with zoom, viewAll, viewArea, viewFit, and center. |
| 917 | |
| 918 | =for category Tk Widget Classes |
| 919 | |
| 920 | =head1 SYNOPSIS |
| 921 | |
| 922 | $worldcanvas = $parent->WorldCanvas(?options?); |
| 923 | |
| 924 | =head1 DESCRIPTION |
| 925 | |
| 926 | This module is a wrapper around the Canvas widget that maps the |
| 927 | user's coordinate system to the now mostly hidden coordinate system of |
| 928 | the Canvas widget. In world coordinates the y-axis increases in |
| 929 | the upward direction. |
| 930 | |
| 931 | I<WorldCanvas> is meant to be a replacement for Canvas. It's not |
| 932 | quite a "drop in" replacement though because the y-axis is inverted |
| 933 | compared to Canvas. Usually to convert you will have to invert all |
| 934 | y-coordinates used to create objects. Typically, you should call |
| 935 | $worldcanvas->viewAll (or $worldcanvas->viewArea(@box)) before calling |
| 936 | MainLoop. |
| 937 | |
| 938 | Most of the I<WorldCanvas> methods are the same as the I<Canvas> |
| 939 | methods except that they accept and return world coordinates instead |
| 940 | of widget coordinates. |
| 941 | |
| 942 | =head1 INSTALLATION |
| 943 | |
| 944 | Standard method: |
| 945 | |
| 946 | perl Makefile.PL |
| 947 | make |
| 948 | make test |
| 949 | make install |
| 950 | |
| 951 | The last step requires proper permissions. |
| 952 | |
| 953 | Or you can copy the WorldCanvas.pm file to a local directory and |
| 954 | skip the formalities. |
| 955 | |
| 956 | =head1 NEW METHODS |
| 957 | |
| 958 | =over 4 |
| 959 | |
| 960 | =item I<$worldcanvas>->B<zoom>(I<zoom factor>) |
| 961 | |
| 962 | Zooms the display by the specified amount. Example: |
| 963 | |
| 964 | $worldcanvas->CanvasBind('<i>' => sub {$worldcanvas->zoom(1.25)}); |
| 965 | $worldcanvas->CanvasBind('<o>' => sub {$worldcanvas->zoom(0.8)}); |
| 966 | |
| 967 | # If you are using the 'Scrolled' constructor as in: |
| 968 | my $worldcanvas = $main->Scrolled('WorldCanvas', -scrollbars => 'nw', ... ) |
| 969 | # you want to bind the key-presses to the 'worldcanvas' Subwidget of Scrolled. |
| 970 | my $scrolled_canvas = $worldcanvas->Subwidget('worldcanvas'); # note the lower case 'worldcanvas' |
| 971 | $scrolled_canvas->CanvasBind('<i>' => sub {$scrolled_canvas->zoom(1.25)}); |
| 972 | $scrolled_canvas->CanvasBind('<o>' => sub {$scrolled_canvas->zoom(0.8)}); |
| 973 | |
| 974 | # I don't like the scrollbars taking the focus when I |
| 975 | # <ctrl>-tab through the windows, so I: |
| 976 | $worldcanvas->Subwidget('xscrollbar')->configure(-takefocus => 0); |
| 977 | $worldcanvas->Subwidget('yscrollbar')->configure(-takefocus => 0); |
| 978 | |
| 979 | |
| 980 | =item I<$worldcanvas>->B<center>(I<x, y>) |
| 981 | |
| 982 | Centers the display around world coordinates x, y. |
| 983 | Example: |
| 984 | |
| 985 | $worldcanvas->CanvasBind('<2>' => |
| 986 | sub { |
| 987 | $worldcanvas->CanvasFocus; |
| 988 | $worldcanvas->center($worldcanvas->eventLocation); |
| 989 | } |
| 990 | ); |
| 991 | |
| 992 | |
| 993 | =item I<$worldcanvas>->B<centerTags>([-exact => {0 | 1}], I<TagOrID, [TagOrID, ...]>) |
| 994 | |
| 995 | Centers the display around the center of the bounding box |
| 996 | containing the specified TagOrID's without changing the current |
| 997 | magnification of the display. |
| 998 | |
| 999 | '-exact => 1' will cause the canvas to be scaled twice to get |
| 1000 | an accurate bounding box. This will be expensive if the canvas |
| 1001 | contains a large number of objects. |
| 1002 | |
| 1003 | |
| 1004 | =item I<$worldcanvas>->B<eventLocation>() |
| 1005 | |
| 1006 | Returns the world coordinates (x, y) of the last Xevent. |
| 1007 | |
| 1008 | |
| 1009 | =item I<$worldcanvas>->B<panWorld>(I<dx, dy>) |
| 1010 | |
| 1011 | Pans the display by the specified world distances. B<panWorld> |
| 1012 | is not meant to replace the xview/yview panning methods. Most |
| 1013 | user interfaces will want the arrow keys tied to the xview/yview |
| 1014 | panning methods (the default bindings), which pan in widget |
| 1015 | coordinates. |
| 1016 | |
| 1017 | If you do want to change the arrow key-bindings to pan in world |
| 1018 | coordinates using B<panWorld> you must disable the default arrow |
| 1019 | key-bindings. |
| 1020 | |
| 1021 | Example: |
| 1022 | |
| 1023 | $mainwindow->bind('WorldCanvas', '<Up>' => ""); |
| 1024 | $mainwindow->bind('WorldCanvas', '<Down>' => ""); |
| 1025 | $mainwindow->bind('WorldCanvas', '<Left>' => ""); |
| 1026 | $mainwindow->bind('WorldCanvas', '<Right>' => ""); |
| 1027 | |
| 1028 | $worldcanvas->CanvasBind( '<Up>' => sub {$worldcanvas->panWorld(0, 100);}); |
| 1029 | $worldcanvas->CanvasBind( '<Down>' => sub {$worldcanvas->panWorld(0, -100);}); |
| 1030 | $worldcanvas->CanvasBind( '<Left>' => sub {$worldcanvas->panWorld(-100, 0);}); |
| 1031 | $worldcanvas->CanvasBind('<Right>' => sub {$worldcanvas->panWorld( 100, 0);}); |
| 1032 | |
| 1033 | This is not usually desired, as the percentage of the display that |
| 1034 | is shifted will be dependent on the current display magnification. |
| 1035 | |
| 1036 | |
| 1037 | =item I<$worldcanvas>->B<pixelSize>() |
| 1038 | |
| 1039 | Returns the width (in world coordinates) of a pixel (at the current magnification). |
| 1040 | |
| 1041 | |
| 1042 | =item I<$worldcanvas>->B<rubberBand>(I<{0|1|2}>) |
| 1043 | |
| 1044 | Creates a rubber banding box that allows the user to graphically |
| 1045 | select a region. B<rubberBand> is called with a step parameter |
| 1046 | '0', '1', or '2'. '0' to start a new box, '1' to stretch the box, |
| 1047 | and '2' to finish the box. When called with '2', the specified |
| 1048 | box is returned (x1, y1, x2, y2) |
| 1049 | |
| 1050 | The band color is set with the I<WorldCanvas> option '-bandColor'. |
| 1051 | The default color is 'red' |
| 1052 | |
| 1053 | Example, specify a region to delete: |
| 1054 | |
| 1055 | $worldcanvas->configure(-bandColor => 'purple'); |
| 1056 | $worldcanvas->CanvasBind('<3>' => sub {$worldcanvas->CanvasFocus; |
| 1057 | $worldcanvas->rubberBand(0) |
| 1058 | }); |
| 1059 | $worldcanvas->CanvasBind('<B3-Motion>' => sub {$worldcanvas->rubberBand(1)}); |
| 1060 | $worldcanvas->CanvasBind('<ButtonRelease-3>' => sub {my @box = $worldcanvas->rubberBand(2); |
| 1061 | my @ids = $worldcanvas->find('enclosed', @box); |
| 1062 | foreach my $id (@ids) {$worldcanvas->delete($id)} |
| 1063 | }); |
| 1064 | # Note: '<B3-ButtonRelease>' will be called for any ButtonRelease! |
| 1065 | # You should use '<ButtonRelease-3>' instead. |
| 1066 | |
| 1067 | # If you want the rubber band to look smooth during panning and |
| 1068 | # zooming, add rubberBand(1) update calls to the appropriate key-bindings: |
| 1069 | |
| 1070 | $worldcanvas->CanvasBind( '<Up>' => sub {$worldcanvas->rubberBand(1);}); |
| 1071 | $worldcanvas->CanvasBind( '<Down>' => sub {$worldcanvas->rubberBand(1);}); |
| 1072 | $worldcanvas->CanvasBind( '<Left>' => sub {$worldcanvas->rubberBand(1);}); |
| 1073 | $worldcanvas->CanvasBind('<Right>' => sub {$worldcanvas->rubberBand(1);}); |
| 1074 | $worldcanvas->CanvasBind('<i>' => sub {$worldcanvas->zoom(1.25); $worldcanvas->rubberBand(1);}); |
| 1075 | $worldcanvas->CanvasBind('<o>' => sub {$worldcanvas->zoom(0.8); $worldcanvas->rubberBand(1);}); |
| 1076 | |
| 1077 | This box avoids the overhead of bounding box calculations |
| 1078 | that can occur if you create your own rubberBand outside of I<WorldCanvas>. |
| 1079 | |
| 1080 | |
| 1081 | =item I<$worldcanvas>->B<viewAll>([-border => number]) |
| 1082 | |
| 1083 | Displays at maximum possible zoom all objects centered in the |
| 1084 | I<WorldCanvas>. The switch '-border' specifies, as a percentage |
| 1085 | of the screen, the minimum amount of white space to be left on |
| 1086 | the edges of the display. Default '-border' is 0.02. |
| 1087 | |
| 1088 | |
| 1089 | =item I<$worldcanvas>->B<viewArea>(x1, y1, x2, y2, [-border => number])) |
| 1090 | |
| 1091 | Displays at maximum possible zoom the specified region centered |
| 1092 | in the I<WorldCanvas>. |
| 1093 | |
| 1094 | |
| 1095 | =item I<$worldcanvas>->B<viewFit>([-border => number], I<TagOrID>, [I<TagOrID>, ...]) |
| 1096 | |
| 1097 | Adjusts the worldcanvas to display all of the specified tags. The '-border' |
| 1098 | switch specifies (as a percentage) how much extra surrounding space should be shown. |
| 1099 | |
| 1100 | |
| 1101 | =item I<$worldcanvas>->B<getView>() |
| 1102 | |
| 1103 | Returns the rectangle of the current view (x1, y1, x2, y2) |
| 1104 | |
| 1105 | |
| 1106 | =item I<$worldcanvas>->B<widgetx>(I<x>) |
| 1107 | |
| 1108 | =item I<$worldcanvas>->B<widgety>(I<y>) |
| 1109 | |
| 1110 | =item I<$worldcanvas>->B<widgetxy>(I<x, y>) |
| 1111 | |
| 1112 | Convert world coordinates to widget coordinates. |
| 1113 | |
| 1114 | |
| 1115 | =item I<$worldcanvas>->B<worldx>(I<x>) |
| 1116 | |
| 1117 | =item I<$worldcanvas>->B<worldy>(I<y>) |
| 1118 | |
| 1119 | =item I<$worldcanvas>->B<worldxy>(I<x, y>) |
| 1120 | |
| 1121 | Convert widget coordinates to world coordinates. |
| 1122 | |
| 1123 | =back |
| 1124 | |
| 1125 | =head1 CHANGED METHODS |
| 1126 | |
| 1127 | =over 4 |
| 1128 | |
| 1129 | World coordinates are supplied and returned to B<WorldCanvas> methods |
| 1130 | instead of widget coordinates unless otherwise specified. (ie. These |
| 1131 | methods take and return world coordinates: center, panWorld, viewArea, |
| 1132 | find, coords, scale, move, bbox, rubberBand, eventLocation, pixelSize, |
| 1133 | and create*) |
| 1134 | |
| 1135 | |
| 1136 | =item I<$worldcanvas>->B<bbox>([-exact => {0 | 1}], I<TagOrID>, [I<TagOrID>, ...]) |
| 1137 | |
| 1138 | '-exact => 1' is only needed if the TagOrID is not 'all'. It |
| 1139 | will cause the canvas to be scaled twice to get an accurate |
| 1140 | bounding box. This will be expensive if the canvas contains |
| 1141 | a large number of objects. |
| 1142 | |
| 1143 | Neither setting of exact will produce exact results because |
| 1144 | the underlying canvas bbox method returns a slightly larger box |
| 1145 | to insure that everything is contained. It appears that a number |
| 1146 | close to '2' is added or subtracted. The '-exact => 1' zooms |
| 1147 | in to reduce this error. |
| 1148 | |
| 1149 | If the underlying canvas B<bbox> method returns a bounding box |
| 1150 | that is small (high error percentage) then '-exact => 1' is done |
| 1151 | automatically. |
| 1152 | |
| 1153 | |
| 1154 | =item I<$worldcanvas>->B<scale>(I<'all', xOrigin, yOrigin, xScale, yScale>) |
| 1155 | |
| 1156 | B<Scale> should not be used to 'zoom' the display in and out as it will |
| 1157 | change the world coordinates of the scaled objects. Methods B<zoom>, |
| 1158 | B<viewArea>, and B<viewAll> should be used to change the |
| 1159 | scale of the display without affecting the dimensions of the objects. |
| 1160 | |
| 1161 | =back |
| 1162 | |
| 1163 | =head1 VIEW AREA CHANGE CALLBACK |
| 1164 | |
| 1165 | I<Tk::WorldCanvas> option '-changeView' can be used to specify |
| 1166 | a callback for a change of the view area. This is useful for |
| 1167 | updating a second worldcanvas which is displaying the view region |
| 1168 | of the first worldcanvas. |
| 1169 | |
| 1170 | The callback subroutine will be passed the coordinates of the |
| 1171 | displayed box (x1, y1, x2, y2). These arguments are added after |
| 1172 | any extra arguments specifed by the user calling 'configure'. |
| 1173 | |
| 1174 | Example: |
| 1175 | |
| 1176 | $worldcanvas->configure(-changeView => [\&changeView, $worldcanvas2]); |
| 1177 | # viewAll if worldcanvas2 widget is resized. |
| 1178 | $worldcanvas2->CanvasBind('<Configure>' => sub {$worldcanvas2->viewAll}); |
| 1179 | |
| 1180 | { |
| 1181 | my $viewBox; |
| 1182 | sub changeView { |
| 1183 | my ($canvas2, @coords) = @_; |
| 1184 | |
| 1185 | $canvas2->delete($viewBox) if $viewBox; |
| 1186 | $viewBox = $canvas2->createRectangle(@coords, -outline => 'orange'); |
| 1187 | } |
| 1188 | } |
| 1189 | |
| 1190 | |
| 1191 | =head1 SCROLL REGION NOTES |
| 1192 | |
| 1193 | (1) The underlying I<Tk::Canvas> has a '-confine' option which is set |
| 1194 | to '1' by default. With '-confine => 1' the canvas will not allow |
| 1195 | the display to go outside of the scroll region causing some methods |
| 1196 | to not work accurately. For example, the 'center' method will not be |
| 1197 | able to center on coordinates near to the edge of the scroll region; |
| 1198 | 'zoom out' near the edge will zoom out and pan towards the center. |
| 1199 | |
| 1200 | I<Tk::WorldCanvas> sets '-confine => 0' by default to avoid these |
| 1201 | problems. You can change it back with: |
| 1202 | |
| 1203 | $worldcanvas->configure(-confine => 1); |
| 1204 | |
| 1205 | |
| 1206 | (2) '-scrollregion' is maintained by I<WorldCanvas> to include all |
| 1207 | objects on the canvas. '-scrollregion' will be adjusted automatically |
| 1208 | as objects are added, deleted, scaled, moved, etc. (You can create a |
| 1209 | static scrollregion by adding a border rectangle to the canvas.) |
| 1210 | |
| 1211 | |
| 1212 | (3) The bounding box of all objects is required to set the scroll region. |
| 1213 | Calculating this bounding box is expensive if the canvas has a large |
| 1214 | number of objects. So for performance reasons these operations will |
| 1215 | not immediately change the bounding box if they potentially shrink it: |
| 1216 | |
| 1217 | coords |
| 1218 | delete |
| 1219 | move |
| 1220 | scale |
| 1221 | |
| 1222 | Instead they will mark the bounding box as invalid, and it will be |
| 1223 | updated at the next zoom or pan operation. The only downside to this |
| 1224 | is that the scrollbars will be incorrect until the update. |
| 1225 | |
| 1226 | If these operations increase the size of the box, changing the box is |
| 1227 | trivial and the update is immediate. |
| 1228 | |
| 1229 | =head1 AUTHOR |
| 1230 | |
| 1231 | Joseph Skrovan (I<joseph@skrovan.com>) |
| 1232 | |
| 1233 | Note: based on an earlier implementation by Rudy Albachten (I<rudy@albachten.com>) |
| 1234 | |
| 1235 | If you use and enjoy I<WorldCanvas> please let me know. |
| 1236 | |
| 1237 | =head1 COPYRIGHTS |
| 1238 | |
| 1239 | Copyright (c) 2002 Joseph Skrovan. All rights reserved. |
| 1240 | This program is free software; you can redistribute it and/or modify it |
| 1241 | under the same terms as Perl itself. |
| 1242 | |
| 1243 | =cut |