Prima::Image::AnimateGIF - animate gif files

	use Prima qw(Application Image::AnimateGIF);
	my $x = Prima::Image::AnimateGIF->load($ARGV[0]);
	die $@ unless $x;
	my ( $X, $Y) = ( 0, 100);
	my $background = $::application-> get_image( $X, $Y, $x-> size);
	$::application-> begin_paint;

	while ( my $info = $x-> next) {
		my $frame = $background-> dup;
		$frame-> begin_paint;
		$x-> draw( $frame, 0, 0);
		$::application-> put_image( $X, $Y, $frame);

		$::application-> sync;
		select(undef, undef, undef, $info-> {delay});
	}

        $::application-> put_image( $X, $Y, $g);

#  Copyright (c) 2008 Dmitry Karasik
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
#
# $Id$
package Prima::Image::AnimateGIF;

use strict;
use warnings;
use Carp;
use Prima;

use constant DISPOSE_NOT_SPECIFIED    => 0; # Leave frame, let new frame draw on top
use constant DISPOSE_KEEP             => 1; # Leave frame, let new frame draw on top
use constant DISPOSE_CLEAR            => 2; # Clear the frame's area, revealing bg
use constant DISPOSE_RESTORE_PREVIOUS => 3; # Restore the previous (composited) frame

sub new
{
	my $class = shift;
	my $self = bless {
		images     => [],
		@_,
		current    => -1,
	}, $class;

	$self-> reset;

	return $self;
}

sub load
{
	my $class = shift;

	my ( $where, %opt) = @_;

	# have any custom notifications?
	my ( %events, %args);
	while ( my ( $k, $v) = each %opt) {
		my $hash = ($k =~ /^on[A-Z]/ ? \%events : \%args);
		$hash-> {$k} = $v;
	}
	
	my $i = Prima::Icon-> new(%events); # dummy object

	my @i = $i-> load(
		$where,
		loadExtras => 1, 
		loadAll    => 1, 
		iconUnmask => 1,
		%args,
	);

	return unless @i;

	return $class-> new( images => \@i);
}

sub add
{
	my ( $self, $image) = @_;
	push @{$self-> {images}}, $image;
}

sub get_extras
{
	my ( $self, $ix) = @_;
	$ix = $self-> {images}-> [$ix];
	return unless $ix;

	my $e = $ix-> {extras} || {};

	$e-> {screenHeight}     ||= $ix-> height;
	$e-> {screenWidth}      ||= $ix-> width;
	$e-> {$_} ||= 0 for qw(disposalMethod useScreenPalette delayTime left top);

	$e-> {iconic} = 
		$ix-> isa('Prima::Icon') 
		&& $ix-> autoMasking != am::None; 
		# gif doesn't support explicit masks, therefore
		# when image actually has a mask, autoMaskign is set to am::Index

	return $e;
}

sub fixup_rect
{
	my ( $self, $info, $image) = @_;
	return if defined $info-> {rect};
	$info-> {rect} = {
		bottom => $self-> {screenHeight} - $info-> {top} - $image-> height,
		top    => $self-> {screenHeight} - $info-> {top} - 1,
		right  => $info-> {left} + $image-> width - 1,
		left   => $info-> {left},
	};
}

sub union_rect
{
	my ( $r1, $r2) = @_;
	return { %$r2 } unless grep { $r1-> {$_} } qw(left bottom right top);
	return { %$r1 } unless grep { $r2-> {$_} } qw(left bottom right top);

	my %ret = %$r1;


	for ( qw(left bottom)) {
		$ret{$_} = $r2-> {$_}
			if $ret{$_} > $r2-> {$_};
	}
	for ( qw(right top)) {
		$ret{$_} = $r2-> {$_}
			if $ret{$_} < $r2-> {$_};
	}

	return \%ret;
}

