Tk ASCII Draw on Canvas

[Discipulus]

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";    
    }
}

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

L*

[choroba]

Canvas is designed to make moving objects around with a mouse easy. Therefore, when you press a button and start moving the mouse, the current is the canvas object that you're moving, i.e. it doesn't change as you move the mouse pointer over the grid. Currently, I have no idea how to implement a "pen" in Canvas.

To make the sterling and degree work, you must save the script as UTF-8 and add use utf8; towards the top. Also, you might need to encode or decode the strings coming to or from Tk (finding the exact way is left as an exercise for the reader).

[Discipulus]

Thanks choroba for looking at my code.

> Canvas is designed to make moving objects around with a mouse easy. Therefore, when you press a button and start moving the mouse, the current is the canvas object that you're moving, i.e. it doesn't change as you move the mouse pointer over the grid.

The above seems very reasonable but i doubt is true: infact, if true, how can my code work? I currently have:

$canvas->Tk::bind("<Control-Motion>", [ \&set_coord, Ev('x'), Ev('y') ]);

and this code actually draws on the canvas and the element tagged as current changes as you move the pointer (you can also see the debug messages on the console like SET 22 - 14 and so on)

So with the Control modifier it works and as Button1 is stated as a valid modifier I expected to work in the same way. Here my working binding and all tries:

    $canvas->Tk::bind("<Control-Motion>", [ \&set_coord, Ev('x'), Ev('
+y') ]);
    
    #no just the first:
    #$canvas->Tk::bind('<Button1-Motion>', [ \&set_coord, Ev('x'), Ev(
+'y') ]);

    # no just the first
    #$canvas->Tk::bind('<B1-Motion>', [ \&set_coord, Ev('x'), Ev('y') 
+]);

    # wrong: extra characters after detail in binding at
    #$canvas->Tk::bind('<Button-1-Motion>', [ \&set_coord, Ev('x'), Ev
+('y') ]);

    # wrong: bad event type or keysym "Button1"
    #$canvas->Tk::bind('<Button1><Motion>', [ \&set_coord, Ev('x'), Ev
+('y') ]);

    # ok after Button-1 (not holding it) until for example Button-3
    #$canvas->Tk::bind('<Button-1><Motion>', [ \&set_coord, Ev('x'), E
+v('y') ]);

The last one is intriguing: it seems to be not a modifier but more a sequence. Anyway I'm happy with <Control-Motion> less carpal tunnel ;)

> To make the sterling and degree work, you must save the script as UTF-8 and add use utf8; towards the top.

Tadąaa! thanks! adding use utf8; on top made sterling and degree to work as expected. My utf8 foo is near to zero.. I did not even suspected the issue.

I've update my code with it ;)

L*

[tybalt89]

Here's a little proof-of-concept of one way to implement a "pen" in Canvas.

#!/usr/bin/perl

use strict;
use warnings;
use Tk;

my @lines;

my $mw = MainWindow->new;
my $c = $mw->Canvas(-width => 900, -height => 900,)->pack(-side => 'bo
+ttom');
$mw->Button(-text => $_->[0], -command => $_->[1])->pack(-side => 'rig
+ht') for
  [ Exit         => sub { $mw->destroy } ],
  [ 'Clear Last' => sub { pop @lines; redraw() } ],
  [ 'Clear All'  => sub { @lines = (); redraw() } ];

$c->Tk::bind('<1>' => sub
  {
  push @lines, [ &xy ];
  redraw();
  $c->Tk::bind('<Motion>' => sub { push @{ $lines[-1] }, &xy; redraw()
+ } );
  } );
$c->Tk::bind('<ButtonRelease-1>' => sub { $c->Tk::bind('<Motion>' => '
+') } );

MainLoop;

sub xy { $_[0]->XEvent->x, $_[0]->XEvent->y }

sub redraw
  {
  $c->delete('pen');
  @$_ >= 4 and $c->createLine(@$_, -smooth => 1, -width => 5, -tag => 
+'pen') 
    for @lines;
  }

[vr]

I think user would expect single mouse click, not only motion, should produce a paint stroke. Plus, not nice that with pointer just above grid line, an item from row below is changed (do bounding boxes of characters overlap slightly, vertically?).

With mouse button pressed, "Motion" event targets same "current" item, but X-Y coordinates are updated continuously. In fact, knowing these X-Y, we can ignore what's "current", fix all of the above and write it simpler:

# ...
$canvas-> Tk::bind( '<B1-Motion>', [ \&set_coord, Ev('x'), Ev('y') ]);
$canvas-> Tk::bind( '<Button-1>', [ \&set_coord, Ev('x'), Ev('y') ]);
$canvas-> Tk::bind( '<Enter>', [ configure => '-cursor', 'crosshair' ]
+);
# ...

sub set_coord {
    my ( $canv, $x, $y ) = @_;
    
    my $r = int( $y / $tile_h );
    my $c = int( $x / $tile_w );
    my ( $item ) = $canv-> find( withtag => "$r-$c", );
    $canv-> itemconfigure( $item, -text => $default_char );
}

Further nitpicks :) : the $default_char = ' '; appears to belong to initialization section, but does nothing. Could be moved somewhere further. + Some would argue that widgets' tab-order (i.e. I press Tab and focus moves from left to right instead of ...in unexpected ways) is important.

[stevieb]

This is quite intriguing :)

I don't often think about GUI applications, but all I had to do was cpanm Tk in my current Perl instance and it just worked.

[Anonymous Monk]

.oO(App::Asciio, Tk::Canvas::Draw, zinc, Tk::Zinc, pTkXbmEdit - a Xbm Editor written in Perl/Tk, )

             00
            000000
          00   000
          00     00
         000     00
         00      00          0
         00      00         00
          000    00        000
           0000000        0000
          00000000000000000000
    00000000000000000000000000
   00       000000000000000000
  00         000         00000
 00          000           000
 0           000             0
 0  000      000
 0 0  00     000
 0 00  0     000
 0  0  0   0 000 0
 00    0   0000000
  00 00    0000000
    00     0000000
           0 000 0
             000
             000
         00  000  00
          00 000000
           0000000
            00000
             000
              0