Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
164 lines (122 sloc) 3.79 KB
#!perl
use strict;
use Imager;
use Getopt::Long;
my $delay = 10;
my $frames = 20;
my $low_pct = 30;
my $back = '#FFFFFF';
my $verbose = 0;
GetOptions('delay|d=i', \$delay,
'frames|f=i', \$frames,
'lowpct|p=i', \$low_pct,
'back|b=s', \$back,
'verbose|v' => \$verbose);
my $back_color = Imager::Color->new($back)
or die "Cannot convert $back to a color: ", Imager->errstr, "\n";
$low_pct >= 0 && $low_pct < 100
or die "lowpct must be >=0 and < 100\n";
$delay > 0 and $delay < 255
or die "delay must be between 1 and 255\n";
$frames > 1
or die "frames must be > 1\n";
my $in_name = shift
or usage();
my $out_name = shift
or usage();
my $base = Imager->new;
$base->read(file => $in_name)
or die "Cannot read image file $in_name: ", $base->errstr, "\n";
# convert to RGBA to simplify the convert() matrix
$base = $base->convert(preset => 'rgb') unless $base->getchannels >=3;
$base = $base->convert(preset => 'addalpha') unless $base->getchannels == 4;
my $width = $base->getwidth;
my $height = $base->getheight;
my @down;
my $down_frames = $frames / 2;
my $step = (100 - $low_pct) / $down_frames;
my $percent = 100 - $step;
++$|;
print "Generating frames\n" if $verbose;
for my $frame_no (1 .. $down_frames) {
print "\rFrame $frame_no/$down_frames";
# canvas with our background color
my $canvas = Imager->new(xsize => $width, ysize => $height);
$canvas->box(filled => 1, color => $back_color);
# make a version of our original with the alpha scaled
my $scale = $percent / 100.0;
my $draw = $base->convert(matrix => [ [ 1, 0, 0, 0 ],
[ 0, 1, 0, 0 ],
[ 0, 0, 1, 0 ],
[ 0, 0, 0, $scale ] ]);
# draw it on the canvas
$canvas->rubthrough(src => $draw);
push @down, $canvas;
$percent -= $step;
}
print "\n" if $verbose;
# generate a sequence going from the original down to the most faded
my @frames = $base;
push @frames, @down;
# remove the most faded frame so it isn't repeated
pop @down;
# and back up again
push @frames, reverse @down;
print "Writing frames\n" if $verbose;
Imager->write_multi({ file => $out_name,
type => 'gif',
gif_loop => 0, # loop forever
gif_delay => $delay,
translate => 'errdiff',
make_colors => 'mediancut',
},
@frames)
or die "Cannot write $out_name: ", Imager->errstr, "\n";
sub usage {
die <<EOS;
Produce an animated gif that cycles an image fading into a background and
unfading back to the original image.
Usage: $0 [options] input output
Input can be any image supported by Imager.
Output should be a .gif file.
Options include:
-v | --verbose
Progress reports
-d <delay> | --delay <delay>
Delay between frames in 1/100 sec. Default 10.
-p <percent> | --percent <percent>
Low percentage coverage. Default: 30
-b <color> | --back <color>
Color to fade towards, in some format Imager understands.
Default: #FFFFFF
-f <frames> | --frames <frames>
Rough total number of frames to produce. Default: 20.
EOS
}
=head1 NAME
flasher.pl - produces a slowly flashing GIF based on an input image
=head1 SYNOPSIS
perl flasher.pl [options] input output.gif
=head1 DESCRIPTION
flasher.pl generates an animation from the given image to C<lowpct>%
coverage on a blank image of color C<back>.
=head1 OPTIONS
=over
=item *
C<-f> I<frames>, C<--frames> I<frames> - the total number of frames.
This is always rounded up to the next even number. Default: 20
=item *
C<-d> I<delay>, C<--delay> I<delay> - the delay in 1/100 second between
frames. Default: 10.
=item *
C<-p> I<percent>, C<--lowpct> I<percent> - the lowest coverage of the image.
Default: 30
=item *
C<-b> I<color>, C<--back> I<color> - the background color to fade to.
Default: #FFFFFF.
=item *
C<-v>, C<--verbose> - produce progress information.
=back
=head1 AUTHOR
Tony Cook <tonyc@cpan.org>
=cut
Jump to Line
Something went wrong with that request. Please try again.