Beefy Boxes and Bandwidth Generously Provided by pair Networks Cowboy Neal with Hat
P is for Practical
 
PerlMonks  

crazy tk xbm tingy

by crazyinsomniac (Prior)
on Sep 14, 2001 at 06:48 UTC ( #112357=CUFP: 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;"

Comment on crazy tk xbm tingy
Download Code
*saner* crazy tk xbm tingy (aka Tk XBM Editor)
by crazyinsomniac (Prior) on Sep 15, 2001 at 19:15 UTC
pTkXbmEdit - a Xbm Editor written in Perl/Tk
by crazyinsomniac (Prior) on May 01, 2002 at 09:55 UTC

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://112357]
Approved by root
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others cooling their heels in the Monastery: (8)
As of 2014-04-16 22:56 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (435 votes), past polls