perlquestion
rocklee
<p>Hi Monks</p>
<p>It's been a busy week, not much time for Perl hacking. Today I'm back at it, though! ;-) So I'm rewriting my previous POE+Tk::Zinc code, going for plain-old modules instead. After some experimenting, I have questions..</p>
<p>My module abstracts the concept of a group of buttons, so I can easily create buttons that scale to a given region on the screen. It turned out more neat than I first anticipated, but it's still full of ugly hacks.. ;-) </p>
<p>1. Am I duplicating effort here? I can't seem to find any modules that focus on UI widgets for Zinc? The exception is IntuiKit which I tried to obtain, but it is no longer for sale :-( How do you guys make UIs in Zinc?
</p>
<p>2. Some things in my constructor seem pretty clumsy to me. I'm sure there are better ways:
<c>
sub new {
my ($proto, $zinc, $args) = @_;
my $self = {
'zinc' => $zinc,
'bbox' => $args->{'bbox'} || [[0,0],[200,200]],
'packer' => $args->{'packer'} || 'vertical',
};
...
}
sub packer { .. }
</c>
<ol>
<li>I have a accessor/mutator function called packer() that allows changing $self->{packer} after creation time. Can I somehow use this function from the constructor to validate $args->{packer}? I.e $self->packer($args->{packer}), but obviously that's not going to work..
</li>
<li>Is there a shorthand way to test if $args->{bbox} conforms to [[int, int], [int, int]] ?
</li>
<li>
Is there a better way to 'extract' $args into $self? Or in general an established way to handle (complex) arguments to a constructor? If so, where is this documented?
</li>
</ol>
<p>
3. I find lots of information about creating composite widgets in Tk; I don't find so much about how to create 'composite items' on a Canvas, or Zinc specifically, which is what I do (?) in my code. Can you point me to some code that implements objects that represent complex item collections on a canvas? (or documentation of such a pattern).. or am I totally missing something obvious that invalidates my approach to this problem..?
</p>
<br>
<b>ButtonCollection.pm</b>
<readmore>
<c>
package ButtonCollection;
use strict;
use warnings;
use Tk::Zinc::Graphics;
use Carp;
use base qw{ Class::Accessor::Fast };
__PACKAGE__->mk_accessors(qw{
spacing order
});
__PACKAGE__->mk_ro_accessors(qw{
width height
});
# Initialization and create a (zinc) group for our buttons.
sub new {
my ($proto, $zinc, $args) = @_;
my $type = ref($proto) || $proto;
my $self = {
'zinc' => $zinc,
'bbox' => $args->{'bbox'} || [[0,0],[200,200]],
'packer' => $args->{'packer'} || 'vertical',
'spacing' => defined($args->{'spacing'}) ? $args->{'spacing'} : 5,
'buttons' => {},
'order' => [],
};
$self->{'width'} = $self->{'bbox'}->[1][0] - $self->{'bbox'}->[0][0];
$self->{'height'} = $self->{'bbox'}->[1][1] - $self->{'bbox'}->[0][1];
$self->{'group'} = $self->{'zinc'}->add(
'group', 1,
-atomic => 0,
-visible => 0,
-tags => ['buttoncollection'],
);
# Place group at bbox X1,Y1, to ease positioning buttons later on.
$self->{'zinc'}->translate(
$self->{'group'},
$self->{'bbox'}[0][0],
$self->{'bbox'}[0][1]
);
return bless($self, $type);
}
#
# Given type, name and callback; create a group, shape and text item on the
# zinc canvas, representing a button. No scaling/positioning is done at this
# time (but mouse bindings are..)
#
# !! NOTE: 'type' is magic and requires two gradients to be present in
# self->zinc. They must be named "$type" and "active_$type".
# gradient "active_$type" is used when pointer is over button.
#
sub add_button {
my ($self, $type, $name, $callback) = @_;
croak "Must specify name." unless defined $name;
croak "Must specify type." unless defined $type;
my $group = $self->{'zinc'}->add(
'group', $self->{'group'},
-atomic => 1,
-visible => 0,
-tags => ['button', $type, 'group'],
);
my $shape = $self->{'zinc'}->add(
'curve', $group,
$self->{'bbox'},
-tags => ['button', $type, 'shape'],
-fillcolor => $type,
-filled => 1,
-closed => 1,
-linewidth => 1,
-linecolor => '#ffffff',
);
my $text = $self->{'zinc'}->add(
'text', $group,
-color => '#ffffff',
-anchor => 'center',
-text => $name,
-tags => ['button', $type, 'text'],
);
if (defined($callback)) {
$self->{'zinc'}->bind($group, '<1>', \&{$callback});
}
$self->{'zinc'}->bind($group, '<Enter>', sub {
$self->{'zinc'}->itemconfigure($shape, -fillcolor=>'active_'.$type);
});
$self->{'zinc'}->bind($group, '<Leave>', sub {
$self->{'zinc'}->itemconfigure($shape, -fillcolor=>$type);
});
$self->{'buttons'}{$group} = [$shape, $text];
push @{ $self->{'order'} }, $group;
return $group;
}
# Return a buttons shape and text items
sub get_button {
my ($self, $group) = @_;
if (defined $self->{'buttons'}{$group}) {
return @{ $self->{'buttons'}{$group}};
}
croak "unknown button $group\n";
}
# Given nothing, reshape all the (ordered) buttons in the collection
# to fit within self->bbox according to packer (then make group visible)
sub pack {
my ($self) = @_;
my $numbtn = 1 + scalar @{ $self->{'order'} };
# Get the width, height and shape of ONE button.
my ($BW, $BH) = $self->_get_button_size($numbtn);
my $shapecoords = &roundedRectangleCoords(
[ [-(int $BW/2),-(int $BH/2)], [int $BW/2, int $BH/2] ]
);
# First hide and deactivate all buttons
foreach my $group ( keys %{ $self->{'buttons'} } ) {
$self->{'zinc'}->itemconfigure($group, -visible => 0);
$self->{'zinc'}->itemconfigure($group, -sensitive => 0);
}
# Then resize, move, show and activate the ones specified by ->order
my $i=0;
my ($group, $shape, $text, $x, $y);
foreach my $group (@{ $self->{'order'} }) {
($shape, $text) = @{ $self->{'buttons'}{$group} };
($x, $y) = $self->_get_button_pos($BW, $BH, $i);
$self->{'zinc'}->coords($shape, $shapecoords);
$self->{'zinc'}->treset($group);
$self->{'zinc'}->translate($group, $x, $y);
$self->{'zinc'}->itemconfigure($group, -visible => 1);
$self->{'zinc'}->itemconfigure($group, -sensitive => 1);
$i++;
}
$self->{'zinc'}->itemconfigure($self->{'group'}, -visible => 1);
}
# Accessor/mutator
sub packer {
my ($self, $packer) = @_;
if (defined $packer and $packer =~ m/^(horizontal|vertical)$/) {
$self->{'packer'} = $packer;
} elsif (not defined $packer) {
return $self->{'packer'};
} else {
die "Packer must be horizontal or vertical.";
}
}
# Accessor/mutator
sub bbox {
my ($self, $bbox) = @_;
if (defined $bbox) {
$self->{'bbox'} = $bbox;
$self->{'width'} = $self->{'bbox'}->[1][0] - $self->{'bbox'}->[0][0];
$self->{'height'} = $self->{'bbox'}->[1][1] - $self->{'bbox'}->[0][1];
return 1;
}
return $self->{'bbox'};
}
# Accessor, return zinc groups of all buttons
sub buttons {
my $self = shift;
return keys %{ $self->{buttons} };
}
# Accessor, return whether _collection_ is visible
sub visible {
my $self = shift;
return $self->{'zinc'}->itemcget($self->{'group'}, -visible);
}
# hides the collection('s zinc group)
sub hide {
my $self = shift;
$self->{'zinc'}->itemconfigure($self->{'group'}, -visible => 0);
}
# shows the collection('s zinc group)
sub show {
my $self = shift;
$self->{'zinc'}->itemconfigure($self->{'group'}, -visible => 1);
}
# _get_button_pos;
# Given button width/height and number, return the buttons x/y position
sub _get_button_pos {
my ($self, $BW, $BH, $num) = @_;
my ($x, $y);
if ($self->{'packer'} eq 'horizontal') {
$x = ($BW/2)+($num*($self->spacing+$BW)+$self->spacing);
$y = ($BH/2)+($self->spacing);
} elsif ($self->{'packer'} eq 'vertical') {
$x = ($BW/2)+($self->spacing);
$y = ($BH/2)+($num*($self->spacing+$BH)+$self->spacing);
} else {
croak "Unsupported packer:", $self->{packer};
}
# print "returning button $num position: $x, $y\n";
return ($x, $y);
}
# _get_button_size:
# Given number of buttons in collection, return width and height of one button
sub _get_button_size {
my ($self, $numbtn) = @_;
my ($BW, $BH);
$numbtn -= 1;
croak "pack() with no buttons?" if ($numbtn <= 0);
if ($self -> {'packer'} eq 'horizontal') {
$BW = ($self->{'width'} - ((1+$numbtn)*$self->{spacing})) / $numbtn;
$BH = $self->{'height'} - ($self->{spacing}*2);
} elsif ($self->{'packer'} eq 'vertical') {
$BW = $self->{'width'} - ($self->{spacing}*2);
$BH = ($self->{'height'} - $self->spacing-($numbtn*$self->{spacing}) ) / $numbtn;
} else {
croak "Unsupported packer:", $self->{packer};
}
return ($BW, $BH);
}
1;
</c>
</readmore>
<br>
<b>TestButtons.pl (Esc exits)</b>
<readmore>
<c>
#!/usr/bin/perl
use strict;
use warnings;
use Tk;
use Tk::Zinc;
use Tk::Zinc::Graphics;
require "ButtonCollection.pm";
# These gradients are used by ButtonCollection, and are
# magically named (ie have a corresponding active_ gradient
# for <Enter> event)
my %gradients = (
'button' => '=axial 200|#aaaaaa;50|#a8a8a8;10',
'active_button' => '=axial 250|#fafafa;20|#fefefe;50',
'button_red' => '=axial 200|#aa0000;20|#881010;10',
'active_button_red' => '=axial 250|#ff0000;50|#aa0000;50',
);
# Initialize the mainwindow and pack a fullscreen zinc
my $mw = new MainWindow;
$mw->withdraw;
my $zinc = $mw -> Zinc(
-width => $mw -> screenwidth,
-height => $mw -> screenheight,
-render => 1,
-borderwidth => 0,
-backcolor => '#000000',
) -> pack;
die "Need OpenGL support!" unless ($zinc->cget(-render) > 0);
# Create a vertically packed buttoncollection on left side of screen
my $mainmenu = new ButtonCollection($zinc,
{
bbox => [[0,0],[300,$mw->screenheight]],
packer => 'vertical',
spacing => 3,
}
);
&setGradients($zinc, \%gradients);
# Add buttons to the collection, first parameter 'type' corresponds to
# a 'magic gradient'. Parameters are type aka gradient, text, callback
my $btn1 = $mainmenu->add_button('button', "Flip order", \&flip_order);
my $btn2 = $mainmenu->add_button('button', "Toggle packer", \&toggle_packer);
my $btn3 = $mainmenu->add_button('button', "Solo - resize", \&solo_resize);
my $btn4 = $mainmenu->add_button('button', "Solo - stretch", \&solo_stretch);
my $btn5 = $mainmenu->add_button('button', 'Solo - group', \&solo_group);
my $btn6 = $mainmenu->add_button('button', 'Solo - Added', \&solo_added);
my $btn7 = $mainmenu->add_button('button', "Add button", \&add_button);
$mainmenu->pack;
$mw -> bind('<Key-Escape>' => sub{exit;});
$mw -> FullScreen(1);
$mw -> focusForce;
$mw -> grabGlobal;
$mw -> deiconify;
MainLoop;
exit 0;
# Reverse the current order of buttons.
sub flip_order {
$mainmenu->order(reverse @{$mainmenu->order});
$mainmenu->pack;
}
# Toggle between horizontal and vertical packer, also set
# the ButtonCollection's bbox accordingly.
sub toggle_packer {
if ($mainmenu -> packer eq 'horizontal') {
$mainmenu -> packer('vertical');
$mainmenu -> bbox([[0,0],[300,$mw->screenheight]]);
} else {
$mainmenu -> packer('horizontal');
$mainmenu -> bbox([[0,0],[$mw->screenwidth,100]]);
}
$mainmenu->pack;
}
# Toggle resized solo mode for button 3
my ($btn3_old_order, $btn3_old_bbox, $btn3_is_solo);
sub solo_resize {
my ($shape, $text) = $mainmenu->get_button($btn3);
if ($btn3_is_solo) {
$mainmenu -> bbox($btn3_old_bbox);
$mainmenu -> order($btn3_old_order);
$zinc->itemconfigure($text, -text => 'Solo - resize');
$btn3_is_solo = 0;
} else {
$btn3_old_order = $mainmenu -> order;
$btn3_old_bbox = $mainmenu -> bbox;
my ($x1, $y1, $x2, $y2) = $zinc->bbox($btn3);
$mainmenu -> order([$btn3]);
$mainmenu -> bbox([[$x1, $y1], [$x2, $y2]]);
$zinc->itemconfigure($text, -text => 'Expand!');
$btn3_is_solo = 1;
}
$mainmenu -> pack;
}
# Toggle stretched solo mode for button 4
my ($btn4_old_order, $btn4_is_solo);
sub solo_stretch {
if ($btn4_is_solo) {
$mainmenu -> order($btn4_old_order);
$btn4_is_solo = 0;
} else {
$btn4_old_order = $mainmenu -> order;
$mainmenu -> order([$btn4]);
$btn4_is_solo = 1;
}
$mainmenu -> pack;
}
# Toggle solo for a given group of buttons
# (same as above, only more buttons in ->order call)
my ($btn5_old_order, $btn5_is_solo);
sub solo_group {
if ($btn5_is_solo) {
$mainmenu -> order($btn5_old_order);
$btn5_is_solo = 0;
} else {
$btn5_old_order = $mainmenu -> order;
$mainmenu -> order([$btn1, $btn2, $btn4, $btn5]);
$btn5_is_solo = 1;
}
$mainmenu -> pack;
}
# Add a new button to the end of collection
my @added_buttons;
sub add_button {
push @added_buttons, $mainmenu -> add_button(
'button_red', (1+scalar @added_buttons), sub{ }
);
$mainmenu -> pack;
}
# Toggle solo mode for added buttons (and btn6)
my ($btn6_old_order, $btn6_is_solo);
sub solo_added {
if ($btn6_is_solo) {
$mainmenu -> order($btn6_old_order);
$btn6_is_solo = 0;
} else {
$btn6_old_order = $mainmenu -> order;
$mainmenu -> order([$btn6, @added_buttons]);
$btn6_is_solo = 1;
}
$mainmenu -> pack;
}
</c>
</readmore>
<p>Thanks in advance (Z);-)<p>