File Coverage

blib/lib/SDLx/Sprite/Animated.pm

Criterion	Covered	Total	%
statement	181	192	94.2
branch	54	70	77.1
condition	5	12	41.6
subroutine	32	34	94.1
pod	0	18	0.0
total	272	326	83.4

package SDLx::Sprite::Animated;
use strict;
use warnings;

use Scalar::Util 'refaddr';
use SDL;
use SDL::Video;
use SDL::Rect;
use SDLx::Sprite;
use SDLx::Validate;

use base 'SDLx::Sprite';

# inside out
my %_ticks;
my %_width;
my %_height;
my %_step_x;
my %_step_y;
my %_offset_x;
my %_offset_y;
my %_type;
my %_max_loops;
my %_ticks_per_frame;
my %_current_frame;
my %_current_loop;
my %_sequences;
my %_sequence;
my %_started;
my %_direction;

sub new {
	my ( $class, %options ) = @_;

	my ( $w, $h );
	if ( exists $options{clip} ) {
		( $w, $h ) = ( $options{clip}->w, $options{clip}->h );
	} elsif ( exists $options{rect} ) {
		( $w, $h ) = ( $options{rect}->w, $options{rect}->h );
	} elsif ( exists $options{width} && $options{height} ) {
		( $w, $h ) = ( $options{width}, $options{height} );
	}

	my $self = $class->SUPER::new(%options);

	$self->_store_geometry( $w, $h );

	$self->step_x( exists $options{step_x} ? $options{step_x} : $self->clip->w );
	$self->step_y( exists $options{step_y} ? $options{step_y} : $self->clip->h );
	$_offset_x{ refaddr $self} = exists $options{clip} ? $options{clip}->x : 0;
	$_offset_y{ refaddr $self} = exists $options{clip} ? $options{clip}->y : 0;

	$self->max_loops( exists $options{max_loops}             ? $options{max_loops}       : 0 );
	$self->ticks_per_frame( exists $options{ticks_per_frame} ? $options{ticks_per_frame} : 1 );
	$self->type( exists $options{type}                       ? $options{type}            : 'circular' );

	if ( exists $options{sequences} ) {
		$_sequences{ refaddr $self} = $options{sequences};
	} else {
		$self->_init_default_sequence();
	}
	$self->sequence( $options{sequence} ) if exists $options{sequence};

	$_ticks{ refaddr $self}     = 0;
	$_direction{ refaddr $self} = 1;

	return $self;
}

sub DESTROY {
	my $self = shift;
	delete $_ticks{ refaddr $self};
	delete $_width{ refaddr $self};
	delete $_height{ refaddr $self};
	delete $_step_x{ refaddr $self};
	delete $_step_y{ refaddr $self};
	delete $_offset_x{ refaddr $self};
	delete $_offset_y{ refaddr $self};
	delete $_type{ refaddr $self};
	delete $_max_loops{ refaddr $self};
	delete $_ticks_per_frame{ refaddr $self};
	delete $_current_frame{ refaddr $self};
	delete $_current_loop{ refaddr $self};
	delete $_sequences{ refaddr $self};
	delete $_sequence{ refaddr $self};
	delete $_started{ refaddr $self};
	delete $_direction{ refaddr $self};
}

sub load {
	my $self  = shift;
	my $image = shift;
	$self->SUPER::load($image);
	$self->_restore_geometry;
	$self->_init_default_sequence;
	return $self;
}

sub _init_default_sequence {
	my $self = shift;

	my $max_x = int( ( $self->surface->w - $_offset_x{ refaddr $self} ) / $self->step_x );
	my $max_y = int( ( $self->surface->h - $_offset_y{ refaddr $self} ) / $self->step_y );

	my @sequence;
	foreach my $y ( 0 .. $max_y - 1 ) {
		foreach my $x ( 0 .. $max_x - 1 ) {
			push @sequence, [ $x, $y ];
		}
	}
	$_sequences{ refaddr $self} = { 'default' => \@sequence };
	$self->sequence('default');
}

sub _store_geometry {
	my ( $self, $w, $h ) = @_;

	$_width{ refaddr $self}  = $w;
	$_height{ refaddr $self} = $h;

	$self->_restore_geometry;
}

sub _restore_geometry {
	my $self = shift;

	$self->clip->w( $_width{ refaddr $self} )  if exists $_width{ refaddr $self};
	$self->clip->h( $_height{ refaddr $self} ) if exists $_height{ refaddr $self};
	$self->rect->w( $_width{ refaddr $self} )  if exists $_width{ refaddr $self};
	$self->rect->h( $_height{ refaddr $self} ) if exists $_height{ refaddr $self};
}

sub step_y {
	my ( $self, $step_y ) = @_;

	if ($step_y) {
		$_step_y{ refaddr $self} = $step_y;
	}

	return $_step_y{ refaddr $self};
}

