#!/usr/bin/perl -w
use Tk 8;
use Tk::Text;
use Tk::Image;
use Image::Xbm;
use strict;
use vars qw/ %GOB $crazy0naCAMEL $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',
\&flip_em_all
,);
&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,
,);
## we don't need a mouse press listener till we got a grid, buttt, so
+what
$GOB{W}->bind('<ButtonPress>' => [\&flip_square, Ev('x'), Ev('y')]
,);
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;
}
$GOB{gridc}->delete('all');
$GOB{gridc}->packForget;
delete $GOB{grid};
delete $GOB{gridc};
return undef;
}
sub make_us_up_the_picture
{
my $picture = "";
if(exists $GOB{grid})
{ for my $row (@{$GOB{grid}})
{
for my $id (@{$row})
{
$picture .= ( $GOB{gridc}->itemcget($id,-fill) eq 'whi
+te' )?
'-' : '#';
}
$picture .="\n";
}
return Image::Xbm->new_from_string($picture);
}
return undef;
}
sub set_us_up_the_grid
{
my ($x, $y, $scale) = @_;
$scale = 8 unless $scale;
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($crazy0naCAMEL) 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;
&clear_us_up_the_grid() if (exists $GOB{grid} );
$GOB{gridc} = $GOB{W}->Canvas(-width => ( $x + 2 ) * $scale,
-height => ( $y + 2 ) * $scale,
-background => "#AFFAAF",
,)->pack;
$GOB{grid} = &layout_canvas_grid($GOB{gridc}, $x, $y, $scale);
return undef;
}
sub layout_canvas_grid
{
my ( $widget , $colsX , $rowsY , $scale) = @_;
$scale = 10 unless $scale;
my @danums;
for my $iy(1..$rowsY)
{
my @dabums;
for my $ix(1..$colsX)
{
my $id = $widget->create('rectangle',
$ix * $scale,
$iy * $scale,
$ix * $scale + $scale,
$iy * $scale + $scale,
-fill=>'white',
,);
$widget->itemconfigure($id);
push @dabums, $id;
}
push @danums, \@dabums;
}
return \@danums;
}
sub flip_em_all
{
for my $row( @{ $GOB{grid} } )
{
for my $id( @{ $row } )
{
my $color = $GOB{gridc}->itemcget($id,-fill);
$color = ( $color eq 'white' ) ? 'black' : 'white';
$GOB{gridc}->itemconfigure($id,
-fill => $color
,);
}
}
}
sub flip_square
{
my ($widget,$x,$y,$wihi) = @_;
return unless $widget =~ /Tk::Canvas/;
my $id = $GOB{gridc}->find('overlapping', $x, $y, $x + 1 , $y + 1
+);
if($id)
{
my $color = $GOB{gridc}->itemcget($id,-fill);
$color = ( $color eq 'white' ) ? 'black' : 'white';
$GOB{gridc}->itemconfigure($id,
-fill => $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++)
{
for( my $ix=0; $ix < $$XBM{-width}; $ix++ )
{
$GOB{gridc}->itemconfigure($GOB{grid}->[$iy][$ix],
-fill => 'black',
,)
unless $picrow[$iy][$ix] ne '#';
}
}
return undef;
}
sub init {
$crazy0naCAMEL =
"---------#-----------#--------
---------##------####---------
-----######-----#---#---------
---##---###-----##--#---------
--##########----#--#----------
---##--#####-----##-----------
---#---####------#-##---------
---#---####---####-#----------
---#--####---#-----#----------
---#--####----##-##-----------
---#-#########--######--------
---#-####---##--#######-------
---#-#######-#-#########------
---#--####################----
----#-#####################---
-----#######################--
-------#####################--
--------###################---
--------######------#######---
---------####-------######----
---------###---------#####----
---------###---------###-#----
---------###---------###-#----
---------###----------##-#----
---------###----------####----
--------##-----------###------
";
$MirrorCamel ="----------.##.-----------------------------------------
+--.##.-----------
--------.########.--------.##.-----------.##.--------.########.-------
+--
-------.###########------.########---########.------###########.------
+--
-------#############.---.##########-##########.---.#############------
+--
-----.################.--#########'-`#########--.################.----
+--
----.###################-#######-------#######-###################.---
+--
---#############################-------#############################--
+--
--##############################'-----`##############################-
+--
-###############################-------###############################
+--
-##############################'-------`##############################
+--
-##--#########################'---------`#########################--##
+--
-##.-###-###################'-------------`###################-###-.##
+--
--#-####--###-#####-#####---------------------#####-#####-###--####-#-
+--
----###---###-#####.-###-----------------------###-.#####-###---###---
+--
----##'---##--`####--###-----------------------###--####'--##---`##---
+--
----##----###.--###'--##'---------------------`##--`###--.###----##---
+--
----##-----#######'---##-----------------------##---`#######-----##---
+--
----##-----.####'-----##-----------------------##-----`####.-----##---
+--
---.##-----#######-----##---------------------##-----#######-----##.--
+--
----###.---`#'`###'----###-------------------###----`###'`#'---.###---
+--
----###----------------#####---------------#####----------------###---
+--
----------------------------------------------------------------------
+--
----------------------------------------------------------------------
+--
----------------------.##.--------------------.##.--------------------
+--
------.##.--------.########.----------------.########.--------.##.----
+--
--########.------###########.--------------.###########------.########
+--
-##########.---.#############--------------#############.---.#########
+#-
-`#########--.################.----------.################.--#########
+'-
----#######-###################.--------.###################-#######--
+--
----#############################------#############################--
+--
---`##############################----##############################'-
+--
----###############################--###############################--
+--
----`##############################--##############################'--
+--
-----`#########################--##--##--#########################'---
+--
-------`###################-###-.##--##.-###-###################'-----
+--
-----------#####-#####-###--####-#----#-####--###-#####-#####---------
+--
------------###-.#####-###---###--------###---###-#####.-###----------
+--
------------###--####'--##---`##--------##'---##--`####--###----------
+--
-----------`##--`###--.###----##--------##----###.--###'--##'---------
+--
------------##---`#######-----##--------##-----#######'---##----------
+--
------------##-----`####.-----##--------##-----.####'-----##----------
+--
-----------##-----#######-----##.------.##-----#######-----##---------
+--
----------###----`###'`#'---.###--------###.---`#'`###'----###--------
+--
--------#####----------------###--------###----------------#####------
+--";
}