lib/SDL/Game/Rect.pm

   1 package SDL::Game::Rect;
   2 use strict;
   3 use warnings;
   4 use Carp;
   5 use base 'SDL::Rect';
   6
   7 our $VERSION = '0.01';
   8
   9 sub 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     my $self = $class->SUPER::new($x, $y, $w, $h);
  17     unless ($$self) {
  18         #require Carp;
  19         croak SDL::GetError();
  20     }
  21     bless $self, $class;
  22     return $self;
  23 }
  24
  25 #############################
  26 ## extra accessors
  27 #############################
  28 sub bottom {
  29     my ($self, $val) = (@_);
  30     if (defined $val) {
  31         $self->top($val - $self->height); # y = val - height
  32     }
  33     return $self->top + $self->height; # y + height
  34 }
  35
  36 sub right {
  37     my ($self, $val) = (@_);
  38     if (defined $val) {
  39         $self->left($val - $self->width); # x = val - width
  40     }
  41     return $self->left + $self->width; # x + width
  42 }
  43
  44 sub centerx {
  45     my ($self, $val) = (@_);
  46     if (defined $val) {
  47         $self->left($val - ($self->width >> 1)); # x = val - (width/2)
  48     }
  49     return $self->left + ($self->width >> 1); # x + (width/2)
  50 }
  51
  52 sub centery {
  53     my ($self, $val) = (@_);
  54     if (defined $val) {
  55         $self->top($val - ($self->height >> 1)); # y = val - (height/2)
  56     }
  57     return $self->top + ($self->height >> 1); # y + (height/2)
  58 }
  59
  60 sub size {
  61     my ($self, $w, $h) = (@_);
  62
  63     return ($self->width, $self->height)  # (width, height)
  64         unless (defined $w or defined $h);
  65
  66     if (defined $w) {
  67         $self->width($w); # width
  68     }
  69     if (defined $h) {
  70         $self->height($h); # height
  71     }
  72 }
  73
  74 sub topleft {
  75     my ($self, $y, $x) = (@_);
  76
  77     return ($self->top, $self->left) # (top, left)
  78         unless (defined $y or defined $x);
  79
  80     if (defined $x) {
  81         $self->left($x); # left
  82     }
  83     if (defined $y) {
  84         $self->top($y); # top
  85     }
  86     return;
  87 }
  88
  89 sub midleft {
  90     my ($self, $centery, $x) = (@_);
  91
  92     return ($self->top + ($self->height >> 1), $self->left) # (centery, left)
  93         unless (defined $centery or defined $x);
  94
  95     if (defined $x) {
  96         $self->left($x); # left
  97     }
  98     if (defined $centery) {
  99         $self->top($centery - ($self->height >> 1)); # y = centery - (height/2)
 100     }
 101     return;
 102 }
 103
 104 sub bottomleft {
 105     my ($self, $bottom, $x) = (@_);
 106
 107     return ($self->top + $self->height, $self->left) # (bottom, left)
 108         unless (defined $bottom or defined $x);
 109
 110     if (defined $x) {
 111         $self->left($x); # left
 112     }
 113     if (defined $bottom) {
 114         $self->top($bottom - $self->height); # y = bottom - height
 115     }
 116     return;
 117 }
 118
 119 sub center {
 120     my ($self, $centerx, $centery) = (@_);
 121
 122     return ($self->left + ($self->width >> 1), $self->top + ($self->height >> 1))
 123         unless (defined $centerx or defined $centery);
 124
 125     if (defined $centerx) {
 126         $self->left($centerx - ($self->width >> 1)); # x = centerx - (width/2)
 127     }
 128     if (defined $centery) {
 129         $self->top($centery - ($self->height >> 1)); # y = centery - (height/2)
 130     }
 131     return;
 132 }
 133
 134 sub topright {
 135     my ($self, $y, $right) = (@_);
 136
 137     return ($self->top, $self->left + $self->width) # (top, right)
 138         unless (defined $y or defined $right);
 139
 140     if (defined $right) {
 141         $self->left($right - $self->width); # x = right - width
 142     }
 143     if (defined $y) {
 144         $self->top($y); # top
 145     }
 146     return;
 147 }
 148
 149 sub midright {
 150     my ($self, $centery, $right) = (@_);
 151
 152     return ($self->top + ($self->height >> 1), $self->left + $self->width) # (centery, right)
 153         unless (defined $centery or defined $right);
 154
 155     if (defined $right) {
 156         $self->left($right - $self->width); # x = right - width
 157     }
 158     if (defined $centery) {
 159         $self->top($centery - ($self->height >> 1)); # y = centery - (height/2)
 160     }
 161     return;
 162 }
 163
 164 sub bottomright {
 165     my ($self, $bottom, $right) = (@_);
 166
 167     return ($self->top + $self->height, $self->left + $self->width) # (bottom, right)
 168         unless (defined $bottom or defined $right);
 169
 170     if (defined $right) {
 171         $self->left($right - $self->width); # x = right - width
 172     }
 173     if (defined $bottom) {
 174         $self->top($bottom - $self->height); # y = bottom - height
 175     }
 176     return;
 177 }
 178
 179 sub midtop {
 180     my ($self, $centerx, $y) = (@_);
 181
 182     return ($self->left + ($self->width >> 1), $self->top) # (centerx, top)
 183         unless (defined $centerx or defined $y);
 184
 185     if (defined $y) {
 186         $self->top($y); # top
 187     }
 188     if (defined $centerx) {
 189         $self->left($centerx - ($self->width >> 1)); # x = centerx - (width/2)
 190     }
 191     return;
 192 }
 193
 194 sub midbottom {
 195     my ($self, $centerx, $bottom) = (@_);
 196
 197     return ($self->left + ($self->width >> 1), $self->top + $self->height) # (centerx, bottom)
 198         unless (defined $centerx or defined $bottom);
 199
 200     if (defined $bottom) {
 201         $self->top($bottom - $self->height); # y = bottom - height
 202     }
 203     if (defined $centerx) {
 204         $self->left($centerx - ($self->width >> 1)); # x = centerx - (width/2)
 205     }
 206     return;
 207 }
 208
 209 ###############################
 210 ## methods                   ##
 211 ###############################
 212
 213 sub duplicate {
 214 }
 215
 216 sub copy {
 217     my $self = shift;
 218     return $self->new(
 219         -top    => $self->top,
 220         -left   => $self->left,
 221         -width  => $self->width,
 222         -height => $self->height,
 223     );
 224 }
 225
 226 sub move {
 227     my ($self, $x, $y) = (@_);
 228     if (not defined $x or not defined $y) {
 229         #require Carp;
 230         croak "must receive x and y positions as argument";
 231     }
 232     return $self->new(
 233         -top    => $self->top + $y,
 234         -left   => $self->left + $x,
 235         -width  => $self->width,
 236         -height => $self->height,
 237     );
 238 }
 239
 240 sub move_ip {
 241     my ($self, $x, $y) = (@_);
 242     if (not defined $x or not defined $y) {
 243         #require Carp;
 244         croak "must receive x and y positions as argument";
 245     }
 246     $self->x($self->x + $x);
 247     $self->y($self->y + $y);
 248
 249     return;
 250 }
 251
 252 sub inflate {
 253     my ($self, $x, $y) = (@_);
 254     if (not defined $x or not defined $y) {
 255         #require Carp;
 256         croak "must receive x and y positions as argument";
 257     }
 258
 259     return $self->new(
 260         -left   => $self->left   - ($x / 2),
 261         -top    => $self->top    - ($y / 2),
 262         -width  => $self->width  + $x,
 263         -height => $self->height + $y,
 264     );
 265 }
 266
 267 sub inflate_ip {
 268     my ($self, $x, $y) = (@_);
 269     if (not defined $x or not defined $y) {
 270         #require Carp;
 271         croak "must receive x and y positions as argument";
 272     }
 273
 274     $self->x( $self->x - ($x / 2) );
 275     $self->y( $self->y - ($y / 2) );
 276
 277     $self->w( $self->w + $x );
 278     $self->h( $self->h + $y );
 279 }
 280
 281 sub _get_clamp_coordinates {
 282     my ($self_pos, $self_len, $rect_pos, $rect_len) = (@_);
 283
 284     if ($self_len >= $rect_len) {
 285         return $rect_pos + ($rect_len / 2) - ($self_len / 2);
 286     }
 287     elsif ($self_pos < $rect_pos) {
 288         return $rect_pos;
 289     }
 290     elsif ( ($self_pos + $self_len) > ($rect_pos + $rect_len) ) {
 291         return $rect_pos + $rect_len - $self_len;
 292     }
 293     else {
 294         return $self_pos;
 295     }
 296 }
 297
 298 sub clamp {
 299     my ($self, $rect) = (@_);
 300
 301     unless ($rect->isa('SDL::Rect')) {
 302         croak "must receive an SDL::Rect-based object";
 303     }
 304
 305     my $x = _get_clamp_coordinates($self->x, $self->w, $rect->x, $rect->w);
 306     my $y = _get_clamp_coordinates($self->y, $self->h, $rect->y, $rect->h);
 307
 308     return $self->new($x, $y, $self->w, $self->h);
 309 }
 310
 311 sub clamp_ip {
 312     my ($self, $rect) = (@_);
 313
 314     unless ($rect->isa('SDL::Rect')) {
 315         croak "must receive an SDL::Rect-based object";
 316     }
 317
 318     my $x = _get_clamp_coordinates($self->x, $self->w, $rect->x, $rect->w);
 319     my $y = _get_clamp_coordinates($self->y, $self->h, $rect->y, $rect->h);
 320
 321     $self->x($x);
 322     $self->y($y);
 323
 324     return;
 325 }
 326
 327 42;
 328 __END__
 329
 330 =head1 NAME
 331
 332 SDL::Game::Rect - SDL::Game object for storing and manipulating rectangular coordinates
 333
 334 =head1 SYNOPSIS
 335
 336
 337 =head1 DESCRIPTION
 338
 339 C<< SDL::Game::Rect >> object are used to store and manipulate rectangular areas. Rect objects are created from a combination of left (or x), top (or y), width (or w) and height (or h) values, just like raw C<< SDL::Rect objects >>.
 340
 341 All C<< SDL::Game::Rect >> methods that change either position or size of a Rect return B<a new copy> of the Rect with the affected changes. The original Rect is B<not> modified. If you wish to modify the current Rect object, you can use the equivalent "in-place" methods that do not return but instead affects the original Rect. These "in-place" methods are denoted with the "ip" suffix. Note that changing a Rect's attribute is I<always> an in-place operation.
 342
 343
 344 =head2 ATTRIBUTES
 345
 346 All Rect attributes are acessors, meaning you can get them by name, and set them by passing a value:
 347
 348    $rect->left(15);
 349    $rect->left;       # 15
 350
 351 The Rect object has several attributes which can be used to resize, move and align the Rect.
 352
 353
 354 =over 4
 355
 356 =item * width, w - gets/sets object's width
 357
 358 =item * height, h - gets/sets object's height
 359
 360 =item * left, x - moves the object left position to match the given coordinate
 361
 362 =item * top, y  - moves the object top position to match the given coordinate
 363
 364 =item * bottom - moves the object bottom position to match the given coordinate
 365
 366 =item * right - moves the object right position to match the given coordinate
 367
 368 =item * centerx - moves the object's horizontal center to match the given coordinate
 369
 370 =item * centery - moves the object's vertical center to match the given coordinate
 371
 372 =back
 373
 374 Some of the attributes above can be fetched or set in pairs:
 375
 376   $rect->topleft(10, 15);   # top is now 10, left is now 15
 377
 378   my ($width, $height) = $rect->size;
 379
 380
 381 =over 4
 382
 383 =item * size - gets/sets object's size (width, height)
 384
 385 =item * topleft - gets/sets object's top and left positions
 386
 387 =item * midleft - gets/sets object's vertical center and left positions
 388
 389 =item * bottomleft - gets/sets object's bottom and left positions
 390
 391 =item * center - gets/sets object's center (horizontal(x), vertical(y))
 392
 393 =item * topright - gets/sets object's top and right positions
 394
 395 =item * midright - gets/sets object's vertical center and right positions
 396
 397 =item * bottomright - gets/sets object's bottom and right positions
 398
 399 =item * midtop - gets/sets object's horizontal center and top positions
 400
 401 =item * midbottom - gets/sets object's horizontal center and bottom positions
 402
 403 =back
 404
 405
 406 =head2 METHODS
 407
 408 Methods denoted as receiving Rect objects can receive either C<<SDL::Game::Rect>> or raw C<<SDL::Rect>> objects.
 409
 410 =head3 new ($left, $top, $width, $height)
 411
 412 Returns a new Rect object with the given coordinates. If any value is omitted (by passing undef), 0 is used instead.
 413
 414 =head3 copy
 415
 416 =head3 duplicate
 417
 418 Returns a new Rect object having the same position and size as the original
 419
 420 =head3 move(x, y)
 421
 422 Returns a new Rect that is moved by the given offset. The x and y arguments can be any integer value, positive or negative.
 423
 424 =head3 move_ip(x, y)
 425
 426 Same as C<<move>> above, but moves the current Rect in place and returns nothing.
 427
 428 =head3 inflate(x, y)
 429
 430 Grows or shrinks the rectangle. Returns a new Rect with the size changed by the given offset. The rectangle remains centered around its current center. Negative values will return a shrinked rectangle instead.
 431
 432 =head3 inflate_ip(x, y)
 433
 434 Same as C<<inflate>> above, but grows/shrinks the current Rect in place and returns nothing.
 435
 436 =head3 clamp($rect)
 437
 438 Returns a new Rect moved to be completely inside the Rect object passed as an argument. If the current Rect is too large to fit inside the passed Rect, it is centered inside it, but its size is not changed.
 439
 440 =head3 clamp_ip($rect)
 441
 442 Same as C<<clamp>> above, but moves the current Rect in place and returns nothing.
 443
 444 =head3 clip($rect)
 445
 446 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.
 447
 448 =head3 clip_ip($rect)
 449
 450 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.
 451
 452 =head3 union($rect)
 453
 454 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.
 455
 456 =head3 union_ip($rect)
 457
 458 Same as C<<union>> above, but resizes the current Rect in place and returns nothing.
 459
 460 =head3 unionall( [$rect1, $rect2, ...] )
 461
 462 Returns the union of one rectangle with a sequence of many rectangles, passed as an ARRAY REF.
 463
 464 =head3 unionall_ip( [$rect1, $rect2, ...] )
 465
 466 Same as C<<unionall>> above, but resizes the current Rect in place and returns nothing.
 467
 468 =head3 fit($rect)
 469
 470 Returns a new Rect moved and resized to fit the Rect object passed as an argument. The aspect ratio of the original Rect is preserved, so the new rectangle may be smaller than the target in either width or height.
 471
 472 =head3 fit_ip($rect)
 473
 474 Same as C<<fit>> above, but moves/resizes the current Rect in place and returns nothing.
 475
 476 =head3 normalize
 477
 478 Corrects negative sizes, flipping width/height of the Rect if they have a negative size. No repositioning is made so the rectangle will remain in the same place, but the negative sides will be swapped. This method returns nothing.
 479
 480 =head3 contains($rect)
 481
 482 Returns true (non-zero) when the argument is completely inside the Rect. Otherwise returns undef.
 483
 484 =head3 collidepoint(x, y)
 485
 486 Returns true (non-zero) if the given point is inside the Rect, otherwise returns undef. A point along the right or bottom edge is not considered to be inside the rectangle.
 487
 488 =head3 colliderect($rect)
 489
 490 Returns true (non-zero) if any portion of either rectangles overlap (except for the top+bottom or left+right edges).
 491
 492 =head3 collidelist( [$rect1, $rect2, ...] )
 493
 494 Test whether the rectangle collides with any in a sequence of rectangles, passed as an ARRAY REF. The index of the first collision found is returned. Returns undef if no collisions are found.
 495
 496 =head3 collidelistall( [$rect1, $rect2, ...] )
 497
 498 Returns an ARRAY REF of all the indices that contain rectangles that collide with the Rect. If no intersecting rectangles are found, an empty list ref is returned.
 499
 500 =head3 collidehash( {key1 => $rect1, key2 => $rect2, ...} )
 501
 502 Receives a HASH REF and returns the a (key, value) list with the key and value of the first hash item that collides with the Rect. If no collisions are found, returns (undef, undef).
 503
 504 =head3 collidehashall( {key1 => $rect1, key2 => $rect2, ...} )
 505
 506 Returns a HASH REF of all the key and value pairs that intersect with the Rect. If no collisions are found an empty hash ref is returned.
 507
 508
 509 =head1 AUTHOR
 510
 511 Breno G. de Oliveira, C<< <garu at cpan.org> >>
 512
 513 =head1 BUGS
 514
 515 Please report any bugs or feature requests to the bug tracker. I will be notified, and then you'll automatically be notified of progress on your bug as we make changes.
 516
 517
 518 =head1 SUPPORT
 519
 520 You can find documentation for this module with the perldoc command.
 521
 522     perldoc SDL::Game::Rect
 523
 524
 525 =head1 ACKNOWLEDGEMENTS
 526
 527 Many thanks to all SDL_Perl contributors, and to the authors of pygame.rect, in which this particular module is heavily based.
 528
 529 =head1 COPYRIGHT & LICENSE
 530
 531 Copyright 2009 Breno G. de Oliveira, all rights reserved.
 532
 533 This program is free software; you can redistribute it and/or modify it
 534 under the same terms as Perl itself.
 535
 536
 537 =head1 SEE ALSO
 538
 539 perl, L<SDL>, L<SDL::Rect>, L<SDL::Game>