PerlTk - Help with binding.

Author

Help with binding.

JoeC

2004-06-30, 4:00 am

I have been reading up on perl/Tk binding and tags, and I am very

. I am trying to experiment with different programs. My
problem here is I would like to change the background screen color and
move the block left and right. I think I need to use tags and binding
but I don't understand how to do it.

#!/user/bin/perl -w

use strict;
use Tk;

my $mw = MainWindow->new();
my $f = $mw->Frame(-relief => 'groove',
-bd => 5,
-label => "Controls:")->pack(-side => 'right', -fill => 'y');

$mw->title("Experiemtn I window");

my $can = $mw->Canvas(-height=>300,
-width =>250,
-relief=>'raised')->pack;
$can->createRectangle(120, 145, 130, 155, -fill=>'cyan');

my $cmenue = $f->Menubutton(-text=> "Color ", -tearoff=>0,
-menuitems=> [[ "command"=> "Black", -command=> \&cc($can, 'black')],
[ "command"=> "White", -command=> \&cc($can, 'white')],
[ "command"=> "Red", -command=> \&cc($can, 'red')]
])->pack(-side=>'top');

$f->Button(-text => "Left", -command => \&move(-10))->
pack(-side=> 'left');

$f->Button(-text => "Right", -command => \&move(10))->
pack(-side=> 'right');

$mw->Button(-text => "End", -command => sub {exit })->pack(-side=>"bottom");

MainLoop;
sub cc{
my ($can, $clr) = @_;
$can->Canvas(-background=>$clr);
}

sub move{
my ($mv) = @_;

}

thundergnat

2004-06-30, 3:58 pm

JoeC wrote:
> I have been reading up on perl/Tk binding and tags, and I am very
>

