Beefy Boxes and Bandwidth Generously Provided by pair Networks
Come for the quick hacks, stay for the epiphanies.
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
... just streching my tk legs ... probably not the best way to do this (sure is a memory hog)

update: its an xbm image editor ... screenshots

#!/usr/bin/perl -w use Tk 8; use Tk::Text; use Tk::Image; use Image::Xbm; use strict; use vars qw/ %GOB $CAMEL $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', sub { my $this = shift; for my $row (@{$GOB{grid}}) { my $F = shift @$row; for my $but (@{$row}) { $but->invoke; } $row = [$F,@$row]; } } ,); &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, ,); 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; } for my $row (@{$GOB{grid}}) { my $F = shift @$row; $F->packForget; $F->destroy; } undef $GOB{grid}; delete $GOB{grid}; return undef; } sub make_us_up_the_picture { my $picture = ""; if(exists $GOB{grid} and @{$GOB{grid}}) { for my $row (@{$GOB{grid}}) { my $F = shift @$row; for my $but (@{$row}) { $picture .= ($but->cget('background') eq 'white')?'-': +'#'; } $row = [$F,@$row]; $picture .="\n"; } return Image::Xbm->new_from_string($picture); } return undef; } sub set_us_up_the_grid { my ($x, $y) = @_; 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($CAMEL) 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; --$x; --$y; &clear_us_up_the_grid() if (exists $GOB{grid} and scalar(@{$GOB{gr +id}})); my @buttons = (); my @common_settings = ( -activebackground => "white", -background => "white", -foreground => "white", -width => 1, -borderwidth => 0, -relief => "groove", -font =>[-family => "Courier", -size => -1, ,], ,); for my $row (0..$y) { my @row=(); my $F = $GOB{W}->Frame( # -borderwidth => 0, # -highlightbackground => "", # -highlightthickness => "", # -takefocus => "", # -class => "", # -highlightcolor => "", -relief => "groove", # -cursor => "", -height => 25, -width => 500, ,); for my $col (0..$x) { my $BUT = $F->Button(@common_settings)->pack(-expand => 'n +o', -side => 'lef +t', -in => $F, ,); $BUT->configure(-command => [ \&flip_bg, $BUT]); push @row, $BUT; } $F->pack(-anchor => 'center', -side => 'top', -expand => 'no', -in => $GOB{W}, ,); push @buttons,[$F, @row]; } $GOB{grid} = \@buttons; return undef; } sub flip_bg { my $fancylabel = shift; if( $fancylabel ) { my $color = $fancylabel->cget('background'); $color = ($color eq 'black') ? 'white' : 'black'; $fancylabel->configure( -activebackground => $color, -background => $color, -foreground => $color, -highlightcolor => $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++) { my $F = shift @{$GOB{grid}->[$iy]}; for( my $ix=0; $ix < $$XBM{-width}; $ix++ ) { ($GOB{grid}->[$iy][$ix])->invoke() unless $picrow[$iy][$ix] ne '#'; } $GOB{grid}->[$iy] = [$F,@{$GOB{grid}->[$iy]}]; } #perl -MImage::Xbm -e"print Image::Xbm->new_from_string(qq'# #\n# #\n- +#-')->as_string" return undef; } sub init { $CAMEL = " #-------------------- ##------------------- ######------------------- ##---###------------------- ##########------------------ ## #####------------------ # ####------------------- # ####------------------- # ####-------------------- # ####-------------------- # #####-------#####-------- # ####-------#######------- # ######----#########------ # ####################---- # #####################--- #######################-- #####################-- ###################--- ######------#######--- ---------####-------######---- ---------###---------#####---- ---------###---------###-#---- ---------###---------###-#---- ---------###----------##-#---- ---------###----------####---- --------##-----------###------"; $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 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 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?Last hourOther CB clients
Other Users?
Others perusing the Monastery: (7)
As of 2024-03-28 19:02 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found