Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

Comment on

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

In reply to Tk Rubberband Demo by crazyinsomniac

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others perusing the Monastery: (8)
    As of 2014-10-25 17:52 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      For retirement, I am banking on:










      Results (146 votes), past polls