PerlTk - Re: (fwd) binding to a derived canvas widget

Author

Re: (fwd) binding to a derived canvas widget

Steve Lidie

2006-03-30, 9:59 pm

To pique everyone's interest, I'll note at the outset that the below
is a very, very, interesting problem. I have a solution, but I have
no time until this w

end to give a proper answer. In short, we'll
use bindtags(), maybe an overridden bind() method, to solve the
problem ....

> From: zentara <zentara@highstream.net>
> Newsgroups: comp.lang.perl.tk
> Subject: binding to a derived canvas widget
> Date: Wed, 29 Mar 2006 20:37:36 GMT
>
> Hi,
> Generally I avoid these problems, by not using objects and
> modules, but I wanted to try and put this in a module form. :-)

good!

>
>
> It has to be something simple, but I've already tried a bunch of
> different things, and figure that I am missing the trick on how to
> handle multiple binding. I've read perldoc Tk::bind, and it said that
> if multiple bindings are made to say Button-1, the callback from the
> class will be called first, then the one from main. BUT the main isn't
> being called in this example.....that is the problem.

and the solution will follow in a few days ...

-++**==--++**==--++**==--++**==--++**==--++**==--++**==
This message was posted through the Stanford campus mailing list
server. If you wish to unsubscribe from this mailing list, send the
message body of "unsubscribe ptk" to majordomo@lists.stanford.edu

Ch Lamprecht

2006-03-31, 3:59 am

Steve Lidie schrieb:
> To pique everyone's interest, I'll note at the outset that the below
> is a very, very, interesting problem. I have a solution, but I have
> no time until this w

end to give a proper answer. In short, we'll
> use bindtags(), maybe an overridden bind() method, to solve the
> problem ....

Hi,

did you think of something like this?

sub ClassInit
{
my ($class, $mw) = @_;
$class->SUPER::ClassInit($mw);
$mw->bind($class, "<1>" =>'pick_one' );
return $class;
}
sub bind{
my $self = shift;
$self->CanvasBind(@_);
}

Christoph
--

perl -e "print scalar reverse q/ed.enilno@ergn.l.hc/"

zentara

2006-03-31, 7:59 am

On Fri, 31 Mar 2006 10:39:05 +0200, Ch Lamprecht
<christoph.lamprecht.no.spam@web.de> wrote:

>Steve Lidie schrieb:
>
>Hi,
>
>did you think of something like this?
>
>sub ClassInit
>{
> my ($class, $mw) = @_;
> $class->SUPER::ClassInit($mw);
> $mw->bind($class, "<1>" =>'pick_one' );
> return $class;
>}
>sub bind{
> my $self = shift;
> $self->CanvasBind(@_);
>}
>
>Christoph

This works perfectly, as far as I can tell:

A <ButtonPress-1> will first do the calback in the
object, then do the callback in the main script. And I
can make whatever binding I want in the main script,
like <1>, <ButtonRelease-1>, etc.

########################################
#
1. Put the binding in ClassInit with an overriding bind sub

sub ClassInit
{
my ($class, $mw) = @_;
$class->SUPER::ClassInit($mw);
$mw->bind($class, "<1>" =>'pick_one' );
return $class;
}

sub bind{
my $self = shift;
$self->CanvasBind(@_);
}
########################################
##

2. Remove the binding from the Populate sub

$self->SUPER::Populate($args);
$self->SetBindtags;
# this will break things
# $self->CanvasBind('all','<ButtonPress-1>' => [\&pick_one] );

########################################
##############

3. bind like normal in the main script

$ztree->bind('<ButtonPress-1>', sub{
my $selected = $ztree->get_selected();

if(length $selected){
$text->insert('end',"$selected\n");
$text->see('end');
}
});
########################################
##############

Thanks for helping me with this. :-)
zentara

Below is a full working script, for the benefit of googler's who
are looking for answers, (and can't figure out where to patch the
example) :-)

############### snip #################################
#!/usr/bin/perl
use warnings;
use strict;
use Tk;

########################################
##################
package CanvasDirTree;
use warnings;
use strict;

use Tk::widgets qw/Canvas/;
use base qw/Tk::Derived Tk::Canvas/;
use File::Spec;
use Tk::JPEG;
use Tk::PNG;

Construct Tk::Widget 'CanvasDirTree';

