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??
Here is a saner version (less buttons, less of a memory hog)
#!/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; ## S U B L A N D 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) { print "loading $file ...\n"; &draw_us_up_a_picture(Image::Xbm->new(-file => $file)->as_stri +ng()); } else { print "no file to load\n"; } return undef; } 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(); print "no picture, nothing to save\n", last unless $picXBM; print "saved $file, looks great\n" if $picXBM->save($file); } else { print "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} ] ); # $GOB{TX}->in($GOB{F}); 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("crazy tk xbm thingy"); # $GOB{W}->resizable(0,0); # no, no $GOB{F} = $GOB{W}->Frame( # -borderwidth => 0, # -highlightbackground => "", # -highlightthickness => "", # -takefocus => "", # -class => "", # -highlightcolor => "", -relief => "groove", # -cursor => "", -height => 25, -width => 500, ,); $GOB{F}->pack(-anchor => 'n', -side => 'top', -expand => 'no', ,); ## 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_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, ,); ## 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')] ,); return undef; } sub set_us_up_a_label { my ($widg, $text,$relief) = @_; $widg->Label(-text => $text, -relief => $relief, -font => "Arial", # -anchor => 'center', ,)->pack(-side => 'left', -expand => 1,); } sub clear_us_up_the_grid { unless (exists $GOB{grid} ) { &draw_us_up_a_picture($MirrorCamel); return undef; } $GOB{gridc}->delete('all'); $GOB{gridc}->packForget; delete $GOB{grid}; delete $GOB{gridc}; return undef; } sub make_us_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"; } return Image::Xbm->new_from_string($picture); } return undef; } sub set_us_up_the_grid { my ($x, $y, $scale) = @_; $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); 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 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 unless $widget =~ /Tk::Canvas/; my $id = $GOB{gridc}->find('overlapping', $x, $y, $x + 1 , $y + 1 +); if($id) { my $color = $GOB{gridc}->itemcget($id,-fill); $color = ( $color eq 'white' ) ? 'black' : 'white'; $GOB{gridc}->itemconfigure($id, -fill => $color ,); } } sub draw_us_up_a_picture { my $XBM = 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 ="----------.##.----------------------------------------- +--.##.----------- --------.########.--------.##.-----------.##.--------.########.------- +-- -------.###########------.########---########.------###########.------ +-- -------#############.---.##########-##########.---.#############------ +-- -----.################.--#########'-`#########--.################.---- +-- ----.###################-#######-------#######-###################.--- +-- ---#############################-------#############################-- +-- --##############################'-----`##############################- +-- -###############################-------############################### +-- -##############################'-------`############################## +-- -##--#########################'---------`#########################--## +-- -##.-###-###################'-------------`###################-###-.## +-- --#-####--###-#####-#####---------------------#####-#####-###--####-#- +-- ----###---###-#####.-###-----------------------###-.#####-###---###--- +-- ----##'---##--`####--###-----------------------###--####'--##---`##--- +-- ----##----###.--###'--##'---------------------`##--`###--.###----##--- +-- ----##-----#######'---##-----------------------##---`#######-----##--- +-- ----##-----.####'-----##-----------------------##-----`####.-----##--- +-- ---.##-----#######-----##---------------------##-----#######-----##.-- +-- ----###.---`#'`###'----###-------------------###----`###'`#'---.###--- +-- ----###----------------#####---------------#####----------------###--- +-- ---------------------------------------------------------------------- +-- ---------------------------------------------------------------------- +-- ----------------------.##.--------------------.##.-------------------- +-- ------.##.--------.########.----------------.########.--------.##.---- +-- --########.------###########.--------------.###########------.######## +-- -##########.---.#############--------------#############.---.######### +#- -`#########--.################.----------.################.--######### +'- ----#######-###################.--------.###################-#######-- +-- ----#############################------#############################-- +-- ---`##############################----##############################'- +-- ----###############################--###############################-- +-- ----`##############################--##############################'-- +-- -----`#########################--##--##--#########################'--- +-- -------`###################-###-.##--##.-###-###################'----- +-- -----------#####-#####-###--####-#----#-####--###-#####-#####--------- +-- ------------###-.#####-###---###--------###---###-#####.-###---------- +-- ------------###--####'--##---`##--------##'---##--`####--###---------- +-- -----------`##--`###--.###----##--------##----###.--###'--##'--------- +-- ------------##---`#######-----##--------##-----#######'---##---------- +-- ------------##-----`####.-----##--------##-----.####'-----##---------- +-- -----------##-----#######-----##.------.##-----#######-----##--------- +-- ----------###----`###'`#'---.###--------###.---`#'`###'----###-------- +-- --------#####----------------###--------###----------------#####------ +--"; }

 
___crazyinsomniac_______________________________________
Disclaimer: Don't blame. It came from inside the void

perl -e "$q=$_;map({chr unpack qq;H*;,$_}split(q;;,q*H*));print;$q/$q;"


In reply to *saner* crazy tk xbm tingy (aka Tk XBM Editor) 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":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others meditating upon the Monastery: (5)
As of 2022-05-23 07:53 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Do you prefer to work remotely?



    Results (81 votes). Check out past polls.

    Notices?