File Coverage

blib/lib/Math/Zap/Triangle2.pm
Criterion Covered Total %
statement 124 197 62.9
branch 25 56 44.6
condition 16 78 20.5
subroutine 30 57 52.6
pod 26 48 54.1
total 221 436 50.6


line stmt bran cond sub pod time code
1            
2             =head1 Triangle2
3            
4             Triangles in 2D space
5            
6             PhilipRBrenan@yahoo.com, 2004, Perl License
7            
8            
9             =head2 Synopsis
10            
11             Example t/triangle2.t
12            
13             #_ Triangle ___________________________________________________________
14             # Test 2d triangles
15             # philiprbrenan@yahoo.com, 2004, Perl License
16             #______________________________________________________________________
17            
18             use Math::Zap::Triangle2;
19             use Math::Zap::Vector2;
20             use Test::Simple tests=>27;
21            
22             $a = triangle2
23             (vector2(0, 0),
24             vector2(2, 0),
25             vector2(0, 2),
26             );
27            
28             $b = triangle2
29             (vector2( 0, 0),
30             vector2( 4, 0),
31             vector2( 0, 4),
32             );
33            
34             $c = triangle2
35             (vector2( 0, 0),
36             vector2(-4, 0),
37             vector2( 0, -4),
38             );
39            
40             $d = $b - vector2(1,1);
41             $e = $c + vector2(1,1);
42            
43             #print "a=$a\nb=$b\nc=$c\nd=$d\ne=$e\n";
44            
45             ok($a->containsPoint(vector2( 1, 1)));
46             ok($a->containsPoint(vector2( 1, 1)));
47             ok($b->containsPoint(vector2( 2, 0)));
48             ok($b->containsPoint(vector2( 1, 0)));
49             ok($c->containsPoint(vector2(-1, 0)));
50             ok($c->containsPoint(vector2(-2, 0)));
51             ok($d->containsPoint(vector2( 1, -1)));
52            
53             ok(!$a->containsPoint(vector2( 9, 1)));
54             ok(!$a->containsPoint(vector2( 1, 9)));
55             ok(!$b->containsPoint(vector2( 2, 9)));
56             ok(!$b->containsPoint(vector2( 9, 0)));
57             ok(!$c->containsPoint(vector2(-9, 0)));
58             ok(!$c->containsPoint(vector2(-2, 9)));
59             ok(!$d->containsPoint(vector2( 9, -1)));
60            
61             ok( $a->containsPoint(vector2(0.5, 0.5)));
62             ok(!$a->containsPoint(vector2( -1, -1)));
63            
64             ok(vector2(1,2)->rightAngle == vector2(-2, 1));
65             ok(vector2(1,0)->rightAngle == vector2( 0, 1));
66            
67             ok($a->area == 2);
68             ok($c->area == 8);
69            
70             eval { triangle2(vector2(0, 0), vector2(3, -6), vector2(-3, 6))};
71             ok($@ =~ /^Narrow triangle2/, 'Narrow triangle');
72            
73             $t = triangle2(vector2(0,0),vector2(0,10),vector2( 10,0));
74             $T = triangle2(vector2(0,0),vector2(0,10),vector2(-10,10))+vector2(5, -2);
75             @p = $t->ring($T);
76             #print "$_\n" for(@p);
77             ok($p[0] == vector2(0, 8), 'Ring 0');
78             ok($p[1] == vector2(2, 8), 'Ring 1');
79             ok($p[2] == vector2(5, 5), 'Ring 2');
80             ok($p[3] == vector2(5, 0), 'Ring 3');
81             ok($p[4] == vector2(3, 0), 'Ring 4');
82             ok($p[5] == vector2(0, 3), 'Ring 5');
83            
84            
85            
86             =head2 Description
87            
88             Triangles in 2d space
89            
90             =cut
91            
92            
93             package Math::Zap::Triangle2;
94             $VERSION=1.07;
95 2     2   1803 use Math::Zap::Line2;
  2         6  
  2         67  
96 2     2   10 use Math::Zap::Matrix2 new2v=>'matrix2New2v';
  2         3  
  2         53  
97 2     2   10 use Math::Zap::Vector2 check=>'vector2Check';
  2         3  
  2         82  
