Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

Re: Why is Tk::Animation so slow?

by vr (Curate)
on Dec 22, 2019 at 18:46 UTC ( [id://11110521]=note: print w/replies, xml ) Need Help??


in reply to Why is Tk::Animation so slow?

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

Replies are listed 'Best First'.
Re^2: Why is Tk::Animation so slow?
by Anonymous Monk on Dec 23, 2019 at 08:15 UTC
    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

    Hopefully someone can use this information to figure out what's wrong with Tk::Photo and get it fixed!

      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 );

      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 }

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://11110521]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others imbibing at the Monastery: (4)
As of 2024-04-19 06:21 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found