PageRenderTime 129ms CodeModel.GetById 34ms app.highlight 89ms RepoModel.GetById 2ms app.codeStats 0ms

/lib/SDLx/Rect.pm

http://github.com/PerlGameDev/SDL
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