Re: Tk::FunkyButton ?

Ala Qumsieh <[email protected]>
Newsgroups gmane.comp.lang.perl.tk
Message-ID <[email protected]> 
--- Dean Arnold <[email protected]> wrote:

> (For Ala Qumsieh):
> 
> You mentioned the subject widget in an old post I
> found on google. Any inclination to post it to
> either CPAN
> or perltk.org ?

It's attached. Note that there is no documentation
yet, but you shouldn't have any problems with the
code.

Also, I think it's overkill to create a complete
Canvas widget just to implement a button. This widget
was just a proof of concept, and part of an article in
TPJ. It can be a useful technique to create more
complex widgets though. I was thinking about a
ReportCard, or BalanceSheet kind of widget which would
allow creating arbitrary report-style documents. But I
couldn't come up with an API that was simple and
generic enough to pursue it any further.

--Ala



		
__________________________________________ 
Yahoo! DSL – Something to write home about. 
Just $16.99/mo. or less. 
dsl.yahoo.com
FunkyButton.pm (application/octet-stream, 13.6 KB) 
package Tk::FunkyButton;

use strict;

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

use Tk::widgets qw/Canvas/;

use base qw/Tk::Derived Tk::Canvas/;
use vars qw/%shapeToFunc %speedToMS/;

use strict;
use Carp;

Construct Tk::Widget 'FunkyButton';

%shapeToFunc = (
		cross     => \&_drawCross,
		circle    => \&_drawCircle,
		rotary    => \&_drawRotary,
		vanishing => \&_drawVanishing,
	       );

%speedToMS = (
	      fast   => 100,
	      normal => 500,
	      slow   => 1000,
	     );

1;

sub ClassInit {
    my $class = shift;

    $class->SUPER::ClassInit(@_);
}

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

  my $shape = delete $args->{-shape} || 'cross';
  unless (exists $shapeToFunc{$shape}) {
    croak "-shape must be one of: ", join(", ", keys %shapeToFunc)," ..";
    return undef;
  }

  my $text = delete $args->{-text}        || '';
  my $cmd  = delete $args->{-command}     || sub {};
  my $relf = delete $args->{-relief}      || 'raised';
  my $bw   = delete $args->{-borderwidth} || 2;
  my $spd  = delete $args->{-speed}       || 'normal';

  my $bg;
  if (exists $args->{-bg}) {
    $bg = delete $args->{-bg};
  } elsif (exists $args->{-background}) {
    $bg = delete $args->{-background};
  } else {
    $bg = Tk::NORMAL_BG;
  }

  # now specify canvas-specific options.
  $args->{-background}  = $self->parent->cget('-background');
  $args->{-borderwidth} = 0;
  $args->{-relief}      = 'flat';

  $self->SUPER::Populate($args);

  my $cb = new Tk::Callback($cmd);

  # now .. draw the button.
  $self->{MY_BUTTON} = $shapeToFunc{$shape}->($self, $text,
					      $relf, $cmd,
					      $bw, $bg, $spd);

  # resize the canvas.
  my @box = $self->bbox('all');

  # not sure why I have to add 1 there ... but it makes things nicer.
  $self->afterIdle(['GeometryRequest', $self,
		    $box[2] - $box[0] + 1,
		    $box[3] - $box[1] + 1]);
		    #$box[2] - $box[0] + $bw,
		    #$box[3] - $box[1] + $bw]);

  # define bindings.
  my $click = 0;
  my $over  = 0;

  for my $tag (qw/BODY TEXT/) {
    $self->bind($tag, '<1>' => sub {
		  return if $click;
		  $click = 1;
		  $over  = 1;

		  $self->_lower($bw);
		});

    $self->bind($tag, '<B1-ButtonRelease>' => sub {
		  $cb->Call if $click && $over;
		  $self->_raise($bw, $relf) if $over;
		  $click = 0;
		});
  }

  $self->CanvasBind('<B1-Motion>' => sub {
		      return unless $click;

		      my ($x, $y) = ($Tk::event->x, $Tk::event->y);
		      my @under;
		      push @under => $self->gettags($_) for
			$self->find(overlapping => $x, $y, $x, $y);
		      my $lapping = "@under" =~ /BODY/;

		      if ($lapping && !$over) {
			$over = 1;
			$self->_lower($bw);
		      } elsif (!$lapping && $over) {
			$over = 0;
			$self->_raise($bw, $relf);
		      }
		      if ($lapping) {
			$self->itemconfigure(qw/BODY -fill/, Tk::ACTIVE_BG);
		      } else {
			$self->itemconfigure(qw/BODY -fill/, $bg);
		      }
		    });

  $self->CanvasBind('<Motion>' => sub {
		      return if $click;
		      my ($x, $y) = ($Tk::event->x, $Tk::event->y);
		      my @under;
		      push @under => $self->gettags($_) for
			$self->find(overlapping => $x, $y, $x, $y);
		      my $lapping = "@under" =~ /BODY/;

		      if ($lapping) {
			$self->itemconfigure(qw/BODY -fill/, Tk::ACTIVE_BG);
		      } else {
			$self->itemconfigure(qw/BODY -fill/, $bg);
		      }
		    });
}

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

  # lower.
  $self->itemconfigure(qw/SHADOW -fill/, Tk::WHITE, -outline => Tk::WHITE);
  $self->itemconfigure(qw/LIGHT  -fill grey40 -outline grey40/);

  # move the text.
  $self->move('TEXT', $bw, $bw);
}

