Tk::MouseGesture - Create bindings for mouse gestures.

    use Tk::MouseGesture;
    my $mg = $top->MouseGesture('B1-left',
                          -xres     => 20,
                          -yres     => 20,
                          -min      => 50,
                          -command  => sub { print "yes!\n" });
    $mg->addGesture('B3-diag-UL');

	perl Makefile.PL
	make
	make install

package Tk::MouseGesture;

use Carp;
use strict;
use Tk;

use vars qw/$VERSION/;
$VERSION = 0.03;

Construct Tk::Widget 'MouseGesture';

# the following hash defines the set of predefined gestures.
my %gestures = (
		'B1-left'    => \&_ges_b1_left,
		'B2-left'    => \&_ges_b2_left,
		'B3-left'    => \&_ges_b3_left,

		'B1-right'   => \&_ges_b1_right,
		'B2-right'   => \&_ges_b2_right,
		'B3-right'   => \&_ges_b3_right,

		'B1-up'      => \&_ges_b1_up,
		'B2-up'      => \&_ges_b2_up,
		'B3-up'      => \&_ges_b3_up,

		'B1-down'    => \&_ges_b1_down,
		'B2-down'    => \&_ges_b2_down,
		'B3-down'    => \&_ges_b3_down,

		'B1-diag-UL' => \&_ges_b1_diag_ul,
		'B2-diag-UL' => \&_ges_b2_diag_ul,
		'B3-diag-UL' => \&_ges_b3_diag_ul,

		'B1-diag-UR' => \&_ges_b1_diag_ur,
		'B2-diag-UR' => \&_ges_b2_diag_ur,
		'B3-diag-UR' => \&_ges_b3_diag_ur,

		'B1-diag-LL' => \&_ges_b1_diag_ll,
		'B2-diag-LL' => \&_ges_b2_diag_ll,
		'B3-diag-LL' => \&_ges_b3_diag_ll,

		'B1-diag-LR' => \&_ges_b1_diag_lr,
		'B2-diag-LR' => \&_ges_b2_diag_lr,
		'B3-diag-LR' => \&_ges_b3_diag_lr,
	       );

my @objects;

sub new {
  my ($class, $parent, $gesture, %args) = @_;

  # make sure the parent is a toplevel.
  unless ($parent->isa('Tk::Toplevel')) {
    #carp "Parent of $class must be a toplevel widget!";
    #    return undef;

    # get the parent.
    $parent = $parent->toplevel;
  }

  # make sure the gesture exists and is one that is known.
  unless ($gesture) {
    carp "Wrong arguments. Must be MouseGesture(gesture_name, callback)";
    return undef;
  }

  unless (exists $gestures{$gesture}) {
    carp "Unknown mouse gesture '$gesture'!";
    return undef;
  }

  my $obj = bless {
		   PARENT => $parent,
		   XRES   => $args{-xres}    || 20,
		   YRES   => $args{-yres}    || 20,
		   SUB    => $args{-command} || sub {},
		   MIN    => $args{-min}     || 50,
		   EN     => 1,
		  } => $class;

  $obj->addGesture($gesture);

  push @objects => $obj;

  return $obj;
}

sub disable { $_[0]{EN} = 0 }
sub enable  { $_[0]{EN} = 1 }

sub disableAll { $_->disable for @objects }
sub enableAll  { $_->enable  for @objects }

sub addGesture {
  my ($self, $gesture) = @_;

  # make sure the gesture is one that is known.
  unless (exists $gestures{$gesture}) {
    carp "Unknown mouse gesture '$gesture'!";
    return undef;
  }

  $gestures{$gesture}->($self);
}

sub command {
  my ($self, $sub) = @_;

  $self->{SUB} = $sub if $sub;

  return $self->{SUB};
}

sub _ges_b1_left { _generic_straight(1, -1, 0, @_) }
sub _ges_b2_left { _generic_straight(2, -1, 0, @_) }
sub _ges_b3_left { _generic_straight(3, -1, 0, @_) }

sub _ges_b1_right { _generic_straight(1, 1, 0, @_) }
sub _ges_b2_right { _generic_straight(2, 1, 0, @_) }
sub _ges_b3_right { _generic_straight(3, 1, 0, @_) }

sub _ges_b1_up { _generic_straight(1, 0, -1, @_) }
sub _ges_b2_up { _generic_straight(2, 0, -1, @_) }
sub _ges_b3_up { _generic_straight(3, 0, -1, @_) }

sub _ges_b1_down { _generic_straight(1, 0, 1, @_) }
sub _ges_b2_down { _generic_straight(2, 0, 1, @_) }
sub _ges_b3_down { _generic_straight(3, 0, 1, @_) }