98 2     2   560 use Math::Zap::Vector check=>'vectorCheck';
  2         4  
  2         69  
99 2     2   13 use Math::Trig;
  2         5  
  2         498  
100 2     2   13 use Carp qw(cluck confess);
  2         3  
  2         124  
101 2     2   11 use constant debug => 0; # Debugging level
  2         4  
  2         7604  
102            
103            
104             =head2 Constructors
105            
106            
107             =head3 new
108            
109             Create a triangle from 3 vectors specifying the coordinates of each
110             corner in space coordinates.
111            
112             =cut
113            
114            
115 9     9 1 12 sub new($$$)
116             {vector2Check(@_) if debug;
117 9         32 my $t = bless {a=>$_[0], b=>$_[1], c=>$_[2]};
118 9         23 narrow($t, 1);
119 8         52 $t;
120             }
121            
122            
123             =head3 triangle2
124            
125             Create a triangle from 3 vectors specifying the coordinates of each
126             corner in space coordinates - synonym for L.
127            
128             =cut
129            
130            
131 6     6 1 18 sub triangle2($$$) {new($_[0],$_[1],$_[2])};
132            
133            
134             =head3 newnnc
135            
136             New without narrowness check
137            
138             =cut
139            
140            
141 0     0 1 0 sub newnnc($$$)
142             {vector2Check(@_) if debug;
143 0         0 bless {a=>$_[0], b=>$_[1], c=>$_[2]};
144             }
145            
146            
147             =head3 newV
148            
149             Create a triangle from the x,y components of 3 3d vectors.
150            
151             =cut
152            
153            
154 0     0 1 0 sub newV($$$)
155             {vectorCheck(@_) if debug;
156 0         0 my $t = bless
157             {a=>vector2($_[0]->{x}, $_[0]->{y}),
158             b=>vector2($_[1]->{x}, $_[1]->{y}),
159             c=>vector2($_[2]->{x}, $_[2]->{y})};
160 0         0 narrow($t, 1);
161 0         0 $t;
162             }
163            
164            
165             =head3 newVnnc
166            
167             Create a triangle from the x,y components of 3 3d vectors without
168             narrowness checking - assumes caller will do thir own.
169            
170             =cut
171            
172            
173 0     0 1 0 sub newVnnc($$$)
174             {vectorCheck(@_) if debug;
175 0         0 bless
176             {a=>vector2($_[0]->{x}, $_[0]->{y}),
177             b=>vector2($_[1]->{x}, $_[1]->{y}),
178             c=>vector2($_[2]->{x}, $_[2]->{y})};
179             }
180            
181            
182             =head2 Methods
183            
184            
185             =head3 accuracy
186            
187             Get/Set accuracy for comparisons
188            
189             =cut
190            
191            
192             my $accuracy = 1e-10;
193            
194             sub accuracy
195 0 0   0 1 0 {return $accuracy unless scalar(@_);
196 0         0 $accuracy = shift();
197             }
198            
199            
200             =head3 narrow
201            
202             Narrow (colinear) colinear?
203            
204             =cut
205            
206            
207 9     9 1 13 sub narrow($$)
208             {my $t = shift; # Triangle
209 9         12 my $a = 1e-2; # Accuracy
210 9         9 my $A = shift; # Action 0: return indicator, 1: confess
211 9         328 my $b = vector($t->{b}{x}-$t->{a}{x}, $t->{b}{y}-$t->{a}{y}, 0);
212 9         226 my $c = vector($t->{c}{x}-$t->{a}{x}, $t->{c}{y}-$t->{a}{y}, 0);
213 9         63 my $n = ($b x $c)->length < $a;
214 9 100 66     223 confess "Narrow triangle2" if $n and $A;
215 8         23 $n;
216             }
217            
218            
219             =head3 check
220            
221             Check its a triangle
222            
223             =cut
224            
225            
226             sub check(@)
227 5     5 1 7 {if (debug)
228             {for my $t(@_)
229             {confess "$t is not a triangle2" unless ref($t) eq __PACKAGE__;
230             }
231             }
232 5         13 @_;
233             }
234            
235            
236             =head3 is
237            
238             Test its a triangle
239            
240             =cut
241            
242            
243 0 0       0 sub is(@)
244 0     0 1 0 {for my $t(@_)
245             {return 0 unless ref($t) eq __PACKAGE__;
246             }
247 0         0 'triangle2';
248             }
249            
250            
251             =head3 components
252            
253             Components of a triangle
254            
255             =cut
256            
257            
258 31     31 0 35 sub a($) {check(@_) if debug; $_[0]->{a}}
  31         120  