sub reset
{
	my $self = shift;
	$self-> {current} = -1;

	delete @{$self}{qw(canvas bgColor saveCanvas 
		saveMask image info 
		screenWidth screenHeight
		loopCount changedRect
		)};

	my $i = $self-> {images};
	return unless @$i;

	my $ix = $i-> [0];
	return unless $ix;

	my $e = $self-> get_extras(0);
	return unless $e;

	$self-> {image} = $self-> {images}-> [0];
	$self-> {info}  = $e;
	$self-> {$_} = $e-> {$_} for qw(screenWidth screenHeight);
	$self-> {changedRect} = {};
	$self-> fixup_rect( $e, $ix);

	# create canvas and mask
	$self-> {canvas}  = Prima::DeviceBitmap-> new(
		width      => $e-> {screenWidth},
		height     => $e-> {screenHeight},
		monochrome => 0,
		backColor  => 0,
	);
	$self-> {canvas}-> clear; # canvas is all-0 initially

	$self-> {mask}    = Prima::DeviceBitmap-> new(
		width      => $e-> {screenWidth},
		height     => $e-> {screenHeight},
		monochrome => 1,
		backColor  => 0xFFFFFF,
		color      => 0x000000,
	);
	$self-> {mask}-> clear; # mask is all-1 initially

	if ( defined $e-> {screenBackGroundColor}) {
		my $cm =
			$e-> {useScreenPalette} ?
				$e-> {screenPalette} :
				$self-> {images}-> [0]-> palette;
		my $i = $e-> {screenBackGroundColor} * 3;
		$self-> {bgColor} = (
			($$cm[$i+2] || 0) | 
			(($$cm[$i+1] || 0) << 8) | 
			(($$cm[$i] || 0) << 16)
		);
	}
}

sub next
{
	my $self = shift;

	my $info = $self-> {info};
	return unless $info;

	my @sz = ( $self-> {screenWidth}, $self-> {screenHeight});
	my %ret;

	# dispose from the previous frame and calculate the changed rect
	if ( $info-> {disposalMethod} == DISPOSE_CLEAR) {
		$self-> {canvas}-> backColor( 0);
		$self-> {canvas}-> clear;
		$self-> {mask}-> backColor(cl::Set);
		$self-> {mask}-> clear;
		
		%ret = %{ $self-> {changedRect} };
		$self-> {changedRect} = {};
	} elsif ( $info-> {disposalMethod} == DISPOSE_RESTORE_PREVIOUS) {
		# cut to the previous frame, that we expect to be saved for us
		if ( $self-> {saveCanvas} && $self-> {saveMask}) {
			$self-> {canvas} = $self-> {saveCanvas};
			$self-> {mask}   = $self-> {saveMask};
		}
		$self-> {changedRect} = $self-> {saveRect};
		delete $self-> {saveCanvas};
		delete $self-> {saveMask};
		delete $self-> {saveRect};
		%ret = %{ $info-> {rect} };
	}
	
	# advance frame
	delete @{$self}{qw(image info)};
	if ( ++$self-> {current} >= @{$self-> {images}}) {
		# go back to first frame, or stop
		if ( defined $self-> {loopCount}) {
		    return if --$self-> {loopCount} <= 0;
		}
		$self-> {current} = 0;
	}
	$self-> {image} = $self-> {images}-> [$self-> {current}];
	my $old_info = $info;
	$info = $self-> {info} = $self-> get_extras( $self-> {current} );
	$self-> fixup_rect( $info, $self-> {image}); 
	my @is = $self-> {image}-> size;

	# load global extension data
	if ( $self-> {current} == 0) {
		unless ( defined $info-> {loopCount}) {
			$self-> {loopCount} = 1;
		} elsif ( $info-> {loopCount} == 0) {
			# loop forever
			$self-> {loopCount} = undef;
		} else {
			$self-> {loopCount} = $info-> {loopCount};
		}
	}

	# remember the background, if needed, and again update the # rect
	if ( $info-> {disposalMethod} == DISPOSE_RESTORE_PREVIOUS) {
		my $c  = Prima::DeviceBitmap-> new(
			width      => $sz[0],
			height     => $sz[1],
			monochrome => 0,
		);
		$c-> put_image( 0, 0, $self-> {canvas});
		$self-> {saveCanvas} = $self-> {canvas};
		$self-> {canvas} = $c;

		$c = Prima::DeviceBitmap-> new(
			width      => $sz[0],
			height     => $sz[1],
			monochrome => 1,
		);
		$c-> put_image( 0, 0, $self-> {mask});
		$self-> {saveMask} = $self-> {mask};
		$self-> {mask} = $c;

		$self-> {saveRect} = $self-> {changedRect};
	}
	$self-> {changedRect} = union_rect( $self-> {changedRect}, $info-> {rect});
	%ret = %{ union_rect( \%ret, $info-> {rect}) };

	# draw the current frame
	if ( $info-> {iconic}) {
		my ( $xor, $and) = $self-> {image}-> split;
		# combine masks
		$self-> {mask}-> set(
			color     => cl::Clear,
			backColor => cl::Set,
		);
		$self-> {mask}-> put_image(
			$info-> {rect}-> {left},
			$info-> {rect}-> {bottom},
			$and,
			rop::AndPut,
		);
	} else {
		$self-> {mask}-> color(cl::Clear);
		$self-> {mask}-> bar(
			$info-> {rect}-> {left},
			$info-> {rect}-> {bottom},
			$info-> {rect}-> {left}   + $is[0],
			$info-> {rect}-> {bottom} + $is[1],
		);
	}

	# put non-transparent image pixels
	$self-> {canvas}-> put_image(
		$info-> {rect}-> {left},
		$info-> {rect}-> {bottom},
		$self-> {image},
	);

	#
	$ret{delay} = $info-> {delayTime} / 100;
	$ret{$_} ||= 0 for qw(left bottom right top);

	return \%ret;
}

