perlcraft
crazyinsomniac
#!/usr/bin/perl -w
# rubberband.pl
# a little rubberbanding Tk demo (demonstrates rubberbanding with perl Tk)
# copyright crazyinsomniac.perlmonk.org 2002, all rights reserved
# released under the same terms as perl itself
use strict;
use Tk 8;
my $MW = new MainWindow(
-background => 'darkblue',
-borderwidth => 1,
-relief => 'groove',
-width => 500,
-height => 500,
,);
my $F = $MW->Frame(
-relief => "groove",
-height => 300,
-width => 500,
,)->pack(
-anchor => 'n',
-side => 'top',
-expand => 'yes',
,);
use vars '$OBJECT'; BEGIN{$OBJECT="oval"};
Button($F, "oval", groove => sub { $OBJECT = "oval" } );
Button($F, "line", groove => sub { $OBJECT = "line" } );
Button($F, "arc", groove => sub { $OBJECT = "arc" } );
Button($F, "rectangle", groove => sub { $OBJECT = "rectangle" } );
$F->Label(
-text => " OBJECT:",
-relief => 'flat',
-font => "Arial",
,)->pack(
-side => 'left',
-expand => 1,
,);
$F->Label(
-textvariable => \$OBJECT,
-relief => 'flat',
-font => "Arial",
,)->pack(
-side => 'left',
-expand => 1,
,);
my $C = $MW->Canvas(
-width => 500,
-height => 500,
-background => "#AFFAAF",
,)->pack;
## S&M (left button down only)
$MW->bind(
'Tk::Canvas',
'<ButtonPress-1>' => [\&BandOn, map{Ev($_)} qw{ x y s } ]
);
$MW->bind(
'Tk::Canvas',
'<ButtonRelease-1>' => [\&BandOff, map{Ev($_)} qw{ x y s } ]
);
&MainLoop();
sub BandOn {
BEEP("BandOn",@_);
my( $C, $X, $Y, $S ) = @_;
$C->{"\0__Xo"} = $X; # the origin, to remain constant
$C->{"\0__Yo"} = $Y;
$C->{"\0__RUBBER"} = "RUBBER".time;
$C->create($OBJECT, $X, $Y, $X+10, $Y+10, -tags => $C->{"\0__RUBBER"});
$MW->bind(
'Tk::Canvas',
'<Motion>' => [\&BandIt, map { Ev($_) } qw{ x y s } ]
);
}
sub BandOff {
BEEP("BandOff",@_);
my( $C, $X, $Y, $S ) = @_;
$MW->bind(
'Tk::Canvas',
'<Motion>' => undef, # essentially unbind
);
}
sub BandIt {
BEEP("BandIt",@_);
my( $C, $X, $Y, $S ) = @_;
$C->delete($C->{"\0__RUBBER"}); # I wish I could transform the existing one
$C->create(
$OBJECT,
$C->{"\0__Xo"},
$C->{"\0__Yo"},
$X, $Y, -tags => $C->{"\0__RUBBER"},
);
}
sub BEEP {
print shift(@_),"\n";
print shift(@_)->{"\0__RUBBER"},"\n";
print "$_)$_[$_]\n" for 0..$#_;
}
sub Button {
my ( $W , $text , $relief , $sub )=@_;
$W = $W->Button(
-text => $text,
-relief => $relief,
,)->pack(
-anchor => 'n',
-expand => 'no',
-side => 'left',
,);
$W->configure(-command => [ $sub, $W ] );
return undef;
}