259 5     5 0 6 sub b($) {check(@_) if debug; $_[0]->{b}}
  5         20  
260 5     5 0 6 sub c($) {check(@_) if debug; $_[0]->{c}}
  5         15  
261            
262 30     30 0 31 sub ab($) {check(@_) if debug; ($_[0]->{b}-$_[0]->{a})}
  30         96  
263 30     30 0 30 sub ac($) {check(@_) if debug; ($_[0]->{c}-$_[0]->{a})}
  30         84  
264 0     0 0 0 sub ba($) {check(@_) if debug; ($_[0]->{a}-$_[0]->{b})}
  0         0  
265 0     0 0 0 sub bc($) {check(@_) if debug; ($_[0]->{c}-$_[0]->{b})}
  0         0  
266 0     0 0 0 sub ca($) {check(@_) if debug; ($_[0]->{a}-$_[0]->{c})}
  0         0  
267 0     0 0 0 sub cb($) {check(@_) if debug; ($_[0]->{b}-$_[0]->{c})}
  0         0  
268            
269 0     0 0 0 sub abc($) {check(@_) if debug; ($_[0]->{a}, $_[0]->{b}, $_[0]->{c})}
  0         0  
270            
271 10     10 0 14 sub lab($) {check(@_) if debug; line2($_[0]->{b}, $_[0]->{a})}
  10         260  
272 10     10 0 11 sub lac($) {check(@_) if debug; line2($_[0]->{c}, $_[0]->{a})}
  10         332  
273 0     0 0 0 sub lba($) {check(@_) if debug; line2($_[0]->{a}, $_[0]->{b})}
  0         0  
274 10     10 0 11 sub lbc($) {check(@_) if debug; line2($_[0]->{c}, $_[0]->{b})}
  10         245  
275 0     0 0 0 sub lca($) {check(@_) if debug; line2($_[0]->{a}, $_[0]->{c})}
  0         0  
276 0     0 0 0 sub lcb($) {check(@_) if debug; line2($_[0]->{b}, $_[0]->{c})}
  0         0  
