File Coverage

blib/lib/SVG/ChristmasTree.pm
Criterion Covered Total %
statement 85 85 100.0
branch n/a
condition n/a
subroutine 19 19 100.0
pod 2 4 50.0
total 106 108 98.1


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             SVG::ChristmasTree - Perl extension to draw Christmas trees with SVG
4              
5             =head1 DESCRIPTION
6              
7             Perl extension to draw Christmas trees with SVG
8              
9             =head1 SYNOPSIS
10              
11             # Default tree
12             my $tree = SVG::ChristmasTree->new;
13             print $tree->as_xml;
14              
15             # Or change things
16             my $tree = SVG::ChristmasTree->new({
17             layers => 5,
18             leaf_colour => 'rgb(0,255,0)',
19             pot_colour => 'rgb(0,0,255)',
20             });
21             print $tree->as_xml;
22              
23             =cut
24              
25             package SVG::ChristmasTree;
26              
27 1     1   55936 use strict;
  1         2  
  1         24  
28 1     1   4 use warnings;
  1         2  
  1         23  
29              
30 1     1   969 use Moose;
  1         758000  
  1         7  
31 1     1   6838 use namespace::autoclean;
  1         90182  
  1         4  
32 1     1   1270 use SVG;
  1         26167  
  1         7  
33 1     1   1499 use Math::Trig qw[deg2rad tan];
  1         11488  
  1         116  
34              
35             with 'MooseX::Getopt';
36              
37             our $VERSION = '0.0.4';
38              
39             # Constants that we haven't made into attributes yet
40             use constant {
41 1         1169 TREE_WIDTH => 600, # Width of the bottom tree layer
42             TOP_ANGLE => 90, # Angle at the top of the tree triangles
43             LAYER_SIZE_RATIO => (5/6), # How much smaller each layer gets
44             LAYER_STACKING => 0.5, # How far up a layer triangle does the next one start
45             POT_TOP_WIDTH => 300, # Width of the top of the pot
46             POT_BOT_WIDTH => 200, # Width of the bottom of the pot
47             TRUNK_WIDTH => 100, # Width of the trunk
48             BAUBLE_RADIUS => 20, # Radius of a bauble
49             STAR_RADIUS => 40, # Raduis of the star
50 1     1   10 };
  1         2  
