http://qs321.pair.com?node_id=11100870

Hello folks!,

another Tk CUFP from my part! It is working and is also a draft for a bigger project (you all know what I'm working on nowadays.. ;)

This is an ASCII drawing program expoiting the best I'm able to from Canvas and their precious feature: tags.

I left some commented code because I have some question in case some Tk expert has answers:

-1 about binding modifiers: I planned the draw action when <Button1-Motion> is on: ie. when button 1 is pressed (modifier) and the pointer is moveing over the Canvas. No luck. The program below now uses <Control-Motion> and perhaps is even better (less mouse->less pain)

-2 I noticed some strange behaviours with some key: £ aka sterling in Tk world and ° aka degree if I use one of them (now commented in the code) I get back a multichar: uppercase A with caret above plus the degree symbol, for instance.

-3 I wonder how can I implement an export coordinates range in my Canvas: something like: when SHIFT modifier is on and Motion is on too I should tag tiles with something like selceted use a different color for them and haveing two buttons for export corrdinates and select nothing Seems this the right way? 

use strict;
use warnings;
use Tk;
use Tk::Pane;
use utf8;      # <-- update: see choroba below. Used to make sterling 
+and degree work

my $mw = Tk::MainWindow->new(-bg=>'ivory',-title=>'ASCII draw');
$mw->geometry("700x600+0+0");

$mw->optionAdd('*font', 'Courier 12');
$mw->optionAdd( '*Entry.background',   'lavender' );
$mw->optionAdd( '*Entry.font',   'Courier 12 bold'  );


# TOP FRAME
my $top_frame0 = $mw->Frame( -borderwidth => 2, -relief => 'groove',)-
+>pack(-anchor=>'ne', -fill => 'both');

$top_frame0->Label( -text=>"press a key to set brush (or choose it fro
+m the below menu)\n".
                            "hold CRTL and move the pointer to paint",
+)->pack( -side=>'top');


my $top_frame1 = $mw->Frame( -borderwidth => 2,-relief => 'groove',)->
+pack(-anchor=>'ne', -fill => 'both');

my $default_char = ' ';

my $maxy = 29;
my $maxx = 29; 

my $tile_w = 15;
my $tile_h = 15;

my $cur_tile_lbl = 'tile (y-x): 0-0';

$top_frame1->Label( -textvariable=>\$cur_tile_lbl,)->pack( -side=>'lef
+t',-padx=>5);


my $list_brushes = $top_frame1->Optionmenu( -textvariable=>\$default_c
+har, )->pack( -side=>'right' ,-padx=>5);
$top_frame1->Label( -text=>"actual brush: ",)->pack( -side=>'right' ,-
+padx=>5);

foreach my $charnum (32..127){
    $list_brushes->addOptions( chr($charnum) );
}


my $top_frame2 = $mw->Frame( -borderwidth => 2, 
                            -relief => 'groove',
)->pack(-anchor=>'ne', -fill => 'both');

$top_frame2->Label(-text => "rows: 0-")->pack(-side => 'left');

$top_frame2->Entry(    
                    -width => 3,
                    -borderwidth => 4, 
                    -textvariable => \$maxy
)->pack(-side => 'left',-padx=>5);

$top_frame2->Label(-text => "columns: 0-")->pack(-side => 'left',-padx
+=>5);

$top_frame2->Entry(    
                    -width => 3,
                    -borderwidth => 4, 
                    -textvariable => \$maxx
)->pack(-side => 'left',,-padx=>5);

$top_frame2->Button(    -padx=> 5,
                    -text => "new",
                    -borderwidth => 4, 
                    -command => sub{ &setup_new }
)->pack(-side => 'left',-padx=>5);



$top_frame2->Button(    -padx=> 5,
                    -text => "toggle grid",
                    -borderwidth => 4, 
                    -command => sub{&toggle_grid()},
)->pack(-side => 'right',-padx=>5);

$top_frame2->Button(    -padx=> 5,
                    -text => "export",
                    -borderwidth => 4, 
                    -command => sub{&export_aoa()},
)->pack(-side => 'right',-padx=>5);

# $top_frame2->Button(    -padx=> 5,
                    # -text => "import",
                    # -borderwidth => 4, 
                    # -command => sub{exit}
# )->pack(-side => 'right',-padx=>5);




# MAP FRAME
my $map_frame = $mw->Scrolled(    'Frame',
                                -scrollbars => 'osoe',
                                -relief => 'groove',
)->pack(-anchor=>'n',-expand => 1, -fill => 'both');

 
my $canvas;
my $grid_show = 1;
my @aoa;
setup_new();    

                  
MainLoop();


sub setup_new{
    $default_char = ' ';
    
    $canvas->packForget if Tk::Exists($canvas); 
    
    @aoa = map{ [ ($default_char) x ($maxx + 1)  ] } 0..$maxy;
    $canvas = $map_frame->Canvas(
                            -bg => 'ivory',
                            -width     => $maxx * $tile_w + $tile_w - 
+2, # -2 correction for the grid
                            -height => $maxy * $tile_h + $tile_h - 2,
              )->pack(-anchor=>'n',-expand => 1, -fill => 'both');
    
    $canvas->focusForce;
    
    $canvas->createGrid(0,0, $tile_w, $tile_h, lines=>1,-width=>1,-tag
+s=>['thegrid']);
     
    my $start_y = 0;
    my $end_y = $start_y + $tile_h;

    my $start_x = 0;
    my $end_x = $start_x + $tile_w;

    foreach my $row (0..$#aoa){
        foreach my $col( 0..$#{$aoa[$row]} ){
            $canvas->createText(
                                    ($start_x + $end_x ) / 2,
                                    ($start_y + $end_y ) / 2,
                                    
                                     -text => $aoa[$row][$col],
                                     -tags => ["$row-$col"],
                                     -font=> 'Courier 14 bold'
            );
            $start_x += $tile_w;
            $end_x    += $tile_w;
        }
        $start_x = 0;
        $end_x = $start_x + $tile_w;
        $start_y += $tile_h;
        $end_y    += $tile_h;
    
    }
    $mw->bind("<Key>", [ \&set_default_char, Ev('K') ] );
    #$mw->bind("<Key-space>", [ \&set_default_char_to_space, Ev('K') ]
+ );
    #$canvas->Tk::bind("<Motion>", [ \&get_coord, Ev('x'), Ev('y') ]);
    $canvas->Tk::bind("<Control-Motion>", [ \&set_coord, Ev('x'), Ev('
+y') ]);
    #$canvas->Tk::bind("<Button1-Motion>", [ \&set_coord, Ev('x'), Ev(
+'y') ]);
    $canvas->Tk::bind("<Button-1>", [ \&get_coord, Ev('x'), Ev('y') ])
+;
    #$canvas->Tk::bind("<Button-3>",  [ \&reset_motion, Ev('x'), Ev('y
+') ]);
    
    
}

