File Coverage

blib/lib/Math/Zap/Cube.pm
Criterion Covered Total %
statement 38 90 42.2
branch 1 8 12.5
condition n/a
subroutine 16 29 55.1
pod 8 23 34.7
total 63 150 42.0


line stmt bran cond sub pod time code
1            
2             =head1 Cube
3            
4             Cubes in 3d space
5            
6             PhilipRBrenan@yahoo.com, 2004, Perl License
7            
8            
9             =head2 Synopsis
10            
11             Example t/cube.t
12            
13             #_ Cube _______________________________________________________________
14             # Test cube
15             # philiprbrenan@yahoo.com, 2004, Perl License
16             #______________________________________________________________________
17            
18             use Math::Zap::Cube unit=>u;
19             use Test::Simple tests=>5;
20            
21             ok(u eq 'cube(vector(0, 0, 0), vector(1, 0, 0), vector(0, 1, 0), vector(0, 0, 1))');
22             ok(u->a eq 'vector(0, 0, 0)');
23             ok(u->x eq 'vector(1, 0, 0)');
24             ok(u->y eq 'vector(0, 1, 0)');
25             ok(u->z eq 'vector(0, 0, 1)');
26            
27            
28            
29             =head2 Description
30            
31             Define and manipulate a cube in 3 dimensions
32            
33             =cut
34            
35            
36             package Math::Zap::Cube;
37             $VERSION=1.07;
38 1     1   916 use Math::Zap::Unique;
  1         2  
  1         24  
39 1     1   615 use Math::Zap::Triangle;
  1         4  
  1         28  
40 1     1   7 use Math::Zap::Vector check=>vectorCheck;
  1         2  
  1         32  
41 1     1   6 use Carp;
  1         2  
  1         1489  
42            
43            
44             =head2 Constructors
45            
46            
47             =head3 new
48            
49             Create a rectangle from 3 vectors:
50            
51             =over
52            
53            
54            
55             =item a position of corner
56            
57            
58            
59             =item x first side
60            
61            
62            
63             =item y second side
64            
65            
66            
67             =item z third side
68            
69            
70            
71             =back
72            
73            
74            
75             =cut
76            
77            
78 5     5 1 147 sub new($$$$)
79             {my ($a, $x, $y, $z) = vectorCheck(@_);
80 5         84 bless {a=>$a, x=>$x, y=>$y, z=>$z};
81             }
82            
83            
84             =head3 cube
85            
86             Synonym for L
87            
88             =cut
89            
90            
91 5     5 1 16 sub cube($$$$) {new($_[0], $_[1], $_[2], $_[3])};
92            
93            
94             =head3 unit
95            
96             Unit cube
97            
98             =cut
99            
100            
101 5     5 1 155 sub unit()
102             {cube(vector(0,0,0), vector(1,0,0), vector(0,1,0), vector(0,0,1));
103             }
104            
105            
106             =head2 Methods
107            
108            
109             =head3 Check
110            
111             Check that an anonymous reference is a reference to a cube and confess
112             if it is not.
113            
114             =cut
115            
116            
117 9 50       38 sub check(@)
118 9     9 0 22 {for my $c(@_)
119             {confess "$c is not a cube" unless ref($c) eq __PACKAGE__;
120             }
121 9         20 return (@_)
122             }
123            
124            
125             =head3 is
126            
127             Same as L but return the result to the caller.
128            
129             =cut
130            
131            
132 0 0       0 sub is(@)
133 0     0 1 0 {for my $r(@_)
134             {return 0 unless ref($r) eq __PACKAGE__;
135             }
136 0         0 'cube';
137             }
138            
139            
140             =head3 a, x, y, z
141            
142             Components of cube
143            
144             =cut
145            
146            
147 2     2 1 6 sub a($) {my ($c) = check(@_); $c->{a}}
  2         11  
148 2     2 1 6 sub x($) {my ($c) = check(@_); $c->{x}}
  2         10  
149 2     2 1 5 sub y($) {my ($c) = check(@_); $c->{y}}
  2         11  
150 2     2 1 5 sub z($) {my ($c) = check(@_); $c->{z}}
  2         8  
