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