Posts tagged: PerlTK

Piksahl, just a little more

Working on Piksahl just a little bit more. Finally labelling all of the columns and rows.

Another sneak peek.

Another sneak peek.

Since the beginning I’ve had the functionality to label the columns/rows, or to at least build a string like “2,1,1” and output the column/row total as “4”. So today I finally got around to parsing the original string and outputting as “2\n1\n1\n” with a little chomp(stirng) for good measure, in the case of a column. Rows are simpler, needing only to s/,/  /g the string.

To do, align the row labels to the right, align those columns to the bottom. For both columns and rows I need to get rid of all that wasted space where there is no text. That will be easily done by calculating the maximum number of characters per row and column individually.

PerlTK and “activating” multiple canvas items

What I was looking for was every row and every column to be “lit up” wherever I put my mouse cursor. I started with the base code snippet:

#!/usr/bin/perl -w

use strict;
use Tk;

my ($x, $y);
my $iconSize = 20;
my ($width, $height) = (3, 3);
my ($canvasWidth, $canvasHeight) = ($iconSize+$width*$iconSize,
                                    $iconSize+$height*$iconSize);

my $MW = MainWindow->new;
my $MF = $MW->Frame->pack;
my $c = $MF->Canvas( -width => $canvasWidth,
                -height => $canvasHeight )->pack;

for ($y = $iconSize; $y < $canvasHeight; $y+=$iconSize)
{
    for ($x = $iconSize; $x < $canvasWidth; $x+=$iconSize)
    {
        $c->createRectangle ($x, $y,
                $x+$iconSize, $y+$iconSize,
                -fill => '#AFAFAF',
                -activefill => '#CFCFCF' );
    }
}

MainLoop

And posted to comp.lang.perl.tk for help. I received two solutions.

Zentara was first to reply, who wrote:

The secret to using the Canvas is tags. Read the perldoc Tk::Canvas
for everything on tags, and search groups.google.com for "Perl Tk canvas
tags" for many examples.
It's kind of an art, to see which tag juggling technique to use, but
generally you bind to motion or a tag, then find the current item, then
addtags or deltags, etc.  You can get very clever and make things very
efficient. For instance, in the following script, I do it the clunky
way, by itemconfiguring a bunch of items returned by find. But you
could also define a tag called "lit' (or something), and addtag lit
to all rows and cols on enter, then deltags lit on leaving. 

Second to reply was Jack D. He altered Zentara’s solution making it more compact.

#!/usr/bin/perl -w

use strict;
use Tk;

my ($x, $y);
my $iconSize = 20;
my ($width, $height) = (10, 10);
my ($canvasWidth, $canvasHeight) = ($iconSize+$width*$iconSize,
                                    $iconSize+$height*$iconSize);

my $MW = MainWindow->new;
my $MF = $MW->Frame->pack;
my $c = $MF->Canvas( -width => $canvasWidth,
                -height => $canvasHeight )->pack;

for ($y = $iconSize; $y < $canvasHeight; $y+=$iconSize)
{
    for ($x = $iconSize; $x < $canvasWidth; $x+=$iconSize)
    {
        $c->createRectangle ($x, $y,
            $x+$iconSize, $y+$iconSize,
            -fill => '#AFAFAF',
            -activefill => '#CFCFCF',
            -tags=>['rect',"row.$y", "col.$x"] );
    }
}

$c->bind('rect', '<Enter>', \&enter );
$c->bind("rect", "<Leave>", \&leave );

MainLoop;

sub findtag {
    my ($canv) = @_;
    my $id = $canv->find('withtag', 'current');
    my @tags = $canv->gettags($id);
    my ($row) = ( grep /^row\d*/, @tags );
    my ($col) = ( grep /^col\d*/, @tags );
    return ($row,$col);
}

sub enter {
    my ($canv) = @_;
    my ($r,$c) = findtag($canv);
    $canv->itemconfigure($r, -fill=>$canv->itemcget($r,-activefill));
    $canv->itemconfigure($c, -fill=>$canv->itemcget($c,-activefill));
}

sub leave{
    my ($canv) = @_;
    $canv->itemconfigure('rect', -fill=>'#AFAFAF');
}

__END__

And it certainly gets the job done. I’m interested in that particular trick for a game I’m currently programming. I call it Piksahl and I’ll release more details as the game sees more progress.

Late-Night PerlTK Fun.

I’m just messing around with PerlTK tonight. Here’s my artistic accomplishment.

#!/usr/bin/perl -w

use strict;
use Tk;

my($width, $height) = (250,250);
my $x;
my $y;
my $mw = MainWindow->new;
my $c = $mw->Canvas(-width => $width, -height => $height);
$c->pack;

$y = $height;

for ($x = 0; $x <= $width; $x+=10) {
	$c->createLine(0, $height-$y, $x, $height, -fill => 'blue');
	$c->createLine($width-$x, 0, $width, $y, -fill => 'black');
	$c->createLine($width-$x, 0, 0, $height-$y, -fill => 'red');
	$c->createLine($x, $height, $width, $y, -fill => 'green');
	$y-=10;
}

MainLoop;

Which results in

PerlTK is refreshingly simple to use. I recommend PerlTK.org to get yourself on your feet with a great tutorial.

Staypressed theme by Themocracy