151            
152            
153             =head3 Clone
154            
155             Create a cube from another cube
156            
157             =cut
158            
159            
160 0     0 0 0 sub clone($)
161             {my ($c) = check(@_); # Cube
162 0         0 bless {a=>$c->a, x=>$c->x, y=>$c->y, z=>$c->z};
163             }
164            
165            
166             =head3 Accuracy
167            
168             Get/Set accuracy for comparisons
169            
170             =cut
171            
172            
173             my $accuracy = 1e-10;
174            
175             sub accuracy
176 0 0   0 0 0 {return $accuracy unless scalar(@_);
177 0         0 $accuracy = shift();
178             }
179            
180            
181             =head3 Add
182            
183             Add a vector to a cube
184            
185             =cut
186            
187            
188 0     0 0 0 sub add($$)
189             {my ($c) = check(@_[0..0]); # Cube
190 0         0 my ($v) = vectorCheck(@_[1..1]); # Vector
191 0         0 new($c->a+$v, $c->x, $c->y, $c->z);
192             }
193            
194            
195             =head3 Subtract
196            
197             Subtract a vector from a cube
198            
199             =cut
200            
201            
202 0     0 0 0 sub subtract($$)
203             {my ($c) = check(@_[0..0]); # Cube
204 0         0 my ($v) = vectorCheck(@_[1..1]); # Vector
205 0         0 new($c->a-$v, $c->x, $c->y, $c->z);
206             }
207            
208            
209             =head3 Multiply
210            
211             Cube times a scalar
212            
213             =cut
214            
215            
216 0     0 0 0 sub multiply($$)
217             {my ($a) = check(@_[0..0]); # Cube
218 0         0 my ($b) = @_[1..1]; # Scalar
219            
220 0         0 new($a->a, $a->x*$b, $a->y*$b, $a->z*$b);
221             }
222            
223            
224             =head3 Divide
225            
226             Cube divided by a non zero scalar
227            
228             =cut
229            
230            
231 0     0 0 0 sub divide($$)
232             {my ($a) = check(@_[0..0]); # Cube
233 0         0 my ($b) = @_[1..1]; # Scalar
234            
235 0 0       0 confess "$b is zero" if $b == 0;
236 0         0 new($a->a, $a->x/$b, $a->y/$b, $a->z/$b);
237             }
238            
239            
240             =head3 Print
241            
242             Print cube
243            
244             =cut
245            
246            
247 1     1 0 6 sub print($)
248             {my ($t) = check(@_); # Cube
249 1         6 my ($a, $x, $y, $z) = ($t->a, $t->x, $t->y, $t->z);
250 1         56 "cube($a, $x, $y, $z)";
251             }
252            
253            
254             =head3 Triangulate
255            
256             Triangulate cube
257            
258             =cut
259            
260            
261 0     0 0 0 sub triangulate($$)
262             {my ($c) = check(@_[0..0]); # Cube
263 0         0 my ($color) = @_[1..1]; # Color
264 0         0 my $plane; # Plane
265            
266             my @t;
267 0         0 $plane = unique();
268 0         0 push @t, {triangle=>triangle($c->a, $c->a+$c->x, $c->a+$c->y), color=>$color, plane=>$plane};
269 0         0 push @t, {triangle=>triangle($c->a+$c->x+$c->y, $c->a+$c->x, $c->a+$c->y), color=>$color, plane=>$plane};
270 0         0 $plane = unique();
271 0         0 push @t, {triangle=>triangle($c->a+$c->z, $c->a+$c->x+$c->z, $c->a+$c->y+$c->z), color=>$color, plane=>$plane};
272 0         0 push @t, {triangle=>triangle($c->a+$c->x+$c->y+$c->z, $c->a+$c->x+$c->z, $c->a+$c->y+$c->z), color=>$color, plane=>$plane};
273            
274             # x y z
275             # y z x
276 0         0 $plane = unique();
277 0         0 push @t, {triangle=>triangle($c->a, $c->a+$c->y, $c->a+$c->z), color=>$color, plane=>$plane};
278 0         0 push @t, {triangle=>triangle($c->a+$c->y+$c->z, $c->a+$c->y, $c->a+$c->z), color=>$color, plane=>$plane};
279 0         0 $plane = unique();
280 0         0 push @t, {triangle=>triangle($c->a+$c->x, $c->a+$c->y+$c->x, $c->a+$c->z+$c->x), color=>$color, plane=>$plane};
281 0         0 push @t, {triangle=>triangle($c->a+$c->y+$c->z+$c->x, $c->a+$c->y+$c->x, $c->a+$c->z+$c->x), color=>$color, plane=>$plane};
282            
283             # x y z
284             # z x y
285 0         0 $plane = unique();
286 0         0 push @t, {triangle=>triangle($c->a, $c->a+$c->z, $c->a+$c->x), color=>$color, plane=>$plane};
287 0         0 push @t, {triangle=>triangle($c->a+$c->z+$c->x, $c->a+$c->z, $c->a+$c->x), color=>$color, plane=>$plane};
288 0         0 $plane = unique();
289 0         0 push @t, {triangle=>triangle($c->a+$c->y, $c->a+$c->z+$c->y, $c->a+$c->x+$c->y), color=>$color, plane=>$plane};
290 0         0 push @t, {triangle=>triangle($c->a+$c->z+$c->x+$c->y, $c->a+$c->z+$c->y, $c->a+$c->x+$c->y), color=>$color, plane=>$plane};
291 0         0 @t;
292             }
293            
294             unless (caller())
295             {$c = cube(vector(0,0,0), vector(1,0,0), vector(0,1,0), vector(0,0,1));
296             @t = $c->triangulate('red');
297             print "Done";
298             }
299            
300            
301             =head2 Operator Overloads
302            
303             Operator overloads
304            
305             =cut
306            
307            
308             use overload
309 1         13 '+', => \&add3, # Add a vector
310             '-', => \&sub3, # Subtract a vector
311             '*', => \&multiply3, # Multiply by scalar
312             '/', => \÷3, # Divide by scalar
313             '==' => \&equals3, # Equals
314             '""' => \&print3, # Print
315 1     1   6 'fallback' => FALSE;
  1         2  