sub ClassInit
{
my ($class, $mw) = @_;
$class->SUPER::ClassInit($mw);
$mw->bind($class, "<1>" =>'pick_one' );
return $class;
}

sub bind{
my $self = shift;
$self->CanvasBind(@_);
}

######################################3
sub SetBindtags {
my($self) = @_;
$self->SUPER::SetBindtags;
}

########################################
##############
sub Populate {
my ($self, $args) = @_;

#-------------------------------------------------------------------
#take care of args which don't belong to the SUPER, see Tk::Derived
foreach my $extra ('backimage','imx','imy','font','indfill
a',
'indfilln','fontcolorn','fontcolora') {
my $xtra_arg = delete $args->{ "-$extra" }; #delete and read
same time
if( defined $xtra_arg ) { $self->{$extra} = $xtra_arg }
}
#-----------------------------------------------------------------
#set some defaults
$self->{'indfilla'} ||= 'red';
$self->{'indfilln'} ||= 'pink';
$self->{'fontcolorn'} ||= 'black';
$self->{'fontcolora'} ||= 'red';
$self->{'backimage'} ||= '';
$self->{'bimage'} ||= '';
$self->{'imx'} ||= 0;
$self->{'imy'} ||= 0;

$self->SUPER::Populate($args);
$self->SetBindtags;

if( length $self->{'backimage'} > 0 ){
$self->set_background(
$self->{'backimage'},$self->{'imx'}, $self->{'imy'}
);
}

$self->{'font'} ||= 'system';

#---determine font spacing by making a capital W---
my $fonttest = $self->createText(0,0,
-fill => 'black',
-text => 'W',
-font => $self->{'font'},
);

my ($bx,$by,$bx1,$by1) = $self->bbox($fonttest);
$self->{'f_width'} = $bx1 - $bx;
$self->{'f_height'} = $by1 - $by;
$self->delete($fonttest);
#--------------------------------------------------

$self->make_trunk('.', 0);

} # end Populate