277            
278            
279             =head3 clone
280            
281             Create a triangle from another triangle
282            
283             =cut
284            
285            
286 0     0 1 0 sub clone($)
287             {my ($t) = check(@_); # Triangle
288 0         0 bless {a=>$t->a, b=>$t->b, c=>$t->c};
289             }
290            
291            
292             =head3 permute
293            
294             Cyclically permute the points of a triangle
295            
296             =cut
297            
298            
299 0     0 1 0 sub permute($)
300             {my ($t) = check(@_); # Triangle
301 0         0 bless {a=>$t->b, b=>$t->c, c=>$t->a};
302             }
303            
304            
305             =head3 center
306            
307             Center
308            
309             =cut
310            
311            
312 0     0 1 0 sub center($)
313             {my ($t) = check(@_); # Triangle
314 0         0 ($t->a + $t->b + $t->c) / 3;
315             }
316            
317            
318             =head3 area
319            
320             Area
321            
322             =cut
323            
324            
325 2     2 1 10 sub area($)
326             {my ($t) = check(@_); # Triangle
327 2         5 sqrt((($t->ab*$t->ab) * ($t->ac*$t->ac)) - ($t->ab * $t->ac))/2;
328             }
329            
330            
331             =head3 add
332            
333             Add a vector to a triangle
334            
335             =cut
336            
337            
338 2     2 1 5 sub add($$)
339             {my ($t) = check(@_[0..0]); # Triangle
340 2         52 my ($v) = vector2Check(@_[1..1]); # Vector
341 2         37 new($t->a+$v, $t->b+$v, $t->c+$v);
342             }
343            
344            
345             =head3 subtract
346            
347             Subtract a vector from a triangle
348            
349             =cut
350            
351            
352 1     1 1 6 sub subtract($$)
353             {my ($t) = check(@_[0..0]); # Triangle
354 1         45 my ($v) = vector2Check(@_[1..1]); # Vector
355 1         6 new($t->a-$v, $t->b-$v, $t->c-$v);
356             }
357            
358            
359             =head3 multiply
360            
361             Multiply a triangle by a scalar
362            
363             =cut
364            
365            
366 0     0 1 0 sub multiply($$)
367             {my ($t) = check(@_[0..0]); # Triangle
368 0         0 my ($s) = @_[1..1] ; # Scalar
369 0         0 new($t->a * $s, $t->b * $s, $t->c * $s);
370             }
371            
372            
373             =head3 divideBy
374            
375             Divide a triangle by a scalar
376            
377             =cut
378            
379            
380 0     0 1 0 sub divideBy($$)
381             {my ($t) = check(@_[0..0]); # Triangle
382 0         0 my ($s) = @_[1..1] ; # Scalar
383 0 0       0 $s != 0 or confess "Attempt to divide by zero";
384 0         0 new($t->a / $s, $t->b / $s, $t->c / $s);
385             }
386            
387            
388             =head3 print
389            
390             Print triangle
391            
392             =cut
393            
394            
395 0     0 1 0 sub print($)
396             {my ($t) = @_; # Triangle
397 0         0 check(@_) if debug;
398 0         0 my ($a, $b, $c) = ($t->a, $t->b, $t->c);
399 0         0 "triangle2($a, $b, $c)";
400             }
401            
402            
403             =head3 convertSpaceToPlane
404            
405             Convert space to plane coordinates
406            
407             =cut
408            
409            
410 0     0 1 0 sub convertSpaceToPlane($$)
411             {my ($t, $p) = @_;
412 0         0 check(@_[0..0]) if debug; # Triangle
413 0         0 vector2Check(@_[1..1]) if debug; # Vector
414            
415 0         0 my $q = $p-$t->a;
416            
417 0         0 vector2
418             ($q * $t->ab / ($t->ab * $t->ab),
419             $q * $t->ac / ($t->ac * $t->ac),
420             );
421             }
422            
423            
424             =head3 containsPoint
425            
426             Check whether point p is completely contained within triangle t.
427            
428             =cut
429            
430            
431 24     24 1 39 sub containsPoint($$)
432             {my ($t, $p) = @_;
433 24         28 check(@_[0..0]) if debug; # Triangle
434 24         24 vector2Check(@_[1..1]) if debug; # Vector
435            
436 24         55 my $s = matrix2New2v($t->ab, $t->ac) / ($p - $t->a);
437            
438 24 100 100     141 return 1 if 0 <= $s->x and $s->x <= 1
      100        
      100        
      100        
439             and 0 <= $s->y and $s->y <= 1
440             and $s->x + $s->y <= 1;
441 16         71 0;
442             }
443            
444            
445             =head3 contains
446            
447             Check whether triangle T is completely contained within triangle t.
448            
449             =cut
450            
451            
452 2     2 1 3 sub contains($$)
453             {my ($t, $T) = @_;
454 2         3 check(@_) if debug; # Triangles
455            
456 2 0 33     4 return 1 if $t->containsPoint($T->a) and
      33        
457             $t->containsPoint($T->b) and
458             $t->containsPoint($T->c);
459 2         8 0;
460             }
461            
462            
463             =head3 pointsInCommon
464            
465             Find points in common to two triangles. A point in common is a point
466             on the border of one triangle touched by the border of the other
467             triangle.
468            
469             =cut
470            
471            
472 1     1 1 2 sub pointsInCommon($$)
473             {my ($t, $T) = @_;
474 1         2 check(@_) if debug; # Triangles
475            
476 1 50       3 return ($T->a, $T->b, $T->c) if $t->contains($T);
477 1 50       3 return ($t->a, $t->b, $t->c) if $T->contains($t);
478            
479 1         3 my @p = ();
480 1 50       3 push @p, $t->a if $T->containsPoint($t->a);
481 1 50       4 push @p, $t->b if $T->containsPoint($t->b);
482 1 50       4 push @p, $t->c if $T->containsPoint($t->c);
483            
484 1 50       4 push @p, $T->a if $t->containsPoint($T->a);
485 1 50       4 push @p, $T->b if $t->containsPoint($T->b);
486 1 50       3 push @p, $T->c if $t->containsPoint($T->c);
487            
488 1 50       7 push @p, $t->lab->intersect($T->lab) if $t->lab->crossOver($T->lab);
489 1 50       12 push @p, $t->lab->intersect($T->lac) if $t->lab->crossOver($T->lac);
490 1 50       9 push @p, $t->lab->intersect($T->lbc) if $t->lab->crossOver($T->lbc);
491 1 50       7 push @p, $t->lac->intersect($T->lab) if $t->lac->crossOver($T->lab);
492 1 50       7 push @p, $t->lac->intersect($T->lac) if $t->lac->crossOver($T->lac);
493 1 50       7 push @p, $t->lac->intersect($T->lbc) if $t->lac->crossOver($T->lbc);
494 1 50       7 push @p, $t->lbc->intersect($T->lab) if $t->lbc->crossOver($T->lab);
495 1 50       6 push @p, $t->lbc->intersect($T->lac) if $t->lbc->crossOver($T->lac);
496 1 50       6 push @p, $t->lbc->intersect($T->lbc) if $t->lbc->crossOver($T->lbc);
497            
498             # Remove duplicate points caused by splitting the vertices - inefficient and unreliable
499 1         6 my %p;
500 1         4 $p{"$_"}=$_ for(@p);
501 1         9 values(%p);
502             }
503            
504            
505             =head3 ring
506            
507             Ring of points formed by overlaying triangle t and T
508            
509             =cut
510            
511            
512 1     1 1 10 sub ring($$)
513             {my ($t, $T) = @_;
514 1         2 check(@_) if debug; # Triangles
515            
516 1         5 my @p = $t->pointsInCommon($T);
517             # scalar(@p) == 1 and warn "Only one point in common";
518             # scalar(@p) == 2 and warn "Only two points in common";
519 1 50       4 return () unless scalar(@p) > 2;
520            
521             # Find center
522 1         27 my $c = vector2(0,0);
523 1         10 $c += $_ for(@p);
524 1         4 $c /= scalar(@p);
525            
526             # Split by y coord
527 1         3 my (@yp, @yn);
528 1 50       3 for my $p(0..@p-1)
  6         13  
529             {return () if ($p[$p]-$c)->length < $accuracy;
530 6 100       18 if (($p[$p]-$c)->y >= 0)
  3         8  
531 3         7 {push @yp, $p;
532             }
533             else
534             {push @yn, $p;
535             }
536             }
537            
538 1         7 @yp = sort {($p[$a]-$c)->norm->x <=> ($p[$b]-$c)->norm->x} @yp;
  3         12  
539 1         5 @yn = sort {($p[$b]-$c)->norm->x <=> ($p[$a]-$c)->norm->x} @yn;
  3         11  
540            
541 1         4 my @a;
542 1         5 push @a, $p[$_] for(@yp);
543 1         4 push @a, $p[$_] for(@yn);
544 1         6 @a;
545             }
546            
547            
548             =head3 convertPlaneToSpace
549            
550             Convert plane to space coordinates
551            
552             =cut
553            
554            
555 0     0 1 0 sub convertPlaneToSpace($$)
556             {my ($t, $p) = @_;
557 0         0 check(@_[0..0]) if debug; # Triangle
558 0         0 vector2Check(@_[1..1]) if debug; # Vector in plane
559            
560 0         0 $t->a + ($p->x * $t->ab) + ($p->y * $t->ac);
561             }
562            
563            
564             =head3 split
565            
566             Split a triangle into 4 sub triangles unless the sub triangles would
567             be too small
568            
569             =cut
570            
571            
572 0     0 1 0 sub split($$)
573             {my ($t) = check(@_[0..0]); # Triangles
574 0         0 my ($s) = (@_[1..1]); # Minimum size
575            
576 0 0 0     0 return () unless
      0        
577             $t->ab->length > $s and
578             $t->ac->length > $s and
579             $t->bc->length > $s;
580            
581 0         0 (new($t->a, ($t->a+$t->b)/2, ($t->a+$t->c)/2),
582             new($t->b, ($t->b+$t->a)/2, ($t->b+$t->c)/2),
583             new($t->c, ($t->c+$t->a)/2, ($t->c+$t->b)/2),
584             new(($t->a+$t->b)/2, ($t->a+$t->b)/2, ($t->b+$t->c)/2)
585             )
586             }
587            
588            
589             =head3 equals
590            
591             Compare two triangles for equality
592            
593             =cut
594            
595            
596 0     0 1 0 sub equals($$)
597             {my ($a, $b) = check(@_); # Triangles
598 0         0 my ($aa, $ab, $ac) = ($a->a, $a->b, $a->c);
599 0         0 my ($ba, $bb, $bc) = ($b->a, $b->b, $b->c);
600 0         0 my $d = $accuracy;
601            
602 0 0 0     0 return 1 if
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
603             abs(($aa-$ba)->length) < $d and abs(($ab-$bb)->length) < $d and abs(($ac-$bc)->length) < $d or
604             abs(($aa-$ba)->length) < $d and abs(($ab-$bc)->length) < $d and abs(($ac-$bb)->length) < $d or
605             abs(($aa-$bb)->length) < $d and abs(($ab-$bc)->length) < $d and abs(($ac-$ba)->length) < $d or
606             abs(($aa-$bb)->length) < $d and abs(($ab-$ba)->length) < $d and abs(($ac-$bc)->length) < $d or
607             abs(($aa-$bc)->length) < $d and abs(($ab-$ba)->length) < $d and abs(($ac-$bb)->length) < $d or
608             abs(($aa-$bc)->length) < $d and abs(($ab-$bb)->length) < $d and abs(($ac-$ba)->length) < $d;
609 0         0 0;
610             }
611            
612            
613             =head3 Operators
614            
615             Operator overloads
616            
617             =cut
618            
619            
620             use overload
621 2         22 '+', => \&add3, # Add a vector
622             '-', => \&sub3, # Subtract a vector
623             '*', => \&multiply3, # Multiply by a scalar
624             '/', => \÷3, # Divide by a scalar
625             '==' => \&equals3, # Equals
626             '""' => \&print3, # Print
627 2     2   15 'fallback' => FALSE;
  2         5  
