Beefy Boxes and Bandwidth Generously Provided by pair Networks
Come for the quick hacks, stay for the epiphanies.
 
PerlMonks  

pTkXbmEdit - a Xbm Editor written in Perl/Tk

by crazyinsomniac (Prior)
on May 01, 2002 at 09:55 UTC ( [id://163230]=note: print w/replies, xml ) Need Help??


in reply to crazy tk xbm tingy

I updated my *saner* version, and now I dare call this

pTkXbmEdit - a Xbm Editor written in Perl/Tk 

#!/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 ;)

[download]

 
______crazyinsomniac_____________________________
Of all the things I've lost, I miss my mind the most.
perl -e "$q=$_;map({chr unpack qq;H*;,$_}split(q;;,q*H*));print;$q/$q;"

Replies are listed 'Best First'.
Re: pTkXbmEdit - a Xbm Editor written in Perl/Tk
by capfan (Sexton) on Feb 02, 2015 at 22:43 UTC
    FYI: I modified it a bit and put it up on Github.
[reply]

In Section Cool Uses for Perl

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: note [id://163230]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others surveying the Monastery: (5)
As of 2025-04-30 22:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found
    Notices?
    • erzuuli‥ Anonymous Monks are no longer allowed to use Super Search, due to an excessive use of this resource by robots.