########################################
################
sub adjust_background{
my ($self, $photo_obj ) = @_;

$self->delete( $self->{'background'} );

$self->{'bimage'} = $photo_obj;
$self->{'bimg_w'} = $self->{'bimage'}->width;
$self->{'bimg_h'} = $self->{'bimage'}->height;

$self->{'background'} = $self->createImage(

$self->{'imx'}, $self->{'imy'},
-anchor => 'nw',
-image => $self->{'bimage'},
);
}
########################################
####################
sub set_background{
my( $self, $image ,$xim, $yim) = @_;

$self->{'backimage'} = $image;
$self->{'imx'} = $xim;
$self->{'imy'} = $yim;

if( ref $image eq 'Tk::Photo'){
$self->adjust_background($image)
}else{
my $photo_obj = $self->Photo( -file => $self->{'backimage'}
);
$self->adjust_background( $photo_obj );
}
}
########################################
######################
sub make_trunk{

my ($self, $dir, $level) = @_;
my $x = 5; my $y = $self->{'f_height'};

my @subdirs;
opendir my $dh, $dir or warn $!;

while ( my $file = readdir($dh) ) {
next if $file =~ m[^\.{1,2}$];
if(-d "$dir/$file"){
push @subdirs, $file;
}else{ next }
}

my $abs_root = File::Spec->rel2abs( $dir );

#for windows compat
$abs_root =~ tr#\\#/#;

my $max = scalar (@subdirs);
my $count = 0;

foreach my $subdir ( sort @subdirs ){
my $abs_path = "$abs_root/$subdir";
my $put_ind = 0;

#see if any depth 2 subdir exists
opendir my $dh, $abs_path or warn $!;
while ( my $file = readdir($dh) ) {
next if $file =~ m[^\.{1,2}$];
if(-d "$abs_path/$file"){
$put_ind = 1;
last;
}
}

#make open indicator if a dir
--------------------------------------
if( $put_ind ){
my $ind = $self->createPolygon(
$x + .1 * $self->{'f_width'} , $y + $y * $count - .3
* $self->{'f_height'},
$x + .5 * $self->{'f_width'}, $y + $y * $count,
$x + .1 * $self->{'f_width'}, $y + $y * $count + .3
* $self->{'f_height'} ,

-fill => $self->{'indfilln'},
-activefill => 'yellow',
-outline => 'black',
-width => 1,
-activewidth => 2,
-tags => ['ind', $abs_path],
);
}
#------------------------------------------------------------
my $id = $self->createText(
$x + .8 * $self->{'f_width'}, $y + $y * $count + (.5
*$self->{'f_height'}),
-fill => $self->{'fontcolorn'},
-activefill => $self->{'fontcolora'},
-text => $subdir,
-font => $self->{'font'},
-anchor => 'sw',
-tags => ['list', $abs_path],
);
$count++;
}

my ($bx,$by,$bx1,$by1)= $self->bbox('all');

$self->configure(
-scrollregion =>[0,0,$bx1,$by1]
);

} # end make_trunk
########################################
####################################
sub pick_one {
my ($self) = @_;
my $item = $self->find('withtag','current'); #returns aref
my @tags = $self->gettags($item->[0]);
$item = $item->[0];

$self->{'selected'} = ''; #default is no selection

if( grep { $_ eq 'ind' } @tags ){

@tags = grep { $_ ne 'ind' and $_ ne 'current'} @tags;
my $dir = $tags[0];

if( $self->itemcget($item, 'fill') eq $self->{'indfilla'}){
$self->rotate_poly($item, -90, undef,undef);
$self->itemconfigure($item, 'fill' => $self->{'indfilln'}
);
$self->close_branch($dir,$item);
}else{
$self->rotate_poly($item, 90, undef,undef);
$self->itemconfigure($item, 'fill' => $self->{'indfilla'}
);
$self->add_branch($dir);
}
}else{
#picked up an indicator click by this point
#clicks on list items will be handled by get_selected
@tags = grep { $_ ne 'list' and $_ ne 'current'} @tags;
$self->{'selected'} = $tags[0];
$self->{'selected'} ||= '';
}

} # end pick_one
########################################
############################
sub get_selected{
my ($self) = @_;

return $self->{'selected'};
}
########################################
###########################
sub add_branch{

my ($self, $abs_path) = @_;

#for windows compat
$abs_path =~ tr#\\#/#;

my $item;
foreach my $it( $self->find('withtag', $abs_path) ){
my @tags = $self->gettags($it);
if( grep { $_ eq 'list'} @tags ){ $item = $it }
}

my ($bx,$by,$bx1,$by1)= $self->bbox($item);
my $x = $bx + $self->{'f_width'};
my $y_edge = ($by + $by1)/2;
my $y = $by1;
my $count = 0;

my @subdirs;
opendir my $dh, $abs_path or warn $!;
while ( my $file = readdir($dh) ) {
next if $file =~ m[^\.{1,2}$];
if(-d "$abs_path/$file"){
push @subdirs, $file;
}else{ next }
}

my $max = scalar @subdirs;
my $max_add = $max * $self->{'f_height'};

$self->make_space($y_edge,$max_add);

# add sub entries
foreach my $subdir (sort @subdirs ){
my $abs_path1 = File::Spec->rel2abs("$abs_path/$subdir");
my $put_ind = 0;

#see if any depth 2 subdir exists
opendir my $dh, $abs_path1 or warn $!;
while ( my $file = readdir($dh) ) {
next if $file =~ m[^\.{1,2}$];
if(-d "$abs_path1/$file"){
$put_ind = 1;
last;
}
}
#for windows compat
$abs_path1 =~ tr#\\#/#;

#make open indicator---------------------------------------------
if( $put_ind ){
my $ind = $self->createPolygon(
$x - .9 * $self->{'f_width'} , .5*$self->{'f_height'}+
$y + $self->{'f_height'}* $count - .3 * $self->{'f_height'},
$x - .5 * $self->{'f_width'}, .5*$self->{'f_height'}+
$y + $self->{'f_height'}* $count,
$x - .9 * $self->{'f_width'}, .5*$self->{'f_height'}+
$y + $self->{'f_height'}* $count + .3 * $self->{'f_height'} ,

-fill => $self->{'indfilln'},
-activefill => 'yellow',
-outline => 'black',
-width => 1,
-activewidth => 2,
-tags => ['ind', $abs_path1],
);

}
#------------------------------------------------------------
my $id = $self->createText(
$x , $y + $self->{'f_height'} * ($count + 1),
-fill => $self->{'fontcolorn'},
-activefill => $self->{'fontcolora'},
-text => $subdir,
-font => $self->{'font'},
-anchor => 'sw',
# -tags => ['list',$abs_path, $abs_path1],
-tags => ['list', $abs_path1],
);

#add tag to upstream indicator

$count++;
}

($bx,$by,$bx1,$by1)= $self->bbox('list');
$self->configure(
-scrollregion =>[0,0,$bx1,$by1],
);

} # end add_branch
########################################
####################################
sub close_branch{
my($self, $abs_path, $ind ) = @_;

my @y; my $x;

foreach my $it( $self->find('all') ){

my @tags = $self->gettags($it);

if( grep { $_ eq 'current'} @tags ){next}
if( grep { $_ eq $abs_path } @tags ){next}
if( grep { $_ =~ /^$abs_path(.*)/ } @tags ){
shift @tags; #shift off ind or list tag

if(scalar @tags > 0 ){
my ($bx,$by,$bx1,$by1)= $self->bbox( $tags[0] );
push @y,$by;
push @y,$by1;
$self->delete($it);
}
}
}

my @sorted = sort {$a<=>$b} @y ;
my $amount = $sorted[-1] - $sorted[0];
my ($bx,$by,$bx1,$by1)= $self->bbox('all');

my @items = $self->find('enclosed',
$bx, $sorted[-1] - $self->{'f_height'} ,
$bx1, $by1 + $self->{'f_height'} );

foreach my $move (@items){
$self->move($move,0, -$amount);
}

#adjust scroll region
($bx,$by,$bx1,$by1)= $self->bbox('list');
$self->configure(
-scrollregion =>[0,0,$bx1,$by1],
);

}
########################################
######################################
sub make_space{
my ($self, $y, $amount) = @_;

my ($bx,$by,$bx1,$by1)= $self->bbox('all');

my @items = $self->find('enclosed',$bx,$y,$bx1,$by1 +
$self->{'f_height'});

foreach my $move (@items){
$self->move($move,0,$amount);
}

}
########################################
######################################