sub set_default_char {
        my ($canv, $k) = @_;
        print "DEBUG [$k] was pressed..\n";
        #return 0 unless $k =~ /^.$/;
        my %other_chars = (
                space        => ' ',
                at            => '@',
                numbersign    => '#',                
                backslash     => '\\',
                bar            => '|',
                exclam        => '!',
                quotedbl    => '"',
        sterling    => '£', # need utf8
                dollar        => '$',
                percent        => '%',
                ampersand    => '&',
                slash        => '/',
                parenleft    => '(',
                parenright    => ')',
                equal        => '=',
                quoteright    =>    "'",
                question    => '?',
                asciicircum    => '^',
                comma         => ',',
                period        => '.',
                minus        => '-',
                semicolon    => ';',
                colon        => ':',
                underscore    => '_',
                plus        => '+',
                asterisk    => '*',
        degree        => '°', # need utf8
                greater        => '>',
                less        => '<',
                                
                
        );
        if( $k =~ /^.$/){
            $default_char = $k;
            print "setting brush to [$k]\n";
        }
        elsif( exists $other_chars{$k} ){
            $default_char = $other_chars{$k};
            print "setting brush to [$other_chars{$k}]\n";
        }
        else{
            print "WARNING: cannot use [$k] as char to draw!\n";
        }
        
        
}
sub set_coord {
    my ($canv, $x, $y) = @_;
    #print "SETtING (x,y) = ", $canv->canvasx($x), ", ", $canv->canvas
+y($y), "\n";
    my $cur = $canv->find('withtag' =>'current' );
    my @list = grep{$_ ne 'current'} $canv->gettags($cur);
    
        if ( $list[0] ){
        
        $canv->itemconfigure($cur, -text=> $default_char);
        my ($tile_y,$tile_x)=split /-/, $list[0];
        $cur_tile_lbl = "tile (y-x): $tile_y-$tile_x";
        print "SET $tile_y - $tile_x\n";
        $aoa[$tile_y][$tile_x]= $default_char;
    }
}

sub toggle_grid{
    if ( $grid_show ){
        $canvas->itemconfigure('thegrid',-color=>'ivory');
    }
    else{
        $canvas->itemconfigure('thegrid',-color=>'black');
    }
    $grid_show = !$grid_show;
}

# from https://www.perlmonks.org/?node_id=987407 zentara rules!!
sub get_coord {
    my ($canv, $x, $y) = @_;
    #print "(x,y) = ", $canv->canvasx($x), ", ", $canv->canvasy($y), "
+\n";
    my $cur = $canv->find('withtag' =>'current' );
    my @list = grep{$_ ne 'current'} $canv->gettags($cur);
    
    $cur_tile_lbl = "tile (y-x): $list[0] " if $list[0];
    
}
sub export_aoa{
    foreach my $row (0..$#aoa){
        foreach my $col( 0..$#{$aoa[$row]} ){
            print $aoa[$row][$col];
        }
        print "\n";    
    }
}

[download]

PS now you can draw fancy things like:

 JJJJJ
   J
   J
   J  AAA
   J  A A
   J A  A
J  J A  A
J  J AAAA PPPP
 JJJ A  A P  P
     A  A P  P
     A  A PPPP
     A  A P
          P  H   H
          P  H   H
          P  H   H
          P  HHHHH
             H   H
             H   H
             H   H

[download]

L*

There are no rules, there are no thumbs..
Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.

Back to Cool Uses for Perl