sub is_stopped
{
	my $self = shift;
	return $self-> {current} >= @{$self-> {images}};
}

sub icon
{
	my $self = shift;

	my $i = Prima::Icon-> new;
	$i-> combine( $self-> {canvas}-> image, $self-> {mask}-> image);
	return $i;
}

sub image
{
	my $self = shift;

	my $i = Prima::Image-> new(
		width     => $self-> {canvas}-> width,
		height    => $self-> {canvas}-> height,
		type      => im::RGB,
		backColor => $self-> {bgColor} || 0,
	);
	$i-> begin_paint;
	$i-> clear;
	$i-> set(
		color     => cl::Clear,
		backColor => cl::Set,
	);
	$i-> put_image( 0, 0,$self-> {mask},   rop::AndPut);
	$i-> put_image( 0, 0,$self-> {canvas}, rop::XorPut);
	$i-> end_paint;

	return $i;
}

sub draw
{
	my ( $self, $canvas, $x, $y) = @_;

	return unless $self-> {canvas};

	my %save = map { $_ => $canvas-> $_() } qw(color backColor);
	$canvas-> set(
		color     => cl::Clear,
		backColor => cl::Set,
	);
	$canvas-> put_image( $x, $y, $self-> {mask},   rop::AndPut);
	$canvas-> put_image( $x, $y, $self-> {canvas}, rop::XorPut);
	$canvas-> set( %save);
}


sub masks   { ( $_[0]-> {canvas}, $_[0]-> {mask} ) }
sub width   { $_[0]-> {canvas} ? $_[0]-> {canvas}-> width  : 0 }
sub height  { $_[0]-> {canvas} ? $_[0]-> {canvas}-> height : 0 }
sub size    { $_[0]-> {canvas} ? $_[0]-> {canvas}-> size   : (0,0) }
sub bgColor { $_[0]-> {bgColor} }
sub current { $_[0]-> {current} }
sub total   { scalar @{$_[0]-> {images}} }

sub length
{
	my $length = 0;
	$length += $_-> {delayTime} || 0 for 
		map { $_-> {extras} || {} } 
		@{$_[0]-> {images}};
	return $length / 100;
}

sub loopCount
{
	return $_[0]-> {loopCount} unless $#_;
	$_[0]-> {loopCount} = $_[1];
}

1;

__END__