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