sub _generic_straight {
  # arguments are:
  # 1. button number.
  # 2. horizontal-sensitivity: if 0 => vertical gesture
  #                               1 => right
  #                              -1 => left
  # 3. veritcal  -sensitivity: if 0 => horizontal gesture
  #                               1 => bottom
  #                              -1 => top
  # 4. self.

  my ($b, $X, $Y, $self) = @_;

  my $p    = $self->{PARENT};
  my $xres = $self->{XRES};
  my $yres = $self->{YRES};
  my $min  = $self->{MIN};
  my $cb   = Tk::Callback->new($self->{SUB});

  my ($x, $y, $xc, $yc, $within);

  # make sure any other bindings are preserved.
  my $old1 = $p->bind("<$b>");
  my $old2 = $p->bind("<B$b-Motion>");
  my $old3 = $p->bind("<B$b-ButtonRelease>");

  $p->bind("<$b>" => sub {
	     $old1 && $old1->Call;
	     return unless $self->{EN};

	     $within    = 1;
	     ($x, $y)   = $p->pointerxy;
	     ($xc, $yc) = ($x, $y);
	   });
  $p->bind("<B$b-Motion>" => sub {
	     $old2 && $old2->Call;
	     return unless $self->{EN};
	     return unless $within;

	     my ($nx, $ny) = $p->pointerxy;

	     if ($Y) {
	       if ($Y > 0) {
		 $within = 0 if $ny < $yc;
	       } else {
		 $within = 0 if $ny > $yc;
	       }
	     } else {
	       $within = 0 if abs($ny - $y) > $yres;
	     }

	     if ($X) {
	       if ($X > 0) {
		 $within = 0 if $nx < $xc;
	       } else {
		 $within = 0 if $nx > $xc;
	       }
	     } else {
	       $within = 0 if abs($nx - $x) > $yres;
	     }

	     $xc = $nx;
	     $yc = $ny;
	   });
  $p->bind("<B$b-ButtonRelease>" => sub {
	     $old3 && $old3->Call;
	     return unless $self->{EN};

	     $within or return;

	     my ($nx, $ny) = $p->pointerxy;
	     my $ok = 0;

	     if ($X) {
	       $ok = 1 if abs($nx - $x) >= $min;
	     } else {
	       $ok = 1 if abs($ny - $y) >= $min;
	     }
	     $ok && $cb->Call;
	   });
}

sub _ges_b1_diag_ul { _generic_diag(1, -1, -1, @_) }
sub _ges_b2_diag_ul { _generic_diag(2, -1, -1, @_) }
sub _ges_b3_diag_ul { _generic_diag(3, -1, -1, @_) }

sub _ges_b1_diag_ur { _generic_diag(1,  1, -1, @_) }
sub _ges_b2_diag_ur { _generic_diag(2,  1, -1, @_) }
sub _ges_b3_diag_ur { _generic_diag(3,  1, -1, @_) }

sub _ges_b1_diag_ll { _generic_diag(1, -1,  1, @_) }
sub _ges_b2_diag_ll { _generic_diag(2, -1,  1, @_) }
sub _ges_b3_diag_ll { _generic_diag(3, -1,  1, @_) }

sub _ges_b1_diag_lr { _generic_diag(1,  1,  1, @_) }
sub _ges_b2_diag_lr { _generic_diag(2,  1,  1, @_) }
sub _ges_b3_diag_lr { _generic_diag(3,  1,  1, @_) }

sub _generic_diag {
  my ($b, $X, $Y, $self) = @_;

  my $p    = $self->{PARENT};
  my $res  = $self->{XRES} > $self->{YRES} ? $self->{XRES} : $self->{YRES};
  my $min  = $self->{MIN};
  my $cb   = Tk::Callback->new($self->{SUB});

  my ($x, $y, $xc, $yc, $within);

  my $slope = $X^$Y ? -1 : 1;

  # dist of point (xo, yo) to line ax + by + c = 0
  # d = abs(axo + bxo + c) / sqrt(a^2 + b^2)   trust me

  my $A = $slope;
  my $B = -1;
  my $C;
  my $den = sqrt($A**2 + 1);

  # make sure any other bindings are preserved.
  my $old1 = $p->bind("<$b>");
  my $old2 = $p->bind("<B$b-Motion>");
  my $old3 = $p->bind("<B$b-ButtonRelease>");

  $p->bind("<$b>" => sub {
	     $old1->Call if $old1;
	     return unless $self->{EN};

	     $within    = 1;
	     ($x, $y)   = $p->pointerxy;
	     ($xc, $yc) = ($x, $y);
	     $C         = $y - $slope * $x;
	   });
  $p->bind("<B$b-Motion>" => sub {
	     $old2->Call if $old2;
	     return unless $self->{EN};
	     return unless $within;

	     my ($nx, $ny) = $p->pointerxy;

	     # get dist to line with slope +/-1
	     my $dist = abs($A * $nx + $B * $ny + $C) / $den;

	     $dist > $res and return $within = 0;

	     if ($X > 0) {  # right
	       $within = 0 if $nx < $xc;
	       if ($Y > 0) { # down => DR
		 $within = 0 if $ny < $yc;
	       } else {      # up   => UR
		 $within = 0 if $ny > $yc;
	       }
	     } else {       # left
	       $within = 0 if $nx > $xc;
	       if ($Y > 0) { # down => DL
		 $within = 0 if $ny < $yc;
	       } else {      # up   => UL
		 $within = 0 if $ny > $yc;
	       }
	     }
	   });

  $p->bind("<B$b-ButtonRelease>" => sub {
	     $old3 && $old3->Call;
	     return unless $self->{EN};
	     $within or return;

	     my ($nx, $ny) = $p->pointerxy;
	     my $ok = 0;
	     $ok     = 1 if $min < sqrt(($x-$nx)**2 + ($y-$ny)**2);

	     $ok && $cb->Call;
	   });
}

"one";

__END__