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: