... just streching my tk legs ... probably not the best way to do this (sure is 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 $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 ="----------.##.-----------------------------------------
+--.##.-----------
--------.########.--------.##.-----------.##.--------.########.-------
+--
-------.###########------.########---########.------###########.------
+--
-------#############.---.##########-##########.---.#############------
+--
-----.################.--#########'-`#########--.################.----
+--
----.###################-#######-------#######-###################.---
+--
---#############################-------#############################--
+--
--##############################'-----`##############################-
+--
-###############################-------###############################
+--
-##############################'-------`##############################
+--
-##--#########################'---------`#########################--##
+--
-##.-###-###################'-------------`###################-###-.##
+--
--#-####--###-#####-#####---------------------#####-#####-###--####-#-
+--
----###---###-#####.-###-----------------------###-.#####-###---###---
+--
----##'---##--`####--###-----------------------###--####'--##---`##---
+--
----##----###.--###'--##'---------------------`##--`###--.###----##---
+--
----##-----#######'---##-----------------------##---`#######-----##---
+--
----##-----.####'-----##-----------------------##-----`####.-----##---
+--
---.##-----#######-----##---------------------##-----#######-----##.--
+--
----###.---`#'`###'----###-------------------###----`###'`#'---.###---
+--
----###----------------#####---------------#####----------------###---
+--
----------------------------------------------------------------------
+--
----------------------------------------------------------------------
+--
----------------------.##.--------------------.##.--------------------
+--
------.##.--------.########.----------------.########.--------.##.----
+--
--########.------###########.--------------.###########------.########
+--
-##########.---.#############--------------#############.---.#########
+#-
-`#########--.################.----------.################.--#########
+'-
----#######-###################.--------.###################-#######--
+--
----#############################------#############################--
+--
---`##############################----##############################'-
+--
----###############################--###############################--
+--
----`##############################--##############################'--
+--
-----`#########################--##--##--#########################'---
+--
-------`###################-###-.##--##.-###-###################'-----
+--
-----------#####-#####-###--####-#----#-####--###-#####-#####---------
+--
------------###-.#####-###---###--------###---###-#####.-###----------
+--
------------###--####'--##---`##--------##'---##--`####--###----------
+--
-----------`##--`###--.###----##--------##----###.--###'--##'---------
+--
------------##---`#######-----##--------##-----#######'---##----------
+--
------------##-----`####.-----##--------##-----.####'-----##----------
+--
-----------##-----#######-----##.------.##-----#######-----##---------
+--
----------###----`###'`#'---.###--------###.---`#'`###'----###--------
+--
--------#####----------------###--------###----------------#####------
+--";
}
