1: #!/usr/bin/perl -w 2: # rubberband.pl 3: # a little rubberbanding Tk demo (demonstrates rubberbanding with perl Tk) 4: # copyright crazyinsomniac.perlmonk.org 2002, all rights reserved 5: # released under the same terms as perl itself 6: use strict; 7: 8: use Tk 8; 9: 10: my $MW = new MainWindow( 11: -background => 'darkblue', 12: -borderwidth => 1, 13: -relief => 'groove', 14: -width => 500, 15: -height => 500, 16: ,); 17: 18: my $F = $MW->Frame( 19: -relief => "groove", 20: -height => 300, 21: -width => 500, 22: ,)->pack( 23: -anchor => 'n', 24: -side => 'top', 25: -expand => 'yes', 26: ,); 27: 28: use vars '$OBJECT'; BEGIN{$OBJECT="oval"}; 29: 30: Button($F, "oval", groove => sub { $OBJECT = "oval" } ); 31: Button($F, "line", groove => sub { $OBJECT = "line" } ); 32: Button($F, "arc", groove => sub { $OBJECT = "arc" } ); 33: Button($F, "rectangle", groove => sub { $OBJECT = "rectangle" } ); 34: 35: 36: $F->Label( 37: -text => " OBJECT:", 38: -relief => 'flat', 39: -font => "Arial", 40: ,)->pack( 41: -side => 'left', 42: -expand => 1, 43: ,); 44: 45: $F->Label( 46: -textvariable => \$OBJECT, 47: -relief => 'flat', 48: -font => "Arial", 49: ,)->pack( 50: -side => 'left', 51: -expand => 1, 52: ,); 53: 54: my $C = $MW->Canvas( 55: -width => 500, 56: -height => 500, 57: -background => "#AFFAAF", 58: ,)->pack; 59: 60: ## S&M (left button down only) 61: $MW->bind( 62: 'Tk::Canvas', 63: '<ButtonPress-1>' => [\&BandOn, map{Ev($_)} qw{ x y s } ] 64: ); 65: 66: $MW->bind( 67: 'Tk::Canvas', 68: '<ButtonRelease-1>' => [\&BandOff, map{Ev($_)} qw{ x y s } ] 69: ); 70: 71: 72: &MainLoop(); 73: 74: sub BandOn { 75: BEEP("BandOn",@_); 76: 77: my( $C, $X, $Y, $S ) = @_; 78: $C->{"\0__Xo"} = $X; # the origin, to remain constant 79: $C->{"\0__Yo"} = $Y; 80: $C->{"\0__RUBBER"} = "RUBBER".time; 81: $C->create($OBJECT, $X, $Y, $X+10, $Y+10, -tags => $C->{"\0__RUBBER"}); 82: 83: $MW->bind( 84: 'Tk::Canvas', 85: '<Motion>' => [\&BandIt, map { Ev($_) } qw{ x y s } ] 86: ); 87: } 88: 89: 90: sub BandOff { 91: BEEP("BandOff",@_); 92: my( $C, $X, $Y, $S ) = @_; 93: 94: $MW->bind( 95: 'Tk::Canvas', 96: '<Motion>' => undef, # essentially unbind 97: ); 98: } 99: 100: sub BandIt { 101: BEEP("BandIt",@_); 102: my( $C, $X, $Y, $S ) = @_; 103: 104: $C->delete($C->{"\0__RUBBER"}); # I wish I could transform the existing one 105: $C->create( 106: $OBJECT, 107: $C->{"\0__Xo"}, 108: $C->{"\0__Yo"}, 109: $X, $Y, -tags => $C->{"\0__RUBBER"}, 110: ); 111: 112: } 113: 114: 115: sub BEEP { 116: print shift(@_),"\n"; 117: print shift(@_)->{"\0__RUBBER"},"\n"; 118: print "$_)$_[$_]\n" for 0..$#_; 119: } 120: 121: 122: 123: 124: sub Button { 125: my ( $W , $text , $relief , $sub )=@_; 126: 127: $W = $W->Button( 128: -text => $text, 129: -relief => $relief, 130: ,)->pack( 131: -anchor => 'n', 132: -expand => 'no', 133: -side => 'left', 134: ,); 135: 136: $W->configure(-command => [ $sub, $W ] ); 137: 138: return undef; 139: } 140:
Back to
Craft