| Tk::Canvas::Draw - Simplifies drawing with a mouse in a perl/Tk Canvas |
Tk::Canvas::Draw - Simplifies drawing with a mouse in a perl/Tk Canvas
use Tk::Canvas::Draw;
Tk::Canvas::Draw->new($canvas, \&final_callback, $h_args);
This module simplifies the drawing of perl/Tk shapes in a Canvas, using a mouse. Once the first <Button-N> event is detected for the given mouse button N, and in the specified Canvas, the Motion and ButtonRelease events are bound to the same mouse button and Canvas. All subsequent points are captured until the final ButtonRelease event occurs. Finally, any previous set bindings for the Canvas and mouse button are reinstated, and the registered callback is invoked to handle any necessary final processing.
Version 0.07
Required parameters:
The final callback parameter names a subroutine to be invoked when the mouse button is released. This subroutine is passed the following 3 arguments:
$o_obj -- The Tk::Canvas::Draw object
$a_points -- A reference to an array containing the captured coordinate points, each of which is an array reference in the form [ x, y ]
$a_ids -- A reference to an array containing the ID(s) of the drawn shape
Lets the user reuse the Tk::Canvas::Draw object, optionally resetting any
of the same arguments as allowed to the new() method. This method takes
the following 2 arguments:
$obj
The Tk::Canvas::Draw object
$h_args
An optional hash, with the same values as allowed in the new() constructor. (See the $h_args parameter in the REQUIRED PARAMETERS section above)
Allows the recreation of the shape given by the points in $a_points to
an alternate location in the canvas (or in a separate canvas), and returns
the ID(s) associated with the new shape. The following arguments are
required:
$obj
The Tk::Canvas::Draw object. The following accessor methods allow retrieval of the corresponding member data:
$obj->canvas $obj->mouse $obj->color $obj->fill $obj->width $obj->style
$a_points
A reference to an array containing the (x, y) points generated by an initial call to Tk::Canvas::Draw::new. For example:
[ [10, 25], [12, 27], [13, 29], ... ]
$xoff
The x-offset by which to vary the new shape from the original
$yoff
The y-offset by which to vary the new shape from the original
$canvas
An optional Canvas on which to draw the new shape (it defaults to the current Canvas used by $obj)
#!/usr/bin/perl -w
#
# Here's a quick example to stimulate your immediate excitement.
# The following program 'doodle' lets you draw colorful, freehand lines
# in a Tk Canvas!
##
use strict;
use warnings;
use Tk;
use Tk::Canvas::Draw;
my $help = qq[
Click and move the mouse anywhere in the white box to begin drawing.
Type 'Escape' to clear everything.
];
my $a_all_ids = [ ];
my $mw = new MainWindow(-title => 'Doodle -- Tk::Canvas::Draw example');
my $cv = $mw->Canvas(-bg => 'white', -width => 512, -height => 512)->pack;
$cv->createText(0, 0, -anch => 'nw', -text => $help);
Tk::Canvas::Draw->new($cv, \&done_drawing, { width => 5 });
$mw->bind("<Escape>" => sub { map { $cv->delete($_) } @$a_all_ids });
MainLoop;
# Tk::Canvas::Draw callback -- reinstall callback with a new, random color
sub done_drawing {
my ($o_obj, $a_points, $a_ids) = @_;
push @$a_all_ids, @$a_ids;
my $color = sprintf "#%02x%02x%02x", rand(256), rand(256), rand(256);
$o_obj->restart( { color => $color });
}
#!/usr/bin/perl -w
#
# Another very simple example of Tk::Canvas::Draw, this time using
# each of the various allowable styles.
##
use strict;
use warnings;
use Tk;
use Tk::Canvas::Draw;
my $a_style = [qw[ free line oval circle rectangle ]];
my $a_color = [qw[ black red blue purple orange ]];
my $stylenum = 0;
my $colornum = 0;
my $mw = new MainWindow(-title => 'Tk::Canvas::Draw example');
my $cv = $mw->Canvas(-width => 512, -height => 512)->pack;
Tk::Canvas::Draw->new($cv, \&done, { width => 5, fill => 'white' });
MainLoop;
# Tk::Canvas::Draw final callback - change style, reinstall callback
sub done {
my ($o_obj, $a_points, $a_ids) = @_;
my $style = $a_style->[++$stylenum % @$a_style];
my $color = $a_color->[++$colornum % @$a_color];
$o_obj->restart( { style => $style, color => $color });
}
#!/usr/bin/perl -w
#
# A more complicated example of Tk::Canvas::Draw, this program gives
# the user more flexibility in choosing options to the constructor
# (although the color and width are randomized). It also demonstrates
# how to use the -action => \&callback argument, to track points while
# they are drawn, as well as showing the transform() method which can
# be used to make copies of the drawn object.
##
use strict;
use warnings;
use Tk;
use Tk::Canvas::Draw;
#############
## Globals ##
#############
my $a_styles = [qw[ free line oval circle rectangle ]];
my $a_font = [qw[ tahoma 12 ]];
my @all_id1 = ( );
my @all_id2 = ( );
my $b_fill = 0;
my $lastxy = "";
my $style;
##################
## Main program ##
##################
my $mw = new MainWindow(-title => 'Tk::Canvas::Draw example');
my $f1 = $mw->Frame()->pack(-fill => 'x');
my $f2 = $mw->Frame()->pack(-fill => 'both');
my $c1 = $f2->Canvas(-wi => 512,-he => 512, -bg => 'white');
my $c2 = $f2->Canvas(-wi => 512,-he => 512, -bg => '#ffffdf');
$c1->pack($c2, -side => 'left');
button($f1, '>Quit (^Q)', sub { exit }, 'Control-q');
button($f1, '<Clear Last (space)', \&clear_last, 'space');
button($f1, '<Clear All (Esc)', \&clear_all, 'Escape');
choose_style($f1);
choose_fill($f1);
last_point($f1);
start_drawing($c1);
MainLoop;
#################
## Subroutines ##
#################
sub button {
my ($w, $text, $c_cmd, $bind) = @_;
my $side = ($text =~ s/^([<>])//)? $1: '<';
my $bt = $w->Button(-bg => '#ffafef', -text => $text);
$bt->configure(-comm => $c_cmd, -font => $a_font);
if ($bind || 0) {
$w->toplevel->bind("<$bind>" => sub { $bt->invoke });
}
$bt->pack(-side => ($side eq '<')? 'left': 'right');
}
sub random_color {
sprintf "#%02x%02x%02x", rand(256), rand(256), rand(256);
}
sub clear_last {
my $a_id1 = pop @all_id1;
my $a_id2 = pop @all_id2;
map { $c1->delete($_) } @$a_id1;
map { $c2->delete($_) } @$a_id2;
}
sub clear_all {
while (@all_id1 > 0) {
clear_last();
}
}
sub labeled_frame {
my ($w, $text) = @_;
my $fr = $w->Frame(-relief => 'ridge', -borderwidth => 4);
my $lb = $fr->Label(-text => $text, -font => $a_font);
$fr->pack(-side => 'left');
$lb->pack(-side => 'left');
return $fr;
}
sub choose_style {
my ($w) = @_;
my $fr = labeled_frame($w, "Style");
my @args = (
-bg => '#7fcfff',
-variable => \$style,
-command => \&start_drawing,
-font => $a_font,
);
my $opt = $fr->Optionmenu(@args);
map { $opt->addOptions($_) } @$a_styles;
$style = 'free';
$opt->pack(-side => 'left');
}
sub choose_fill {
my ($w) = @_;
my $fr = labeled_frame($w, "Fill Shapes");
my $a_comm = [
-font => $a_font,
-variable => \$b_fill,
-command => \&start_drawing,
];
my $a_no = [ -text => "No", -value => 0 ];
my $a_yes = [ -text => "Yes", -value => 1 ];
my $r_no = $fr->Radiobutton(@$a_no, @$a_comm);
my $r_yes = $fr->Radiobutton(@$a_yes, @$a_comm);
$r_no->pack($r_yes, -side => 'left');
}
sub last_point {
my ($w) = @_;
my $fr = labeled_frame($w, "Last Point");
my $lbl = $fr->Label(-textvar => \$lastxy, -font => $a_font);
$lbl->pack(-side => 'left');
}
#==============================#
## Tk::Canvas::Draw interface ##
#==============================#
sub start_drawing {
my $width = int(1 + rand(32));
my $color = random_color();
my $fill = $b_fill? random_color: 0;
my $h_opts = {
'width' => $width,
'color' => $color,
'fill' => $fill,
'style' => $style,
'action' => \&show_last,
};
new Tk::Canvas::Draw($c1, \&done_drawing, $h_opts);
}
sub show_last {
my ($a_point) = @_;
my ($x, $y) = @$a_point;
$lastxy = sprintf "($x, $y)";
}
sub done_drawing {
my ($o_obj, $a_pts, $a_ids) = @_;
push @all_id1, $a_ids;
push @all_id2, Tk::Canvas::Draw::transform($o_obj, $a_pts, 0, 0, $c2);
start_drawing();
}
John C. Norton
Copyright 2009-2010 John C. Norton.
This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License.
See http://dev.perl.org/licenses/ for more information.
| Tk::Canvas::Draw - Simplifies drawing with a mouse in a perl/Tk Canvas |