sub rotate_poly {
my ($self, $id, $angle, $midx, $midy) = @_;

# Get the old coordinates.
my @coords = $self->coords($id);

# Get the center of the poly. We use this to translate the
# above coords back to the origin, and then rotate about
# the origin, then translate back. (old)

($midx, $midy) = _get_CM(@coords) unless defined $midx;

my @new;

# Precalculate the sin/cos of the angle, since we'll call
# them a few times.
my $rad = 3.1416*$angle/180;
my $sin = sin $rad;
my $cos = cos $rad;

# Calculate the new coordinates of the line.
while (my ($x, $y) = splice @coords, 0, 2) {
my $x1 = $x - $midx;
my $y1 = $y - $midy;

push @new => $midx + ($x1 * $cos - $y1 * $sin);
push @new => $midy + ($x1 * $sin + $y1 * $cos);
}

# Redraw the poly.
$self->coords($id, @new);
}
########################################
#########################
# This sub finds the center of mass of a polygon.
# I grabbed the algorithm somewhere from the web.
# I grabbed it from Slaven Reszic's RotCanvas :-)
sub _get_CM {
my ($x, $y, $area);

my $i = 0;

while ($i < $#_) {
my $x0 = $_[$i];
my $y0 = $_[$i+1];

my ($x1, $y1);
if ($i+2 > $#_) {
$x1 = $_[0];
$y1 = $_[1];
} else {
$x1 = $_[$i+2];
$y1 = $_[$i+3];
}

$i += 2;

my $a1 = 0.5*($x0 + $x1);
my $a2 = ($x0**2 + $x0*$x1 + $x1**2)/6;
my $a3 = ($x0*$y1 + $y0*$x1 + 2*($x1*$y1 + $x0*$y0))/6;
my $b0 = $y1 - $y0;

$area += $a1 * $b0;
$x += $a2 * $b0;
$y += $a3 * $b0;
}

return split ' ', sprintf "%.0f %0.f" => $x/$area, $y/$area;
}

1;
########################################
###############################
package main;

my $mw = MainWindow->new();

$mw->fontCreate('big',
-family=>'arial',
-weight=>'bold',
-size=>int(-18*18/14));

my $frame = $mw->Frame()->pack(-expand=>1,-fill=>'both');