. I am trying to experiment with different programs. My
> problem here is I would like to change the background screen color and
> move the block left and right. I think I need to use tags and binding
> but I don't understand how to do it.
>
> #!/user/bin/perl -w
>
> use strict;
> use Tk;
>
> my $mw = MainWindow->new();
> my $f = $mw->Frame(-relief => 'groove',
> -bd => 5,
> -label => "Controls:")->pack(-side => 'right', -fill => 'y');
>
> $mw->title("Experiemtn I window");
>
> my $can = $mw->Canvas(-height=>300,
> -width =>250,
> -relief=>'raised')->pack;
> $can->createRectangle(120, 145, 130, 155, -fill=>'cyan');
my $rect = $can->createRectangle(120, 145, 130, 155, -fill=>'cyan');
# you need to capture a referance to the rect somehow so you can act
# on it later.
>
> my $cmenue = $f->Menubutton(-text=> "Color ", -tearoff=>0,
> -menuitems=> [[ "command"=> "Black", -command=> \&cc($can, 'black')],
-menuitems=> [[ 'command' => 'Black', -command => [\&cc, $can, 'black']],
# You need to pass either a code reference array or an anonymous sub.
# Avoid using double quotes where sigle quotes are more appropriate.

> [ "command"=> "White", -command=> \&cc($can, 'white')],
[ 'command' => 'White', -command=> [\&cc, $can, 'white']],
# Same comments as above.

> [ "command"=> "Red", -command=> \&cc($can, 'red')]
[ 'command' => 'Red', -command=> [\&cc, $can, 'red']],
# Same comments as above.

[ 'command' => 'Default', -command=> [\&cc, $can, 'SystemButtonFace']]
# In case you want to get back to default.

> ])->pack(-side=>'top');
>
> $f->Button(-text => "Left", -command => \&move(-10))->
$f->Button(-text => 'Left', -command => [\&move, $rect, -10 ])->
# Same comments as above. Also passing object reference in case you want
# to expand this to operate on different objects. You could also pass
# a Canvas reference too if you wanted to specify which Canvas to
# operate on. There is only one in this example so I kept it simple.

> pack(-side=> 'left');
>
> $f->Button(-text => "Right", -command => \&move(10))->
$f->Button(-text => 'Right', -command => [\&move, $rect, 10 ])->
# Same comments as above.

> pack(-side=> 'right');
>
>
> $mw->Button(-text => "End", -command => sub {exit
> })->pack(-side=>"bottom");
>
>
>
> MainLoop;
> sub cc{
> my ($can, $clr) = @_;
> $can->Canvas(-background=>$clr);
$can->configure(-background=>$clr);
# You were creating another Canvas as a chld of the Canvas $can. It was
# never handed to a geometry manager, so it was never made visible.
# Configure the existing Canvas instead.
> }
>
> sub move{
> my ($mv) = @_;
my ($object, $mv) = @_;
$can->move($object, $mv, 0);
# You passed the argument but never did anything with it.
>
> }
>

None of the modifications I suggested really have to do with bindings.
They are more appropriatly decribed as callbacks. Binding are more
typically describing actions that are associated with a particular event
(Button press, Key press, Mouse motion, whatever.)

An example. If you add the following three lines to the above script,
just above the MainLoop; line, you will be able to move the rect left
and right using the 'l' and 'r' keys on the keyboard.

$mw->bind($can, '<r>' => sub { move($rect, 10) });
$mw->bind($can, '<l>' => sub { move($rect, -10) });
$can->CanvasFocus;

You should avoid enclosing strings that don't do any variable
interpolation in double quotes. Use single quotes instead. Innstead of
"Right", "Left", "command", etc use 'Right', 'Left', 'command'... It is
not really /wrong/ to do so, your script will likely work exactly the
same either way, but it is considered poor coding style, can make your
scripts more difficult to troubleshoot and can lead to obscure and hard
to track down bugs.

thundergnat

2004-06-30, 3:58 pm

JoeC wrote:

> I have been reading up on perl/Tk binding and tags, and I am very
>

. I am trying to experiment with different programs. My
> problem here is I would like to change the background screen color and
> move the block left and right. I think I need to use tags and binding
> but I don't understand how to do it.
>

I was bored and messed around with your script a bit more to show some
other interesting stuff you can do with a canvas. Added a few more
objects to the canvas. You can select which you wan to act on. Added up
and down buttons as well as left and right. Bound the keys 'w', 'a', 's'
& 'z' to the Up, Left, Right and Down motions respectively. Bound the
mouse to the objects so you can click and drag them.

For lots of useful examples of how to do things in Tk, look in your
/Perl/bin directory for the widgets example script. It is a real help
when you are trying to figure out implementation details.

#!/user/bin/perl

use strict;
use warnings;
use Tk;

my $mw = MainWindow->new();

my $f = $mw->Frame(
-relief => 'groove',
-bd => 5,
-label => 'Controls:'
)->pack(
-side => 'right',
-fill => 'y'
);

$mw->title('Experiment II');

my $can = $mw->Canvas(
-height => 300,
-width => 250,
-relief => 'raised'
)->pack(
-fill => 'both',
-expand => 'y'
);

my $current;
my @xy;

my $cyanobj = $can->createRectangle(120, 145, 130, 155, -fill => 'cyan');
my $grnobj = $can->createOval( 80, 105, 90, 115, -fill => 'green');
my $orgobj = $can->createPolygon(160, 165, 150, 175, 140, 165, -fill =>
'orange');

choose($current, $cyanobj);
$current = $cyanobj;

bindchoose($cyanobj);
bindchoose($grnobj);
bindchoose($orgobj);

bindmouse($cyanobj);
bindmouse($grnobj);
bindmouse($orgobj);

my $cmenue = $f->Menubutton(-text=> 'Color', -tearoff=>0,
-menuitems=> [
[ 'command' => 'Black', -command => [\&cc, $can, 'black']],
[ 'command' => 'White', -command => [\&cc, $can, 'white']],
[ 'command' => 'Red', -command => [\&cc, $can, 'red']],
[ 'command' => 'Default', -command => [\&cc, $can,
'SystemButtonFace']]
]
)->pack(
-side=>'top'
);

my $f1 = $f->Frame->pack;

$f1->Button(
-text => 'Up',
-width => 4,
-command => sub { move($current, 0, -10) }
)->grid(-row => 0, -column => 2);

$f1->Button(
-text => 'Left',
-width => 4,
-command => sub { move($current, -10, 0) }
)->grid(-row => 1, -column => 1);

$f1->Button(
-text => 'Right',
-width => 4,
-command => sub { move($current, 10, 0) }
)->grid(-row => 1, -column => 3);

$f1->Button(
-text => 'Down',
-width => 4,
-command => sub { move($current, 0, 10) }
)->grid(-row => 2, -column => 2);

$mw->Button(
-text => 'End',
-command => sub { Tk::exit }
)->pack(-side => 'bottom');

$mw->bind($can, '<w>' => sub {move($current, 0, -10)});
$mw->bind($can, '<a>' => sub {move($current, -10, 0)});
$mw->bind($can, '<s>' => sub {move($current, 10, 0)});
$mw->bind($can, '<z>' => sub {move($current, 0, 10)});

$can->CanvasFocus;

MainLoop;
sub cc{
$_[0]->configure(-background=>$_[1]);
}

sub move{
$can->move(@_);
}

sub choose{
$can->itemconfigure($_[0], -outline => 'black', -width => 1.0);
$can->itemconfigure($_[1], -outline => 'purple', -width => 3.0);
}

sub mousemove{
my $x = $can->canvasx($mw->pointerx) - $xy[0];
my $y = $can->canvasy($mw->pointery) - $xy[1];
move($current, $x, $y);
$xy[0] += $x;
$xy[1] += $y;
}

sub bindchoose{
my $object = shift;
$can->bind($object, '<1>' => sub{
choose($current, $object);
$current = $object;
$xy[0] = $can->canvasx($mw->pointerx);
$xy[1] = $can->canvasy($mw->pointery)
});
}

sub bindmouse{
my $object = shift;
$can->bind($object, '<B1-Motion>' => \&mousemove);
}

Sponsored Links