Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
I updated my *saner* version, and now I dare call this

pTkXbmEdit - a Xbm Editor written in Perl/Tk

#!/usr/bin/perl -w use Tk 8; use Tk::Text; use Tk::Image; use Image::Xbm; use strict; use vars qw/ %GOB $crazy0naCAMEL $MirrorCamel/; &init(); &set_us_up_the_gui(); &MainLoop(); exit; # I can't wait to do this in Wx already ## S U B L A N D sub duck { my ( $widget, $x, $y, $s ) = @_; if( $GOB{gridc} ) { return() if $widget != $GOB{gridc}; # if we're not on it, don't do sh* if( $s =~ m{^B1}ix ) { # button1 down (left button) flip_square($widget, $x, $y, 0 ); } elsif( $s =~ m{^B3}ix ) { # button3 down (right button) flip_square($widget, $x, $y, 1 ); } } else { $widget = $1 if $widget =~ m{^ ( [^=]+ ) = }x; Statuss("$widget : x( $x ) / y( $y ) modifier( $s )"); } return (); } sub set_us_up_the_menu_bar { $GOB{filemenu} = $GOB{F}->Menubutton( -text => 'File', -relief => 'raised', -background => "#AFFAAF", -borderwidth => 2, )->pack(side => 'left', padx => 2 ); $GOB{filemenu}->configure(-menu => $GOB{filemenu}->Menu(-tearoff => 0) ,); # "Open" menubutton $GOB{filemenu}->command( -label => 'Load', -accelerator => 'Ctrl+O', -underline => 0, -command => \&f_open, ); # "Open" menubutton $GOB{filemenu}->command( -label => 'Save As', -accelerator => 'Ctrl+A', -underline => 5, -command => \&f_saveas, ); return undef; } sub f_open { my $file=$GOB{W}->getOpenFile(-defaultextension => "xbm", -initialdir => ".", -title => "Open File:" ,); if($file) { Statuss("loading $file ...\n", "[$file]"); &draw_us_up_a_picture(Image::Xbm->new(-file => $file)->as_stri +ng()); Statuss("","[$file]"); } else { Statuss( "no file to load\n" ); } return undef; } sub Statuss { my ( $msg, $sticky ) = @_; $GOB{_status_sticky} = $sticky if defined $sticky; # "" will be us +ed to clear $GOB{_status} = "$GOB{_status_sticky} $msg"; return (); } sub f_saveas { my $file=$GOB{W}->getSaveFile(-defaultextension => ".xbm", -initialdir => "./*.xbm", -title => "Save File:" ,); if($file and length $file > 0) { my $picXBM = &make_us_up_the_picture(); Statuss("no picture, nothing to save\n"), last unless $picXBM; Statuss("saved $file, looks great\n") if $picXBM->save($file); } else { Statuss("no filename, can't save shit\n"); } return undef; } sub set_us_up_an_entry { my $key = shift; $GOB{$key} = $GOB{W}->Entry( -background => "white", -borderwidth => 1, -relief => "groove", -font => "Courier", -width => 2, ,); $GOB{$key}->pack(-expand => 'no', -side => 'left', -in => $GOB{F}, # pack the thing into Frame ,); return undef; } sub set_us_up_a_button { my ( $wig , $key , $text , $relief , $sub )=@_; $GOB{$key} = $wig->Button(-text => $text, -relief => $relief, ,)->pack(-expand => 'no', -side => 'left', ,); $GOB{$key}->configure(-command => [ $sub, $GOB{$key} ] ); return undef; } sub set_us_up_the_gui { $GOB{W} = new MainWindow(-background => 'darkblue', -borderwidth => 1, -relief => 'groove', -width => 500, -height => 500, ,); $GOB{W}->title("pTkXbmEdit - a Xbm Editor written in Perl/Tk by cr +azyinsomniac"); $GOB{F} = $GOB{W}->Frame(-relief => "groove", -height => 300, -width => 500, ,); $GOB{F}->pack(-anchor => 'n', -side => 'top', -expand => 'yes', ,); ## called in this order, because of the packing order &set_us_up_the_menu_bar(); &set_us_up_a_label( $GOB{F} , ' ', 'flat' ); &set_us_up_a_button($GOB{F}, 'flip', 'Flip All Squares', 'groove', \&flip_em_all ,); &set_us_up_a_button($GOB{F}, 'flip', 'White All Squares', 'groove', \&white_em_all ,); &set_us_up_a_button($GOB{F}, 'flip', 'Black All Squares', 'groove', \&black_em_all ,); &set_us_up_a_label( $GOB{F} , ' ', 'flat' ); &set_us_up_a_label( $GOB{F} , 'X:', 'groove' ); &set_us_up_an_entry('TX'); &set_us_up_a_label( $GOB{F} , ' ', 'flat' ); &set_us_up_a_label( $GOB{F} , 'Y:', 'groove' ); &set_us_up_an_entry('TY'); &set_us_up_a_label( $GOB{F} , ' ', 'flat' ); &set_us_up_a_button($GOB{F}, 'makegrid', 'Make the grid', 'groove', \&set_us_up_the_grid, ,); &set_us_up_a_label( $GOB{F} , ' ', 'flat' ); &set_us_up_a_button($GOB{F}, 'cleargrid', 'Clear the grid', 'groove', \&clear_us_up_the_grid, ,); $GOB{_status} = "status"; $GOB{_status_sticky} = ""; $GOB{status} = $GOB{W}->Label(-textvariable => \$GOB{_status}, -relief => 'groove', -font => "Arial", -anchor => 'center', ,)->pack(-side => 'bottom', -anchor => 's', -expand => 'no', ,); ## we don't need a mouse press listener till we got a grid, buttt, so +what $GOB{W}->bind('<ButtonPress>' => [\&flip_square, Ev('x'), Ev('y')] ,); $GOB{W}->bind('<Motion>' => [\&duck, map { Ev($_) } qw{ x y s } ] +); return undef; } sub set_us_up_a_label { my ($widg, $text,$relief) = @_; $widg->Label(-text => $text, -relief => $relief, -font => "Arial", ,)->pack(-side => 'left', -expand => 1,); } sub clear_us_up_the_grid { Statuss(" ... clearing up the grid ... ",""); unless ($GOB{grid} and $GOB{gridc}) { &draw_us_up_a_picture($MirrorCamel); return undef; } $GOB{gridc}->delete('all'); $GOB{gridc}->packForget; delete $GOB{grid}; delete $GOB{gridc}; Statuss(" ... done clearing up the grid."); return undef; } sub make_us_up_the_picture { Statuss(" ... making up the picture ... "); my $picture = ""; if(exists $GOB{grid}) { for my $row (@{$GOB{grid}}) { for my $id (@{$row}) { $picture .= ( $GOB{gridc}->itemcget($id,-fill) eq 'whi +te' )? '-' : '#'; } $picture .="\n"; } Statuss(" ... done making up the picture."); return Image::Xbm->new_from_string($picture); } Statuss(" there was no grid to make a picture from."); return undef; } sub set_us_up_the_grid { my ($x, $y, $scale) = @_; Statuss(" ... setting up the grid ...",""); $scale = 8 unless $scale; unless($x and $y) { $x = $GOB{TX}->get(); $y = $GOB{TY}->get(); } $GOB{TX}->delete(0,'end'); $GOB{TY}->delete(0,'end'); &draw_us_up_a_picture($crazy0naCAMEL) unless $x and $y; $x =~ s/\D//; $y =~ s/\D//; $x =~ s/(.{2}).*$/$1/; $y =~ s/(.{2}).*$/$1/; return unless $x and $y; $GOB{TX}->insert(0,$x) if $x; $GOB{TY}->insert(0,$y) if $y; &clear_us_up_the_grid() if (exists $GOB{grid} ); $GOB{gridc} = $GOB{W}->Canvas(-width => ( $x + 2 ) * $scale, -height => ( $y + 2 ) * $scale, -background => "#AFFAAF", ,)->pack; $GOB{grid} = &layout_canvas_grid($GOB{gridc}, $x, $y, $scale); Statuss(" ... done setting up the grid."); return undef; } sub layout_canvas_grid { my ( $widget , $colsX , $rowsY , $scale) = @_; $scale = 10 unless $scale; my @danums; for my $iy(1..$rowsY) { my @dabums; for my $ix(1..$colsX) { my $id = $widget->create('rectangle', $ix * $scale, $iy * $scale, $ix * $scale + $scale, $iy * $scale + $scale, -fill=>'white', ,); $widget->itemconfigure($id); push @dabums, $id; } push @danums, \@dabums; } return \@danums; } sub black_em_all { for my $row( @{ $GOB{grid} } ) { for my $id( @{ $row } ) { $GOB{gridc}->itemconfigure($id, -fill => 'black' ,); } } } sub white_em_all { for my $row( @{ $GOB{grid} } ) { for my $id( @{ $row } ) { $GOB{gridc}->itemconfigure($id, -fill => 'white' ,); } } } sub flip_em_all { for my $row( @{ $GOB{grid} } ) { for my $id( @{ $row } ) { my $color = $GOB{gridc}->itemcget($id,-fill); $color = ( $color eq 'white' ) ? 'black' : 'white'; $GOB{gridc}->itemconfigure($id, -fill => $color ,); } } } sub flip_square { my ($widget,$x,$y,$wihi) = @_; return () if not defined $GOB{gridc}; return () if $widget != $GOB{gridc}; my $id = $GOB{gridc}->find('overlapping', $x, $y, $x + 1 , $y + 1 +); if($id) { my $color = $GOB{gridc}->itemcget($id,-fill); if( defined $wihi ) { if ( $wihi ) { $color = 'white'; } else { $color = 'black'; } } else { $color = ( $color eq 'white' ) ? 'black' : 'white'; } $GOB{gridc}->itemconfigure($id, -fill => $color ,); } } sub draw_us_up_a_picture { my ( $string , $ornot ) = @_; my $XBM = $ornot ? Image::Xbm->new( -file => $string) : Image::Xbm->new_from_string(shift); my @picrow = map {[split '',$_ ]} split "\n", $XBM->as_string(); return undef unless @picrow; &set_us_up_the_grid( $$XBM{-width} , $$XBM{-height} ); for( my $iy =0; $iy < $$XBM{-height}; $iy++) { for( my $ix=0; $ix < $$XBM{-width}; $ix++ ) { $GOB{gridc}->itemconfigure($GOB{grid}->[$iy][$ix], -fill => 'black', ,) unless $picrow[$iy][$ix] ne '#'; } } return undef; } sub init { $crazy0naCAMEL = "---------#-----------#-------- ---------##------####--------- -----######-----#---#--------- ---##---###-----##--#--------- --##########----#--#---------- ---##--#####-----##----------- ---#---####------#-##--------- ---#---####---####-#---------- ---#--####---#-----#---------- ---#--####----##-##----------- ---#-#########--######-------- ---#-####---##--#######------- ---#-#######-#-#########------ ---#--####################---- ----#-#####################--- -----#######################-- -------#####################-- --------###################--- --------######------#######--- ---------####-------######---- ---------###---------#####---- ---------###---------###-#---- ---------###---------###-#---- ---------###----------##-#---- ---------###----------####---- --------##-----------###------ "; $MirrorCamel ="----####-----##----------------- ---######---###----------------- ---######--##-##-##------------- ---######--#---#####------------ ---######----####--#-------##--- ----###-----##-##----######-###- -------------#-#-#--##--------## -#####---------#---#------------ ##----#####----#-##------------- ----------#######--------------- -#-------------#---------------- -#---#--#-----------#-----##---- ###-#-#-#----------###---####--- #--------#-----#--#############- -#--------##------------######-- --#------#---------------#---#-- ###-----#----------------#---#-- -#------#----------------------- -------------------------------- -------------------------------- --------#---#-###--##-##----###- --------#####-#--#-#-#-#---##-#- ###-------#---###--#-#-#--##--#- -#-#-#--#####-#--#-#---#---#--#- -#-##---#---#-#-#--#---#---#-##- -#-#-#--#---#-##---#---#---#-#-- ---------------------------##--- ----------###-----#-#--#----#--- ---------##-#--####---###------- --------##-#---#-##-#--#----###- ---------###-#-####-#--#---##-#- ----------####-##-#-#--##---###- "; } __END__ plans rewrite in Wx eventually (ought to speed everything up, makes adding scrollbars easier) but first add undo/redo, and the behaviour so button_down/button_up does a bind/unbind of Motion (rather than listening all the time) and add for configurable [SQUARE] sizes ('em little boxes which flip) that way you can cram a 500 x 500 xbm on screen ;) add Ctrl-S (save buffer to file) Ctrl-A ( save as) use vars qw/ $VERSION /; $VERSION = 2.4; # probably ;)

 
______crazyinsomniac_____________________________
Of all the things I've lost, I miss my mind the most.
perl -e "$q=$_;map({chr unpack qq;H*;,$_}split(q;;,q*H*));print;$q/$q;"


In reply to pTkXbmEdit - a Xbm Editor written in Perl/Tk by crazyinsomniac
in thread crazy tk xbm tingy 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
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            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 lurking in the Monastery: (10)
    As of 2015-07-06 11:22 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (72 votes), past polls