File Coverage

blib/lib/Algorithm/Shape/RandomTree.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             package Algorithm::Shape::RandomTree;
2              
3 1     1   28536 use Moose;
  0            
  0            
4             use namespace::autoclean;
5              
6             use Algorithm::Shape::RandomTree::Branch;
7             use Algorithm::Shape::RandomTree::Branch::Point;
8              
9             our $VERSION = '0.01';
10              
11             ## Attributes ##
12              
13             has 'stem_length' => ( is => 'ro', isa => 'Int' ); # Length of stem
14             has 'tree_width' => ( is => 'ro', isa => 'Int' ); # Width of stem
15             has 'stem_curve' => ( is => 'ro', isa => 'Int' ); # Curvature and complexity of stem
16             has 'branch_length' => ( is => 'ro', isa => 'Int' ); # Average (non-stem) branch length
17             has 'branch_stdev' => ( is => 'ro', isa => 'Int' ); # Plus-minus range around the average
18             has 'complexity' => ( is => 'ro', isa => 'Int' ); # Branching modifier: max number of
19             # branches sprouting from a node
20             has 'branch_curve' => ( is => 'ro', isa => 'Num' ); # Average curvature of (non-stem)
21             # branches
22              
23             # Nodulation: determins the number of levels of sub-branching
24             has 'nodulation' => ( is => 'ro', isa => 'Int' );
25             # Ebbing Factor: Determins how quickly the nodulation decreases along the tree
26             has 'ebbing_factor' => ( is => 'ro', isa => 'Int', default => 2 );
27              
28             # Creation algorithm: can be either linear or recursive
29             # Linear gives more control but looks slightly less natural
30             has 'creation_algorithm' => ( is => 'ro', isa => 'Str', default => 'recursive' );
31              
32             has 'branches' => (
33             is => 'ro',
34             isa => 'ArrayRef',
35             traits => [ 'Array' ],
36             default => sub { [ ] },
37             handles => {
38             add_branch => 'push',
39             count_branches => 'count',
40             filter_branches => 'grep',
41             },
42             );
43              
44             # These two determine the amount of change in branch length and angle
45             # between branches, and along the whole shape of the tree
46             has 'dx_range' => ( is => 'ro', isa => 'Int' );
47             has 'dy_range' => ( is => 'ro', isa => 'Int' );
48              
49             has 'verbose' => ( is => 'ro', isa => 'Bool' );
50              
51             # TODO: Determines whether the tree's shape is more dominated by a single stem with
52             # shorter and less developed sub-branches, or is highly complex and branching.
53             # An apically dominant tree will have one dominant stem with many branches
54             # sprouting out of it, throughout it's length. ** Not yet implemented (I still
55             # need to think how to do this). **
56             # The easier model is the non-apically-dominant tree, with modular branches.
57             has 'apical_dominance' => ( is => 'ro', isa => 'Int' );
58              
59             # This is the width of the image on which the tree will be rendered, in pixels
60             has 'image_width' => ( is => 'ro', isa => 'Int' );
61              
62              
63             ## Methods ##
64              
65             sub create_tree {
66             my $self = shift;
67              
68             my $verb = $self->verbose;
69            
70             $verb && print "[create_tree] Starting\n";
71             $verb && print "[create_tree] algorithm is $self->creation_algorithm\n";
72              
73             if ( $self->creation_algorithm eq 'recursive' ) {
74             # Create main stem
75             my $stem = $self->create_stem;
76            
77             $verb && print "[create_tree] creating primary branches\n";
78            
79             # Create primary branches and recurse all sub-branches
80             foreach my $branch ( 1 .. $self->complexity ) {
81             $verb && print "[create_tree] \t creating primary branch $branch\n";
82            
83             $self->create_branches_recursive( $stem );
84             }
85              
86             } else {
87            
88             # Set number of branching levels
89             my $levels = $self->nodulation;
90            
91             $verb && print "[create_tree] creating $levels levels\n";
92            
93             foreach my $level ( 0 .. $levels ) {
94             $verb && print "[create_tree] \t creating level $level\n";
95             $self->create_branches( $level );
96             }
97             }
98             }
99              
100             # Create Branches: Linear branch creating function
101             sub create_branches {
102             my ( $self, $level ) = @_;
103              
104             my $verb = $self->verbose;
105             $verb && print "[create_branches] Starting\n";
106            
107             my $branch_num;
108              
109             # If it's the first level, the stem and primary branches need to be created
110             if ( $level == 1 ) {
111             my $stem = $self->create_stem;
112             $branch_num = $self->complexity;
113              
114             # Create primary branches
115             foreach my $branch ( 1 .. $branch_num ) {
116             $self->create_branch( $stem, $level );
117             }
118              
119             } else {
120              
121             # Get the current level's parent branches
122             # ( i.e. the previous level's branches )
123             my @parent_branches = $self->filter_branches(
124             sub { $_->level = ( $level - 1 ) }
125             );
126              
127             foreach my $parent ( @parent_branches ) {
128             # Number of sub branches
129             my $sub_branches = int( rand( $self->complexity ) );
130            
131             # Create sub-branches for the current parent branch
132             foreach my $idx ( 1 .. $sub_branches ) {
133             $self->create_branch( $parent, $level );
134             }
135             }
136             }
137             }
138              
139             # Create Stem: creates the primary branch (stem) for in both recursive and
140             # linear tree creating algorithms
141             sub create_stem {
142             my $self = shift;
143            
144             my $verb = $self->verbose;
145             $verb && print "[create_stem] Starting\n";
146            
147             my $d = $self->stem_length;
148            
149             # Set stem slope ( currently it's stragight up - slope = 0 )
150             my $m = 0;
151             # To set the slope to a random number between -/+0.5:
152             # my $m = -0.5 + rand(1);
153              
154             # Set starting coordinates for the Tree's stem
155              
156             # Stem's X position is in the middle of the image
157             my $x_start = int( $self->image_width / 2 );
158             # Y position is of 1st point is on the ground.
159             my $y_start = 0;
160              
161             # Mathematically speaking:
162             # Stem length = distance between it's start and end points:
163             # d = sqrt[ (x2-x1)**2 + (y2-y1)**2 ] = sqrt( dx**2 + dy**2 )
164             # Slope:
165             # m = dy / dx = (y2-y1) / (x2-x1)
166              
167             # After development and a applying the square-root:
168             # y = sqrt[ d**2 / ( m**2 + 1 ) ] + y1
169             # x = m * (y1 - y) + x1
170            
171             my $y_end = int(
172             sqrt( $d ** 2 / ( ( $m ** 2 ) + 1 ) + $y_start )
173             );
174            
175             my $x_end = int(
176             $m * ( $y_end - $y_start ) + $x_start
177             );
178            
179              
180             # Create stem coordinates
181             my $start_point = Algorithm::Shape::RandomTree::Branch::Point->new(
182             x => $x_start, y => $y_start,
183             );
184             my $end_point = Algorithm::Shape::RandomTree::Branch::Point->new(
185             x => $x_end, y => $y_end,
186             );
187              
188             $verb && print "[create_stem] \tcreating stem\n";
189              
190             my $stem = Algorithm::Shape::RandomTree::Branch->new(
191             name => 1,
192             start_point => $start_point,
193             end_point => $end_point,
194             dx => $x_end - $x_start,
195             dy => $y_end - $y_start,
196             level => 0,
197             nodulation => $self->nodulation,
198             complexity => $self->complexity,
199             width => $self->tree_width,
200             );
201              
202             # Add stem to branches collection
203             $self->add_branch( $stem );
204              
205             return $stem;
206             }
207              
208             # Linear algorithm's branch creation sub
209             sub create_branch {
210             my ( $self, $parent, $level ) = @_;
211             my $start_point = $parent->end_point;
212              
213             my $verb = $self->verbose;
214              
215             my ( $dx, $dy ) = $self->calc_new_deltas( $parent );
216             my ( $x_end, $y_end ) = $self->calc_new_endpoints(
217             $start_point, $dx, $dy
218             );
219              
220             my $end_point = Algorithm::Shape::RandomTree::Branch::Point->new(
221             x => $x_end, y => $y_end
222             );
223             my $number = $self->count_branches + 1; # New branch's num (name)
224              
225             my $newbranch = Algorithm::Shape::RandomTree::Branch->new(
226             name => $number,
227             start_point => $start_point,
228             end_point => $end_point,
229             dx => $dx,
230             dy => $dy,
231             level => $level,
232             parent => $parent,
233             # nodulation => ,
234             # complexity => ,
235             );
236              
237             $self->add_branch( $newbranch );
238             }
239              
240              
241             # Calculate New Deltas: uses the parent branch's attributes and random factors
242             # to modify a new branche's dx and dy values, who determin the angle and length
243             # of the new branch.
244             sub calc_new_deltas {
245             my ( $self, $parent ) = @_;
246              
247             my $verb = $self->verbose;
248              
249             # Get parent branch's deltas
250             my $old_dx = $parent->dx;
251             my $old_dy = $parent->dy;
252            
253             # Calculate modifiers:
254             # These slightly change the dx and dy to create variation and randomness
255             # in branches lengths and angles.
256             # Modifiers range from -range_value to +range_value
257             my $dx_modifier = (
258             int( rand( $self->dx_range ) * -1 ) +
259             int( rand( $self->dx_range ) )
260             );
261              
262             my $dy_modifier = (
263             int( rand( $self->dy_range ) * -1 ) +
264             int( rand( $self->dy_range ) )
265             );
266            
267             # If the level is 0, it's the stem's children, so the falloff should be 1.5
268             # (so that they would still be a bit shorter than the stem).
269             # otherwise, it should be the level + 1
270             my $falloff = ( $parent->level == 0 ) ? 1.5 : $parent->level + 1;
271            
272             # Apply modifiers
273             my $new_dx = int ( ( $old_dx + $dx_modifier ) / $falloff );
274             my $new_dy = int ( ( $old_dy + $dy_modifier ) / $falloff );
275            
276             return( $new_dx, $new_dy );
277             }
278              
279             # Calculate New End-points: ( by adding the deltas to the start-points )
280             sub calc_new_endpoints {
281             my ( $self, $start_point, $dx, $dy ) = @_;
282              
283             my $x_end = $dx + $start_point->x;
284             my $y_end = $dy + $start_point->y;
285              
286             return( $x_end, $y_end );
287             }
288              
289             # The recursive algorithm for creating all non-stem branches
290             sub create_branches_recursive {
291             my ( $self, $parent ) = @_;
292              
293             my $verb = $self->verbose;
294              
295             my $name = $parent->name;
296             $verb && print "[create_branches_recursive] on parent: $name\n";
297            
298             # Create a new branch connected to parent
299             my $branch = $self->make_branch( $parent );
300            
301             # Create this branche's sub-branches
302             if ( $branch->nodulation ) {
303             foreach my $idx ( 1 .. $branch->complexity ) {
304             $verb && print qq{
305             [create_branches_recursive] \tcreating $name 's branches\n
306             };
307             $self->create_branches_recursive( $branch );
308             }
309             }
310             }
311              
312             # Sub for creating single branches used by the recursive algorithm
313             sub make_branch {
314             my ( $self, $parent ) = @_;
315             my $start_point = $parent->end_point;
316              
317             my $verb = $self->verbose;
318              
319             my $name = $parent->name;
320             $verb && print "[make_branche] on parent: $name\n";
321              
322             my ( $dx, $dy ) = $self->calc_new_deltas( $parent );
323             my ( $x_end, $y_end ) = $self->calc_new_endpoints(
324             $start_point, $dx, $dy
325             );
326              
327             my $end_point = Algorithm::Shape::RandomTree::Branch::Point->new(
328             x => $x_end, y => $y_end
329             );
330              
331             my $number = $self->count_branches + 1; # New branch's num (name)
332             my $nodulation = $self->calc_new_nodulation( $parent );
333              
334             my $complexity = int( rand( $self->complexity ) ); # Calculate new complexity
335            
336             # Calculate new width, and prevent a less than 1 width
337             my $falloff = ( $parent->level == 0 ) ? 1.5 : $parent->level + 1;
338             my $new_width = int ( $self->tree_width / $falloff );
339             my $width = $new_width ? $new_width : 1;
340            
341             my $path_str = $self->create_path( $start_point, $end_point, $dx, $dy );
342            
343             my $newbranch = Algorithm::Shape::RandomTree::Branch->new(
344             name => $number,
345             start_point => $start_point,
346             end_point => $end_point,
347             dx => $dx,
348             dy => $dy,
349             level => $parent->level + 1,
350             parent => $parent,
351             nodulation => $nodulation,
352             complexity => $complexity,
353             width => $width,
354             path_string => $path_str,
355             );
356              
357             $verb && print "[make_branche] \tmaking branch $number\n";
358              
359             $self->add_branch( $newbranch );
360              
361             return $newbranch;
362             }
363              
364             sub calc_new_nodulation {
365             my ( $self, $parent ) = @_;
366              
367             my $verb = $self->verbose;
368              
369             my $old = $parent->nodulation;
370            
371             # Reduce ebbing factor from the parent's nodulation
372             my $new = $old - $self->ebbing_factor;
373            
374             return $new;
375             }
376              
377             sub create_path {
378             my ( $self, $start, $end, $dx, $dy ) = @_;
379            
380             my $x1 = $start->x;
381             my $y1 = $start->y;
382             my $x2 = $end->x;
383             my $y2 = $end->y;
384            
385             my $length = sqrt( $dx ** 2 + $dy ** 2 );
386             my $phandle = $self->branch_curve * $length;
387            
388             # X / Y values of control point 1 (curving the start point)
389             my $c1_x = $x1 - rand($phandle) + rand($phandle);
390             my $c1_y = $y1 - rand($phandle) + rand($phandle);
391              
392             # X / Y values of control point 2 (curving the end point)
393             my $c2_x = $x2 - rand($phandle) + rand($phandle);
394             my $c2_y = $y2 - rand($phandle) + rand($phandle);
395            
396             my $d_str = "M $x1 $y1 C $c1_x $c1_y $c2_x $c2_y $x2 $y2";
397              
398             return $d_str;
399             }
400              
401             no Moose;
402              
403             1;
404              
405             __END__
406              
407             =head1 NAME
408              
409             Algorithm::Shape::RandomTree - Create an object representing a procedural, editable, randomized plant shape that
410             can be rendered graphically by other modules.
411              
412             =head1 VERSION
413              
414             Version 0.01
415              
416             =head1 SYNOPSIS
417              
418             A detailed synopsis with examples will be released soon.
419              
420             =head1 EXPORT
421              
422             A list of functions that can be exported. You can delete this section
423             if you don't export anything, such as for a purely object-oriented module.
424              
425             =head1 SUBROUTINES/METHODS
426              
427             =head2 calc_new_deltas
428              
429             =head2 calc_new_endpoints
430              
431             =head2 calc_new_nodulation
432              
433             =head2 create_branch
434              
435             =head2 create_branches
436              
437             =head2 create_branches_recursive
438              
439             =head2 create_path
440              
441             =head2 create_stem
442              
443             =head2 create_tree
444              
445             =head2 make_branch
446              
447             =head1 AUTHOR
448              
449             Tamir Lousky, C<< <tlousky at cpan.org> >>
450              
451             =head1 BUGS
452              
453             Please report any bugs or feature requests to C<bug-algorithm-shape-randomtree at rt.cpan.org>, or through
454             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Algorithm-Shape-RandomTree>. I will be notified, and then you'll
455             automatically be notified of progress on your bug as I make changes.
456              
457             =head1 SUPPORT
458              
459             You can find documentation for this module with the perldoc command.
460              
461             perldoc Algorithm::Shape::RandomTree
462              
463              
464             You can also look for information at:
465              
466             =over 4
467              
468             =item * RT: CPAN's request tracker
469              
470             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Algorithm-Shape-RandomTree>
471              
472             =item * AnnoCPAN: Annotated CPAN documentation
473              
474             L<http://annocpan.org/dist/Algorithm-Shape-RandomTree>
475              
476             =item * CPAN Ratings
477              
478             L<http://cpanratings.perl.org/d/Algorithm-Shape-RandomTree>
479              
480             =item * Search CPAN
481              
482             L<http://search.cpan.org/dist/Algorithm-Shape-RandomTree/>
483              
484             =back
485              
486              
487             =head1 ACKNOWLEDGEMENTS
488              
489              
490             =head1 LICENSE AND COPYRIGHT
491              
492             Copyright 2010 Tamir Lousky.
493              
494             This program is free software; you can redistribute it and/or modify it
495             under the terms of either: the GNU General Public License as published
496             by the Free Software Foundation; or the Artistic License.
497              
498             See http://dev.perl.org/licenses/ for more information.