Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

Tk ASCII Draw on Canvas

by Discipulus (Abbot)
on Jun 03, 2019 at 10:57 UTC ( #11100870=CUFP: print w/replies, xml ) Need Help??

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*

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.

Replies are listed 'Best First'.
Re: Tk ASCII Draw on Canvas
by vr (Deacon) on Jun 04, 2019 at 09:11 UTC

    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.

Re: Tk ASCII Draw on Canvas
by choroba (Bishop) on Jun 03, 2019 at 21:43 UTC
    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).

    map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
      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*

      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.

      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; }
Re: Tk ASCII Draw on Canvas
by stevieb (Canon) on Jun 03, 2019 at 22:21 UTC

    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.

Re: Tk ASCII Draw on Canvas
by Anonymous Monk on Jun 14, 2019 at 01:29 UTC

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://11100870]
Approved by dorko
Front-paged by haukex
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others wandering the Monastery: (8)
As of 2019-09-17 10:21 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    The room is dark, and your next move is ...












    Results (206 votes). Check out past polls.

    Notices?