#!/usr/bin/perl
use strict;
use warnings;
use Tk;

my $mw = MainWindow->new;
my $canvas = $mw->Canvas();
$canvas -> pack;

$canvas->createRectangle(227,  96, 239, 108, -tags => ['square']);
$canvas->createRectangle(130, 107, 142, 119, -tags => ['square']);
$canvas->createRectangle(160,  49, 172,  61, -tags => ['square']);
$canvas->createRectangle(222,  75, 234,  87, -tags => ['square']);
$canvas->createRectangle(238, 171, 250, 183, -tags => ['square']);
$canvas->createRectangle(215, 113, 227, 125, -tags => ['square']);
$canvas->createRectangle(220,  96, 232, 108, -tags => ['square']);
$canvas->createRectangle(157, 181, 169, 193, -tags => ['square']);
$canvas->createRectangle(200, 180, 212, 192, -tags => ['square']);
$canvas->createRectangle(174, 153, 186, 165, -tags => ['square']);
$canvas->createRectangle(219, 102, 231, 114, -tags => ['square']);

my @lasso = ();
my @selected = ();
&select($canvas);
&moveItems($canvas);

MainLoop;

# Lasso selection (left-click+drag)
sub select {
     $canvas = shift;
     #my ($old_x,$old_y);
     my $lasso_id;
     $canvas->
         CanvasBind(
             '<Button1-Motion>' =>
             sub {
                 # Allow two-step selection
                 if (!(@lasso)) {
                     $lasso_id = 0;

                 }
                 my $x, my $y;
                 ($x, $y) = ($Tk::event->x, $Tk::event->y);
                 unless ($lasso_id){
                     $lasso_id = $canvas ->
                         createPolygon(0,0,
                                       -outline =>"green",
                                       -fill =>"green",
                                       -stipple => 'gray25',
                                       -tags => ['lasso']);
                 }
                 push @lasso, ($x, $y);
                 $canvas->coords($lasso_id,@lasso);
             });
     $canvas->
         CanvasBind(
             '<ButtonRelease-1>' =>
             sub {
                 if (@lasso) {

                     # Find the subset of items contained in the
                     # lasso's bounding box
                     my @lasso_bbox = $canvas->bbox($lasso_id);
                     my @candidates = $canvas->
                         find('enclosed',@lasso_bbox);

                     # For each candidate...
                     foreach my $id (@candidates) {
                         # ...excluding the lasso itself...
                         my @tags = $canvas->gettags($id);
                         foreach my $tag (@tags) {
                             if ($tag eq 'square') {
                                 my @coords  = $canvas->coords($id);
                                 my $fix_x = $coords[0] + 5 ;
                                 my $fix_y = $coords[1] + 5;
                                 # ...check if it's in the lasso
                                 if (point_in_polygon($fix_x,
                                                      $fix_y,
                                                      @lasso)) {
                                     # Tag the selected items and
                                     # mark them red
                                     $canvas->
                                         addtag('in_polygon',
                                                'withtag', $id);
                                     $canvas->
                                         itemconfigure(
                                             $id,
                                             -fill => 'red');
                                 }
                             }
                             last;
                         }
                     }
                     @selected = $canvas->find('withtag',
                                               'in_polygon');
                     $canvas->delete(-tags => ['lasso']);
                     @lasso = ();
                 }
             }
         );
}

# Moving selected items (right-click+drag)
sub moveItems {
     $canvas = shift;
     my $x, my $y;
     $canvas->
         bind('in_polygon','<Button-3>' =>
                    sub {
                        ($x, $y) = ($Tk::event->x, $Tk::event->y);
                    });
     $canvas->bind('in_polygon','<B3-Motion>' =>
                         sub{
                             if (@selected) {
                                 # Start coordinates
                                 (my $old_x, my $old_y) = ($x, $y);
                                 # End coordinates
                                 ($x, $y) = ($Tk::event->x, $Tk::event
+->y);
                                 foreach my $id (@selected) {
                                     $canvas->move($id => $x - $old_x,
                                                   $y -$old_y);
                                 }
                             }
                         }
                     );
     $canvas->
         bind('in_polygon',
             '<ButtonRelease-3>' =>
             sub {
                 if (@selected) {
                #     # Start coordinates
                #     (my $old_x, my $old_y) = ($x, $y);
                #     # End coordinates
                #     ($x, $y) = ($Tk::event->x, $Tk::event->y);
                     foreach my $id (@selected) {
                #         $canvas->move($id => $x - $old_x, $y -$old_y
+);
                         # Clean up: Remove tags
                         $canvas->dtag($id, 'in_polygon');
                     }
                     # Remove the lasso itself
                     $canvas->delete(-tags => ['lasso']);
                     $canvas->itemconfigure('all', -fill => '');
                     @selected = ();
                     @lasso = ();
                 }
             }
         );
}

# point_in_polygon($x, $y, @polygon);
# ($x,$y): point
# @polygon: ($x0, $y0, $x1, $y1, ...)
# Returns 1 for strictly interior points,
# 0 for strictly exterior points
# From chapter 10 of "Mastering Algorithms with Perl"
# (sample chapter available on the O'Reilly web site)
#
sub point_in_polygon {
     my ($x, $y, @polygon) = @_;
     my $n = @polygon / 2; # Number of points in polygon.
     # The even indices of @polygon
     my @i = map { 2 * $_ } 0..(@polygon/2);
     my @x = map { $polygon[$_] } @i; # Even indices: x-coordinates
     my @y = map { $polygon[$_ + 1] } @i; # Odd indices: y-coordinates
     my ($i, $j); # Indices
     my $side = 0; # 0 = outside, 1 = inside
     for ($i = 0, $j = $n - 1 ; $i < $n; $j = $i++) {
         if ((
             # If $y is between the y-borders ...
             (($y[$i] <= $y ) && ( $y < $y[$j])) ||
             (($y[$j] <= $y ) && ( $y < $y[$i]))
             )
             and
             (
              # ...the ($x,$y) to infinity line crosses the edge
              # from the i^th point to the j^th point...
              $x <
              ($x[$j] - $x[$i]) *
              ($y - $y[$i]) / ($y[$j] - $y[$i]) + $x[$i]
             )) {
             $side = not $side; # Jump the fence
         }
     }
     return $side ? 1 : 0;
}
[download]