## methods ##
###############################
-sub duplicate {
+{
+ no strict 'refs';
+ *{'duplicate'} = *{copy};
}
sub copy {
return;
}
-=head3 union($rect)
-
-Returns a new rectangle that completely covers the area of the current Rect and the one passed as an argument. There may be area inside the new Rect that is not covered by the originals.
-
-=cut
sub _test_union {
my ($self, $rect) = (@_);
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__
projects / sdlgit/SDL_perl.git / blobdiff