sub _raise {
  my ($self, $bw, $relf) = @_;

  my ($c1, $c2);
  if ($relf eq 'flat') {
    $c1 = $c2 = Tk::NORMAL_BG;
  } elsif ($relf eq 'raised') {
    $c1 = 'grey40';
    $c2 = Tk::WHITE;
  } elsif ($relf eq 'sunken') {
    $c2 = 'grey40';
    $c1 = Tk::WHITE;
  }

  # raise.
  $self->itemconfigure(qw/SHADOW -fill/, $c1, -outline => $c1);
  $self->itemconfigure(qw/LIGHT  -fill/, $c2, -outline => $c2);

  # move the text.
  $self->move('TEXT', -$bw, -$bw);
}

sub _drawCross {
  my ($self, $text, $relief, $cmd, $bw, $bg) = @_;

  my $t = $self->createText(0, 0, -text => $text, -tags => ['TEXT']);

  my @coords = $self->bbox($t);
  my $w      = $coords[2] - $coords[0];
  $w *= 1.3; $w += (3 - $w % 3);

  my $h = $w;
  my $miter = 1;

  $self->_draw3DVerticalBevel  (2*$w/3, $bw, $bw, $h/3, 0, $relief, ['SHADOW']);
  $self->_draw3DHorizontalBevel($bw + $w/3, $bw, $w/3, $bw, 1, $relief, $miter ? 'right' : 'none', ['LIGHT']);

  $self->_draw3DVerticalBevel  ($w, $bw + $h/3, $bw, $h/3, 0, $relief, ['SHADOW']);
  $self->_draw3DHorizontalBevel(2*$w/3, $bw + $h/3, $w/3, $bw, 1, $relief, $miter ? 'right' : 'none', ['LIGHT']);

  $self->_draw3DHorizontalBevel($bw + 2*$w/3, $bw + 2*$h/3, $w/3, $bw, 0, $relief, 'none', ['SHADOW']);
  $self->_draw3DVerticalBevel  (2*$w/3, $bw + 2*$h/3, $bw, $h/3, 0, $relief, ['SHADOW']);

  $self->_draw3DVerticalBevel  ($bw + $w/3, $bw + 2*$h/3, $bw, $h/3, 1, $relief, ['LIGHT']);
  $self->_draw3DHorizontalBevel($bw + $w/3, $bw + $h, $w/3, $bw, 0, $relief, $miter ? 'left' : 'none', ['SHADOW']);

  $self->_draw3DVerticalBevel  ($bw, $bw + $h/3, $bw, $h/3, 1, $relief, ['LIGHT']);
  $self->_draw3DHorizontalBevel($bw, $bw + 2*$h/3, $w/3, $bw, 0, $relief, $miter ? 'left' : 'none', ['SHADOW']);

  $self->_draw3DHorizontalBevel($bw, $bw + $h/3, $w/3, $bw, 1, $relief, 'none', ['LIGHT']);
  $self->_draw3DVerticalBevel  ($bw + $w/3, 2*$bw, $bw, $h/3, 1, $relief, ['LIGHT']);

  my $xoff = my $yoff = $bw + 1;
  if ($relief eq 'sunken') {
    $xoff++; $yoff++;
  }

  $self->coords($t => $w / 2 + $xoff,
		$h / 2 + $yoff);

  # now draw the button 'body'
  $self->createPolygon($bw, $h/3 + $bw, $w/3+$bw, $h/3+$bw,
		       $w/3+$bw, $bw, 2*$w/3+$bw, $bw,
		       2*$w/3+$bw, $h/3+$bw, $w+$bw, $h/3+$bw,
		       $w+$bw, 2*$h/3+$bw, 2*$w/3+$bw, 2*$h/3+$bw,
		       2*$w/3+$bw, $h+$bw, $w/3+$bw, $h+$bw,
		       $w/3+$bw, 2*$h/3+$bw, $bw, 2*$h/3+$bw,
		       -fill    => $bg,
		       -outline => undef,
		       -tags    => ['BODY'],
		      );

  $self->lower('BODY');
}

