wulvrine has asked for the wisdom of the Perl Monks concerning the following question:
A question for my fellow monks,
I am having difficulty with a small TK program I am writing that moves little 'bots' around on a canvas. After a short period, TK canvas will stop any display updates. The program continues to run underneath, but the updates no longer happen.
I have shrunk the original program down to this example that brings up a 150x150 pixel canvas with 6 'bots' only travelling up, covering the screen one pixel at a time with a color. After a few minutes of running the updates will just 'stop'.
I am keeping track of the canvas ids for 'deletion' when a bot walks over a pixel already drawn in an attempt to limit the number of ids. However, even at 100x100, thats 10k canvas ids. I do, however, want to 'walk' one pixel at a time. Could this be just hitting a wall with too many id's or some other memory requirement?
Any help is appreciated.
#! /usr/bin/perl
##############
# freeze.pl #
##############
use strict;
use warnings;
use Tk;
my $mw; #main window
my $maxX = 150;
my $maxY = 150;
my $canvasMaxX;
my $canvasMaxY;
my $canvas; #canvas object
my %bots; #Hash containing bot ID's, position, color
my $debug = 1;
# Pack parameter abbreviations
my $psides = { 't' => 'top', 'l' => 'left', 'r' => 'right', 'b' => 'bo
+ttom' };
my $pfills = { 'b' => 'both', 'n' => 'none' };
#main display grid
my @dispGrid;
#set entire grid to some neutral color
map { my $row = $_;
map {$dispGrid[$row][$_]{"colored"} = 0; } (0..$maxY);
} (0..$maxX);
#create the main gui etc
create_gui();
#place bots at random positions with
#random colors and directions
for my $b (0 .. 6) {
$bots{$b}->{"x"} = 0 + $b*(($maxX/6));
$bots{$b}->{"y"} = $maxY/2;
}
#Move the bots and update the display, repeatedly
$mw->repeat(100,\&updateBots);
MainLoop();
###############################
### Convenience Tk routines ###
###############################
sub packit {
my ($w, $side_exp_fill) = @_;
my ($side, $exp, $fill) = ($side_exp_fill =~ /(.)(.)(.)/);
defined($psides->{$side}) and $side = $psides->{$side};
defined($pfills->{$fill}) and $fill = $pfills->{$fill};
$w->pack(-side => $side, -expand => $exp, -fill => $fill);
return $w;
}
sub frame {
my ($w, $bg, $side_exp_fill) = @_;
my $fr = $w->Frame(-bg => $bg);
return packit($fr, $side_exp_fill);
}
#state normal, disabled, hidden
sub canvas {
my ($w, $width, $h, $state, $psub, $side_exp_fill) = @_;
my $bg = $w->cget(-bg);
my $c = $w->Canvas(-bg=>$bg, -state=>$state);
$psub and $c->configure(-command => $psub);
$h and $c->configure(-height => $h);
$width and $c->configure(-width => $width);
return(packit($c,$side_exp_fill));
}
#Create the main gui interface
sub create_gui {
# Main applcation window.
$mw = MainWindow->new("title", "tk-freeze");
#Create a group of frames to help in aligning items
my $mainFrame = frame($mw, 'cyan', "t1b");
my $canvasFrame = frame($mainFrame, 'white', "t1b");
my $canWidth = $maxX;
my $canHeight = $maxY;
$canvas = canvas($canvasFrame, ,$canWidth, $canHeight, "normal", 0,
+"t1b");
}
#delete a previously drawn bot
#use the group id to delete group members
sub deleteBot {
my ($bid)= @_;
my $bcid = $bots{$bid}{"canvasID"};
#delete the old drawing of this bot
if (defined $bcid) {
$canvas->delete($bcid);
}
$bots{$bid}{"canvasID"} = undef;
}
#draw a bot, be wary of edje cases. Also change
#bot facing and its color
sub drawBot {
my ($bid) = @_;
#clear out old version of drawn bot
deleteBot($bid);
my $bx = $bots{$bid}{"x"};
my $by = $bots{$bid}{"y"};
my $bnx = $bots{$bid}{"newX"};
my $bny = $bots{$bid}{"newY"};
#need color name to use in 'draw line' function
my $bc = "magenta";
#draw new bot
#while going through directions see if we hit boundary conditions
my $boundHit = boundcheck($bid);
my $body = $canvas->createRectangle($bnx-1,$bny-1,$bnx+1,$bny+1);
#save canvasID for later use
$bots{$bid}{"canvasID"} = $body;
#draw line
if ($boundHit == 0) {
#delete any line id that might already exist at the point in que
+stion
my $line = $dispGrid[$by][$bx]{"lineID"};
$canvas->delete($line) if ($line);
#draw new line, remember the id
my $id = $canvas->createLine($bx,$by,$bnx,$bny,-fill=>$bc,-tag=>
+"line");
#save id of new line for later deletion
$dispGrid[$by][$bx]{"lineID"} = $id;
}
#update the display grid showing spot has been colored
$dispGrid[$by][$bx]{"colored"}= 1;
$bots{$bid}{"x"} = $bots{$bid}{"newX"};
$bots{$bid}{"y"} = $bots{$bid}{"newY"};
#debugging stuff, how many canvas items do we have.
my @tags = $canvas->find("all");
my $total = $#tags +1;
print " There are " . @tags . " canvas items \n" if ($debug);
}
#move a bot to its new position,
sub moveBot {
my ($bid) = @_;
my $bx = $bots{$bid}{"x"};
my $by = $bots{$bid}{"y"};
$bots{$bid}{"newX"} = $bx;
$bots{$bid}{"newY"} = $by-1;
#have we hit something already drawn upon, move over a pixel
if ($dispGrid[$by][$bx]{"colored"} == 1) {
$bots{$bid}{"newX"} = $bx+1;
}
}
sub updateBots() {
#cycle through all 'bots', update all the bots position and directio
+n
foreach my $bot (keys %bots) {
moveBot($bot);
drawBot($bot);
}
}
#did we hit a side?
sub boundcheck {
my ($bid) = @_;
my $hit = 1;
my $nx = $bots{$bid}{"newX"};
my $ny = $bots{$bid}{"newY"};
if ($nx>$maxX) {
$bots{$bid}{"newX"}= 0;
} elsif ($ny<0) {
$bots{$bid}{"newY"}= $maxY;
} else {
$hit = 0;
}
return $hit;
}
s&&VALKYRIE &&& print $_^q|!4 =+;' *|
Re: Problems with Tk freezing
by zentara (Archbishop) on Feb 06, 2007 at 17:43 UTC
|
Hi, I ran your program and can see what the problem is. You are creating too many canvas items, and not deleting them when they leave the visual part of the canvas. After you hit about 6000 items, the canvas bogs down because it can't update that many items in the time span you give it. Any Tk widget can be overloaded to the point where it bogs down.
So what you need to do is watch for when an item leaves the visible canvas, then delete it. Even that may not be good enough. What you should do is create a set of display objects, as many as you want to handle in view at any one time, and reuse them, and reconfigure them. The script below demonstrates this. I used Zinc, instead of Tk, because I wanted rotations, and some other cool Zinc stuff, but the same principle would work in the plain Tk canvas. I create 100 bubble objects, and when they leave the viewable screen, I don't delete them, but reconfigure them to be reused. This script can run all day, without bogging down.
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::Zinc;
my $mw = MainWindow->new;
$mw->geometry("700x600");
$mw->resizable(0,0);
my $launcher;
my $zinc = $mw->Zinc(-width => 700, -height => 565,
-backcolor => 'black',
-borderwidth => 3, -relief => 'sunken')->pack();
# Then we create a filled rectangle, in which we will display explain
+text.
$zinc->add('rectangle', 1 , [200, 400, 490, 490],
-linewidth => 2,
-filled => 1,
-fillcolor => 'SkyBlue',
-priority => 1,
);
my $text = $zinc->add('text', 1,
-position => [350, 445],
-anchor => 'center',
-priority => 3,
-width => 200,
);
#####setup 100 bubble objects for reuse#############################
my %bubs; #reusable object space
our @bubjects = (1..100); #shared array for object reuse
my @x = (1,-2,3,-4,5, -1,2,-3,4,-5 ); #give random diagonal motion
our $count = 0;
foreach my $bub (@bubjects){
$count++;
my $tag = $count;
push (@x,shift(@x));
my $afterdelay = 1 + int(rand(99));
# Create the 100 ztkbubble object (see Package ztkbubble below)
$bubs{$bub} = ZtkBubble->new(
-widget => $zinc,
-name => $count,
-bub => $bub,
-tags => $tag,
-x => rand 700,
-y => 700,
-radius => 10 + rand(30),
-color => 'white',
-dx => $x[0],
-dy => -20,
-afterdelay => $afterdelay,
);
}
###########################################################
# Display comment
&comment("Strike any key to begin");
# Create Tk binding
$mw->Tk::bind('<Key>', \&openmode);
my $closebutton = $mw->Button(-text => 'Exit',
-command => sub{
if(defined $launcher){$launcher->cancel};
exit(0);
})->pack;
MainLoop;
#####################################################
sub openmode {
$mw->Tk::bind('<Key>', \&closemode);
&comment("Bubbling!!");
# 50 is about my max on a 800 Mhz K6, adjust accordingly
$launcher = $mw->repeat(500,sub{
my $bub = shift @bubjects;
$bubs{$bub}->bubble_move();
# print "bubjects->@bubjects\n";
});
}
sub closemode {
# and then inform user
&comment("We are bubbling baby !!");
}
# Just display comment
sub comment {
my $string = shift;
$zinc->itemconfigure($text, -text => $string);
}
#=====================================================================
+========
# ZtkBubble Class
#=====================================================================
+========
package ZtkBubble;
use strict 'vars';
use Carp;
#====================
# Object constructor
#====================
sub new {
my ($class, %arg) = @_;
# object attributes
my $self = {
'widget' => $arg{-widget}, # widget reference into which it g
+oes
'name' => $arg{-name}, #identifying name
'bub' => $arg{-bub}, #which reusable bubble space i
+t's using
'tags' => $arg{-tags}, # tag object of self
'x' => $arg{-x},
'y' => $arg{-y}, # origin coordinates
'radius' => $arg{-radius}, # radius
'color' => $arg{-color}, # top Group item
'dx' => $arg{-dx}, # initial x direction
'dy' => $arg{-dy}, # initial y direction
'afterdelay' => $arg{-afterdelay}, # repeater time delay
};
bless $self;
# print "just blessed $self\n";
$self->{self} = $self;
$self->{topgroup} = $self->{widget}->add('group', 1,
-priority => 2,
-visible => 1);
$self->{widget}->coords($self->{topgroup}, [$self->{x},$self->{y}]
+);
$self->{timer} = ''; #declare variable to store internal timer
$self->{'init'} = $self->{widget}->tget( $self->{topgroup} );
# print join ' ',@{ $self->{init} },"\n"; #initial position
my $color1 = '#';
for (0 .. 2){
my $rgb = unpack('H*', pack('n', (int(rand(192)+64))));
$rgb =~ s/.+(\w\w)$/$1/;
$color1 .= $rgb;
}
#add items to self group
$self->{arc1} =
$self->{widget}->add('arc', $self->{topgroup},
[-$self->{radius}, -$self->{radius}, $self->{radius}, $se
+lf->{radius}],
# -visible => 1,
-filled => 1,
# -closed => 1,
# -extent => 360,
# -pieslice => 1,
-fillcolor => $color1,
# -linewidth => 1,
# -startangle => 0 ,
-tags => [$self->{tags},'bubble'],
);
$self->{arc2} =
$self->{widget}->add('arc', $self->{topgroup},
[-$self->{radius}/2, -$self->{radius}/2, $self->{radius}/
+2, $self->{radius}/2],
# -visible => 1,
-filled => 1,
# -closed => 1,
# -extent => 360,
# -pieslice => 1,
-fillcolor => $self->{color},
# -linewidth => 1,
# -startangle => 0 ,
-tags => [$self,'bubble'],
);
# Create the Text item representing the jackpot.
$self->{txt} =
$self->{widget}->add('text', $self->{topgroup},
-position => [0, 0],
-anchor => 'center',
-text => $self->{'name'},
);
$self->{line} =
$self->{widget}->add('curve', $self->{topgroup},
[-$self->{radius}, -$self->{radius},$self->{radius}, $sel
+f->{radius}],
-visible => 1,
-linecolor => 'white',
-linewidth => 3,
-tags => [$self,'bubble'],
);
return $self;
}
#############################################
sub DESTROY{
my ($self) = @_;
print "destroying->",$self,' ', $self->{bub}. "\n";
}
###########################################
#================
# Public methods
#================
# Start motion of $self
sub bubble_move {
my $self = shift;
$self->_move();
}
#=================
# Private methods
#=================
sub _close {
my ($self) = @_;
my $widget = $self->{widget};
my $group = $self->{topgroup};
my $name = $self->{name};
my $bub = $self->{bub};
my $tag = $self->{tags};
&main::comment("Poof!! name->$name bub#->$bub");
$widget->dtag($tag);
$self->{timer}->cancel;
push @main::bubjects, $self->{bub}; #return to pool
#$self->DESTROY; #don't use this, since we are reusing them
}
# Generate motion and rotation animation.
sub _move {
my ($self) = @_;
my $widget = $self->{widget};
my $group = $self->{topgroup};
$widget->translate($group, $self->{'dx'} ,$self->{'dy'});
$self->{x} += $self->{'dx'};
$self->{y} += $self->{'dy'};
#check for side collisions
if( ( $self->{x} < 0) or ($self->{x} > $self->{widget}->reqwidth )
+)
{ $self->{'dx'} *= -2 }
#reset bubbles for next run with new name
if($self->{y} < -$self->{radius}){
$self->_close();
$self->{widget}->tset( $self->{topgroup} , @{ $self->{init} }
+ );
# print join ' ',@{ $self->{init} },"\n";
$self->{x} = ${ $self->{init} }[4];
$self->{y} = ${ $self->{init} }[5];
# $self->{widget}->coords($self->{topgroup}, [$self->{x},$sel
+f->{y}]);
$self->{name} = $main::count++;
$self->{widget}->itemconfigure($self->{txt}, -text => $self->
+{'name'} );
return }
$widget->rotate($group,.9,$self->{x},$self->{y} );
#use $self->timer instead of anonymous timer, in order to cancel on cl
+ose
$self->{timer} = $widget->after($self->{afterdelay}, sub { $self->_mov
+e() });
}
1;
| [reply] [d/l] |
Re: Problems with Tk freezing
by rinceWind (Monsignor) on Feb 06, 2007 at 15:36 UTC
|
You might want to pepper some of your callbacks with calls to $mw->update, especially where it's compute bound.
--
Oh Lord, won’t you burn me a Knoppix CD ?
My friends all rate Windows, I must disagree.
Your powers of persuasion will set them all free,
So oh Lord, won’t you burn me a Knoppix CD ? (Missquoting Janis Joplin)
| [reply] [d/l] |
|
| [reply] |
|
Having a second look at the code, your app looks very busy. When does it ever hand control back to the event loop to process events?
My suggestion is to defer some of the movement events by using timers with after or repeat. This will relinquish some control back to the controlling event loop, and it might get a chance to service some events that have been queued up.
--
Oh Lord, won’t you burn me a Knoppix CD ?
My friends all rate Windows, I must disagree.
Your powers of persuasion will set them all free,
So oh Lord, won’t you burn me a Knoppix CD ? (Missquoting Janis Joplin)
| [reply] |
Re: Problems with Tk freezing
by eric256 (Parson) on Feb 06, 2007 at 16:21 UTC
|
If you use a pattern like Language::Logo where the graphic portion is a separate thread, then you could handle the bots in one thread and the display in a separate thread. Then your bots could update at a rate that is not linked to your display refresh. I don't know how to do this ;) but it would be cool if someone built a module that would allow this kind of disassociation between a Tk window and long running processes
| [reply] |
|
| [reply] |
Re: Problems with Tk freezing
by wulvrine (Friar) on Feb 06, 2007 at 18:39 UTC
|
Thanks for the help all!
rinceWind
I am unsure where to try those update commands, every place I have tried has left me with a 'deep recursion' error
eric256<bbr>
Good Idea though I think I will have the same problem doing the client server technique I suggested to liverpole for that project.
Zentara
Besides a great example zinc code (cool! thanks!) I think you have hit the problem on the head. The unfortunate problem is, I 'am' doing just that. At least as far as the original concept is concerned. @dispGrid is actually recording the id of the line going over that pixel. Later, if another line (not in this smaller example) walks over a path, it uses @dispGrid to erase the pixel and re-draw the new one, re-recording the ID. Remove the following section from the above code
if ($dispGrid[$by][$bx]{"colored"} == 1) {
$bots{$bid}{"newX"} = $bx+1;
}
which will move the bot over one position if it hits something already walked upon. Re-run and after they make one full screenwidth the ids stop accumulating.
I really wanted to walk a line one pixel at a time, so every pixel is, unfortunately, a seperate, persistant line segment. The items never 'go off the canvas' they wrap around and continue (or potentially bounce). So this little project may be just too 'big' for Tk's abilities to handle??
Thanks for the help!!
s&&VALKYRIE &&& print $_^q|!4 =+;' *|
| [reply] [d/l] |
|
Yeah, I see you try to handle deleting objects in your code, but the sad fact is, you are overlooking something. In my experience, it is a hash key that is not getting completely removed, or you get auto-vivication in some hashes. But without actually trying to trouble shoot your code, and just from your comment " so every pixel is, unfortunately, a seperate, persistant line segment" , you need to rethink how you draw your lines, so that every pixel IS NOT a new segment. My first thought would be to create 1 segment for each moving object. Then as it moves and consumes another pixel, reconfigure the original segment to the end points of the collective pixels. If you think about it a bit, you should be able to do this easily, especially if they move vertically. I encountered a similar problem in Tk Realtime data aquisition, where I was adding many segments to a continuing graph, and the cpu would bog down after awhile. My solution was to use segments up to a point, then write them out as a solid non-updating curve, then start another temporary segment.
So this little project may be just too 'big' for Tk's abilities to handle?? No you are reaching a point where your desire to use straight forward programming techniques is hitting the limit, where you need to start creatively juggling. Just about any language you use, that has a canvas (and canvas items) will be the same. You cannot expect a widget to handle a gazzillion items, as effectively as a few hundred. BUT if you really insist on following your way of thinking, you might want to switch to SDL. SDL dosn't have the notion of line segments to keep track of, In SDL you write something to the screen and forget it and move on. This has advantages in situations like yours, but disadvantages in that there is no way to easily identify and manipulate an existing segment, and if it gets erased from the screen, it's gone. Just think about an algorithm that you can feed a set of points (pixels) and it will return 2 pixels which are the extreme end points. Then use those 2 points to reconfigure the bot on the update. That way your canvas will only be handling a fixed number of lines at any one time, just making them longer thru a reconfigure. Or if you eventually want to move along curves, use the technique I showed in Tk Realtime data aquisition, and have each bot, after say 100 updates, leave the last 100 points as a solid non-updatable curve, then start another 100 pixel set which is continually updated.
| [reply] |
|
| [reply] |
|
|
|