## methods ##
###############################
-sub duplicate {
+{
+ no strict 'refs';
+ *{'duplicate'} = *{copy};
}
sub copy {
$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__
=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<<clip>> 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<<clip>> 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)
projects / sdlgit/SDL_perl.git / blobdiff