implemented 'duplicate' as 'copy' alias

[sdlgit/SDL_perl.git] / lib / SDL / Game / Rect.pm

diff --git a/lib/SDL/Game/Rect.pm b/lib/SDL/Game/Rect.pm
index 18f4067..92e0948 100644 (file)
--- 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 {
@@ -488,8 +490,9 @@ sub _test_unionall {
 sub unionall {
     my ($self, $rects) = (@_);
     
-    croak "must receive an array reference of SDL::Rect-based objects"
-        unless defined $rects and ref $rects eq 'ARRAY';
+    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);
     
@@ -499,8 +502,9 @@ sub unionall {
 sub unionall_ip {
     my ($self, $rects) = (@_);
     
-    croak "must receive an array reference of SDL::Rect-based objects"
-        unless defined $rects and ref $rects eq 'ARRAY';
+    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);
     
@@ -557,6 +561,151 @@ sub fit_ip {
     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__