628            
629            
630             =head3 add
631            
632             Add operator.
633            
634             =cut
635            
636            
637             sub add3
638 2     2 0 5 {my ($a, $b, $c) = @_;
639 2         6 return $a->add($b);
640             }
641            
642            
643             =head3 subtract
644            
645             Subtract operator.
646            
647             =cut
648            
649            
650             sub sub3
651 1     1 0 3 {my ($a, $b, $c) = @_;
652 1         7 return $a->subtract($b);
653             }
654            
655            
656             =head3 multiply
657            
658             Multiply operator.
659            
660             =cut
661            
662            
663             sub multiply3
664 0     0 0   {my ($a, $b) = @_;
665 0           return $a->multiply($b);
666             }
667            
668            
669             =head3 divide
670            
671             Divide operator.
672            
673             =cut
674            
675            
676             sub divide3
677 0     0 0   {my ($a, $b, $c) = @_;
678 0           return $a->divideBy($b);
679             }
680            
681            
682             =head3 equals
683            
684             Equals operator.
685            
686             =cut
687            
688            
689             sub equals3
690 0     0 0   {my ($a, $b, $c) = @_;
691 0           return $a->equals($b);
692             }
693            
694            
695             =head3 print
696            
697             Print a triangle
698            
699             =cut
700            
701            
702             sub print3
703 0     0 0   {my ($a) = @_;
704 0           return $a->print;
705             }
706            
707            
708             =head2 Exports
709            
710             Export L, L, L, L, L
711            
712             =cut
713            
714            
715 2         15 use Math::Zap::Exports qw(
716             triangle2 ($$$)
717             new ($$$)
718             newnnc ($$$)
719             newV ($$$)
720             newVnnc ($$$)
721 2     2   798 );
  2         42  
722            
723             #_ Triangle2 ___________________________________________________________
724             # Package loaded successfully
725             #_______________________________________________________________________
726            
727             1;
728            
729            
730            
731             =head2 Credits
732            
733             =head3 Author
734            
735             philiprbrenan@yahoo.com
736            
737             =head3 Copyright
738            
739             philiprbrenan@yahoo.com, 2004
740            
741             =head3 License
742            
743             Perl License.
744            
745            
746             =cut