X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSDL%2FGame%2FRect.pm;h=92e094831b28f1634692f5e2e11dd97706209948;hb=506445434c661b3ddf95fb6853aff27eb900f474;hp=19fb2eca3751a9e1b27cd69056b5b54fd19817b6;hpb=f193ea4b591f557fe8681071962068024a8a7adb;p=sdlgit%2FSDL_perl.git diff --git a/lib/SDL/Game/Rect.pm b/lib/SDL/Game/Rect.pm index 19fb2ec..92e0948 100644 --- a/lib/SDL/Game/Rect.pm +++ b/lib/SDL/Game/Rect.pm @@ -210,7 +210,9 @@ sub midbottom { ## methods ## ############################### -sub duplicate { +{ + no strict 'refs'; + *{'duplicate'} = *{copy}; } sub copy { @@ -278,6 +280,432 @@ sub inflate_ip { $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')) { + croak "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')) { + croak "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')) { + croak "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')) { + croak "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')) { + croak "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')) { + croak "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) + croak "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') { + croak "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') { + croak "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')) { + croak "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')) { + croak "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')) { + croak "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) { + croak "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')) { + croak "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') { + croak "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') { + croak "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') { + croak "must receive an hash reference of SDL::Rect-based objects"; + } + + while ( my ($key, $value) = each %{$rects} ) { + unless ($value->isa('SDL::Rect')) { + croak "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') { + croak "must receive an hash reference of SDL::Rect-based objects"; + } + + my %collisions = (); + while ( my ($key, $value) = each %{$rects} ) { + unless ($value->isa('SDL::Rect')) { + croak "hash element of key '$key' is not an SDL::Rect-based object"; + } + + if ( _do_rects_intersect($self, $value) ) { + $collisions{$key} = $value; + } + } + return \%collisions; +} + 42; __END__ @@ -398,11 +826,11 @@ Same as C<> above, but moves the current Rect in place and returns nothin =head3 clip($rect) -Returns a new Rect with the intersection between the two Rect objects, that is, returns a new Rect cropped to be completely inside the Rect object passed as an argument. If the two rectangles do not overlap to begin with, a Rect with 0 size is returned. +Returns a new Rect with the intersection between the two Rect objects, that is, returns a new Rect cropped to be completely inside the Rect object passed as an argument. If the two rectangles do not overlap to begin with, a Rect with 0 size is returned, in the original Rect's (x,y) coordinates. =head3 clip_ip($rect) -Same as C<> above, but crops the current Rect in place and returns nothing. As the original method, the Rect becomes zero-sized if the two rectangles do not overlap to begin with. +Same as C<> above, but crops the current Rect in place and returns nothing. As the original method, the Rect becomes zero-sized if the two rectangles do not overlap to begin with, retaining its (x, y) coordinates. =head3 union($rect)