Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
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;"

Replies are listed 'Best First'.
*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
      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: 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 studying the Monastery: (2)
As of 2016-06-30 01:48 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My preferred method of making French fries (chips) is in a ...











    Results (388 votes). Check out past polls.