Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
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 about the Monastery: (9)
As of 2014-09-16 09:26 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite cookbook is:










    Results (158 votes), past polls