sub _drawCircle {
  my ($self, $text, $relief, $cmd, $bw, $bg) = @_;

  my $t = $self->createText(0, 0, -text => $text, -tags => ['TEXT']);

  my @coords = $self->bbox($t);
  my $w      = $coords[2] - $coords[0];
  $w *= 1.3; $w += (3 - $w % 3);

  my $h = $w;

  $self->createOval(map($_+1,0, 0, $w, $h),
		    -fill    => Tk::WHITE,
		    -outline => undef,#Tk::WHITE,
		    -tags    => ['LIGHT'],
		    );

  $self->createOval(map($_+1,2*$bw, 2*$bw, $w+2*$bw, $h+2*$bw),
		    -fill    => 'grey40',
		    -outline => undef,#'grey40',
		    -tags    => ['SHADOW'],
		    );

  $self->createOval(map($_+1,$bw, $bw, $w+$bw, $h+$bw),
		    -fill    => $bg,
		    -outline => undef,
		    -tags    => ['BODY'],
		   );

  my $xoff = my $yoff = $bw + 1;
  if ($relief eq 'sunken') { $xoff++; $yoff++ }

  $self->coords($t => $w / 2 + $xoff,
		$h / 2 + $yoff);

  $self->raise($_) for qw/LIGHT SHADOW BODY TEXT/;
}

sub _drawRegular {
  my ($self, $text, $relief, $cmd, $bw, $bg) = @_;

  $self->createText(0, 0, -text => $text, -tags => ['TEXT']);

  my @coords = $self->bbox('TEXT');
  my $w      = $coords[2] - $coords[0];
  $w *= 1.3; $w += (3 - $w % 3);

  my $h = 3 * ($coords[3] - $coords[1]);

  my $miter = 1;

  $self->_draw3DVerticalBevel  ($w+$bw, $bw, $bw, $h, 0, $relief, ['SHADOW']);
  $self->_draw3DHorizontalBevel($bw, $bw, $w+$bw, $bw, 1, $relief, $miter ? 'right' : 'none', ['LIGHT']);

  $self->_draw3DVerticalBevel  ($bw, $bw, $bw, $h+$bw, 1, $relief, ['LIGHT']);
  $self->_draw3DHorizontalBevel($bw, $h+$bw, $w+$bw, $bw, 0, $relief, $miter ? 'left' : 'none', ['SHADOW']);

  $self->createRectangle(
			 $bw, $bw, $w+$bw, $h+$bw,
			 -fill    => $bg,
			 -outline => undef,
			 -tags    => ['BODY'],
			);

  my $xoff = my $yoff = $bw + 1;
  if ($relief eq 'sunken') { $xoff++; $yoff++ }

  $self->coords(TEXT => $w / 2 + $xoff,
		$h / 2 + $yoff);

  $self->lower($_) for qw/TEXT BODY/;

  $self->_raise($bw, $relief);
  return ($w, $h);
}

