GUIs in Tk.:Zinc; a perl module experiment

rocklee has asked for the wisdom of the Perl Monks concerning the following question:

Hi Monks

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..

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.. ;-)

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?

2. Some things in my constructor seem pretty clumsy to me. I'm sure there are better ways:

sub new {
  my ($proto, $zinc, $args) = @_;
  
  my $self = {
    'zinc'      => $zinc,
    'bbox'      => $args->{'bbox'}    || [[0,0],[200,200]],
    'packer'    => $args->{'packer'}  || 'vertical',
  };  
...
}

sub packer { .. }
[download]

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..
Is there a shorthand way to test if $args->{bbox} conforms to [[int, int], [int, int]] ?
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?

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..?

ButtonCollection.pm

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 o
+n the 
# zinc canvas, representing a button. No scaling/positioning is done a
+t 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 butto
+n.
#

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 visibl
+e)
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 positio
+n 
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 on
+e 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})) / $numbt
+n; 
    $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;
[download]

TestButtons.pl (Esc exits)

#!/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_or
+der);
my $btn2 = $mainmenu->add_button('button', "Toggle packer",  \&toggle_
+packer);
my $btn3 = $mainmenu->add_button('button', "Solo - resize",  \&solo_re
+size);
my $btn4 = $mainmenu->add_button('button', "Solo - stretch", \&solo_st
+retch);
my $btn5 = $mainmenu->add_button('button', 'Solo - group',   \&solo_gr
+oup);
my $btn6 = $mainmenu->add_button('button', 'Solo - Added',   \&solo_ad
+ded);
my $btn7 = $mainmenu->add_button('button', "Add button",     \&add_but
+ton);
$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;
}
[download]

Thanks in advance (Z);-)

Back to Seekers of Perl Wisdom