sub step_x {
	my ( $self, $step_x ) = @_;

	if ($step_x) {
		$_step_x{ refaddr $self} = $step_x;
	}

	return $_step_x{ refaddr $self};
}

sub type {
	my ( $self, $type ) = @_;

	if ($type) {
		$_type{ refaddr $self} = lc $type;
	}

	return $_type{ refaddr $self};
}

sub max_loops {
	my $self = shift;

	if (@_) {
		$_max_loops{ refaddr $self} = shift;
	}

	return $_max_loops{ refaddr $self};
}

sub ticks_per_frame {
	my ( $self, $ticks ) = @_;

	if ($ticks) {
		$_ticks_per_frame{ refaddr $self} = $ticks;
	}

	return $_ticks_per_frame{ refaddr $self};
}

sub current_frame {
	my ( $self, $frame ) = @_;
	return $_current_frame{ refaddr $self};
}

sub current_loop {
	my ($self) = @_;
	return $_current_loop{ refaddr $self };
}

sub set_sequences {
	my ( $self, %sequences ) = @_;

	# TODO: Validate sequences.
	$_sequences{ refaddr $self} = \%sequences;

	return $self;
}

sub sequence {
	my ( $self, $sequence ) = @_;
	my $me = refaddr $self;

	if ($sequence) {

		if ( !defined( $_sequences{ $me }{$sequence} ) ) {
			warn 'Unknown sequence: ', $sequence;
			return;
		}
		$_sequence{ $me }      = $sequence;
		$_current_frame{ $me } = 1;
		$_current_loop{ $me }  = 1;
		$_direction{ $me }     = 1;
		$self->_update_clip;
	}

	return $_sequence{ $me };
}

sub _sequence {
	my $self = shift;
	return $_sequences{ refaddr $self}{ $_sequence{ refaddr $self} };
}

sub _frame {
	my $self = shift;
	return $self->_sequence->[ $_current_frame{ refaddr $self} - 1 ];
}

sub next {
	my $self = shift;
	my $me = refaddr $self;

	return if @{ $self->_sequence } == 1;

	return if $_max_loops{ $me } && $_current_loop{ $me } > $_max_loops{ $me };

	my $next_frame = ( $_current_frame{ $me } - 1 + $_direction{ $me } ) % @{ $self->_sequence };

	if ( $next_frame == 0 ) {
		$_current_loop{ $me }++ if $_type{ $me } eq 'circular';

		if ( $_type{ $me } eq 'reverse' ) {

			if ( $_direction{ $me } == 1 ) {
				$next_frame = @{ $self->_sequence } - 2;
			} else {
				$_current_loop{ $me }++;
			}

			$_direction{ $me } *= -1;
		}
	}
	$_current_frame{ $me } = $next_frame + 1;

	$self->_update_clip;

	return $self;
}

sub previous {
	my $self = shift;

	return if $_max_loops{ refaddr $self} && $_current_loop{ refaddr $self } > $_max_loops{ refaddr $self};

	$_ticks{ refaddr $self} = 0;

	return if @{ $self->_sequence } == 1;

	my $previous_frame = ( $_current_frame{ refaddr $self} - 1 - $_direction{ refaddr $self} ) % @{ $self->_sequence };

	if ( $previous_frame == 0 ) {
		if ( $_type{ refaddr $self} eq 'reverse' ) {

			if ( $_direction{ refaddr $self} == -1 ) {
				$previous_frame = 1;
			}

			$_direction{ refaddr $self} *= -1;
		}
	}
	$_current_frame{ refaddr $self} = $previous_frame + 1;

	$self->_update_clip;

	return $self;
}

sub reset {
	my $self = shift;

	$self->stop;
	$_current_frame{ refaddr $self} = 1;
	$self->_update_clip;

	return $self;
}

sub start {
	my $self = shift;

	$_started{ refaddr $self} = 1;

	return $self;
}

sub stop {
	my $self = shift;

	$_started{ refaddr $self} = 0;

	return $self;
}

sub _update_clip {
	my $self = shift;

	my $clip  = $self->clip;
	my $frame = $self->_frame;

	$clip->x( $_offset_x{ refaddr $self} + $frame->[0] * $_step_x{ refaddr $self} );
	$clip->y( $_offset_y{ refaddr $self} + $frame->[1] * $_step_y{ refaddr $self} );
}

sub alpha_key {
	my $self = shift;
	$self->SUPER::alpha_key(@_);
	$self->_restore_geometry;
	return $self;
}

sub draw {
	my ( $self, $surface ) = @_;

	$surface = SDLx::Validate::surface($surface);

	$_ticks{ refaddr $self}++;
	$self->next if $_started{ refaddr $self} && $_ticks{ refaddr $self} % $_ticks_per_frame{ refaddr $self} == 0;

	SDL::Video::blit_surface( $self->surface, $self->clip, $surface, $self->rect );

	return $self;
}

1;