Anonymous Monk has asked for the wisdom of the Perl Monks concerning the following question:

It's fast enough on small images, but things get inconsistently slow on some images around 5MB+. I gave up after waiting 45 minutes for it to load a 22MB image. Here are some of my timings: 
Tk::Animation took 0.14844584465027 seconds for 1006835 bytes
Tk::Animation took 1.19320297241211 seconds for 2032517 bytes
Tk::Animation took 1.62702703475952 seconds for 2973341 bytes
Tk::Animation took 3.64366102218628 seconds for 4077049 bytes
Tk::Animation took 21.1366820335388 seconds for 5031810 bytes
Tk::Animation took 46.9553859233856 seconds for 5088374 bytes
Here are some details on the inconsistent timing of 2 images of similar size: 
BackgroundColor 	 0 
color_type 	 	 Indexed-RGB 
ColorResolution 	 8 
ColorTableSize 	         64 
Delay 	 		 0.2 
file_ext 	 	 gif 
file_media_type 	 image/gif 
GIF_Loop 	 	 forever 
GIF_Version 	 	 89a 
GlobalColorTableFlag 	 1 
height 	 	         955 
resolution 	 	 1/1 
ScreenHeight 	         955 
ScreenWidth 	 	 1655 
SortedColors 	         0 
width 	 		 1655 
XPosition 	 	 0 
YPosition 	 	 0 
Tk::Animation took 2.31423592567444 seconds for 4781580 bytes

BackgroundColor 	 255 
color_type 	 	 Indexed-RGB 
ColorResolution 	 8 
ColorTableSize 	         256 
Delay 	 		 0.04 
DisposalMethod 	         1 
file_ext 	 	 gif 
file_media_type 	 image/gif 
GIF_Loop 	 	 forever 
GIF_Version 	 	 89a 
GlobalColorTableFlag 	 1 
height 	 	         200 
resolution 	 	 1/1 
ScreenHeight 	         200 
ScreenWidth 	 	 480 
SortedColors 	         0 
TransparencyIndex 	 255 
width 	 		 480 
XPosition 	 	 0 
YPosition 	 	 0 
Tk::Animation took 21.7195520401001 seconds for 5031810 bytes
Here is a test script: 
#!/usr/bin/perl

use strict;
use warnings;

use File::Spec;
use Time::HiRes;

use Tk;
use Tk::Animation;

my $path = shift || die 'need an image';
die 'image not found' if not -e $path;

my $size = -s $path;

my $mw = MainWindow->new;
   $mw->configure(-title => $path);

my $top = $mw->Frame()->pack();

my $start = Time::HiRes::time;  
my $image = $mw->Animation(-format => 'gif', -file => $path);
print 'Tk::Animation took ', Time::HiRes::time - $start,
" seconds for $size bytes \n";

my $label = $top->Label(-image => $image)->pack();
$image->start_animation;

MainLoop;

[download]
I can't find the source code for Tk::Animation on CPAN (only the POD) so here it is from my local installation: 
package Tk::Animation;

use vars qw($VERSION);
$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Animation.pm#8 $

use Tk::Photo;
use base  qw(Tk::Photo);

Construct Tk::Widget 'Animation';

sub MainWindow
{
 return shift->{'_MainWIndow_'};
}

sub add_frame
{
 my $obj = shift;
 $obj->{'_frames_'} = [] unless exists $obj->{'_frames_'};
 push(@{$obj->{'_frames_'}},@_);
}

sub new
{
 my ($class,$widget,%args) = @_;
 my $obj = $class->SUPER::new($widget,%args);
 $obj->{'_MainWIndow_'} = $widget->MainWindow;
 if ($args{'-format'} eq 'gif')
  {
   my @images;
   local $@;
   while (1)
    {
     my $index = @images;
     $args{'-format'} = "gif -index $index";
     my $img;
     eval {local $SIG{'__DIE__'};  $img = $class->SUPER::new($widget,%
+args) };
     last if $@;
     push(@images,$img);
    }
   if (@images > 1)
    {
     $obj->add_frame(@images);
     $obj->{'_frame_index_'}  = 0;
    }
  }
 $obj->set_image( 0 );
 $obj->_get_gif_info;
 return $obj;
}