51              
52             =head1 Methods
53              
54             =head2 $tree = SVG::ChristmasTree->new(\%args)
55              
56             Constructs and returns a new SVG::ChristmasTree object. With no arguments,
57             a default tree design is created, but it is possible to change that by
58             passing the following attributes to the method.
59              
60             =over 4
61              
62             =item width INT
63              
64             The width of the tree diagram in "pixels". The default is 1,000.
65              
66             =item layers INT
67              
68             The number of layers in the tree. The default tree has four layers.
69              
70             =item trunk_length INT
71              
72             The length of the trunk in "pixels". The default length is 100.
73              
74             =item leaf_colour STR
75              
76             The colour of the tree's leaves. This must be defined as an SVG RGB value.
77             The default value is "rgb(0,127,0)".
78              
79             =item bauble_colour STR
80              
81             The colour of the baubles that hang on the tree. This must be defined as an
82             SVG RGB value. The default value is "rgb(212,175,55)".
83              
84             =item trunk colour STR
85              
86             The colour of the tree trunk. This must be defined as an SVG RGB value. The
87             default value is "rgb(139,69,19)".
88              
89             =item pot_colour STR
90              
91             The colour of the pot. This must be defined as an SVG RGB value. The default
92             value is "rgb(191,0,0)".
93              
94             =item pot_height INT
95              
96             The height of the pot in "pixels". The default height is 200.
97              
98             =back
99              
100             =head2 $tree->as_xml
101              
102             Returns the SVG document as XML. You will usually want to store the returned
103             value in a variable, print it to C<STDOUT> or write it to a file.
104              
105             =cut
106              
107             has width => (
108             isa => 'Int',
109             is => 'ro',
110             default => 1_000,
111             );
112              
113             has height => (
114             isa => 'Int',
115             is => 'ro',
116             lazy_build => 1,
117             init_arg => undef,
118             );
119              
120             # Height is calculated from all the other stuff
121             sub _build_height {
122 1     1   3 my $self = shift;
123              
124             # Pot height ...
125 1         26 my $height = $self->pot_height;
126             # ... plus the trunk length ...
127 1         24 $height += $self->trunk_length;
128             # ... for most of the layers ...
129 1         59 for (0 .. $self->layers - 2) {
130             # ... add LAYER_STACKING of the height ...
131 3         67 $height += $self->triangle_heights->[$_] * LAYER_STACKING;
132             }
133             # ... add all of the last layer ...
134 1         22 $height += $self->triangle_heights->[-1];
135             # ... and (finally) half of the star
136 1         2 $height += STAR_RADIUS / 2;
137              
138 1         22 return int($height + 0.5);
139             }
140              
141             has triangle_heights => (
142             isa => 'ArrayRef',
143             is => 'ro',
144             lazy_build => 1,
145             init_arg => undef,
146             );
147              
148             sub _build_triangle_heights {
149 1     1   2 my $self = shift;
150              
151 1         2 my @heights;
152 1         1 my $width = TREE_WIDTH;
153 1         26 for (1 .. $self->layers) {
154 4         10 push @heights, $self->_triangle_height($width, TOP_ANGLE);
155 4         79 $width *= LAYER_SIZE_RATIO;
156             }
157              
158 1         28 return \@heights;
159             }
160              
161             sub _triangle_height {
162 4     4   6 my $self = shift;
163 4         5 my ($base, $top_angle) = @_;
164              
165             # Assume $top_angle is in degrees
166 4         11 $top_angle = deg2rad($top_angle) / 2;
167             # If I remember my trig correctly...
168 4         38 return ($base / 2) / tan($top_angle);
169             }
170              
171             has svg => (
172             isa => 'SVG',
173             is => 'ro',
174             lazy_build => 1,
175             init_arg => undef,
176             );
177              
178             sub _build_svg {
179 1     1   2 my $self = shift;
180              
181 1         23 return SVG->new(
182             width => $self->width,
183             height => $self->height,
184             );
185             }
186              
187             has layers => (
188             isa => 'Int',
189             is => 'ro',
190             default => 4,
191             );
192              
193             has trunk_length => (
194             isa => 'Int',
195             is => 'ro',
196             default => 100,
197             );
198              
199             has leaf_colour => (
200             isa => 'Str',
201             is => 'ro',
202             default => 'rgb(0,127,0)',
203             );
204              
205             has bauble_colour => (
206             isa => 'Str',
207             is => 'ro',
208             default => 'rgb(212,175,55)',
209             );
210              
211             has trunk_colour => (
212             isa => 'Str',
213             is => 'ro',
214             default => 'rgb(139,69,19)',
215             );
216              
217             has pot_colour => (
218             isa => 'Str',
219             is => 'ro',
220             default => 'rgb(191,0,0)',
221             );
222              
223             has pot_height => (
224             isa => 'Int',
225             is => 'ro',
226             default => 200,
227             );
228              
229             has triangles => (
230             isa => 'ArrayRef',
231             is => 'ro',
232             lazy_build => 1,
233             init_arg => undef,
234             );
235              
236             sub _build_triangles {
237 1     1   2 my $self = shift;
238              
239 1         10 my $width = TREE_WIDTH;
240 1         26 my $tri_bottom = $self->height - $self->pot_height - $self->trunk_length;
241              
242 1         1 my @triangles;
243 1         21 for (1 .. $self->layers) {
244 4         9 push @triangles, $self->_triangle(TOP_ANGLE, $width, $tri_bottom);
245 4         6 $width *= LAYER_SIZE_RATIO;
246 4         8 $tri_bottom -= $triangles[-1]->{h} * LAYER_STACKING;
247             }
248              
249 1         21 return \@triangles;
250             }
251              
252             sub as_xml {
253 1     1 1 2 my $self = shift;
254              
255 1         11 $self->pot;
256 1         62 $self->trunk;
257              
258 1         47 for (@{$self->triangles}) {
  1         25  
259 4         148 my $h = $self->_triangle(TOP_ANGLE, $_->{w}, $_->{b});
260 4         6 $self->bauble($self->_mid_y - ($_->{w}/2), $_->{b});
261 4         245 $self->bauble($self->_mid_y + ($_->{w}/2), $_->{b});
262             $self->_coloured_shape(
263 4         333 $_->{x}, $_->{y}, $self->leaf_colour,
264             );
265             }
266              
267 1         65 return $self->svg->xmlify;
268             }
269              
270             sub pot {
271 1     1 0 2 my $self = shift;
272              
273 1         30 my $pot_top = $self->height - $self->pot_height;
274              
275 1         4 $self->_coloured_shape(
276             [ $self->_mid_y - (POT_BOT_WIDTH / 2),
277             $self->_mid_y - (POT_TOP_WIDTH / 2),
278             $self->_mid_y + (POT_TOP_WIDTH / 2),
279             $self->_mid_y + (POT_BOT_WIDTH / 2) ],
280             [ $self->height, $pot_top, $pot_top, $self->height ],
281             $self->pot_colour,
282             );
283             }
284              
285             sub trunk {
286 1     1 1 3 my $self = shift;
287              
288 1         28 my $trunk_bottom = $self->height - $self->pot_height;
289 1         22 my $trunk_top = $trunk_bottom - $self->trunk_length;
290              
291 1         3 $self->_coloured_shape(
292             [ $self->_mid_y - (TRUNK_WIDTH / 2), $self->_mid_y - (TRUNK_WIDTH / 2),
293             $self->_mid_y + (TRUNK_WIDTH / 2), $self->_mid_y + (TRUNK_WIDTH / 2) ],
294             [ $trunk_bottom, $trunk_top, $trunk_top, $trunk_bottom ],
295             $self->trunk_colour,
296             );
297             }
298              
299             sub _triangle {
300 8     8   12 my $self = shift;
301 8         10 my ($top_angle, $base, $bottom) = @_;
302              
303 8         12 my ($x, $y);
304              
305             # Assume $top_angle is in degrees
306 8         17 $top_angle = deg2rad($top_angle) / 2;
307             # If I remember my trig correctly...
308 8         67 my $height = ($base / 2) / tan($top_angle);
309              
310 8         92 $x = [ $self->_mid_y - ($base / 2), $self->_mid_y, $self->_mid_y + ($base / 2) ];
311 8         17 $y = [ $bottom, $bottom - $height, $bottom ];
312              
313             return {
314 8         25 x => $x, # array ref of x points
315             y => $y, # array ref of y points
316             h => $height, # height of the triangle
317             w => $base, # length of the base of the triangle
318             b => $bottom, # y-coord of the bottom of the triangle
319             };
320             }
321              
322             sub bauble {
323 8     8 0 9 my $self = shift;
324 8         14 my ($x, $y) = @_;
325              
326 8         159 $self->svg->circle(
327             cx => $x,
328             cy => $y + BAUBLE_RADIUS,
329             r => BAUBLE_RADIUS,
330             style => {
331             fill => $self->bauble_colour,
332             stroke => $self->bauble_colour,
333             },
334             );
335             }
336              
337             sub _mid_y {
338 40     40   49 my $self = shift;
339              
340 40         841 return $self->width / 2;
341             }
342              
343             sub _coloured_shape {
344 6     6   9 my $self = shift;
345 6         8 my ($x, $y, $colour) = @_;
346              
347 6         122 my $path = $self->svg->get_path(
348             x => $x,
349             y => $y,
350             -type => 'polyline',
351             -closed => 1,
352             );
353              
354 6         341 $self->svg->polyline(
355             %$path,
356             style => {
357             fill => $colour,
358             stroke => $colour,
359             },
360             );
361             }
362              
363             __PACKAGE__->meta()->make_immutable();
364              
365             =head1 AUTHOR
366              
367             Dave Cross <dave@perlhacks.com>
368              
369             =head1 COPYRIGHT AND LICENCE
370              
371             Copyright (c) 2018, Magnum Solutions Ltd. All Rights Reserved.
372              
373             This library is free software; you can redistribute it and/or modify it
374             under the same terms as Perl itself.
375              
376             =cut
377              
378             1;