# base64encoded png
my $bunny = $mw->Photo(-data =>
'iVBORw0KGgoAAAANSUhEUgAAAB4AAAAjEAIAAAB
cJvHFAAAACXBIWXMAAAsSAAALEgHS3X78AAAD
F0lEQVR42u1YL+yqUBj1vfcLbhY3C44is8BIREYS
G9FoNBqNkok2aFhp2BhJDWyadCZN/ilOGxan
jRdOuRsPxl/f+23vJKfX7x6+73znu5dK5RviV9QPDMMwDIPP7/f7/X6XTWU0Go1Go06n0+l0PM/z
PC91CNu2bduWZVmW5bLpjsfj8XgcBEEQBJPJZDKZ
ZAw0n8/n8zkCGYZhGIYgCIIgFEt3OBwOh8OA
gKZpmqZlDDedTqfTKRnO933f95GVer1er9fz0BVF
URRFxCR3QfyMQfv9fr/fDyLgOI7jONmo419k
JUkMBoPBYJCRNBrxdrvdbrco6qvVarVaIWdFpQO/5tIcFBbE4nQ6nU6nJIpHjlGlEklTFEVRFDIa
T32/3+/ 3+3jqHMdxHBcfB2sK6HFFURRFeb1er9crfksoNUr
r0GvUfxGfnA+FmX+QALDItGLDA6O2
pQyCJFkPqxMDK2p9LodOAhQaLRjfoKRGo2wObl3G
8PoDsA0Gb5Q5oonjfSNKTh96AOh+u91ut1uS
FuZrONPJ7bJ06tA9TDDsD6QkCnDltEDRkV1Q9AnE
Nyuk8hcyChkkcZKo5uv1er1er3S6cAPkFXSx
MQodPrXFg2zTEsVANhO2JNdEmVo80ub7K/ lSDHPyLkNaXrVarVar2W46LMuyLFsKaZ7neZ4nvw
FR
NGKeGjYajUajkXz9z+RLn8/n8/ms/ANIQXq5XC6Xy/v9fr/fvw3p9Xq9Xq9VVVVV9fF4PB6Pokhc
r9fr9Vr6s6Lf4dNpbS6/exQA3BHDt/ fkPl3wwT85wlcEcrCHZyHO1tmOSl95iGLcQN80Td
M0jTa1
LMuyLF3XdV03TdM0zWaz2Ww2Xdd1XRenDlDHgTbt
vj/ykMZpDm/6LpfL5XLBmGi32+12G6Th5RAA
Pne73W63iwfGYFosFovF4kOZrtVqtVoN16TD4XA4
HPAAKDp5yZUkSZIk1GGz2Ww2m91ut9vt0Mof
lcfxeDwej7PZbDaboRFbrVar1SJfIsLdYZfn8/l8Pue3y1zyiH9VAMFElb5Yp/+PcvAbH/25ox5S
PYYAAAAASUVORK5CYII=');

my $ztree = $frame->Scrolled('CanvasDirTree',
-bg =>'white',
-width =>300,
-height =>300,
# -backimage => 'bridget-5a.jpg', #either a file
-backimage => $bunny, #or Tk::Photo object data
-imx => 170, # position relative to nw corner
-imy => 10, # to place nw corner of image
-font => 'big',
-fontcolorn => 'black',
-fontcolora => 'red',
-indfilln => 'blue',
-indfilla => 'red',
-scrollbars =>'osw',
)->pack(-side=>'left',-fill=>'both', -expand=>1);

my $text = $frame->Scrolled('Text',
-bg=>'white',
-width => 40,
-scrollbars =>'osoe',
)->pack(-side=>'right',-fill=>'both',-expand=>1);

my $button = $mw->Button(-text=>'Exit',-command=>sub{exit})->pack();

$ztree->bind('<ButtonPress-1>', sub{
my $selected = $ztree->get_selected();

if(length $selected){
$text->insert('end',"$selected\n");
$text->see('end');
}
});

MainLoop;
################### snip ##################################

--
I'm not really a human, but I play one on earth.
http://zentara.net/japh.html

zentara

2006-04-01, 7:59 am

On Fri, 31 Mar 2006 11:16:01 GMT, zentara <zentara@highstream.net>
wrote:

>Below is a full working script, for the benefit of googler's who
>are looking for answers, (and can't figure out where to patch the
>example) :-)
>
>############### snip #################################
>#!/usr/bin/perl
>use warnings;

I've put a version which I keep updating and improving, at
http://perlmonks.org?node_id=540439

I keep finding little usability bugs that need fixing.
If anyone uses a Mac, can you tell me if it runs Ok,
especially from the topmost root directory?

--
I'm not really a human, but I play one on earth.
http://zentara.net/japh.html

Sponsored Links