|
Montain_Gman has asked for the wisdom of the Perl Monks concerning the following question:
So I have found using perl canvases to debug problems; and visualize things in my field can be quite easy and fast to do. Anyway what I've found is that if I do more than say 400x400 pixels worth of stuff on a canvas, it tends to bog down; and basically it will hang.
If i stay at say 200x200; the canvas behaves fast and I just don't get this problem. I have found (maybe superstitiously); that using idletasks to break things up helps, but I'm not sure exactly what is going on. I suspect without it, I am flooding some queue inside TK. There also seems to be a relationship with the hang and the amount of memory I am using.
Anyway I can't post my 'real' script, as it's tied to real work. Essentially i need to simulate a legacy graphics system, and I'm using perl/tk to test things out before we do the real work on the target. My real resolution I need to hit is just over 400x400; but if i operate it that way, I can generally only get 1-2 images displayed before it will hang. (200x200; runs nice) So i created this little script to just see if i could get the same thing to happen to post here, and it generally has the same issue. If you run this, you can then use the mouse (press and hold, move, and release) to draw lines. Hitting go will redraw the back ground. If you do those things 2-3 times; especially if you make the resolution a bit higher; it is locking up for me.
Can anyone enlighten me on what can be done to avoid this, or what is happening under the hood? Is there an easier way to just do straight pixel level screen outputs? (image magic ? I tried getting that to work but had issues on my work machine...) So would rather just stick with TK because it is very lightweight to support. (easy to install / support; anyone with perl 5.8 already has it too...)
Thanks.
ONE last thing; in reviewing this; I found I am not clearing TAGS array. So that will keep eating more memory. But even if you do @TAGS =(); if you run the script enough; you'll still see the same thing happening. So that seems to be a clue; that it's a memory thing...
use Tk;
my @TAGS;
my $canvas_width = 600;
my $canvas_height = 600;
my $mw = new MainWindow;
my $top = $mw->Frame()->pack(-side=>'top');
$canvas=$top->Canvas(
-width=>$canvas_width,
-height=>$canvas_height,
)->pack(-side=>'left');
my $size = 410;
my $entry = $top->Entry(-textvariable=>\$size)->pack(-side=>'top');
my $button = $top->Button(-text=>"go",-command=>\&go)->pack(
-side=>'top');
$mw->Tk::bind('<MouseWheel>', [\&wheel,Ev('D')]);
$canvas->Tk::bind( "<Button>", [\&button_press,Ev('x'),Ev('y')]);
$canvas->Tk::bind( "<ButtonRelease>",
[\&button_release,Ev('x'),Ev('y')]);
$canvas->Tk::bind( "<Motion>", [\&motion,Ev('x'),Ev('y')]);
$mw->Tk::bind('<KeyPress>', [\&key,Ev('k')]);
my $start_x;
my $start_y;
my $start_draw = 0;
$mw->after(100,\&go);
MainLoop();
####################################################################
sub button_press{
my ($dontknow,$x1,$y1) = @_;
$start_draw = 1;
$start_x = $x1;
$start_y = $y1;
}
####################################################################
sub button_release{
my ($dontknow,$x1,$y1) = @_;
if($start_draw){
$start_draw = 0;
$canvas->createLine($start_x,$start_y,$x1,$y1,
-width=>2,-fill=>'white');
}
}
####################################################################
sub motion{
my ($dontknow,$x1,$y1) = @_;
}
####################################################################
sub key{
my ($na,$key) = @_;
print "$key\n";
}
####################################################################
sub wheel{
my ($dontknow,$clicks) = @_;
}
####################################################################
sub erase{
for my $i (0..$#TAGS){
$canvas->delete($TAGS[$i]);
if($i%($size*5)==0){
$mw->idletasks();
}
}
}
####################################################################
sub go{
my @USE;
&erase();
for my $i (0..$size-1){
for my $j (0..$size-1){
my $a = ($i%20) > 9;
my $b = ($j%20) > 9;
my $c;
if($a^$b){
$c = sprintf("#%02X0000",$i%0xFF);
} else {
$c = sprintf("#00%02X00",$j%0xFF);
}
$USE[$i][$j]=$c;
}
}
my $ps = $canvas_width/$size;
for my $i (0..$#USE){
for my $j (0..$#{$USE[$i]}){
my $c = $USE[$i][$j];
my $tag = $canvas->createRectangle(
$i*$ps,$j*$ps,
$i*$ps+$ps,$j*$ps+$ps,
-fill=>$c,-outline=>$c);
push(@TAGS,$tag);
}
if($i%5==0){
$mw->idletasks();
}
}
$center_x = $canvas_width/2;
$center_y = $canvas_height/2;
$x_tag1 =
$canvas->createLine(
$center_x-10,
$center_y-10,
$center_x+10,
$center_y+10,
-width=>2,-fill=>'red');
$x_tag2 =
$canvas->createLine(
$center_x-10,
$center_y+10,
$center_x+10,
$center_y-10,
-width=>2,-fill=>'red');
# $mw->after(3000,\&go);
}
|
Re: Perl Tk canvases / abuse...
by choroba (Cardinal) on May 11, 2021 at 23:02 UTC
|
I wasn't able to reproduce the problem. Also, the script needed some changes to run under strict.
The word "tag" has a special meaning in the Tk domain. You aren't storing any tags in the @TAGS array, you're storing ids of the rectangles.
What about using a single tag for the background?
$canvas->createRectangle(
$i * $ps, $j * $ps,
$i * $ps + $ps, $j * $ps + $ps,
-fill => $c,
-outline => $c,
-tags => ['bg']);
}
The erase routine can be now simplified to
sub erase{
$canvas->delete('bg');
}
No need to store any tags/ids anywhere. That's usually the reason why to use the Canvas.
Update: I would also use tags for the lines, so you can easily raise them above the new background.
$canvas->createLine($start_x, $start_y, $x1, $y1,
-width => 2,
-fill => 'white',
-tags => ['fg']);
# ...
# and after drawing the new background:
$canvas->raise('fg', 'bg');
map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
| [reply]
[d/l]
[select] |
|
|
Thanks; I have longer response in second reply below. For the tags (ids); I know if i keep drawing stuff and don't delete; it will definitely bog down. I assume that's just because you are forcing the TK side to keep track of all that stuff, and it just has more and more work to do to figure out what is on top.
Ok; I see what you did with the bg tag as well; that may help. When I saw that first thing this morning I thought you had stacked all the pixels into a single call; but now I see it's just more tieing them to a tag. Doing that, might make tk's job easier as well.
Thanks.
| [reply] |
Re: Perl Tk canvases / abuse...
by kcott (Archbishop) on May 12, 2021 at 10:42 UTC
|
G'day Montain_Gman,
Welcome to the Monastery.
I ran your code unaltered and, like ++choroba noted, was not able to reproduce your problem
(i.e. no hangs, crashes, or other problems like that).
I'm running Perl 5.32.0 and Tk 804.035. I have a reasonably high-end rig with a fairly powerful GPU (RTX 2080 Ti).
This could easily affect the outcome. What do you have?
The $size variable starts at 410.
I increased this, via the Entry box, to 600, then 1000, then 2000.
With each increase, rendering was progressively slower (at 2000, the rendering seemed to take some minutes).
However, at no point did I experience any hangs or exception messages.
In a current Tk project, I have a canvas with around 2000x1000 pixels.
It contains a very large number of elements, which include lines, arcs, rectangles, polygons,
as well as Photo and Bitmap images.
This renders in about one second: substantially different from what I'm seeing with your code.
"... idletasks ... but I'm not sure exactly what is going on."
There are two methods for updating the display: idletasks() and update().
Both are described in Tk::Widget.
You've got the correct one (idletasks()) here but you're only interested in updating the canvas. Change
$mw->idletasks();
to
$canvas->idletasks();
Calling this intermittently in a for loop is correct; however, you also need to do so after the loop:
for ... (...) {
...
if (...) {
$canvas->idletasks();
}
}
$canvas->idletasks();
Unless the if is TRUE on the last iteration, you'll end up with a strip that isn't updated.
This fixes that.
You can also play around with the if condition to get an optimal value based on the range of numbers you're expecting.
"... more than say 400x400 pixels worth of stuff on a canvas, it tends to bog down ..."
There are a lot of places where you're repeating operations needlessly. Consider:
for my $i (0..$size-1){
for my $j (0..$size-1){
my $a = ($i%20) > 9;
my $b = ($j%20) > 9;
my $c;
if($a^$b){
$c = sprintf("#%02X0000",$i%0xFF);
} else {
$c = sprintf("#00%02X00",$j%0xFF);
}
$USE[$i][$j]=$c;
}
}
The calculations involving $i are repeated on every iteration of the inner loop;
however, the results only change in the outer loop.
$a and $b are special variables,
so you should avoid using them;
but, you don't need either of them, nor do you need $c.
You could have written:
for my $i (0..$size-1){
my $i_col = $i%0xFF;
my $i_mod20_9 = $i%20>9;
for my $j (0..$size-1){
$USE[$i][$j] = $i_mod20_9^($j%20>9)
? sprintf("#%02X0000",$i_col)
: sprintf("#00%02X00",$j%0xFF);
}
}
Having done that, you may notice that both of those sprintf calls can only result in 256 different values each.
With your small, default $size of 410, the inner loop is entered 168,100 times;
that number grows exponentially as $size is increased.
If you precalculated all 512 possible sprintf values, you could reduce the code further to something like:
for my $i (0..$size-1){
my $i_col = $i%0xFF;
my $i_mod20_9 = $i%20>9;
for my $j (0..$size-1){
$USE[$i][$j] = $i_mod20_9^($j%20>9) ? $reds[$i_col] : $greens
+[$j%0xFF];
}
}
You could go a step further by caching @USE.
If $size doesn't change, nor will @USE:
don't run through those hundreds of thousands (or potentially millions) of iterations when you already have the result.
You could use something along these lines:
if (exists $use_cols{$size}) {
@USE = @{$use_cols{$size}};
}
else {
for ... {
...
$USE[$i][$j] = ...;
}
$use_cols{$size} = [@USE];
}
If you look down the code to the next nested for loops, you'll see something similar:
you're calculating $i*$ps and $i*$ps+$ps on every iteration of the inner loop
when the value only changes in the outer loop.
Also, the assignment to $c is pointless:
you could write "-fill=>$USE[$i][$j],-outline=>$USE[$i][$j]" and have no need of the extra $c variable.
I'll leave it there as I think I've written more than enough.
Look through all of your code for further opportunities for improvement.
| [reply]
[d/l]
[select] |
|
|
Ok many thanks; I see a few of these things here that could definitely help. To you; and the other responder; in general this was just a test script to do something on the canvas to get the issue to happen.
So for the real thing, i'm generally processing some kind of data input to figure out what the pixels are. (say a video input, some telemetry data, etc) So that side of the problem doesn't bother me; nor does the overall speed of the render.
I am running on a beast of a work machine (precision 7820 tower); but it does not have much in the way of graphics support. So that could definitely be part of the problem; but I have seen this issue before on my home machine with at an least decent graphics card. I have also done stuff drawing tons of lines and good results with a canvas; but probably not nearly as many as 400x400 items going to the canvas at once. I am running in windows and my company also has a ton of spyware / antivirus stuff that kills all productivity, which could be at play.
I will also try the other responders single call to the canvas (if that's possible in my case); I need to study what he was suggesting more. (I am not really interested in drawing a checker board; I'd generally be drawing something real) But I assume there's probably a way to stack up all my pixels into a single call and only have 1 tag/object in the same kind of way he did.
BTW: i am running strawberry perl on windows:
This is perl 5, version 30, subversion 0 (v5.30.0) built for MSWin32-x64-multi-thread
Thanks; I will try to get back to post my results in next day or so.
| [reply] |
|
|
So between your response; and the other response; I have gotten a huge amount of improvement; but I still get the hang / crash eventually.
I actually think the main thing helping; is using the single tag for all the entries, and not keeping track of them. That uses way way less memory.
I suspect the difference in using $canvas vs $mw for the idle tasks; may not matter in the end; as doing it either way clearly helps. My real script now runs almost at an acceptable level at least. I am about to go on vacation for about a week, but when I get back I'm planning on retrying this on active state perl to see if i see the same thing or not.
Thanks.
| [reply] |
|
|
