Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

pTkXbmEdit - a Xbm Editor written in Perl/Tk

by crazyinsomniac (Prior)
on May 01, 2002 at 09:55 UTC ( #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;"


Comment on pTkXbmEdit - a Xbm Editor written in Perl/Tk
Download Code
Re: pTkXbmEdit - a Xbm Editor written in Perl/Tk
by capfan (Acolyte) 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
Node Status?
node history
Node Type: note [id://163230]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (5)
As of 2015-07-02 23:44 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 (47 votes), past polls