File Coverage

blib/lib/SVG/TrafficLight.pm
Criterion Covered Total %
statement 36 37 97.3
branch n/a
condition n/a
subroutine 11 11 100.0
pod 2 3 66.6
total 49 51 96.0


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             SVG::TrafficLight - Perl extension to produce SVG diagrams of traffic lights.
4              
5             =head1 DESCRIPTION
6              
7             Perl extension to produce SVG diagrams of traffic lights.
8              
9             =head1 SYNOPSIS
10              
11             use SVG::TrafficLight;
12              
13             my $tl = SVG::TrafficLight->new; # default image
14             print $some_file_handle $tl->xmlify;
15              
16             my $tl2 = SVG::TrafficLight->new({
17             sequence => [
18             { red => 1, amber => 1, green => 1 }, # all lights on
19             { red => 0, amber => 0, green => 0 }, # all lights off
20             ],
21             });
22              
23             =cut
24              
25             package SVG::TrafficLight;
26              
27 2     2   198379 use Moose;
  2         974318  
  2         17  
28 2     2   17194 use SVG;
  2         26993  
  2         15  
29              
30             our $VERSION = '0.1.2';
31              
32             =head1 ATTRIBUTES AND METHODS
33              
34             =head2 radius()
35              
36             Returns the radius of the circles used to draw the traffic lights. The default
37             is 50, but this can be altered when creating the object.
38              
39             my $tl = SVG::TrafficLight->new({ radius => 1000 });
40              
41             =cut
42              
43             has radius => (
44             is => 'ro',
45             isa => 'Num',
46             default => 50,
47             );
48              
49             =head2 diameter
50              
51             Returns the diameter of the circles used to draw the traffic lights. This is
52             just twice the radius. The default is 100. Change it by setting a different
53             radius.
54              
55             =cut
56              
57             sub diameter {
58 18     18 1 25 my $self = shift;
59              
60 18         355 return $self->radius * 2;
61             }
62              
63             =head2 padding
64              
65             Returns a value which is used to pad various shapes in the image.
66              
67             =over 4
68              
69             =item *
70              
71             The padding between the edge of the image and the traffic light block.
72              
73             =item *
74              
75             The padding between two traffic light blocks in the sequence.
76              
77             =item *
78              
79             The padding between the edge of a traffic light block and the lights
80             contained within it.
81              
82             =item *
83              
84             The padding between two vertically stacked traffic lights within a block.
85              
86             =back
87              
88             The default value is half the radius of a traffic light circle. This can
89             be set when creating the object;
90              
91             my $tl = SVG::TrafficLight->new({ padding => 100 });
92              
93             =cut
94              
95             has padding => (
96             is => 'ro',
97             isa => 'Num',
98             lazy_build => 1,
99             );
100              
101             sub _build_padding {
102 1     1   22 return shift->radius * .5;
103             }
104              
105             =head2 light_width
106              
107             Returns the width of a traffic light. This is the diameter of a light plus
108             twice the padding (one padding for each side of the light).
109              
110             =cut
111              
112             has light_width => (
113             is => 'ro',
114             isa => 'Num',
115             lazy_build => 1,
116             );
117              
118             sub _build_light_width {
119 1     1   2 my $self = shift;
120              
121             # A light is a diameter plus two paddings
122 1         3 return $self->diameter + (2 * $self->padding);
123             }
124              
125             =head2 light_height
126              
127             Returns the height of a traffic light. This is the diameter of three lights
128             plus four times the padding (one at the top, one at the bottom and two between
129             lights in the block).
130              
131             =cut
132              
133             has light_height => (
134             is => 'ro',
135             isa => 'Num',
136             lazy_build => 1,
137             );
138              
139             sub _build_light_height {
140 1     1   2 my $self = shift;
141              
142             # Height is three diameters + four paddings
143 1         3 return (3 * $self->diameter) + (4 * $self->padding);
144             }
145              
146             =head2 width
147              
148             Returns the width of the SVG document.
149              
150             This is the width of a traffic light block multiplied by the number of blocks
151             in the sequence plus padding on the left and right and padding between each
152             pair of lights.
153              
154             =cut
155              
156             has width => (
157             is => 'ro',
158             isa => 'Num',
159             lazy_build => 1,
160             );
161              
162             sub _build_width {
163 1     1   2 my $self = shift;
164              
165 1         2 my $count_lights = scalar @{ $self->sequence };
  1         24  
166              
167             # One light is 2 * radius
168             # + 2 * padding
169 1         21 my $one_light = $self->light_width;
170              
171             # Multiply by the number of lights
172 1         2 my $lights = $count_lights * $one_light;
173              
174             # Add padding at the edges and between the lights
175 1         21 return ($count_lights + 1) * $self->padding + $lights;
176             }
177              
178             =head2 height
179              
180             Returns the height of the SVG document.
181              
182             This is the height of a traffic light block plus padding at the top and
183             bottom.
184              
185             =cut
186              
187             has height => (
188             is => 'ro',
189             isa => 'Num',
190             lazy_build => 1,
191             );
192              
193             sub _build_height {
194 1     1   2 my $self = shift;
195              
196             # Height of a light bank + two lots of padding
197 1         22 return $self->light_height + (2 * $self->padding);
198             }
199              
200             =head2 corner_radius
201              
202             Returns the radius of the circles used to curve the corners of a traffic
203             light block. The default is 20. This can be changed when creating the object.
204              
205             my $tl = SVG::TrafficLight->new({ corner_radius => 500 });
206              
207             =cut
208              
209             has corner_radius => (
210             is => 'ro',
211             isa => 'Num',
212             default => 20,
213             );
214              
215             =head2 svg
216              
217             This is the SVG object that used to create the SVG document. A standard
218             object is created for you. It's possible to pass in your own when
219             creating the object.
220              
221             my $tl = SVG::TrafficLight->new({
222             svg => SVG->new(width => $width, height => $height,
223             });
224              
225             =cut
226              
227             has svg => (
228             is => 'ro',
229             isa => 'SVG',
230             lazy_build => 1,
231             handles => [ qw(rect circle xmlify) ],
232             );
233              
234             sub _build_svg {
235 1     1   2 my $self = shift;
236              
237 1         59 return SVG->new(
238             width => $self->width,
239             height => $self->height,
240             );
241             }
242              
243             =head2 colours
244              
245             This defines the colours used to draw the traffic lights. The value must be
246             a reference to a hash. The hash must contain three keys - C<red>, C<amber>,
247             and C<green>. The values are references to two-element arrays. The first
248             element in each array is the colour used when the light is off and the
249             second is the colour used when the light is on.
250              
251             The values of the colours can be anything that is recognised as a colour in
252             SVG. These are either colour names (e.g. 'red') or RGB definitions (e.g.
253             'rgb(255,0,0,)'.
254              
255             The default values can be overridden when creating the object.
256              
257             my $tl = SVG::TrafficLight->new({
258             colours => {
259             red => [ ... ],
260             amber => [ ... ],
261             green => [ ... ],
262             }.
263             });
264              
265             =cut
266              
267             has colours => (
268             is => 'ro',
269             isa => 'HashRef',
270             default => sub { {
271             red => ['rgb(63,0,0)', 'red'],
272             amber => ['rgb(59,29,0)', 'orange'],
273             green => ['rgb(0,63,0)', 'green'],
274             } },
275             );
276              
277             =head2 sequence
278              
279             Defines a sequence of traffic lights to display. This is an array reference.
280             Each element in the array is a hash reference which defines which of the
281             three lights are on or off.
282              
283             The default sequence demonstates the full standard British traffic light
284             sequence of green, amber, red, red and amber, green. This can be changed
285             when creating the object. For example here is how to reproduct the green,
286             amber, red, green sequence that is used in many countries.
287              
288             my $tl = SVG::TrafficLight->new({
289             sequence => [
290             { red => 0, amber => 0, green => 1 },
291             { red => 0, amber => 1, green => 0 },
292             { red => 1, amber => 0, green => 0 },
293             { red => 0, amber => 0, green => 1 },
294             ],
295             });
296              
297             You don't need to reproduce sequences that are seen in the real world, The
298             following code, for example, gives a sequence consisting of two steps - one
299             where all lights are off followed by one where all lights are on.
300              
301             my $tl = SVG::TrafficLight->new({
302             sequence => [
303             { red => 0, amber => 0, green => 0 },
304             { red => 1, amber => 1, green => 1 },
305             ],
306             });
307              
308             =cut
309              
310             has sequence => (
311             is => 'ro',
312             isa => 'ArrayRef',
313             default => sub { [{
314             red => 0,
315             amber => 0,
316             green => 1,
317             }, {
318             red => 0,
319             amber => 1,
320             green => 0,
321             }, {
322             red => 1,
323             amber => 0,
324             green => 0,
325             }, {
326             red => 1,
327             amber => 1,
328             green => 0,
329             }, {
330             red => 0,
331             amber => 0,
332             green => 1,
333             }] },
334             );
335              
336 0         0 sub BUILD {
337 1     1 0 1435 my $self = shift;
338              
339 1         2 for my $i (0 .. $#{$self->sequence}) {
  1         26  
340 5         114 my $light_set_x = ($i * ($self->light_width + $self->padding))
341             + $self->padding;
342              
343 5         101 $self->draw_a_lightset_at($light_set_x, $self->padding,
344             $self->sequence->[$i]);
345             }
346              
347             =head2 draw_a_lightset_at($x, $y, \%lights)
348              
349             Draws a set of three lights at a given position on the canvas.
350              
351             Takes three mandatory parameters:
352              
353             =over 4
354              
355             =item $x
356              
357             The x co-ordinate of the top-left corner of the light set.
358              
359             =item $y
360              
361             The co-ordinate of the top left corner of the light set.
362              
363             =item \%lights
364              
365             A reference to a hash indicating which lights should be turned on or off.
366             The keys in the has should be the names of the lights in the light set (red,
367             amber and green) and the associated values should be a 1 (to indicate that the
368             light is on) or a 0 (to indicate that the light is off).
369              
370             =back
371              
372             =cut
373              
374             sub draw_a_lightset_at {
375 5     5 1 9 my $self = shift;
376 5         7 my ($x, $y, $lights) = @_;
377              
378 5         104 $self->rect(
379             x => $x,
380             y => $y,
381             width => $self->light_width,
382             height => $self->light_height,
383             fill => 'black',
384             rx => $self->corner_radius,
385             ry => $self->corner_radius,
386             );
387              
388 5         344 my $light = 0;
389 5         10 for my $l (qw[red amber green]) {
390 15         333 my $fill = $self->colours->{$l}[$lights->{$l}];
391              
392 15         300 $self->circle(
393             cx => $x + $self->padding + $self->radius,
394             cy => $y + $self->padding + $self->radius
395             + $light * ($self->diameter + $self->padding),
396             r => $self->radius,
397             fill => $fill,
398             );
399 15         822 ++$light;
400             }
401             }
402             }
403              
404             =head1 AUTHOR
405              
406             Dave Cross E<lt>dave@perlhacks.comE<gt>
407              
408             =head1 COPYRIGHT
409              
410             Copyright (c) 2017 Magnum Solutions Ltd. All rights reserved.
411              
412             This module is free software; you can redistribute it and/or
413             modify it under the same terms as Perl itself.
414              
415             =head1 SEE ALSO
416              
417             L<SVG>
418              
419             =cut
420              
421             1;