sub _drawRotary {
  my ($self, $text, $relief, $cmd, $bw, $bg, $spd) = @_;

  my ($w, $h) = $self->_drawRegular($text, $relief, $cmd, $bw, $bg);

  my $delay    = $speedToMS{$spd} || $speedToMS{normal};

  my @orig = $self->coords('TEXT');
  $self->repeat($delay => sub {
		  $self->move(TEXT => -3, 0);
		  my @box = $self->bbox('TEXT');
		  if ($box[2] < 0) {
		    $self->coords(TEXT => $w + 0.5 * ($box[2] - $box[0]),
				  $orig[1]);
		  }
		});
}

sub _drawVanishing {
  my ($self, $text, $relief, $cmd, $bw, $bg, $spd) = @_;

  my ($w, $h) = $self->_drawRegular($text, $relief, $cmd, $bw, $bg);

  my @stipples = ('', qw/gray75 gray50 gray25 transparent/);

  my $delay    = $speedToMS{$spd} || $speedToMS{normal};

  my $i   = 0;
  my $inc = 1;
  $self->repeat($delay => sub {
		  $i += $inc;
		  $inc = -1 if $i == $#stipples;
		  $inc =  1 if $i == 0;
		  $self->itemconfigure(TEXT => -stipple => $stipples[$i]);
		});
}

sub _getColor {
  my ($self, $relief, $left) = @_;

  my $color = $k::WHITE;

  if    ($relief eq 'raised' && $left ) { $color = Tk::WHITE     }
  elsif ($relief eq 'raised' && !$left) { $color = 'grey40'      }
  elsif ($relief eq 'sunken' && $left)  { $color = 'grey40'      }
  elsif ($relief eq 'sunken' && !$left) { $color = Tk::WHITE     }
  elsif ($relief eq 'flat')             { $color = Tk::NORMAL_BG }

  return $color;
}

sub _draw3DVerticalBevel {
  my ($self,
      $x,
      $y,
      $w,
      $h,
      $left,
      $relief,
      $tags,
     ) = @_;

  if ($relief eq 'ridge' || $relief eq 'groove') {
    my $half = $w / 2;
    $half++ if !$left && ($w & 1);

    my ($c1, $c2) = $relief eq 'ridge' ? (Tk::WHITE, 'grey40') : ('grey40', Tk::WHITE);

    $self->createRectangle($x, $y,
			   $x + $half, $y + $h,
			   -fill     => $c1,
			   -outline  => undef,
			   -tags     => $tags,
			  );
    $self->createRectangle($x + $half, $y,
			   $x + ($w - $half), $y + $h,
			   -fill     => $c2,
			   -outline  => undef,
			   -tags     => $tags,
			  );
    return;
  }

  my $color = $self->_getColor($relief, $left);

  $self->createRectangle($x, $y,
			 $x + $w, $y + $h,
			 -fill     => $color,
			 -outline  => $color,#undef,
			 -tags     => $tags,
			);
}

sub _draw3DHorizontalBevel {
  my ($self,
      $x,
      $y,
      $w,
      $h,
      $left,
      $relief,
      $miter,
      $tags,
     ) = @_;

  if ($relief eq 'ridge' || $relief eq 'groove') {
    my $x1  = $x;
    my $x2  = $x + $w;
    my $dx1 =  1;
    my $dx2 = -1;

    if ($miter eq 'left') {
	$x1 += $h;
	$x2 -= $h;
	$dx1 = -1;
	$dx2 =  1;
    }

    my $hw  = $y + $h / 2;
    $hw++ if $relief eq 'right' && ($h & 1);
    my $b   = $y + $h;

    my ($c1, $c2) = $relief eq 'ridge' ?
      (Tk::WHITE, 'grey40') : ('grey40', Tk::WHITE);

    while ($y < $b) {
      next unless $x1 < $x2;
      $self->createRectangle($x1, $y,
			     $x2, $y + 1,
			     -fill => $y < $hw ? $c1 : $c2,
			     -outline  => undef,,
			     -tags     => $tags,
			    );
    } continue {
      $x1 += $dx1;
      $x2 += $dx2;
      $y++;
    }

    return;
  }

  my $color = $self->_getColor($relief, $left);

  my @coords;

  if ($miter eq 'none') {
    @coords = ($x, $y,
	       $x + $w, $y,
	       $x + $w, $y + $h,
	       $x, $y + $h);
  } elsif ($miter eq 'right') {
    @coords = ($x, $y,
	       $x + $w, $y,
	       $x + $w - $h, $y + $h,
	       $x, $y + $h,
	       $x, $y);
  } else { # left
    @coords = ($x + $h, $y,
	       $x + $w, $y,
	       $x + $w, $y + $h,
	       $x, $y + $h,
	       $x + $h, $y);
  }

  $self->createPolygon(@coords,
		       -outline  => undef,,
		       -fill     => $color,
		       -tags     => $tags,
		      );
}

