1: #!/usr/bin/perl -w
   2: # rubberband.pl
   3: # a little rubberbanding Tk demo (demonstrates rubberbanding with perl Tk)
   4: # copyright crazyinsomniac.perlmonk.org 2002, all rights reserved
   5: # released under the same terms as perl itself
   6: use strict;
   7: 
   8: use Tk 8;
   9: 
  10: my $MW = new MainWindow(
  11:         -background => 'darkblue',
  12:         -borderwidth => 1,
  13:         -relief => 'groove',
  14:         -width => 500,
  15:         -height => 500,
  16:     ,);
  17: 
  18: my $F = $MW->Frame(
  19:     -relief  => "groove",
  20:     -height => 300,
  21:     -width => 500,
  22: ,)->pack(
  23:     -anchor => 'n',
  24:     -side => 'top',
  25:     -expand => 'yes',
  26: ,);
  27: 
  28: use vars '$OBJECT'; BEGIN{$OBJECT="oval"};
  29: 
  30: Button($F, "oval", groove => sub { $OBJECT = "oval" } );
  31: Button($F, "line", groove => sub { $OBJECT = "line" } );
  32: Button($F, "arc", groove => sub { $OBJECT = "arc" } );
  33: Button($F, "rectangle", groove => sub { $OBJECT = "rectangle" } );
  34: 
  35: 
  36: $F->Label(
  37:     -text => " OBJECT:",
  38:     -relief => 'flat',
  39:     -font => "Arial",
  40: ,)->pack(
  41:     -side => 'left',
  42:     -expand => 1,
  43: ,);
  44: 
  45: $F->Label(
  46:     -textvariable => \$OBJECT,
  47:     -relief => 'flat',
  48:     -font => "Arial",
  49: ,)->pack(
  50:     -side => 'left',
  51:     -expand => 1,
  52: ,);
  53: 
  54: my $C = $MW->Canvas(
  55:         -width      => 500,
  56:         -height     => 500,
  57:         -background => "#AFFAAF",
  58:     ,)->pack;
  59: 
  60: ## S&M (left button down only)
  61: $MW->bind(
  62:     'Tk::Canvas',
  63:     '<ButtonPress-1>' => [\&BandOn, map{Ev($_)} qw{ x y s } ]
  64: );
  65: 
  66: $MW->bind(
  67:     'Tk::Canvas',
  68:     '<ButtonRelease-1>' => [\&BandOff, map{Ev($_)} qw{ x y s } ]
  69: );
  70: 
  71: 
  72: &MainLoop();
  73: 
  74: sub BandOn {
  75:     BEEP("BandOn",@_);
  76:     
  77:     my( $C, $X, $Y, $S ) = @_;
  78:     $C->{"\0__Xo"} = $X; # the origin, to remain constant
  79:     $C->{"\0__Yo"} = $Y;
  80:     $C->{"\0__RUBBER"} = "RUBBER".time;
  81:     $C->create($OBJECT, $X, $Y, $X+10, $Y+10, -tags => $C->{"\0__RUBBER"});
  82: 
  83:     $MW->bind(
  84:         'Tk::Canvas',
  85:         '<Motion>' => [\&BandIt, map { Ev($_) } qw{ x y s } ]
  86:     );
  87: }
  88: 
  89: 
  90: sub BandOff {
  91:     BEEP("BandOff",@_);
  92:     my( $C, $X, $Y, $S ) = @_;
  93:     
  94:     $MW->bind(
  95:         'Tk::Canvas',
  96:         '<Motion>' => undef, # essentially unbind
  97:     );   
  98: }
  99: 
 100: sub BandIt {
 101:     BEEP("BandIt",@_);
 102:     my( $C, $X, $Y, $S ) = @_;
 103: 
 104:     $C->delete($C->{"\0__RUBBER"}); # I wish I could transform the existing one
 105:     $C->create(
 106:         $OBJECT,
 107:         $C->{"\0__Xo"},
 108:         $C->{"\0__Yo"},
 109:         $X, $Y, -tags => $C->{"\0__RUBBER"},
 110:     );
 111: 
 112: }
 113: 
 114: 
 115: sub BEEP {
 116:    print shift(@_),"\n";
 117:    print shift(@_)->{"\0__RUBBER"},"\n";
 118:    print "$_)$_[$_]\n" for 0..$#_;
 119: }
 120: 
 121: 
 122: 
 123: 
 124: sub Button {
 125:     my ( $W , $text , $relief , $sub )=@_;
 126: 
 127:     $W = $W->Button(
 128:         -text => $text,
 129:         -relief => $relief,
 130:     ,)->pack(
 131:         -anchor => 'n',
 132:         -expand => 'no',
 133:         -side => 'left',
 134:     ,);
 135: 
 136:     $W->configure(-command => [ $sub, $W ] );
 137: 
 138:     return undef;
 139: }
 140: