Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

pTkXbmEdit - a Xbm Editor written in Perl/Tk

by crazyinsomniac (Prior)
on May 01, 2002 at 09:55 UTC ( [id://163230]=note: print w/replies, xml ) Need Help??


in reply to crazy tk xbm tingy

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;"

Replies are listed 'Best First'.
Re: pTkXbmEdit - a Xbm Editor written in Perl/Tk
by capfan (Sexton) on Feb 02, 2015 at 22:43 UTC
    FYI: I modified it a bit and put it up on Github.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://163230]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (5)
As of 2024-03-28 20:06 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found