sub _findParallel {   # experimental
  my ($pt1,
      $pt2,
      $d,
     ) = @_;

  my $dx = $pt2->[0] - $pt1->[0];
  my $dy = $pt2->[1] - $pt1->[1];

  if      ($dx == 0) { # vertical
    return (
	    [$pt1->[0], $pt1->[1] + $d],
	    [$pt2->[0], $pt2->[1] + $d],
	   );
  } elsif ($dy == 0) { # horizontal
    return (
	    [$pt1->[0] + $d, $pt1->[1]],
	    [$pt2->[0] + $d, $pt2->[1]],
	   );
  }

  my $m  = $dy / $dx;
  my $b  = $pt1->[1] - $m * $pt1->[0] + $d / sin(atan2 $dy, $dx);
  my $bb  = $d / sin(atan2 $dy, $dx);

  return (
	  [$pt1->[0], $pt1->[0] * $m + $b],
	  [$pt2->[0], $pt2->[0] * $m + $b],
	 );
}

sub _findIntersection {   # experimental
  my ($l1p1,
      $l1p2,
      $l2p1,
      $l2p2,
     ) = @_;

  my $dy1 = $l1p2->[1] - $l1p1->[1];
  my $dx1 = $l1p2->[0] - $l1p1->[0];
  my $dy2 = $l2p2->[1] - $l2p1->[1];
  my $dx2 = $l2p2->[0] - $l2p1->[0];

  my $m1  = $dy1 / $dx1;
  my $m2  = $dy2 / $dx2;
  return undef if abs($m1 - $m2) < 0.001;  # parallel

  my $b1  = $l1p1->[1] - $m1 * $l1p1->[0];
  my $b2  = $l2p1->[1] - $m1 * $l2p1->[0];

  my $xn  = ($b2 - $b1) / ($m1 - $m2);

  return [$xn, $m1 * $xn + $b1];
}

sub _test {   # experimental
  my $c = shift;

  my $p1 = [10, 10];
  my $p2 = [100, 100];
  my $p3 = [120, 60];

  $c->createLine(@$p1, @$p2, @$p3, @$p1, -fill => 'red');

  my @par1 = _findParallel($p1, $p2, 2);
  my @par2 = _findParallel($p2, $p3, 2);
  my @par3 = _findParallel($p3, $p1, 2);

  for my $p (\@par1, \@par2, \@par3) {
    $c->createLine(@{$p->[0]}, @{$p->[1]}, -fill => 'blue');
  }
  return;
  print "Par1 is >@{$par1[0]}< >@{$par1[1]}<\n";
  print "Par2 is >@{$par2[0]}< >@{$par2[1]}<\n";
  print "Par3 is >@{$par3[0]}< >@{$par3[1]}<\n";

  my $int1 = _findIntersection(@par1, @par2);
  my $int2 = _findIntersection(@par2, @par3);
  my $int3 = _findIntersection(@par3, @par1);

  my @crd1 = (@$p1, @$p2, @$int1, @$int3, @$p1);
  my @crd2 = (@$p2, @$p3, @$int2, @$int1);
  my @crd3 = (@$p3, @$p1, @$int3, @$int2);

  #@crd2 = (@$p1, @$p2, @$p3);
  #for my $crd (\@crd1, \@crd2, \@crd3) {
  for my $crd (\@crd1) {
    $c->createPolygon(@$crd,
		      -fill => 'white',
		      -outline => undef,
		     );
  }
}
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.