#!/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; # I can't wait to do this in Wx already
## S U B L A N D
sub duck {
my ( $widget, $x, $y, $s ) = @_;
if( $GOB{gridc} ) {
return() if $widget != $GOB{gridc};
# if we're not on it, don't do sh*
if( $s =~ m{^B1}ix ) { # button1 down (left button)
flip_square($widget, $x, $y, 0 );
} elsif( $s =~ m{^B3}ix ) { # button3 down (right button)
flip_square($widget, $x, $y, 1 );
}
} else {
$widget = $1 if $widget =~ m{^ ( [^=]+ ) = }x;
Statuss("$widget : x( $x ) / y( $y ) modifier( $s )");
}
return ();
}
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) {
Statuss("loading $file ...\n", "[$file]");
&draw_us_up_a_picture(Image::Xbm->new(-file => $file)->as_stri
+ng());
Statuss("","[$file]");
} else {
Statuss( "no file to load\n" );
}
return undef;
}
sub Statuss {
my ( $msg, $sticky ) = @_;
$GOB{_status_sticky} = $sticky if defined $sticky; # "" will be us
+ed to clear
$GOB{_status} = "$GOB{_status_sticky} $msg";
return ();
}
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();
Statuss("no picture, nothing to save\n"), last unless $picXBM;
Statuss("saved $file, looks great\n") if $picXBM->save($file);
}
else
{
Statuss("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} ] );
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("pTkXbmEdit - a Xbm Editor written in Perl/Tk by cr
+azyinsomniac");
$GOB{F} = $GOB{W}->Frame(-relief => "groove",
-height => 300,
-width => 500,
,);
$GOB{F}->pack(-anchor => 'n',
-side => 'top',
-expand => 'yes',
,);
## 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_button($GOB{F},
'flip',
'White All Squares',
'groove',
\&white_em_all
,);
&set_us_up_a_button($GOB{F},
'flip',
'Black All Squares',
'groove',
\&black_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,
,);
$GOB{_status} = "status";
$GOB{_status_sticky} = "";
$GOB{status} = $GOB{W}->Label(-textvariable => \$GOB{_status},
-relief => 'groove',
-font => "Arial",
-anchor => 'center',
,)->pack(-side => 'bottom',
-anchor => 's',
-expand => 'no',
,);
## 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')]
,);
$GOB{W}->bind('<Motion>' => [\&duck, map { Ev($_) } qw{ x y s } ]
+);
return undef;
}
sub set_us_up_a_label
{
my ($widg, $text,$relief) = @_;
$widg->Label(-text => $text,
-relief => $relief,
-font => "Arial",
,)->pack(-side => 'left',
-expand => 1,);
}
sub clear_us_up_the_grid
{
Statuss(" ... clearing up the grid ... ","");
unless ($GOB{grid} and $GOB{gridc}) {
&draw_us_up_a_picture($MirrorCamel);
return undef;
}
$GOB{gridc}->delete('all');
$GOB{gridc}->packForget;
delete $GOB{grid};
delete $GOB{gridc};
Statuss(" ... done clearing up the grid.");
return undef;
}
sub make_us_up_the_picture
{
Statuss(" ... making 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";
}
Statuss(" ... done making up the picture.");
return Image::Xbm->new_from_string($picture);
}
Statuss(" there was no grid to make a picture from.");
return undef;
}
sub set_us_up_the_grid
{
my ($x, $y, $scale) = @_;
Statuss(" ... setting up the grid ...","");
$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);
Statuss(" ... done setting up the grid.");
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 black_em_all {
for my $row( @{ $GOB{grid} } ) {
for my $id( @{ $row } ) {
$GOB{gridc}->itemconfigure($id,
-fill => 'black'
,);
}
}
}
sub white_em_all {
for my $row( @{ $GOB{grid} } ) {
for my $id( @{ $row } ) {
$GOB{gridc}->itemconfigure($id,
-fill => 'white'
,);
}
}
}
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 () if not defined $GOB{gridc};
return () if $widget != $GOB{gridc};
my $id = $GOB{gridc}->find('overlapping', $x, $y, $x + 1 , $y + 1
+);
if($id) {
my $color = $GOB{gridc}->itemcget($id,-fill);
if( defined $wihi ) {
if ( $wihi ) {
$color = 'white';
} else {
$color = 'black';
}
} else {
$color = ( $color eq 'white' ) ? 'black' : 'white';
}
$GOB{gridc}->itemconfigure($id,
-fill => $color
,);
}
}
sub draw_us_up_a_picture
{
my ( $string , $ornot ) = @_;
my $XBM = $ornot ? Image::Xbm->new( -file => $string)
: 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 ="----####-----##-----------------
---######---###-----------------
---######--##-##-##-------------
---######--#---#####------------
---######----####--#-------##---
----###-----##-##----######-###-
-------------#-#-#--##--------##
-#####---------#---#------------
##----#####----#-##-------------
----------#######---------------
-#-------------#----------------
-#---#--#-----------#-----##----
###-#-#-#----------###---####---
#--------#-----#--#############-
-#--------##------------######--
--#------#---------------#---#--
###-----#----------------#---#--
-#------#-----------------------
--------------------------------
--------------------------------
--------#---#-###--##-##----###-
--------#####-#--#-#-#-#---##-#-
###-------#---###--#-#-#--##--#-
-#-#-#--#####-#--#-#---#---#--#-
-#-##---#---#-#-#--#---#---#-##-
-#-#-#--#---#-##---#---#---#-#--
---------------------------##---
----------###-----#-#--#----#---
---------##-#--####---###-------
--------##-#---#-##-#--#----###-
---------###-#-####-#--#---##-#-
----------####-##-#-#--##---###-
";
}
__END__
plans
rewrite in Wx eventually
(ought to speed everything up, makes adding scrollbars easier)
but first add undo/redo, and
the behaviour so button_down/button_up does a bind/unbind of
Motion (rather than listening all the time)
and add for configurable [SQUARE] sizes ('em little boxes which flip)
that way you can cram a 500 x 500 xbm on screen ;)
add Ctrl-S (save buffer to file) Ctrl-A ( save as)
use vars qw/ $VERSION /;
$VERSION = 2.4; # probably ;)
