/lib/SDLx/Rect.pm
Perl | 752 lines | 573 code | 160 blank | 19 comment | 80 complexity | dca0a4aeaf35147350c6101b6b0925b0 MD5 | raw file
1package SDLx::Rect; 2use strict; 3use warnings; 4use Carp; 5use base 'SDL::Rect'; 6 7our $VERSION = 2.548; 8 9sub new { 10 my $class = shift; 11 my $x = shift || 0; 12 my $y = shift || 0; 13 my $w = shift || 0; 14 my $h = shift || 0; 15 16 $class = ref($class) || $class; 17 my $self = $class->SUPER::new( $x, $y, $w, $h ); 18 unless ($$self) { 19 20 #require Carp; 21 Carp::confess SDL::get_error(); 22 } 23 return bless $self, $class; 24} 25 26############################# 27## extra accessors 28############################# 29 30sub left { 31 my $self = shift; 32 $self->x(@_); 33} 34 35sub top { 36 my $self = shift; 37 $self->y(@_); 38} 39 40sub width { 41 my $self = shift; 42 $self->w(@_); 43} 44 45sub height { 46 my $self = shift; 47 $self->h(@_); 48} 49 50sub bottom { 51 my ( $self, $val ) = (@_); 52 if ( defined $val ) { 53 $self->top( $val - $self->height ); # y = val - height 54 } 55 return $self->top + $self->height; # y + height 56} 57 58sub right { 59 my ( $self, $val ) = (@_); 60 if ( defined $val ) { 61 $self->left( $val - $self->width ); # x = val - width 62 } 63 return $self->left + $self->width; # x + width 64} 65 66sub centerx { 67 my ( $self, $val ) = (@_); 68 if ( defined $val ) { 69 $self->left( $val - ( $self->width >> 1 ) ); # x = val - (width/2) 70 } 71 return $self->left + ( $self->width >> 1 ); # x + (width/2) 72} 73 74sub centery { 75 my ( $self, $val ) = (@_); 76 if ( defined $val ) { 77 $self->top( $val - ( $self->height >> 1 ) ); # y = val - (height/2) 78 } 79 return $self->top + ( $self->height >> 1 ); # y + (height/2) 80} 81 82sub size { 83 my ( $self, $w, $h ) = (@_); 84 85 return ( $self->width, $self->height ) # (width, height) 86 unless ( defined $w or defined $h ); 87 88 if ( defined $w ) { 89 $self->width($w); # width 90 } 91 if ( defined $h ) { 92 $self->height($h); # height 93 } 94} 95 96sub topleft { 97 my ( $self, $y, $x ) = (@_); 98 99 return ( $self->top, $self->left ) # (top, left) 100 unless ( defined $y or defined $x ); 101 102 if ( defined $x ) { 103 $self->left($x); # left 104 } 105 if ( defined $y ) { 106 $self->top($y); # top 107 } 108 return; 109} 110 111sub midleft { 112 my ( $self, $centery, $x ) = (@_); 113 114 return ( 115 $self->top + ( $self->height >> 1 ), 116 $self->left 117 ) # (centery, left) 118 unless ( defined $centery or defined $x ); 119 120 if ( defined $x ) { 121 $self->left($x); # left 122 } 123 if ( defined $centery ) { 124 $self->top( $centery - ( $self->height >> 1 ) ); # y = centery - (height/2) 125 } 126 return; 127} 128 129sub bottomleft { 130 my ( $self, $bottom, $x ) = (@_); 131 132 return ( $self->top + $self->height, $self->left ) # (bottom, left) 133 unless ( defined $bottom or defined $x ); 134 135 if ( defined $x ) { 136 $self->left($x); # left 137 } 138 if ( defined $bottom ) { 139 $self->top( $bottom - $self->height ); # y = bottom - height 140 } 141 return; 142} 143 144sub center { 145 my ( $self, $centerx, $centery ) = (@_); 146 147 return ( 148 $self->left + ( $self->width >> 1 ), 149 $self->top + ( $self->height >> 1 ) 150 ) unless ( defined $centerx or defined $centery ); 151 152 if ( defined $centerx ) { 153 $self->left( $centerx - ( $self->width >> 1 ) ); # x = centerx - (width/2) 154 } 155 if ( defined $centery ) { 156 $self->top( $centery - ( $self->height >> 1 ) ); # y = centery - (height/2) 157 } 158 return; 159} 160 161sub topright { 162 my ( $self, $y, $right ) = (@_); 163 164 return ( $self->top, $self->left + $self->width ) # (top, right) 165 unless ( defined $y or defined $right ); 166 167 if ( defined $right ) { 168 $self->left( $right - $self->width ); # x = right - width 169 } 170 if ( defined $y ) { 171 $self->top($y); # top 172 } 173 return; 174} 175 176sub midright { 177 my ( $self, $centery, $right ) = (@_); 178 179 return ( 180 $self->top + ( $self->height >> 1 ), 181 $self->left + $self->width 182 ) # (centery, right) 183 unless ( defined $centery or defined $right ); 184 185 if ( defined $right ) { 186 $self->left( $right - $self->width ); # x = right - width 187 } 188 if ( defined $centery ) { 189 $self->top( $centery - ( $self->height >> 1 ) ); # y = centery - (height/2) 190 } 191 return; 192} 193 194sub bottomright { 195 my ( $self, $bottom, $right ) = (@_); 196 197 return ( 198 $self->top + $self->height, 199 $self->left + $self->width 200 ) # (bottom, right) 201 unless ( defined $bottom or defined $right ); 202 203 if ( defined $right ) { 204 $self->left( $right - $self->width ); # x = right - width 205 } 206 if ( defined $bottom ) { 207 $self->top( $bottom - $self->height ); # y = bottom - height 208 } 209 return; 210} 211 212sub midtop { 213 my ( $self, $centerx, $y ) = (@_); 214 215 return ( $self->left + ( $self->width >> 1 ), $self->top ) # (centerx, top) 216 unless ( defined $centerx or defined $y ); 217 218 if ( defined $y ) { 219 $self->top($y); # top 220 } 221 if ( defined $centerx ) { 222 $self->left( $centerx - ( $self->width >> 1 ) ); # x = centerx - (width/2) 223 } 224 return; 225} 226 227sub midbottom { 228 my ( $self, $centerx, $bottom ) = (@_); 229 230 return ( 231 $self->left + ( $self->width >> 1 ), 232 $self->top + $self->height 233 ) # (centerx, bottom) 234 unless ( defined $centerx or defined $bottom ); 235 236 if ( defined $bottom ) { 237 $self->top( $bottom - $self->height ); # y = bottom - height 238 } 239 if ( defined $centerx ) { 240 $self->left( $centerx - ( $self->width >> 1 ) ); # x = centerx - (width/2) 241 } 242 return; 243} 244 245############################### 246## methods ## 247############################### 248 249{ 250 no strict 'refs'; 251 *{'duplicate'} = *{copy}; 252} 253 254sub copy { 255 my $self = shift; 256 return $self->new( 257 $self->x, 258 $self->y, 259 $self->w, 260 $self->h, 261 ); 262} 263 264sub move { 265 my ( $self, $x, $y ) = (@_); 266 if ( not defined $x or not defined $y ) { 267 268 #require Carp; 269 Carp::confess "must receive x and y positions as argument"; 270 } 271 return $self->new( 272 $self->left + $x, 273 $self->top + $y, 274 $self->width, 275 $self->height, 276 ); 277} 278 279sub move_ip { 280 my ( $self, $x, $y ) = (@_); 281 if ( not defined $x or not defined $y ) { 282 283 #require Carp; 284 Carp::confess "must receive x and y positions as argument"; 285 } 286 $self->x( $self->x + $x ); 287 $self->y( $self->y + $y ); 288 289 return; 290} 291 292sub inflate { 293 my ( $self, $x, $y ) = (@_); 294 if ( not defined $x or not defined $y ) { 295 296 #require Carp; 297 Carp::confess "must receive x and y positions as argument"; 298 } 299 300 return $self->new( 301 $self->left - ( $x / 2 ), 302 $self->top - ( $y / 2 ), 303 $self->width + $x, 304 $self->height + $y, 305 ); 306} 307 308sub inflate_ip { 309 my ( $self, $x, $y ) = (@_); 310 if ( not defined $x or not defined $y ) { 311 312 #require Carp; 313 Carp::confess "must receive x and y positions as argument"; 314 } 315 316 $self->x( $self->x - ( $x / 2 ) ); 317 $self->y( $self->y - ( $y / 2 ) ); 318 319 $self->w( $self->w + $x ); 320 $self->h( $self->h + $y ); 321} 322 323sub _get_clamp_coordinates { 324 my ( $self_pos, $self_len, $rect_pos, $rect_len ) = (@_); 325 326 if ( $self_len >= $rect_len ) { 327 return $rect_pos + ( $rect_len / 2 ) - ( $self_len / 2 ); 328 } elsif ( $self_pos < $rect_pos ) { 329 return $rect_pos; 330 } elsif ( ( $self_pos + $self_len ) > ( $rect_pos + $rect_len ) ) { 331 return $rect_pos + $rect_len - $self_len; 332 } else { 333 return $self_pos; 334 } 335} 336 337sub clamp { 338 my ( $self, $rect ) = (@_); 339 340 unless ( $rect->isa('SDL::Rect') ) { 341 Carp::confess "must receive an SDL::Rect-based object"; 342 } 343 344 my $x = _get_clamp_coordinates( $self->x, $self->w, $rect->x, $rect->w ); 345 my $y = _get_clamp_coordinates( $self->y, $self->h, $rect->y, $rect->h ); 346 347 return $self->new( $x, $y, $self->w, $self->h ); 348} 349 350sub clamp_ip { 351 my ( $self, $rect ) = (@_); 352 353 unless ( $rect->isa('SDL::Rect') ) { 354 Carp::confess "must receive an SDL::Rect-based object"; 355 } 356 357 my $x = _get_clamp_coordinates( $self->x, $self->w, $rect->x, $rect->w ); 358 my $y = _get_clamp_coordinates( $self->y, $self->h, $rect->y, $rect->h ); 359 360 $self->x($x); 361 $self->y($y); 362 363 return; 364} 365 366sub _get_intersection_coordinates { 367 my ( $self, $rect ) = (@_); 368 my ( $x, $y, $w, $h ); 369 370 INTERSECTION: 371 { 372 ### Left 373 if ( ( $self->x >= $rect->x ) 374 && ( $self->x < ( $rect->x + $rect->w ) ) ) 375 { 376 $x = $self->x; 377 } elsif ( ( $rect->x >= $self->x ) 378 && ( $rect->x < ( $self->x + $self->w ) ) ) 379 { 380 $x = $rect->x; 381 } else { 382 last INTERSECTION; 383 } 384 385 ## Right 386 if ( ( ( $self->x + $self->w ) > $rect->x ) 387 && ( ( $self->x + $self->w ) <= ( $rect->x + $rect->w ) ) ) 388 { 389 $w = ( $self->x + $self->w ) - $x; 390 } elsif ( ( ( $rect->x + $rect->w ) > $self->x ) 391 && ( ( $rect->x + $rect->w ) <= ( $self->x + $self->w ) ) ) 392 { 393 $w = ( $rect->x + $rect->w ) - $x; 394 } else { 395 last INTERSECTION; 396 } 397 398 ## Top 399 if ( ( $self->y >= $rect->y ) 400 && ( $self->y < ( $rect->y + $rect->h ) ) ) 401 { 402 $y = $self->y; 403 } elsif ( ( $rect->y >= $self->y ) 404 && ( $rect->y < ( $self->y + $self->h ) ) ) 405 { 406 $y = $rect->y; 407 } else { 408 last INTERSECTION; 409 } 410 411 ## Bottom 412 if ( ( ( $self->y + $self->h ) > $rect->y ) 413 && ( ( $self->y + $self->h ) <= ( $rect->y + $rect->h ) ) ) 414 { 415 $h = ( $self->y + $self->h ) - $y; 416 } elsif ( ( ( $rect->y + $rect->h ) > $self->y ) 417 && ( ( $rect->y + $rect->h ) <= ( $self->y + $self->h ) ) ) 418 { 419 $h = ( $rect->y + $rect->h ) - $y; 420 } else { 421 last INTERSECTION; 422 } 423 424 return ( $x, $y, $w, $h ); 425 } 426 427 # if we got here, the two rects do not intersect 428 return ( $self->x, $self->y, 0, 0 ); 429 430} 431 432sub clip { 433 my ( $self, $rect ) = (@_); 434 435 unless ( $rect->isa('SDL::Rect') ) { 436 Carp::confess "must receive an SDL::Rect-based object"; 437 } 438 439 my ( $x, $y, $w, $h ) = _get_intersection_coordinates( $self, $rect ); 440 441 return $self->new( $x, $y, $w, $h ); 442} 443 444sub clip_ip { 445 my ( $self, $rect ) = (@_); 446 447 unless ( $rect->isa('SDL::Rect') ) { 448 Carp::confess "must receive an SDL::Rect-based object"; 449 } 450 451 my ( $x, $y, $w, $h ) = _get_intersection_coordinates( $self, $rect ); 452 453 $self->x($x); 454 $self->y($y); 455 $self->w($w); 456 $self->h($h); 457 458 return; 459} 460 461sub _test_union { 462 my ( $self, $rect ) = (@_); 463 my ( $x, $y, $w, $h ); 464 465 $x = $self->x < $rect->x ? $self->x : $rect->x; # MIN 466 $y = $self->y < $rect->y ? $self->y : $rect->y; # MIN 467 468 $w = 469 ( $self->x + $self->w ) > ( $rect->x + $rect->w ) 470 ? ( $self->x + $self->w ) - $x 471 : ( $rect->x + $rect->w ) - $x; # MAX 472 473 $h = 474 ( $self->y + $self->h ) > ( $rect->y + $rect->h ) 475 ? ( $self->y + $self->h ) - $y 476 : ( $rect->y + $rect->h ) - $y; # MAX 477 478 return ( $x, $y, $w, $h ); 479} 480 481sub union { 482 my ( $self, $rect ) = (@_); 483 484 unless ( $rect->isa('SDL::Rect') ) { 485 Carp::confess "must receive an SDL::Rect-based object"; 486 } 487 488 my ( $x, $y, $w, $h ) = _test_union( $self, $rect ); 489 return $self->new( $x, $y, $w, $h ); 490} 491 492sub union_ip { 493 my ( $self, $rect ) = (@_); 494 495 unless ( $rect->isa('SDL::Rect') ) { 496 Carp::confess "must receive an SDL::Rect-based object"; 497 } 498 499 my ( $x, $y, $w, $h ) = _test_union( $self, $rect ); 500 501 $self->x($x); 502 $self->y($y); 503 $self->w($w); 504 $self->y($h); 505 506 return; 507} 508 509sub _test_unionall { 510 my ( $self, $rects ) = (@_); 511 512 # initial values for union rect 513 my $left = $self->x; 514 my $top = $self->y; 515 my $right = $self->x + $self->w; 516 my $bottom = $self->y + $self->h; 517 518 foreach my $rect ( @{$rects} ) { 519 unless ( $rect->isa('SDL::Rect') ) { 520 521 # TODO: better error message, maybe saying which item 522 # is the bad one (by list position) 523 Carp::confess "must receive an array reference of SDL::Rect-based objects"; 524 } 525 526 $left = $rect->x if $rect->x < $left; # MIN 527 $top = $rect->y if $rect->y < $top; # MIN 528 $right = ( $rect->x + $rect->w ) 529 if ( $rect->x + $rect->w ) > $right; # MAX 530 $bottom = ( $rect->y + $rect->h ) 531 if ( $rect->y + $rect->h ) > $bottom; # MAX 532 } 533 534 return ( $left, $top, $right - $left, $bottom - $top ); 535} 536 537sub unionall { 538 my ( $self, $rects ) = (@_); 539 540 unless ( defined $rects and ref $rects eq 'ARRAY' ) { 541 Carp::confess "must receive an array reference of SDL::Rect-based objects"; 542 } 543 544 my ( $x, $y, $w, $h ) = _test_unionall( $self, $rects ); 545 546 return $self->new( $x, $y, $w, $h ); 547} 548 549sub unionall_ip { 550 my ( $self, $rects ) = (@_); 551 552 unless ( defined $rects and ref $rects eq 'ARRAY' ) { 553 Carp::confess "must receive an array reference of SDL::Rect-based objects"; 554 } 555 556 my ( $x, $y, $w, $h ) = _test_unionall( $self, $rects ); 557 558 $self->x($x); 559 $self->y($y); 560 $self->w($w); 561 $self->h($h); 562 563 return; 564} 565 566sub _check_fit { 567 my ( $self, $rect ) = (@_); 568 569 my $x_ratio = $self->w / $rect->w; 570 my $y_ratio = $self->h / $rect->h; 571 my $max_ratio = ( $x_ratio > $y_ratio ) ? $x_ratio : $y_ratio; 572 573 my $w = int( $self->w / $max_ratio ); 574 my $h = int( $self->h / $max_ratio ); 575 576 my $x = $rect->x + int( ( $rect->w - $w ) / 2 ); 577 my $y = $rect->y + int( ( $rect->h - $h ) / 2 ); 578 579 return ( $x, $y, $w, $h ); 580} 581 582sub fit { 583 my ( $self, $rect ) = (@_); 584 585 unless ( $rect->isa('SDL::Rect') ) { 586 Carp::confess "must receive an SDL::Rect-based object"; 587 } 588 589 my ( $x, $y, $w, $h ) = _check_fit( $self, $rect ); 590 591 return $self->new( $x, $y, $w, $h ); 592} 593 594sub fit_ip { 595 my ( $self, $rect ) = (@_); 596 597 unless ( $rect->isa('SDL::Rect') ) { 598 Carp::confess "must receive an SDL::Rect-based object"; 599 } 600 601 my ( $x, $y, $w, $h ) = _check_fit( $self, $rect ); 602 603 $self->x($x); 604 $self->y($y); 605 $self->w($w); 606 $self->h($h); 607 608 return; 609} 610 611sub normalize { 612 my $self = shift; 613 614 if ( $self->w < 0 ) { 615 $self->x( $self->x + $self->w ); 616 $self->w( -$self->w ); 617 } 618 619 if ( $self->h < 0 ) { 620 $self->y( $self->y + $self->h ); 621 $self->h( -$self->h ); 622 } 623 return; 624} 625 626sub contains { 627 my ( $self, $rect ) = (@_); 628 629 unless ( $rect->isa('SDL::Rect') ) { 630 Carp::confess "must receive an SDL::Rect-based object"; 631 } 632 633 my $contained = 634 ( $self->x <= $rect->x ) 635 && ( $self->y <= $rect->y ) 636 && ( $self->x + $self->w >= $rect->x + $rect->w ) 637 && ( $self->y + $self->h >= $rect->y + $rect->h ) 638 && ( $self->x + $self->w > $rect->x ) 639 && ( $self->y + $self->h > $rect->y ); 640 641 return $contained; 642} 643 644sub collidepoint { 645 my ( $self, $x, $y ) = (@_); 646 647 unless ( defined $x and defined $y ) { 648 Carp::confess "must receive (x,y) as arguments"; 649 } 650 651 my $inside = 652 $x >= $self->x 653 && $x < $self->x + $self->w 654 && $y >= $self->y 655 && $y < $self->y + $self->h; 656 657 return $inside; 658} 659 660sub _do_rects_intersect { 661 my ( $rect_A, $rect_B ) = (@_); 662 663 return ( 664 ( $rect_A->x >= $rect_B->x && $rect_A->x < $rect_B->x + $rect_B->w ) || ( $rect_B->x >= $rect_A->x 665 && $rect_B->x < $rect_A->x + $rect_A->w ) 666 ) 667 && ( ( $rect_A->y >= $rect_B->y && $rect_A->y < $rect_B->y + $rect_B->h ) 668 || ( $rect_B->y >= $rect_A->y && $rect_B->y < $rect_A->y + $rect_A->h ) ); 669} 670 671sub colliderect { 672 my ( $self, $rect ) = (@_); 673 674 unless ( $rect->isa('SDL::Rect') ) { 675 Carp::confess "must receive an SDL::Rect-based object"; 676 } 677 678 return _do_rects_intersect( $self, $rect ); 679} 680 681sub collidelist { 682 my ( $self, $rects ) = (@_); 683 684 unless ( defined $rects and ref $rects eq 'ARRAY' ) { 685 Carp::confess "must receive an array reference of SDL::Rect-based objects"; 686 } 687 688 for ( my $i = 0; $i < @{$rects}; $i++ ) { 689 if ( _do_rects_intersect( $self, $rects->[$i] ) ) { 690 return $i; 691 } 692 } 693 return; 694} 695 696sub collidelistall { 697 my ( $self, $rects ) = (@_); 698 699 unless ( defined $rects and ref $rects eq 'ARRAY' ) { 700 Carp::confess "must receive an array reference of SDL::Rect-based objects"; 701 } 702 703 my @collisions = (); 704 for ( my $i = 0; $i < @{$rects}; $i++ ) { 705 if ( _do_rects_intersect( $self, $rects->[$i] ) ) { 706 push @collisions, $i; 707 } 708 } 709 return \@collisions; 710} 711 712sub collidehash { 713 my ( $self, $rects ) = (@_); 714 715 unless ( defined $rects and ref $rects eq 'HASH' ) { 716 Carp::confess "must receive an hash reference of SDL::Rect-based objects"; 717 } 718 719 while ( my ( $key, $value ) = each %{$rects} ) { 720 unless ( $value->isa('SDL::Rect') ) { 721 Carp::confess "hash element of key '$key' is not an SDL::Rect-based object"; 722 } 723 724 if ( _do_rects_intersect( $self, $value ) ) { 725 return ( $key, $value ); 726 } 727 } 728 return ( undef, undef ); 729} 730 731sub collidehashall { 732 my ( $self, $rects ) = (@_); 733 734 unless ( defined $rects and ref $rects eq 'HASH' ) { 735 Carp::confess "must receive an hash reference of SDL::Rect-based objects"; 736 } 737 738 my %collisions = (); 739 while ( my ( $key, $value ) = each %{$rects} ) { 740 unless ( $value->isa('SDL::Rect') ) { 741 Carp::confess "hash element of key '$key' is not an SDL::Rect-based object"; 742 } 743 744 if ( _do_rects_intersect( $self, $value ) ) { 745 $collisions{$key} = $value; 746 } 747 } 748 return \%collisions; 749} 750 7511; #NOT 42! 752