316            
317            
318             =head3 Add
319            
320             Add operator.
321            
322             =cut
323            
324             sub add3
325 0     0 0 0 {my ($a, $b, $c) = @_;
326 0         0 return $a->add($b);
327             }
328            
329            
330             =head3 Subtract
331            
332             Subtract operator.
333            
334             =cut
335            
336            
337             sub sub3
338 0     0 0 0 {my ($a, $b, $c) = @_;
339 0         0 return $a->subtract($b);
340             }
341            
342            
343             =head3 Multiply
344            
345             Multiply operator.
346            
347             =cut
348            
349            
350             sub multiply3
351 0     0 0 0 {my ($a, $b) = @_;
352 0         0 return $a->multiply($b);
353             }
354            
355            
356             =head3 Divide
357            
358             Divide operator.
359            
360             =cut
361            
362            
363             sub divide3
364 0     0 0 0 {my ($a, $b, $c) = @_;
365 0         0 return $a->divide($b);
366             }
367            
368            
369             =head3 Equals
370            
371             Equals operator.
372            
373             =cut
374            
375            
376             sub equals3
377 0     0 0 0 {my ($a, $b, $c) = @_;
378 0         0 return $a->equals($b);
379             }
380            
381            
382             =head3 Print
383            
384             Print a cube
385            
386             =cut
387            
388            
389             sub print3
390 1     1 0 2 {my ($a) = @_;
391 1         6 return $a->print;
392             }
393            
394            
395             =head2 Exports
396            
397             Export L, L
398            
399             =cut
400            
401            
402 1         4 use Math::Zap::Exports qw(
403             cube ($$$)
404             unit ()
405 1     1   259 );
  1         2  
406            
407             #______________________________________________________________________
408             # Package loaded successfully
409             #______________________________________________________________________
410            
411             1;
412            
413            
414            
415             =head2 Credits
416            
417             =head3 Author
418            
419             philiprbrenan@yahoo.com
420            
421             =head3 Copyright
422            
423             philiprbrenan@yahoo.com, 2004
424            
425             =head3 License
426            
427             Perl License.
428            
429            
430             =cut