http://www.perlmonks.org?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"; } }

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.