/lib/SDLx/Rect.pm

http://github.com/PerlGameDev/SDL · Perl · 752 lines · 573 code · 160 blank · 19 comment · 80 complexity · dca0a4aeaf35147350c6101b6b0925b0 MD5 · raw file

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