package Tk::Canvas::Draw;
our $VERSION = '0.05';
=head1 NAME
Tk::Canvas::Draw - Simplifies drawing with a mouse in a perl/Tk Canvas
=head1 DESCRIPTION
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.
=head1 VERSION
Version 0.05
=head1 SYNOPSIS
use Tk::Canvas::Draw;
Tk::Canvas::Draw->new($canvas, \&final_callback, $h_args);
=head1 REQUIRED PARAMETERS
=over 4
=item $canvas
The Tk::Canvas object where the mouse events will be captured.
=item \&final_callback
A callback to invoked when the <ButtonRelease> event occurs. The argument
is required, but may be a non-blank string (eg. 'none') if the user is
certain that no final processing is necessary.
(See the section FINAL CALLBACK below)
=item $h_args
An optional reference to a hash containing any of the following arguments:
=over 4
=item 'style'
The style of drawing to be done. Must be one of:
=over 4
=item 'none'
Does not draw anything, just collects the (x,y) points generated by
moving the mouse over the canvas.
=item 'free'
Joins all points drawn to create freehand lines (this is the default).
=item 'line'
Joins the first point with the most recent point, to create a straight line.
=item 'oval'
Joins the first point with the most recent point to create an oval.
=item 'circle'
Joins the first point with the most recent point to create a circle.
=item 'rectangle'
Joins the first point with the most recent point to create a rectangle.
=item 'mouse'
The mouse button to bind the drawing to; one of {'1', '2' or '3'}.
The default is '1'.
=back
=item 'color'
The color of the object being drawn. (Do not confuse this with the
'fill' argument). The default color is 'black'.
=item 'fill'
The color with which to fill the drawn shape (does not apply to styles
'free' or 'line'). The default fill is '0' (ie. no fill).
=item 'width'
The width of the shape being draw. In the case of lines (style 'free'
or 'line'), this referes to the line width; in all other shapes it is
the width of the shape's outline. The default width is '1'.
=item 'action'
A callback to invoke each time a new point is detected. It will be passed
a reference to an array containing the most recent (x, y) point detected,
eg. [ 123, 45 ].
=back
=back
=head1 FINAL CALLBACK
The final callback parameter names a subroutine to be invoked
when the mouse button is released. This subroutine is passed the
following 3 arguments:
=over 4
$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
=back
=head1 METHODS
restart($obj, $h_args)
=over 4
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:
=over 4
$obj
=over 4
The Tk::Canvas::Draw object
=back
$h_args
=over 4
An optional hash, with the same values as allowed in the I<new()>
constructor. (See the I<$h_args> parameter in the REQUIRED PARAMETERS
section above)
=back
=back
=back
transform($obj, $a_points, $xoff, $yoff, $canvas)
=over 4
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:
=over 4
$obj
=over 4
The Tk::Canvas::Draw object. The following accessor methods allow retrieval
of the corresponding member data:
=over 4
$obj->canvas
$obj->mouse
$obj->color
$obj->fill
$obj->width
$obj->style
=back
=back
$a_points
=over 4
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], ... ]
=back
$xoff
=over 4
The x-offset by which to vary the new shape from the original
=back
$yoff
=over 4
The y-offset by which to vary the new shape from the original
=back
$canvas
=over 4
An optional Canvas on which to draw the new shape (it defaults to the
current Canvas used by $obj)
=back
=back
=back
=head1 EXAMPLE 1
#!/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 });
}
=head1 EXAMPLE 2
#!/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 });
}
=head1 EXAMPLE 3
#!/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();
}
=head1 AUTHOR
John C. Norton
=head1 COPYRIGHT & LICENSE
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.
=cut
###############
## Libraries ##
###############
use strict;
use warnings;
use Carp;
use Tk;
#############
## Globals ##
#############
my $b_drawing = 0; # Disallow multiple simultaneous invocations
my $h_defaults = {
'mouse' => 1,
'color' => 'black',
'fill' => 0,
'width' => 1,
'action' => 0,
'style' => 'free',
};
my $h_aliases = {
'a' => 'action',
'c' => 'color',
'f' => 'fill',
'm' => 'mouse',
'w' => 'width',
's' => 'style',
};
my $h_styles = {
'none' => 'Do not draw anything, just collect points',
'free' => 'Join all points to create freehand lines (default)',
'line' => 'Join first/last points to create straight lines',
'oval' => 'Join first/last points to create ovals',
'circle' => 'Join first/last points to create circles',
'rectangle' => 'Join first/last points to create rectangles',
};
###############
## Libraries ##
###############
sub new {
my ($proto, $canvas, $c_result, $h_args) = @_;
my $self = { 'points' => [ ], 'ids' => [ ], 'bindings' => { } };
bless $self, $proto;
$self->assign_args($h_args);
($canvas || 0) or $self->fatal("Missing Canvas argument (arg \$1)");
($c_result || 0) or $self->fatal("Missing result callback (arg \$2)");
$self->{'canvas'} = $canvas;
$self->{'result'} = $c_result;
my $mouse = $self->{'mouse'};
my $event = $self->{'start_event'};
my $a_draw = [ sub { $self->start_drawing(@_) }, Ev('x'), Ev('y') ];
$self->new_binding($canvas, $event, $a_draw);
return $self;
}
###############
## Accessors ##
###############
sub canvas { my ($self) = @_; $self->{'canvas'} }
sub mouse { my ($self) = @_; $self->{'mouse'} }
sub color { my ($self) = @_; $self->{'color'} }
sub fill { my ($self) = @_; $self->{'fill'} }
sub width { my ($self) = @_; $self->{'width'} }
sub style { my ($self) = @_; $self->{'style'} }
##########################
## User-visible Methods ##
##########################
sub restart {
my ($self, $h_args) = @_;
$self->assign_args($h_args);
my $canvas = $self->{'canvas'};
my $event = $self->{'start_event'};
my $a_draw = [ sub { $self->start_drawing(@_) }, Ev('x'), Ev('y') ];
$self->new_binding($canvas, $event, $a_draw);
}
sub transform {
my ($self, $a_points, $xoff, $yoff, $canvas) = @_;
my $a_ids = [ ];
my ($x0, $y0);
$canvas ||= $self->canvas;
my $color = $self->color;
my $fill = $self->fill;
my $width = $self->width;
my $style = $self->style;
for (my $i = 0; $i < @$a_points; $i++) {
my $a_point = $a_points->[$i];
my ($x1, $y1) = ( $a_point->[0] + $xoff, $a_point->[1] + $yoff );
if ($i > 0) {
my @args = ($x0, $y0, $x1, $y1);
if ($style eq 'free' or $style eq 'line') {
push @args, -width => $width;
$color and push @args, -fill => $color;
push @$a_ids, $canvas->createLine(@args);
} elsif ($style eq 'oval') {
push @args, -width => $width, -outline => $color;
$fill and push @args, -fill => $fill;
push @$a_ids, $canvas->createOval(@args);
} elsif ($style eq 'rectangle') {
push @args, -width => $width, -outline => $color;
$fill and push @args, -fill => $fill;
push @$a_ids, $canvas->createRectangle(@args);
} elsif ($style eq 'circle') {
my $rad = sqrt(($x1 - $x0) ** 2 + ($y1 - $y0) ** 2);
@args = ($x0 - $rad, $y0 - $rad, $x0 + $rad, $y0 + $rad);
push @args, -width => $width, -outline => $color;
$fill and push @args, -fill => $fill;
push @$a_ids, $canvas->createOval(@args);
}
}
($x0, $y0) = ($x1, $y1);
}
return $a_ids;
}
######################
## Internal Methods ##
######################
sub fatal {
my ($self, $errmsg) = @_;
carp "$errmsg\n";
exit;
}
sub new_binding {
my ($self, $canvas, $binding, $a_args) = @_;
my $c_prev = $canvas->Tk::bind($binding);
$self->{'bindings'}->{$binding} = $c_prev;
$canvas->Tk::bind($binding => $a_args);
}
sub restore_bindings {
my ($self, $canvas, $binding) = @_;
my $c_prev = delete $self->{'bindings'}->{$binding};
$canvas->Tk::bind($binding => $c_prev);
}
sub styles {
print "[Available Tk::Canvas::Draw styles]\n";
foreach my $key (sort keys %$h_styles) {
my $desc = $h_styles->{$key};
printf "%10.10s .... %s\n", $key, $desc;
}
}
sub assign_args {
my ($self, $h_args) = @_;
# Make a copy of user-supplied args, resolving aliases
$h_args ||= { };
my $h_copy = { };
foreach my $k (keys %$h_args) {
my $key = $h_aliases->{$k} || $k;
$h_copy->{$key} = $h_args->{$k};
}
# Resolve all arguments
foreach my $key (keys %$h_defaults) {
my $val = delete $h_copy->{$key};
if (defined($val)) {
$self->{$key} = $val;
} elsif (!defined($self->{$key})) {
$self->{$key} = $h_defaults->{$key};
}
}
# Give an error if any arguments were invalid
my @leftover = keys %$h_copy;
if (@leftover > 0) {
my $s = (1 == @leftover)? "": "s";
my $errstr = "Unknown Tk::Canvas::Draw arg$s: ";
for (my $i = 0; $i < @leftover; $i++) {
my $arg = $leftover[$i];
$errstr .= ($i > 0)? ", '$arg'": "'$arg'";
}
$self->fatal($errstr);
}
# Determine action when mouse button is clicked/moving/released
my $style = $self->{'style'};
if (!exists($h_styles->{$style})) {
my $styles = join(', ', keys %$h_styles);
$self->fatal("Unknown style '$style' (must be one of {$styles})");
}
# Validate the mouse button
my $mouse = $self->{'mouse'};
if ($mouse !~ /^[123]$/) {
$self->fatal("Unknown mouse '$mouse' (must be one of {1, 2, 3})");
}
# Assign events
$self->{'start_event'} = "<Button-$mouse>";
$self->{'stop_event'} = "<ButtonRelease-$mouse>";
}
sub start_drawing {
my ($self, $canvas, $x, $y) = @_;
$b_drawing++ and return;
push @{$self->{'points'}}, [ $self->{'x'} = $x, $self->{'y'} = $y ];
my $a_move = [ sub { $self->keep_drawing(@_) }, Ev('x'), Ev('y') ];
$self->new_binding($canvas, '<Motion>', $a_move);
my $a_stop = [ sub { $self->stop_drawing(@_) }, Ev('x'), Ev('y') ];
$self->new_binding($canvas, $self->{'stop_event'}, $a_stop);
my $c_action = $self->{'action'};
($c_action || 0) and $c_action->([ $x, $y ]);
}
sub keep_drawing {
my ($self, $canvas, $x1, $y1) = @_;
my ($x0, $y0) = ($self->{'x'}, $self->{'y'});
my $style = $self->{'style'};
if ($style ne 'none') {
my $method = "style_$style";
$self->$method($canvas, [ $x0, $y0, $x1, $y1 ]);
}
my $c_action = $self->{'action'};
($c_action || 0) and $c_action->([ $x1, $y1 ]);
}
sub stop_drawing {
my ($self, $canvas, $x, $y) = @_;
my $h_bindings = $self->{'bindings'};
foreach my $binding (keys %$h_bindings) {
$self->restore_bindings($canvas, $binding);
}
my $c_result = $self->{'result'};
my $a_points = $self->{'points'};
my $a_ids = $self->{'ids'};
$self->{'points'} = [ ];
$self->{'ids'} = [ ];
if (ref $c_result eq 'CODE') {
$c_result->($self, $a_points, $a_ids, $canvas);
}
$b_drawing = 0;
}
#==========#
## Styles ##
#==========#
sub style_free {
my ($self, $canvas, $a_points) = @_;
my ($x0, $y0, $x1, $y1) = @$a_points;
my $width = $self->{'width'};
my $color = $self->{'color'};
my $a_ids = $self->{'ids'};
my @args = ( -width => $width, -fill => $color );
push @$a_ids, $canvas->createLine($x0, $y0, $x1, $y1, @args);
push @{$self->{'points'}}, [ $self->{'x'} = $x1, $self->{'y'} = $y1 ];
}
sub style_line {
my ($self, $canvas, $a_points) = @_;
my ($x1, $y1) = ($a_points->[-2], $a_points->[-1]);
my ($x0, $y0) = @{$self->{'points'}->[0]};
my $width = $self->{'width'};
my $color = $self->{'color'};
my $a_ids = $self->{'ids'};
if (@$a_ids > 0) {
pop @{$self->{'points'}};
my $id = pop @{$self->{'ids'}};
$canvas->delete($id);
}
my @args = ( -width => $width, -fill => $color );
push @$a_ids, $canvas->createLine($x0, $y0, $x1, $y1, @args);
push @{$self->{'points'}}, [ $self->{'x'} = $x1, $self->{'y'} = $y1 ];
}
sub style_oval {
my ($self, $canvas, $a_points) = @_;
my ($x1, $y1) = ($a_points->[-2], $a_points->[-1]);
my ($x0, $y0) = @{$self->{'points'}->[0]};
my $width = $self->{'width'};
my $color = $self->{'color'};
my $fill = $self->{'fill'};
my $a_ids = $self->{'ids'};
if (@$a_ids > 0) {
pop @{$self->{'points'}};
my $id = pop @{$self->{'ids'}};
$canvas->delete($id);
}
my @args = ( -width => $width, -outline => $color );
$fill and push @args, -fill => $fill;
push @$a_ids, $canvas->createOval($x0, $y0, $x1, $y1, @args);
push @{$self->{'points'}}, [ $self->{'x'} = $x1, $self->{'y'} = $y1 ];
}
sub style_rectangle {
my ($self, $canvas, $a_points) = @_;
my ($x1, $y1) = ($a_points->[-2], $a_points->[-1]);
my ($x0, $y0) = @{$self->{'points'}->[0]};
my $width = $self->{'width'};
my $color = $self->{'color'};
my $fill = $self->{'fill'};
my $a_ids = $self->{'ids'};
if (@$a_ids > 0) {
pop @{$self->{'points'}};
my $id = pop @{$self->{'ids'}};
$canvas->delete($id);
}
my @args = ( -width => $width, -outline => $color );
$fill and push @args, -fill => $fill;
push @$a_ids, $canvas->createRectangle($x0, $y0, $x1, $y1, @args);
push @{$self->{'points'}}, [ $self->{'x'} = $x1, $self->{'y'} = $y1 ];
}
sub style_circle {
my ($self, $canvas, $a_points) = @_;
my ($x1, $y1) = ($a_points->[-2], $a_points->[-1]);
my $a_center = $self->{'points'}->[0];
my ($x0, $y0) = @$a_center;
my $rad = sqrt(($x1 - $x0) ** 2 + ($y1 - $y0) ** 2);
# Create the box surrounding the larger circle
my $a_corner1 = [ $x0 - $rad, $y0 - $rad ];
my $a_corner2 = [ $x0 + $rad, $y0 + $rad ];
my $width = $self->{'width'};
my $color = $self->{'color'};
my $fill = $self->{'fill'};
my $a_ids = $self->{'ids'};
if (@$a_ids > 0) {
pop @{$self->{'points'}};
my $id = pop @{$self->{'ids'}};
$canvas->delete($id);
}
my @args = ( -width => $width, -outline => $color );
$fill and push @args, -fill => $fill;
push @$a_ids, $canvas->createOval(@$a_corner1, @$a_corner2, @args);
push @{$self->{'points'}}, [ $self->{'x'} = $x1, $self->{'y'} = $y1 ];
}
1;