/lib/SDLx/Rect.pm
http://github.com/PerlGameDev/SDL · Perl · 752 lines · 573 code · 160 blank · 19 comment · 80 complexity · dca0a4aeaf35147350c6101b6b0925b0 MD5 · raw file
- package SDLx::Rect;
- use strict;
- use warnings;
- use Carp;
- use base 'SDL::Rect';
- our $VERSION = 2.548;
- sub new {
- my $class = shift;
- my $x = shift || 0;
- my $y = shift || 0;
- my $w = shift || 0;
- my $h = shift || 0;
- $class = ref($class) || $class;
- my $self = $class->SUPER::new( $x, $y, $w, $h );
- unless ($$self) {
- #require Carp;
- Carp::confess SDL::get_error();
- }
- return bless $self, $class;
- }
- #############################
- ## extra accessors
- #############################
- sub left {
- my $self = shift;
- $self->x(@_);
- }
- sub top {
- my $self = shift;
- $self->y(@_);
- }
- sub width {
- my $self = shift;
- $self->w(@_);
- }
- sub height {
- my $self = shift;
- $self->h(@_);
- }
- sub bottom {
- my ( $self, $val ) = (@_);
- if ( defined $val ) {
- $self->top( $val - $self->height ); # y = val - height
- }
- return $self->top + $self->height; # y + height
- }
- sub right {
- my ( $self, $val ) = (@_);
- if ( defined $val ) {
- $self->left( $val - $self->width ); # x = val - width
- }
- return $self->left + $self->width; # x + width
- }
- sub centerx {
- my ( $self, $val ) = (@_);
- if ( defined $val ) {
- $self->left( $val - ( $self->width >> 1 ) ); # x = val - (width/2)
- }
- return $self->left + ( $self->width >> 1 ); # x + (width/2)
- }
- sub centery {
- my ( $self, $val ) = (@_);
- if ( defined $val ) {
- $self->top( $val - ( $self->height >> 1 ) ); # y = val - (height/2)
- }
- return $self->top + ( $self->height >> 1 ); # y + (height/2)
- }
- sub size {
- my ( $self, $w, $h ) = (@_);
- return ( $self->width, $self->height ) # (width, height)
- unless ( defined $w or defined $h );
- if ( defined $w ) {
- $self->width($w); # width
- }
- if ( defined $h ) {
- $self->height($h); # height
- }
- }
- sub topleft {
- my ( $self, $y, $x ) = (@_);
- return ( $self->top, $self->left ) # (top, left)
- unless ( defined $y or defined $x );
- if ( defined $x ) {
- $self->left($x); # left
- }
- if ( defined $y ) {
- $self->top($y); # top
- }
- return;
- }
- sub midleft {
- my ( $self, $centery, $x ) = (@_);
- return (
- $self->top + ( $self->height >> 1 ),
- $self->left
- ) # (centery, left)
- unless ( defined $centery or defined $x );
- if ( defined $x ) {
- $self->left($x); # left
- }
- if ( defined $centery ) {
- $self->top( $centery - ( $self->height >> 1 ) ); # y = centery - (height/2)
- }
- return;
- }
- sub bottomleft {
- my ( $self, $bottom, $x ) = (@_);
- return ( $self->top + $self->height, $self->left ) # (bottom, left)
- unless ( defined $bottom or defined $x );
- if ( defined $x ) {
- $self->left($x); # left
- }
- if ( defined $bottom ) {
- $self->top( $bottom - $self->height ); # y = bottom - height
- }
- return;
- }
- sub center {
- my ( $self, $centerx, $centery ) = (@_);
- return (
- $self->left + ( $self->width >> 1 ),
- $self->top + ( $self->height >> 1 )
- ) unless ( defined $centerx or defined $centery );
- if ( defined $centerx ) {
- $self->left( $centerx - ( $self->width >> 1 ) ); # x = centerx - (width/2)
- }
- if ( defined $centery ) {
- $self->top( $centery - ( $self->height >> 1 ) ); # y = centery - (height/2)
- }
- return;
- }
- sub topright {
- my ( $self, $y, $right ) = (@_);
- return ( $self->top, $self->left + $self->width ) # (top, right)
- unless ( defined $y or defined $right );
- if ( defined $right ) {
- $self->left( $right - $self->width ); # x = right - width
- }
- if ( defined $y ) {
- $self->top($y); # top
- }
- return;
- }
- sub midright {
- my ( $self, $centery, $right ) = (@_);
- return (
- $self->top + ( $self->height >> 1 ),
- $self->left + $self->width
- ) # (centery, right)
- unless ( defined $centery or defined $right );
- if ( defined $right ) {
- $self->left( $right - $self->width ); # x = right - width
- }
- if ( defined $centery ) {
- $self->top( $centery - ( $self->height >> 1 ) ); # y = centery - (height/2)
- }
- return;
- }
- sub bottomright {
- my ( $self, $bottom, $right ) = (@_);
- return (
- $self->top + $self->height,
- $self->left + $self->width
- ) # (bottom, right)
- unless ( defined $bottom or defined $right );
- if ( defined $right ) {
- $self->left( $right - $self->width ); # x = right - width
- }
- if ( defined $bottom ) {
- $self->top( $bottom - $self->height ); # y = bottom - height
- }
- return;
- }
- sub midtop {
- my ( $self, $centerx, $y ) = (@_);
- return ( $self->left + ( $self->width >> 1 ), $self->top ) # (centerx, top)
- unless ( defined $centerx or defined $y );
- if ( defined $y ) {
- $self->top($y); # top
- }
- if ( defined $centerx ) {
- $self->left( $centerx - ( $self->width >> 1 ) ); # x = centerx - (width/2)
- }
- return;
- }
- sub midbottom {
- my ( $self, $centerx, $bottom ) = (@_);
- return (
- $self->left + ( $self->width >> 1 ),
- $self->top + $self->height
- ) # (centerx, bottom)
- unless ( defined $centerx or defined $bottom );
- if ( defined $bottom ) {
- $self->top( $bottom - $self->height ); # y = bottom - height
- }
- if ( defined $centerx ) {
- $self->left( $centerx - ( $self->width >> 1 ) ); # x = centerx - (width/2)
- }
- return;
- }
- ###############################
- ## methods ##
- ###############################
- {
- no strict 'refs';
- *{'duplicate'} = *{copy};
- }
- sub copy {
- my $self = shift;
- return $self->new(
- $self->x,
- $self->y,
- $self->w,
- $self->h,
- );
- }
- sub move {
- my ( $self, $x, $y ) = (@_);
- if ( not defined $x or not defined $y ) {
- #require Carp;
- Carp::confess "must receive x and y positions as argument";
- }
- return $self->new(
- $self->left + $x,
- $self->top + $y,
- $self->width,
- $self->height,
- );
- }
- sub move_ip {
- my ( $self, $x, $y ) = (@_);
- if ( not defined $x or not defined $y ) {
- #require Carp;
- Carp::confess "must receive x and y positions as argument";
- }
- $self->x( $self->x + $x );
- $self->y( $self->y + $y );
- return;
- }
- sub inflate {
- my ( $self, $x, $y ) = (@_);
- if ( not defined $x or not defined $y ) {
- #require Carp;
- Carp::confess "must receive x and y positions as argument";
- }
- return $self->new(
- $self->left - ( $x / 2 ),
- $self->top - ( $y / 2 ),
- $self->width + $x,
- $self->height + $y,
- );
- }
- sub inflate_ip {
- my ( $self, $x, $y ) = (@_);
- if ( not defined $x or not defined $y ) {
- #require Carp;
- Carp::confess "must receive x and y positions as argument";
- }
- $self->x( $self->x - ( $x / 2 ) );
- $self->y( $self->y - ( $y / 2 ) );
- $self->w( $self->w + $x );
- $self->h( $self->h + $y );
- }
- sub _get_clamp_coordinates {
- my ( $self_pos, $self_len, $rect_pos, $rect_len ) = (@_);
- if ( $self_len >= $rect_len ) {
- return $rect_pos + ( $rect_len / 2 ) - ( $self_len / 2 );
- } elsif ( $self_pos < $rect_pos ) {
- return $rect_pos;
- } elsif ( ( $self_pos + $self_len ) > ( $rect_pos + $rect_len ) ) {
- return $rect_pos + $rect_len - $self_len;
- } else {
- return $self_pos;
- }
- }
- sub clamp {
- my ( $self, $rect ) = (@_);
- unless ( $rect->isa('SDL::Rect') ) {
- Carp::confess "must receive an SDL::Rect-based object";
- }
- my $x = _get_clamp_coordinates( $self->x, $self->w, $rect->x, $rect->w );
- my $y = _get_clamp_coordinates( $self->y, $self->h, $rect->y, $rect->h );
- return $self->new( $x, $y, $self->w, $self->h );
- }
- sub clamp_ip {
- my ( $self, $rect ) = (@_);
- unless ( $rect->isa('SDL::Rect') ) {
- Carp::confess "must receive an SDL::Rect-based object";
- }
- my $x = _get_clamp_coordinates( $self->x, $self->w, $rect->x, $rect->w );
- my $y = _get_clamp_coordinates( $self->y, $self->h, $rect->y, $rect->h );
- $self->x($x);
- $self->y($y);
- return;
- }
- sub _get_intersection_coordinates {
- my ( $self, $rect ) = (@_);
- my ( $x, $y, $w, $h );
- INTERSECTION:
- {
- ### Left
- if ( ( $self->x >= $rect->x )
- && ( $self->x < ( $rect->x + $rect->w ) ) )
- {
- $x = $self->x;
- } elsif ( ( $rect->x >= $self->x )
- && ( $rect->x < ( $self->x + $self->w ) ) )
- {
- $x = $rect->x;
- } else {
- last INTERSECTION;
- }
- ## Right
- if ( ( ( $self->x + $self->w ) > $rect->x )
- && ( ( $self->x + $self->w ) <= ( $rect->x + $rect->w ) ) )
- {
- $w = ( $self->x + $self->w ) - $x;
- } elsif ( ( ( $rect->x + $rect->w ) > $self->x )
- && ( ( $rect->x + $rect->w ) <= ( $self->x + $self->w ) ) )
- {
- $w = ( $rect->x + $rect->w ) - $x;
- } else {
- last INTERSECTION;
- }
- ## Top
- if ( ( $self->y >= $rect->y )
- && ( $self->y < ( $rect->y + $rect->h ) ) )
- {
- $y = $self->y;
- } elsif ( ( $rect->y >= $self->y )
- && ( $rect->y < ( $self->y + $self->h ) ) )
- {
- $y = $rect->y;
- } else {
- last INTERSECTION;
- }
- ## Bottom
- if ( ( ( $self->y + $self->h ) > $rect->y )
- && ( ( $self->y + $self->h ) <= ( $rect->y + $rect->h ) ) )
- {
- $h = ( $self->y + $self->h ) - $y;
- } elsif ( ( ( $rect->y + $rect->h ) > $self->y )
- && ( ( $rect->y + $rect->h ) <= ( $self->y + $self->h ) ) )
- {
- $h = ( $rect->y + $rect->h ) - $y;
- } else {
- last INTERSECTION;
- }
- return ( $x, $y, $w, $h );
- }
- # if we got here, the two rects do not intersect
- return ( $self->x, $self->y, 0, 0 );
- }
- sub clip {
- my ( $self, $rect ) = (@_);
- unless ( $rect->isa('SDL::Rect') ) {
- Carp::confess "must receive an SDL::Rect-based object";
- }
- my ( $x, $y, $w, $h ) = _get_intersection_coordinates( $self, $rect );
- return $self->new( $x, $y, $w, $h );
- }
- sub clip_ip {
- my ( $self, $rect ) = (@_);
- unless ( $rect->isa('SDL::Rect') ) {
- Carp::confess "must receive an SDL::Rect-based object";
- }
- my ( $x, $y, $w, $h ) = _get_intersection_coordinates( $self, $rect );
- $self->x($x);
- $self->y($y);
- $self->w($w);
- $self->h($h);
- return;
- }
- sub _test_union {
- my ( $self, $rect ) = (@_);
- my ( $x, $y, $w, $h );
- $x = $self->x < $rect->x ? $self->x : $rect->x; # MIN
- $y = $self->y < $rect->y ? $self->y : $rect->y; # MIN
- $w =
- ( $self->x + $self->w ) > ( $rect->x + $rect->w )
- ? ( $self->x + $self->w ) - $x
- : ( $rect->x + $rect->w ) - $x; # MAX
- $h =
- ( $self->y + $self->h ) > ( $rect->y + $rect->h )
- ? ( $self->y + $self->h ) - $y
- : ( $rect->y + $rect->h ) - $y; # MAX
- return ( $x, $y, $w, $h );
- }
- sub union {
- my ( $self, $rect ) = (@_);
- unless ( $rect->isa('SDL::Rect') ) {
- Carp::confess "must receive an SDL::Rect-based object";
- }
- my ( $x, $y, $w, $h ) = _test_union( $self, $rect );
- return $self->new( $x, $y, $w, $h );
- }
- sub union_ip {
- my ( $self, $rect ) = (@_);
- unless ( $rect->isa('SDL::Rect') ) {
- Carp::confess "must receive an SDL::Rect-based object";
- }
- my ( $x, $y, $w, $h ) = _test_union( $self, $rect );
- $self->x($x);
- $self->y($y);
- $self->w($w);
- $self->y($h);
- return;
- }
- sub _test_unionall {
- my ( $self, $rects ) = (@_);
- # initial values for union rect
- my $left = $self->x;
- my $top = $self->y;
- my $right = $self->x + $self->w;
- my $bottom = $self->y + $self->h;
- foreach my $rect ( @{$rects} ) {
- unless ( $rect->isa('SDL::Rect') ) {
- # TODO: better error message, maybe saying which item
- # is the bad one (by list position)
- Carp::confess "must receive an array reference of SDL::Rect-based objects";
- }
- $left = $rect->x if $rect->x < $left; # MIN
- $top = $rect->y if $rect->y < $top; # MIN
- $right = ( $rect->x + $rect->w )
- if ( $rect->x + $rect->w ) > $right; # MAX
- $bottom = ( $rect->y + $rect->h )
- if ( $rect->y + $rect->h ) > $bottom; # MAX
- }
- return ( $left, $top, $right - $left, $bottom - $top );
- }
- sub unionall {
- my ( $self, $rects ) = (@_);
- unless ( defined $rects and ref $rects eq 'ARRAY' ) {
- Carp::confess "must receive an array reference of SDL::Rect-based objects";
- }
- my ( $x, $y, $w, $h ) = _test_unionall( $self, $rects );
- return $self->new( $x, $y, $w, $h );
- }
- sub unionall_ip {
- my ( $self, $rects ) = (@_);
- unless ( defined $rects and ref $rects eq 'ARRAY' ) {
- Carp::confess "must receive an array reference of SDL::Rect-based objects";
- }
- my ( $x, $y, $w, $h ) = _test_unionall( $self, $rects );
- $self->x($x);
- $self->y($y);
- $self->w($w);
- $self->h($h);
- return;
- }
- sub _check_fit {
- my ( $self, $rect ) = (@_);
- my $x_ratio = $self->w / $rect->w;
- my $y_ratio = $self->h / $rect->h;
- my $max_ratio = ( $x_ratio > $y_ratio ) ? $x_ratio : $y_ratio;
- my $w = int( $self->w / $max_ratio );
- my $h = int( $self->h / $max_ratio );
- my $x = $rect->x + int( ( $rect->w - $w ) / 2 );
- my $y = $rect->y + int( ( $rect->h - $h ) / 2 );
- return ( $x, $y, $w, $h );
- }
- sub fit {
- my ( $self, $rect ) = (@_);
- unless ( $rect->isa('SDL::Rect') ) {
- Carp::confess "must receive an SDL::Rect-based object";
- }
- my ( $x, $y, $w, $h ) = _check_fit( $self, $rect );
- return $self->new( $x, $y, $w, $h );
- }
- sub fit_ip {
- my ( $self, $rect ) = (@_);
- unless ( $rect->isa('SDL::Rect') ) {
- Carp::confess "must receive an SDL::Rect-based object";
- }
- my ( $x, $y, $w, $h ) = _check_fit( $self, $rect );
- $self->x($x);
- $self->y($y);
- $self->w($w);
- $self->h($h);
- return;
- }
- sub normalize {
- my $self = shift;
- if ( $self->w < 0 ) {
- $self->x( $self->x + $self->w );
- $self->w( -$self->w );
- }
- if ( $self->h < 0 ) {
- $self->y( $self->y + $self->h );
- $self->h( -$self->h );
- }
- return;
- }
- sub contains {
- my ( $self, $rect ) = (@_);
- unless ( $rect->isa('SDL::Rect') ) {
- Carp::confess "must receive an SDL::Rect-based object";
- }
- my $contained =
- ( $self->x <= $rect->x )
- && ( $self->y <= $rect->y )
- && ( $self->x + $self->w >= $rect->x + $rect->w )
- && ( $self->y + $self->h >= $rect->y + $rect->h )
- && ( $self->x + $self->w > $rect->x )
- && ( $self->y + $self->h > $rect->y );
- return $contained;
- }
- sub collidepoint {
- my ( $self, $x, $y ) = (@_);
- unless ( defined $x and defined $y ) {
- Carp::confess "must receive (x,y) as arguments";
- }
- my $inside =
- $x >= $self->x
- && $x < $self->x + $self->w
- && $y >= $self->y
- && $y < $self->y + $self->h;
- return $inside;
- }
- sub _do_rects_intersect {
- my ( $rect_A, $rect_B ) = (@_);
- return (
- ( $rect_A->x >= $rect_B->x && $rect_A->x < $rect_B->x + $rect_B->w ) || ( $rect_B->x >= $rect_A->x
- && $rect_B->x < $rect_A->x + $rect_A->w )
- )
- && ( ( $rect_A->y >= $rect_B->y && $rect_A->y < $rect_B->y + $rect_B->h )
- || ( $rect_B->y >= $rect_A->y && $rect_B->y < $rect_A->y + $rect_A->h ) );
- }
- sub colliderect {
- my ( $self, $rect ) = (@_);
- unless ( $rect->isa('SDL::Rect') ) {
- Carp::confess "must receive an SDL::Rect-based object";
- }
- return _do_rects_intersect( $self, $rect );
- }
- sub collidelist {
- my ( $self, $rects ) = (@_);
- unless ( defined $rects and ref $rects eq 'ARRAY' ) {
- Carp::confess "must receive an array reference of SDL::Rect-based objects";
- }
- for ( my $i = 0; $i < @{$rects}; $i++ ) {
- if ( _do_rects_intersect( $self, $rects->[$i] ) ) {
- return $i;
- }
- }
- return;
- }
- sub collidelistall {
- my ( $self, $rects ) = (@_);
- unless ( defined $rects and ref $rects eq 'ARRAY' ) {
- Carp::confess "must receive an array reference of SDL::Rect-based objects";
- }
- my @collisions = ();
- for ( my $i = 0; $i < @{$rects}; $i++ ) {
- if ( _do_rects_intersect( $self, $rects->[$i] ) ) {
- push @collisions, $i;
- }
- }
- return \@collisions;
- }
- sub collidehash {
- my ( $self, $rects ) = (@_);
- unless ( defined $rects and ref $rects eq 'HASH' ) {
- Carp::confess "must receive an hash reference of SDL::Rect-based objects";
- }
- while ( my ( $key, $value ) = each %{$rects} ) {
- unless ( $value->isa('SDL::Rect') ) {
- Carp::confess "hash element of key '$key' is not an SDL::Rect-based object";
- }
- if ( _do_rects_intersect( $self, $value ) ) {
- return ( $key, $value );
- }
- }
- return ( undef, undef );
- }
- sub collidehashall {
- my ( $self, $rects ) = (@_);
- unless ( defined $rects and ref $rects eq 'HASH' ) {
- Carp::confess "must receive an hash reference of SDL::Rect-based objects";
- }
- my %collisions = ();
- while ( my ( $key, $value ) = each %{$rects} ) {
- unless ( $value->isa('SDL::Rect') ) {
- Carp::confess "hash element of key '$key' is not an SDL::Rect-based object";
- }
- if ( _do_rects_intersect( $self, $value ) ) {
- $collisions{$key} = $value;
- }
- }
- return \%collisions;
- }
- 1; #NOT 42!