0: #!/usr/bin/perl -w
1: # rubberband.pl
2: # a little rubberbanding Tk demo (demonstrates rubberbanding with perl Tk)
3: # copyright crazyinsomniac.perlmonk.org 2002, all rights reserved
4: # released under the same terms as perl itself
5: use strict;
6:
7: use Tk 8;
8:
9: my $MW = new MainWindow(
10: -background => 'darkblue',
11: -borderwidth => 1,
12: -relief => 'groove',
13: -width => 500,
14: -height => 500,
15: ,);
16:
17: my $F = $MW->Frame(
18: -relief => "groove",
19: -height => 300,
20: -width => 500,
21: ,)->pack(
22: -anchor => 'n',
23: -side => 'top',
24: -expand => 'yes',
25: ,);
26:
27: use vars '$OBJECT'; BEGIN{$OBJECT="oval"};
28:
29: Button($F, "oval", groove => sub { $OBJECT = "oval" } );
30: Button($F, "line", groove => sub { $OBJECT = "line" } );
31: Button($F, "arc", groove => sub { $OBJECT = "arc" } );
32: Button($F, "rectangle", groove => sub { $OBJECT = "rectangle" } );
33:
34:
35: $F->Label(
36: -text => " OBJECT:",
37: -relief => 'flat',
38: -font => "Arial",
39: ,)->pack(
40: -side => 'left',
41: -expand => 1,
42: ,);
43:
44: $F->Label(
45: -textvariable => \$OBJECT,
46: -relief => 'flat',
47: -font => "Arial",
48: ,)->pack(
49: -side => 'left',
50: -expand => 1,
51: ,);
52:
53: my $C = $MW->Canvas(
54: -width => 500,
55: -height => 500,
56: -background => "#AFFAAF",
57: ,)->pack;
58:
59: ## S&M (left button down only)
60: $MW->bind(
61: 'Tk::Canvas',
62: '<ButtonPress-1>' => [\&BandOn, map{Ev($_)} qw{ x y s } ]
63: );
64:
65: $MW->bind(
66: 'Tk::Canvas',
67: '<ButtonRelease-1>' => [\&BandOff, map{Ev($_)} qw{ x y s } ]
68: );
69:
70:
71: &MainLoop();
72:
73: sub BandOn {
74: BEEP("BandOn",@_);
75:
76: my( $C, $X, $Y, $S ) = @_;
77: $C->{"\0__Xo"} = $X; # the origin, to remain constant
78: $C->{"\0__Yo"} = $Y;
79: $C->{"\0__RUBBER"} = "RUBBER".time;
80: $C->create($OBJECT, $X, $Y, $X+10, $Y+10, -tags => $C->{"\0__RUBBER"});
81:
82: $MW->bind(
83: 'Tk::Canvas',
84: '<Motion>' => [\&BandIt, map { Ev($_) } qw{ x y s } ]
85: );
86: }
87:
88:
89: sub BandOff {
90: BEEP("BandOff",@_);
91: my( $C, $X, $Y, $S ) = @_;
92:
93: $MW->bind(
94: 'Tk::Canvas',
95: '<Motion>' => undef, # essentially unbind
96: );
97: }
98:
99: sub BandIt {
100: BEEP("BandIt",@_);
101: my( $C, $X, $Y, $S ) = @_;
102:
103: $C->delete($C->{"\0__RUBBER"}); # I wish I could transform the existing one
104: $C->create(
105: $OBJECT,
106: $C->{"\0__Xo"},
107: $C->{"\0__Yo"},
108: $X, $Y, -tags => $C->{"\0__RUBBER"},
109: );
110:
111: }
112:
113:
114: sub BEEP {
115: print shift(@_),"\n";
116: print shift(@_)->{"\0__RUBBER"},"\n";
117: print "$_)$_[$_]\n" for 0..$#_;
118: }
119:
120:
121:
122:
123: sub Button {
124: my ( $W , $text , $relief , $sub )=@_;
125:
126: $W = $W->Button(
127: -text => $text,
128: -relief => $relief,
129: ,)->pack(
130: -anchor => 'n',
131: -expand => 'no',
132: -side => 'left',
133: ,);
134:
135: $W->configure(-command => [ $sub, $W ] );
136:
137: return undef;
138: }
139:
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.