sub fast_forward {

    my( $self, $delta) = @_;

    $self->{_delta_} = $delta;
    if( not exists $self->{_playing_} ) {
    my $playing = exists $self->{'_NextId_'};
    $self->{_playing_} = $playing;
    $self->resume_animation if not $playing;
    } else {
    my $playing = delete $self->{_playing_};
    $self->pause_animation if not $playing;
    }

} # end fast_forward

*fast_reverse = \&fast_forward;

sub frame_count {
    my $frames = shift->{'_frames_'};
    return -1 unless $frames;
    return @$frames;
}

sub set_disposal_method {
    my( $self, $blank ) = @_;
    $blank = 1 if not defined $blank;
    $self->{_blank_} = $blank;
    $blank;
}

sub set_image
{
 my ($obj,$index)  = @_;
 my $frames = $obj->{'_frames_'};
 return unless $frames && @$frames;
 $index = 0 unless $index < @$frames;
 $obj->blank if $obj->{_blank_};  # helps some make others worse
 $obj->copy($frames->[$index]);
 $obj->{'_frame_index_'} = $index;
}

sub next_image
{
 my ($obj, $delta)  = @_;
 $obj->_next_image($delta);
}

sub _next_image
{
 my ($obj, $delta, $in_animation)  = @_;
 $delta = $obj->{_delta_} unless $delta;
 my $frames = $obj->{'_frames_'};
 return unless $frames && @$frames;
 my $next_index = (($obj->{'_frame_index_'} || 0) + $delta);
 if ($next_index > @$frames && $in_animation && $obj->{'_loop_'} ne 'f
+orever')
  {
   return 0; # signal to stop animation
  }
 $next_index %= @$frames;
 $obj->set_image($next_index);
 1;
}

sub prev_image { shift->next_image( -1 ) }

sub next_image_in_animation
{
 my ($obj, $delta) = @_;
 my $continue = $obj->_next_image($delta, 1);
 if (!$continue && $self->{'_NextId_'})
  {
   $obj->pause_animation;
  }
}

sub pause_animation { 
    my $self = shift;
    my $id = delete $self->{'_NextId_'};
    Tk::catch { $id->cancel } if $id;
}

sub resume_animation {
    my( $self, $period ) = @_;
    if( not defined $self->{'_period_'} ) {
    $self->{'_period_'} = defined( $period ) ? $period : 100;
    }
    $period = $self->{'_period_'};
    my $w = $self->MainWindow;
    $self->{'_NextId_'} = $w->repeat( $period => [ $self => 'next_imag
+e_in_animation' ] );
}

sub start_animation
{
 my ($obj,$period) = @_;
 my $frames = $obj->{'_frames_'};
 return unless $frames && @$frames;
 my $w = $obj->MainWindow;
 $obj->stop_animation;
 $obj->{'_period_'} = $period if $period;
 $obj->{'_NextId_'} = $w->repeat($obj->{'_period_'},[$obj,'next_image_
+in_animation']);
}

sub stop_animation
{
 my ($obj) = @_;
 my $id = delete $obj->{'_NextId_'};
 Tk::catch { $id->cancel } if $id;
 $obj->set_image(0);
}

sub _get_gif_info
{
 my ($obj) = @_;
 my $info;
 if (defined(my $file = $obj->cget(-file)) && eval { require Image::In
+fo; 1; })
  {
   $info = Image::Info::image_info($file);
  }
 elsif (defined(my $data = $obj->cget(-data)))
  {
   if ($data =~ m{^GIF8} && eval { require Image::Info; 1; })
    {
     $info = Image::Info::image_info(\$data);
    }
   elsif (eval { require Image::Info; require MIME::Base64; 1; })
    {
     $data = MIME::Base64::decode_base64($data);
     $info = Image::Info::image_info(\$data);
    }
  }
 if ($info)
  {
   $obj->{'_blank_'} = $info->{DisposalMethod} == 2 || $info->{Disposa
+lMethod} == 3;
   $obj->{'_period_'} = $info->{Delay}*1000 if defined $info->{Delay};
   $obj->{'_loop_'} = $info->{GIF_Loop};
  }
 $obj->{'_blank_'} = 0 if !defined $obj->{'_blank_'};
 $obj->{'_period_'} = 100 if !defined $obj->{'_period_'};
 $obj->{'_loop_'} = 'forever' if !defined $obj->{'_loop_'};
 $obj->{'_delta_'} = 1;
}

1;

__END__

#
# This almost works for changing the animation on the fly
# but does not resize things correctly
#

sub gif_sequence
{
 my ($obj,%args) = @_;
 my $widget = $obj->MainWindow;
 my @images;
 local $@;
 while (1)
  {
   my $index = @images;
   $args{'-format'} = "gif -index $index";
   my $img;
   eval
    {local $SIG{'__DIE__'};
     my $img = $widget->Photo(%args);
     push(@images,$img);
    };
   last if $@;
  }
 if (@images)
  {
   delete $obj->{'_frames_'};
   $obj->add_frame(@images);
   $obj->configure(-width => 0, -height => 0);
   $obj->set_frame(0);
  }
}

[download]

Replies are listed 'Best First'.
Re: Why is Tk::Animation so slow?
by vr (Curate) on Dec 22, 2019 at 18:46 UTC

    Reading the POD, Tk::Animation is represented as array of Tk::Photo images, which, in turn, are stored "32 bits per pixel". Apparently, when going from possibly masked and/or partial frame, paletted <=8 bpp GIF to full-frame 32 bpp data, something horribly unoptimized happens inside Tk.

    Here is a way of improving speed by 10 times (arguably, easier than examining Tk guts), for this 10 MB GIF, for which I only had to manually "collect" image data onto a "backdrop" accounting for mask of each frame (thankfully, no offsets etc. -- i.e. adjust as required for your images). I didn't try to optimize what I did with Imager, possibly it can be faster yet. + There are some glitches for couple of frames, I didn't investigate.

    use strict;
use warnings;
use feature 'say';
use Time::HiRes 'time';
use Imager ':handy';
use Tk;
use Tk::Animation;
use Tk::Photo;
use MIME::Base64;

my $path = 'Animated_GIF_cheloVechek.gif';
die 'image not found' unless -e $path;
my $size = -s $path;

my $mw = MainWindow-> new;
$mw-> configure( -title => $path );
my $top = $mw-> Frame-> pack;

my $start = time;
my $image_1 = $mw-> Animation( -format => 'gif', -file => $path );
print 'Tk::Animation took ', time - $start,
    " seconds for $size bytes \n";
$top-> Label( -image => $image_1 )-> pack;
$image_1-> start_animation;

$start = time;
my $backdrop;
my @frames = map {
    if ( $backdrop ) {              # not 1st?
        my $mask = $_-> copy;
        my @mask_plt = map NC( 255, 255, 255 ), $mask-> getcolors;
        my $trans_idx = $mask-> tags( name => 'gif_trans_index' );
        $mask_plt[ $trans_idx ] = NC( 0, 0, 0 ) if $trans_idx;
        $mask-> setcolors( colors => \@mask_plt );
        $backdrop-> compose( src => $_, mask => $mask );
    }
    else {
        $backdrop = $_
    }

    $backdrop-> write( data => \my $data, type => 'bmp' );
    $mw-> Photo( -data => encode_base64( $data ));
} Imager-> read_multi( file => $path );

my $image_2 = $mw-> Animation;
$image_2-> add_frame( @frames );
print 'Imager & Tk::Animation took ', time - $start,
    " seconds for $size bytes \n";

$top-> Label( -image => $image_2 )-> pack;
$image_2-> start_animation;

MainLoop;

__END__

Tk::Animation took 10.3439958095551 seconds for 10740455 bytes
Imager & Tk::Animation took 1.12088799476624 seconds for 10740455 byte
+s

    [download]
[reply]
[d/l]
      Very nice work. Is the problem caused by transparency? If so I can detect that and use your process to avoid the wait.

      I mentioned a 22MB GIF that didn't load after 45 minutes. It's actually 28MB and your code loads it in ~7 seconds! A tremendous improvement.

      The 28MB GIF I was working with is some gorgeous footage of Comet ISON grazing the sun taken with the Large Angle Coronagraph on NASA/ESA's Solar Heliospheric Observatory. This version of your script downloads and displays it (The minor glitches in the upper left corner are not part of the GIF. Maybe fixable by setting a proper DisposalMethod): 

      #!/usr/bin/perl

use strict;
use warnings;

use HTTP::Tiny;
use MIME::Base64;
use Time::HiRes 'time';

use Imager ':handy';
use Tk;
use Tk::Animation;
use Tk::Photo;

my $file = 'http://web.archive.org/web/20131202114602if_/'.
'http://science.nasa.gov/media/medialibrary/2013/12/01/ghost_anim.gif'
+;

print "Downloading image $file \n";

my $path = HTTP::Tiny->new->get($file)->{content};

die 'Download failed!' unless $path;

my $size = length $path;

my $mw = MainWindow-> new;
$mw-> configure( -title => 'Comet ISON via SOHO LASCO C3' );
my $top = $mw-> Frame-> pack;

my $start = time;
my $backdrop;
my @frames = map {
    if ( $backdrop ) {              # not 1st?
        my $mask = $_-> copy;
        my @mask_plt = map NC( 255, 255, 255 ), $mask-> getcolors;
        my $trans_idx = $mask-> tags( name => 'gif_trans_index' );
        $mask_plt[ $trans_idx ] = NC( 0, 0, 0 ) if $trans_idx;
        $mask-> setcolors( colors => \@mask_plt );
        $backdrop-> compose( src => $_, mask => $mask );
    }
    else {
        $backdrop = $_
    }

    $backdrop-> write( data => \my $data, type => 'bmp' );
    $mw-> Photo( -data => encode_base64( $data ));
} Imager-> read_multi( data => $path );

my $image_2 = $mw-> Animation;
$image_2-> add_frame( @frames );

print "\nImager & Tk::Animation took ", time - $start,
    " seconds for $size bytes \n";

$top-> Label( -image => $image_2 )-> pack;
$image_2-> start_animation;

MainLoop;

__END__

Imager & Tk::Animation took 6.60826396942139 seconds for 28042970 byte
+s

      [download]
      Hopefully someone can use this information to figure out what's wrong with Tk::Photo and get it fixed!
[reply]
[d/l]

        Ah, I knew it: code runs with result (almost) as expected on 1st attempt: no errors, no typos even. Then something _must_ be wrong with it:). Because of those "glitches" I said "almost" and "didn't investigate", though I should have :)

        First thing, "copy" method doesn't copy gif tags (bug in Imager?), $trans_idx was undefined, mask always blank.

        However, "compose" method apparently works, even if source image is converted to 3 channel RGB (no alpha) with "to_rgb8", and mask attribute not supplied at all. Statement in fragment further below could be replaced with

        $backdrop-> rubthrough( src => $_-> to_rgb8, 
                        tx => $left, ty => $top );

        [download]

        and animation would still work. Where and why Imager gets transparency information in this case -- I don't know. I'd expect the result be the same as with "paste" method (you can try it if you wish -- that's where there are no masks, no transparency).

        Further, I should have checked for offsets of gif frames -- they are not always zero. Whole "if else" fragment can be replaced with the following (though mask may be unnecessary(?), I'm not omitting it):

            if ( $backdrop ) {              # not 1st?
        my $mask = $_-> copy;
        my @mask_plt = map NC( 255, 255, 255 ), $_-> getcolors;
        my $trans_idx = $_-> tags( name => 'gif_trans_index' );
        my $left      = $_-> tags( name => 'gif_left' );
        my $top       = $_-> tags( name => 'gif_top' );

        $mask_plt[ $trans_idx ] = NC( 0, 0, 0 ) 
            if defined $trans_idx;
        $mask-> setcolors( colors => \@mask_plt );
        $backdrop-> compose( src => $_, mask => $mask, 
                             tx => $left, ty => $top );
    }
    else {
        $backdrop = $_-> to_rgb8
    }

        [download]
[reply]
[d/l]
[select]
Re: Why is Tk::Animation so slow?
by Anonymous Monk on Dec 24, 2019 at 09:55 UTC 
    #!/usr/bin/perl

=head1 DESCRIPTION

This program demonstrates how to load a large GIF animation
in Perl Tk without having to wait forever. Thank you vr!

Question: Why is Tk::Animation so slow?
https://www.perlmonks.org/index.pl?node_id=11110499

Answer: Apparently...something horribly unoptimized happens inside Tk.
https://www.perlmonks.org/index.pl?node_id=11110521
https://www.perlmonks.org/index.pl?node_id=11110545

=head1 SYNOPSIS

On first run it downloads and saves a 28MB animated GIF
from archive.org to the current directory. Subsequent runs
use the local image. The image is Comet ISON grazing the sun
taken with the Large Angle Coronagraph on NASA/ESA's Solar
Heliospheric Observatory.

=cut

use autodie;
use strict;
use warnings;

use HTTP::Tiny;
use MIME::Base64;
use Time::HiRes 'time';

use Imager ':handy';
use Tk;
use Tk::Animation;
use Tk::Photo;

my $file = 'ghost_anim.gif';
my $path;

if (-e $file) {
  print "Loading image $file \n";
  open my $fh, '<', $file;
  $path = join '', <$fh>
}
else {
  my $http = 'http://web.archive.org/web/20131202114602if_/'.
  'http://science.nasa.gov/media/medialibrary/2013/12/01/'.
  $file;
  
  print "Downloading image $http \n";
  
  $path = HTTP::Tiny->new->get($http)->{content};
  die 'Download failed!' unless $path;
  
  open my $fh, '>', $file;
  $fh->binmode;
  print $fh $path
}
my $size = length $path;

my $mw = MainWindow->new;
$mw->configure(-title => 'Comet ISON via SOHO LASCO C3');
my $top = $mw->Frame->pack;

my $backdrop;
my $start = time;

my @frames = map {
  if ($backdrop) { # not 1st?
    my $mask      = $_->copy;
    my @mask_plt  = map NC(255, 255, 255), $_->getcolors;
    my $trans_idx = $_->tags(name => 'gif_trans_index');
    my $left      = $_->tags(name => 'gif_left');
    my $top       = $_->tags(name => 'gif_top');

    $mask_plt[$trans_idx] = NC(0, 0, 0) 
    if defined $trans_idx;
    
    $mask->setcolors(colors => \@mask_plt);
    
    $backdrop->compose(
      src  => $_,
      mask => $mask, 
      tx   => $left,
      ty   => $top
    )
  }
  else {
    $backdrop = $_->to_rgb8
  }
  $backdrop->write(data => \my $data, type => 'bmp');
  $mw->Photo(-data => encode_base64($data))
  
} Imager->read_multi(data => $path);

my $image = $mw->Animation;
$image->add_frame(@frames);

print join ' ',
"\nImager & Tk::Animation took", time - $start,
"seconds for $size bytes \n";

$top->Label(-image => $image)->pack;
$image->start_animation;

MainLoop

    [download]
[reply]
[d/l]
Re: Why is Tk::Animation so slow?
by Anonymous Monk on Dec 22, 2019 at 02:51 UTC
[reply]
      Here's the data on 2 animations with similar filesize, parts (frames), colortable, and delay but I still can't see why the slow one spends so much time in Tk::image::new: 
       my $obj = $widget->Tk::image('create',$leaf,@_); # the slowest line of code

      GIF1 3.9M
66 parts
Tk::Animation took 3.60994100570679 seconds for 4096259 bytes

Stmts	Exclusive
	Time 		Source File
490	3.29s	line	Tk/Image.pm
659	812ms	line	Tk.pm
102086	274ms	line	Image/Info/GIF.pm

# spent 3.29s (2.17ms+3.29) within Tk::Image::new which was called 68 times, avg 48.4ms/call: 
# 67 times (2.15ms+3.29s) by Tk::Animation::new at line 37 of Tk/Animation.pm, avg 49.1ms/call 
# once (28µs+2.33ms) by Tk::Animation::new at line 26 of Tk/Animation.pm

# spent 121ms (57.5+63.4) within Image::Info::GIF::my_read which was called 16632 times, avg 7µs/call:
# 16094 times (56.0ms+63.3ms) by Image::Info::GIF::seek_data_blocks at line 50, avg 7µs/call
#   203 times (582µs+47µs) by Image::Info::GIF::read_data_blocks at line 41, avg 3µs/call
#   134 times (375µs+50µs) by Image::Info::GIF::process_file at line 110, avg 3µs/call
#    67 times (166µs+13µs) by Image::Info::GIF::process_file at line 152, avg 3µs/call
#    66 times (179µs+20µs) by Image::Info::GIF::process_file at line 143, avg 3µs/call
#    66 times (164µs+10µs) by Image::Info::GIF::process_file at line 126, avg 3µs/call
#        once (11µs+9µs) by Image::Info::GIF::process_file at line 59
#        once (1µs+1µs) by Image::Info::GIF::process_file at line 99

BackgroundColor  0
ColorResolution  8
ColorTableSize 	 256
Delay 	         0.08
DisposalMethod 	 1
GIF_Loop 	 forever
GIF_Version 	 89a
GlobalColorTableFlag 	 1
ScreenHeight 	 360
ScreenWidth 	 300
SortedColors 	 0
XPosition 	 0
YPosition 	 0
color_type 	 Indexed-RGB
file_ext 	 gif
file_media_type  image/gif
height 	         360
resolution 	 1/1
width 	         300

      GIF2 4.9M
60 parts
Tk::Animation took 33.700756072998 seconds for 5088374 bytes 

Stmts	Exclusive
	Time 		Source File
448	33.4s	line	Tk/Image.pm
645	738ms	line	Tk.pm
124973	254ms	line	Image/Info/GIF.pm
	
# spent 33.4s (1.58ms+33.4) within Tk::Image::new which was called 62 times, avg 539ms/call:
# 61 times (1.54ms+33.4s) by Tk::Animation::new at line 37 of Tk/Animation.pm, avg 548ms/call
#     once (39µs+6.58ms) by Tk::Animation::new at line 26 of Tk/Animation.pm

# spent 112ms (54.6+57.9) within Image::Info::GIF::my_read which was called 20478 times, avg 5µs/call:
# 19957 times (53.3ms+57.7ms) by Image::Info::GIF::seek_data_blocks at line 50, avg 6µs/call
#   214 times (539µs+57µs) by Image::Info::GIF::read_data_blocks at line 41, avg 3µs/call
#   123 times (284µs+40µs) by Image::Info::GIF::process_file at line 110, avg 3µs/call
#    62 times (117µs+14µs) by Image::Info::GIF::process_file at line 152, avg 2µs/call
#    60 times (167µs+6µs) by Image::Info::GIF::process_file at line 126, avg 3µs/call
#    60 times (130µs+15µs) by Image::Info::GIF::process_file at line 143, avg 2µs/call
#        once (16µs+16µs) by Image::Info::GIF::process_file at line 59
#        once (5µs+2µs) by Image::Info::GIF::process_file at line 99

BackgroundColor.  0
ColorResolution   8
ColorTableSize 	  256
Delay 	          0.03
DisposalMethod 	  1
GIF_Loop 	  forever
GIF_Version 	  89a
GlobalColorTableFlag 	 1
ScreenHeight 	  480
ScreenWidth 	  480
SortedColors 	  0
TransparencyIndex 255
XPosition 	  0
YPosition 	  0
color_type 	  Indexed-RGB
file_ext 	  gif
file_media_type   image/gif
height 	          480
resolution 	  1/1
width 	          480
      Thank you
[reply]

        but I still can't see why the slow one spends so much time in Tk::image::new:

        Look deeper ;)

[reply]
Re: Why is Tk::Animation so slow?
by Anonymous Monk on Dec 22, 2019 at 09:06 UTC
[reply]
[reply]

Back to Seekers of Perl Wisdom