File Coverage

blib/lib/GD/Chart/Radial.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             #####################################################################
2             # Radial - A module to generate radial charts as JPG and PNG images #
3             # (c) Copyright 2002,2004-2007 Aaron J Trevena #
4             # (c) Copyright 2007-2013 Barbie #
5             #####################################################################
6             package GD::Chart::Radial;
7              
8 7     7   252985 use strict;
  7         21  
  7         303  
9 7     7   37 use warnings;
  7         13  
  7         239  
10              
11 7     7   71648 use Data::Dumper;
  7         104958  
  7         571  
12 7     7   13570 use GD;
  0            
  0            
13              
14             our $VERSION = '0.08';
15              
16             =head1 NAME
17              
18             GD::Chart::Radial - plot and output Radial or Radar charts using the GD library.
19              
20             =head1 SYNOPSIS
21              
22             use GD::Chart::Radial;
23              
24             my $chart = GD::Chart::Radial->new($width, $height);
25             $chart->set(title=>"This is a chart");
26             $chart->plot(\@data);
27             print OUTFILE $chart->png;
28              
29             =head1 DESCRIPTION
30              
31             This module allows you to plot and output Radial or Radar charts
32             using the GD library. The module is based on GD::Graph in how it
33             can be used where possible.
34              
35             A radial chart has multiple axis spread out from the centre, like
36             spokes on a wheel. Each axis represents a particular measurement.
37             Values are plotted by marking the value for what is being measured
38             on each axis and optionally joining these points. The result can
39             look like a spiderweb or a radar depending on how you plot the
40             values.
41              
42             =cut
43              
44             my %COLOURS = (
45             white => [255,255,255],
46             black => [0,0,0],
47             red => [255,0,0],
48             blue => [0,0,255],
49             purple => [230,0,230],
50             green => [0,255,0],
51             grey => [128,128,128],
52             light_grey => [170,170,170],
53             dark_grey => [75,75,75],
54             cream => [200,200,240],
55             yellow => [255,255,0],
56             orange => [255,128,0],
57             );
58              
59             my %FONT = (
60             1 => [5, gdSmallFont, gdTinyFont, gdTinyFont],
61             2 => [10, gdMediumBoldFont, gdSmallFont, gdTinyFont],
62             3 => [15, gdLargeFont, gdMediumBoldFont, gdSmallFont],
63             4 => [20, gdGiantFont, gdLargeFont, gdMediumBoldFont],
64             5 => [20, gdGiantFont, gdGiantFont, gdLargeFont],
65             6 => [20, gdGiantFont, gdGiantFont, gdGiantFont],
66             );
67              
68             my @FONT = sort keys %FONT;
69              
70             =head1 METHODS
71              
72             =head2 new
73              
74             This constructor method creates a new chart object.
75              
76             my $chart = GD::Chart::Radial->new($width,$height);
77              
78             =cut
79              
80             sub new {
81             my ($class, $width, $height, $debug) = (@_,0);
82              
83             # instantiate Chart
84             my $chart = {};
85             bless($chart, ref($class) || $class);
86              
87             # initialise Chart
88             $chart->{width} = $width;
89             $chart->{height} = $height;
90             $chart->{debug} = $debug;
91             $chart->{PI} = 4 * atan2 1, 1;
92             return $chart;
93             }
94              
95             =head2 set
96              
97             This accessor sets attributes of the graph such as the Title
98              
99             $chart->set(title=>"This is a chart");
100              
101             or
102              
103             $chart->set(
104             legend => [qw/april may/],
105             title => 'Some simple graph',
106             y_max_value => $max,
107             y_tick_number => 5,
108             style => 'Notch',
109             colours => [qw/white black red blue green/],
110             );
111              
112             Style can be Notch, Circle, Polygon or Fill. The default style is Notch. Where
113             style is set to Fill, the data sets are also filled, as opposed to lines drawn
114             for all other styles
115              
116             Colours can be any of the following: white, black, red, blue, purple, green,
117             grey, light_grey, dark_grey, cream, yellow, orange. The first colour is used
118             for the background colour, the second is used for the scale markings, while
119             the remaining colours represent the different data sets. If there are less
120             colours than data sets, colours will be taken from the unused set of defined
121             colours.
122              
123             The default list of colours are white, black, red, blue and green, i.e. white
124             background, black scale markings and data sets in red blue and green.
125              
126             Both legend and title can be undefined. If this is the case then the relavent
127             entry will not appear on the graph. This is useful if you plan to use other
128             forms of labelling along with the graph, and only require the image.
129              
130             =cut
131              
132             sub set {
133             my $self = shift;
134             my %attributes = @_;
135             foreach my $attribute (%attributes) {
136             next unless ($attributes{$attribute});
137             $self->{$attribute} = $attributes{$attribute};
138             }
139             }
140              
141             =head2 plot
142              
143             This method plots the chart based on the data provided and the attributes of
144             the graph.
145              
146             my @data = ([qw/A B C D E F G/],
147             [12,21,23,30,23,22,5],
148             [10,20,21,24,28,15,9]);
149             $chart->plot(\@data);
150              
151             =cut
152              
153             sub plot {
154             my $self = shift;
155             return unless(@_);
156              
157             my @values = @{shift()};
158             my @labels = @{shift(@values)};
159             my @records;
160              
161             if($self->{colours}) {
162             for(@{$self->{colours}}) {
163             next unless(/^\#[a-f0-9]{3}([a-f0-9]{3})?$/i);
164             my ($r,$g,$b);
165             if(length($_) == 7) {
166             my ($r,$g,$b) = (/^\#(..)(..)(..)$/);
167             $COLOURS{$_} = [hex($r),hex($g),hex($b)];
168             } else {
169             my ($r,$g,$b) = (/^\#(.)(.)(.)$/);
170             $COLOURS{$_} = [hex("$r$r"),hex("$g$g"),hex("$b$b")];
171             }
172             }
173              
174             # ensure we only have valid colours
175             my @c = grep {$COLOURS{$_}} @{$self->{colours}};
176             $self->{colours} = \@c;
177             }
178              
179             my $BGColour = $self->{colours} ? shift @{$self->{colours}} : 'white';
180             my $FGColour = $self->{colours} ? shift @{$self->{colours}} : 'black';
181             my @DSColours = $self->{colours} ? @{$self->{colours}} : qw/red blue green yellow orange/;
182              
183             # try and avoid running out of colours
184             my %AllColours = map {$_ => 1} keys %COLOURS;
185             delete $AllColours{$_} for($BGColour,$FGColour,@DSColours);
186             push @DSColours, keys %AllColours;
187             while(scalar(@labels) > scalar(@DSColours) || scalar(@values) > scalar(@DSColours)) {
188             push @DSColours, @DSColours;
189             }
190              
191             #print STDERR "\n#Colours:";
192             #print STDERR "\n#Background=$BGColour";
193             #print STDERR "\n#Markings =$FGColour";
194             #print STDERR "\n#Labels =".(join(",",@DSColours));
195             #print STDERR "\n#Legends =".(join(",",@{$self->{legend}}));
196             #print STDERR "\n";
197              
198             #print STDERR "\n#Data:";
199             #print STDERR "\n#Labels=".(join(",",@labels));
200             #print STDERR "\n#Points=[".(join("][", map{join(",",@$_)} @values))."]";
201             #print STDERR "\n";
202              
203             my $Max = 0;
204             my $r = 0;
205             foreach my $values (@values) {
206             my $record = { Colour => $DSColours[$r] };
207             $record->{Label} = $self->{legend}->[$r] if($self->{legend});
208             my $v = 0;
209             foreach my $value (@$values) {
210             $record->{Values}->{$labels[$v]} = $value;
211             $Max = $value if($Max < $value);
212             $v++;
213             }
214             push(@records,$record);
215             $r++;
216             }
217              
218             $self->{records} = \@records;
219             $self->{y_max_value} ||= $Max;
220             $self->{y_tick_number} ||= $Max;
221              
222             my $PI = $self->{PI};
223              
224             # style can be Fill, Circle, Polygon or Notch
225             my %scale = (
226             Max => $self->{y_max_value},
227             Divisions => $self->{y_tick_number},
228             Style => $self->{style} || "Notch",
229             Colour => $FGColour
230             );
231              
232             # calculate image dimensions
233             my (@axis, %axis_lookup);
234             my $longest_axis_label = 0;
235             my $a = 0;
236             foreach my $key (@labels) {
237             push (@axis, { Label => "$key" });
238             $axis_lookup{$key} = $a;
239             $longest_axis_label = length $key
240             if (length $key > $longest_axis_label);
241             $a++;
242             }
243              
244             my $number_of_axis = scalar @axis;
245             my $legend_height = 0;
246              
247             if($self->{legend}) {
248             $legend_height = 8 + (15 * scalar @{$self->{records}});
249             }
250              
251             my $left_space = 15 + $longest_axis_label * 6;
252             my $right_space = 15 + $longest_axis_label * 6;
253             my $top_space = $self->{title} ? 50 : 15;
254             my $bottom_space = $self->{legend} ? 30 + $legend_height : 15;
255              
256             unless($self->{width}) { $self->{width} = 200 + $left_space + $right_space; }
257             unless($self->{height}) { $self->{height} = 200 + $top_space + $bottom_space; }
258              
259             my $x_radius = int(($self->{width} - $left_space - $right_space) / 2);
260             my $y_radius = int(($self->{height} - $top_space - $bottom_space) / 2);
261             my $min_radius = 100;
262              
263             $x_radius = $min_radius if($x_radius < $min_radius);
264             $y_radius = $min_radius if($y_radius < $min_radius);
265             $x_radius = $y_radius if($x_radius > $y_radius);
266             $y_radius = $x_radius if($y_radius > $x_radius);
267              
268             $top_space += _font_offset($x_radius);
269              
270             my $x_centre = $left_space + $x_radius;
271             my $y_centre = $top_space + $y_radius;
272             my $height = (2 * $y_radius) + $bottom_space + $top_space;
273             my $width = (2 * $x_radius) + $left_space + $right_space;
274              
275             #print STDERR "\n#width=$width, height=$height\n" if($self->{debug});
276             $self->{_im} = GD::Image->new($width,$height);
277              
278             # define the colours and fonts
279             my %colours = map {$_ => $self->{_im}->colorAllocate(@{$COLOURS{$_}})} ($BGColour,$FGColour,@DSColours);
280             $self->{fonts} = {
281             Title => _font_size(1,$x_radius),
282             Label => _font_size(2,$x_radius),
283             Legend => _font_size(3,$x_radius)
284             };
285              
286             my (@Axis,@Label,@Notch);
287             my $Theta = 90;
288             my $i = $number_of_axis;
289             foreach my $axis (@axis) {
290             my ($proportion,$theta,$x,$y);
291              
292             if ($i > 0) {
293             $proportion = $i / $number_of_axis;
294             $theta = ((360 * $proportion) + $Theta) % 360;
295             $axis->{theta} = $theta;
296             $theta *= ((2 * $PI) / 360);
297             } else {
298             $axis->{theta} = $Theta;
299             $theta = $Theta;
300             }
301             $x = cos $theta - (2 * $theta);
302             $y = sin $theta - (2 * $theta);
303              
304             my $x_outer = ($x * $x_radius) + $x_centre;
305             my $x_proportion = ($x >= 0) ? $x : $x - (2 * $x) ;
306             my $x_label = ($x_outer >= $x_centre)
307             ? $x_outer + 3
308             : $x_outer - ((length ( $axis->{Label} ) * 5) + (3 * $x_proportion));
309             my $y_outer = ($y * $y_radius) + $y_centre;
310             my $y_proportion = ($y >= 0) ? $y : $y - (2 * $y) ;
311             my $y_label = ($y_outer >= $y_centre)
312             ? $y_outer + (3 * $y_proportion)
313             : $y_outer - (9 * $y_proportion);
314              
315             $axis->{X} = $x;
316             $axis->{Y} = $y;
317              
318             # round down coords
319             $x_outer =~ s/(\d+)\..*/$1/;
320             $y_outer =~ s/(\d+)\..*/$1/;
321             $x_label =~ s/(\d+)\..*/$1/;
322             $y_label =~ s/(\d+)\..*/$1/;
323              
324             # top label needs to be slightly offset to avoid the scale marking
325             $y_label -= _font_offset($x_radius) if($i == $number_of_axis);
326              
327             # draw axis and label
328             if ($scale{Style} eq "Fill") {
329             push @Axis, [$x_outer, $y_outer, $x_centre, $y_centre, $colours{$scale{Colour}}];
330             push @Label, [$x_label, $y_label, $axis->{Label}, $colours{$scale{Colour}}];
331             } else {
332             $self->{_im}->line($x_outer, $y_outer, $x_centre, $y_centre, $colours{$scale{Colour}});
333             $self->{_im}->string($self->{fonts}->{Label}, $x_label, $y_label, $axis->{Label}, $colours{$scale{Colour}});
334             }
335             $i--;
336             }
337              
338             # loop through adding scale, and values
339             $r = 0;
340             $i = 0;
341             foreach my $axis (@axis) {
342             my $x = $axis->{X};
343             my $y = $axis->{Y};
344             # draw scale
345             my $theta1;
346             my $theta2;
347             if ($scale{Style} eq "Notch" || $scale{Style} eq "Fill") {
348             $theta1 = $axis->{theta} + 90;
349             $theta2 = $axis->{theta} - 90;
350             # convert theta to radians
351             $theta1 *= ((2 * $PI) / 360);
352             $theta2 *= ((2 * $PI) / 360);
353             for (my $j = 0 ; $j <= $scale{Max} ; $j+=int($scale{Max} / $scale{Divisions})) {
354             my $x_interval = $x_centre + ($x * ($x_radius / $scale{Max}) * $j);
355             my $y_interval = $y_centre + ($y * ($y_radius / $scale{Max}) * $j);
356             my $x1 = cos $theta1 - (2 * $theta1);
357             my $y1 = sin $theta1 - (2 * $theta1);
358             my $x2 = cos $theta2 - (2 * $theta2);
359             my $y2 = sin $theta2 - (2 * $theta2);
360             my $x1_outer = ($x1 * 3 * ($j / $scale{Max})) + $x_interval;
361             my $y1_outer = ($y1 * 3 * ($j / $scale{Max})) + $y_interval;
362             my $x2_outer = ($x2 * 3 * ($j / $scale{Max})) + $x_interval;
363             my $y2_outer = ($y2 * 3 * ($j / $scale{Max})) + $y_interval;
364              
365             if($scale{Style} eq "Fill") {
366             push @Notch, [$x1_outer,$y1_outer,$x_interval,$y_interval,$colours{$scale{Colour}}];
367             push @Notch, [$x2_outer,$y2_outer,$x_interval,$y_interval,$colours{$scale{Colour}}];
368             } else {
369             $self->{_im}->line($x1_outer,$y1_outer,$x_interval,$y_interval,$colours{$scale{Colour}});
370             $self->{_im}->line($x2_outer,$y2_outer,$x_interval,$y_interval,$colours{$scale{Colour}});
371             }
372             }
373             }
374              
375             if ($scale{Style} eq "Polygon" || $scale{Style} eq "Fill") {
376             for (my $j = 0 ; $j <= $scale{Max} ; $j+=int($scale{Max} / $scale{Divisions})) {
377             my $x_interval_1 = $x_centre + ($x * ($x_radius / $scale{Max}) * $j);
378             my $y_interval_1 = $y_centre + ($y * ($y_radius / $scale{Max}) * $j);
379             my $x_interval_2 = $x_centre + ($axis[$i-1]->{X} * ($x_radius / $scale{Max}) * $j);
380             my $y_interval_2 = $y_centre + ($axis[$i-1]->{Y} * ($y_radius / $scale{Max}) * $j);
381              
382             if ($i > 0) {
383             next if ($j == 0);
384             $self->{_im}->line($x_interval_1,$y_interval_1,$x_interval_2,$y_interval_2,$colours{$scale{Colour}});
385             if ($i == $number_of_axis -1) {
386             my $x_interval_2 = $x_centre + ($axis[0]->{X} * ($x_radius / $scale{Max}) * $j);
387             my $y_interval_2 = $y_centre + ($axis[0]->{Y} * ($y_radius / $scale{Max}) * $j);
388             $self->{_im}->line($x_interval_1,$y_interval_1,$x_interval_2,$y_interval_2,$colours{$scale{Colour}});
389             }
390             }
391             }
392             }
393              
394             if ($scale{Style} eq "Circle") {
395             for (my $j = 0 ; $j <= $scale{Max} ; $j+=int($scale{Max} / $scale{Divisions})) {
396             if ($i > 0) {
397             next if ($j == 0);
398             my $radius = (($y_radius * 2) / $scale{Max}) * $j;
399             $self->{_im}->arc($x_centre,$y_centre,$radius,$radius,$axis[0]->{theta}-2,$axis[$i-1]->{theta}-2,$colours{$scale{Colour}});
400             $self->{_im}->arc($x_centre,$y_centre,$radius,$radius,$axis[$i]->{theta}-2,$axis[0]->{theta}-2,$colours{$scale{Colour}});
401             }
402             }
403             }
404              
405             # draw graph points
406             if ($i != 0) {
407             my $r = 0;
408             foreach my $record (@{$self->{records}}) {
409             my $value = $record->{Values}->{$axis->{Label}};
410             my $colour = $colours{$record->{Colour}};
411             $value ||= 0;
412             #print STDERR "Max=[$scale{Max}], value=[$value]" if($self->{debug});
413             my $x_interval_1 = $x_centre + ($x * ($x_radius / $scale{Max}) * $value);
414             my $y_interval_1 = $y_centre + ($y * ($y_radius / $scale{Max}) * $value);
415              
416             if ($scale{Style} eq "Fill") {
417             push @{$record->{Points}}, [$x_interval_1,$y_interval_1];
418             if ($i == $number_of_axis -1) {
419             my $first_value = $record->{Values}->{$axis[0]->{Label}};
420             my $x_interval_2 = $x_centre + ($axis[0]->{X} * ($x_radius / $scale{Max}) * $first_value);
421             my $y_interval_2 = $y_centre + ($axis[0]->{Y} * ($y_radius / $scale{Max}) * $first_value);
422             push @{$record->{Points}}, [$x_interval_2,$y_interval_2];
423             }
424             } else {
425             $self->draw_shape($x_interval_1,$y_interval_1,$colours{$record->{Colour}}, $r);
426              
427             my $last_value = $record->{Values}->{$axis[$i-1]->{Label}};
428             my $x_interval_2 = $x_centre + ($axis[$i-1]->{X} * ($x_radius / $scale{Max}) * $last_value);
429             my $y_interval_2 = $y_centre + ($axis[$i-1]->{Y} * ($y_radius / $scale{Max}) * $last_value);
430             $self->{_im}->line($x_interval_1,$y_interval_1,$x_interval_2,$y_interval_2,$colour);
431              
432             if ($i == $number_of_axis -1) {
433             my $first_value = $record->{Values}->{$axis[0]->{Label}};
434             my $x_interval_2 = $x_centre + ($axis[0]->{X} * ($x_radius / $scale{Max}) * $first_value);
435             my $y_interval_2 = $y_centre + ($axis[0]->{Y} * ($y_radius / $scale{Max}) * $first_value);
436             $self->{_im}->line($x_interval_1,$y_interval_1,$x_interval_2,$y_interval_2,$colour);
437             $self->draw_shape($x_interval_2,$y_interval_2,$colours{$record->{Colour}}, $r);
438             }
439             $r++;
440             }
441             }
442             }
443             $i++;
444             }
445              
446             # Fill is a filled polgon
447             if ($scale{Style} eq "Fill") {
448             foreach my $record (@{$self->{records}}) {
449             my $poly = GD::Polygon->new();
450             $poly->addPt($_->[0],$_->[1]) for(@{$record->{Points}});
451             $self->{_im}->filledPolygon($poly,$colours{$record->{Colour}});
452             }
453              
454             $self->{_im}->line(@$_) for(@Axis,@Notch);
455             $self->{_im}->string($self->{fonts}->{Label},@$_) for(@Label);
456             }
457              
458             # draw scale values
459             my $x = $axis[0]->{X};
460             my $y = $axis[0]->{Y};
461             for (my $j = 0 ; $j <= $scale{Max} ; $j+=int($scale{Max} / $scale{Divisions})) {
462             my $x_interval_1 = $x_centre + ($x * ($x_radius / $scale{Max}) * $j);
463             my $y_interval_1= $y_centre + ($y * ($y_radius / $scale{Max}) * $j);
464             $self->{_im}->string($self->{fonts}->{Legend}, $x_interval_1 + 2,$y_interval_1 - 4,$j,$colours{$scale{Colour}});
465             }
466              
467             # draw Legend
468             if($self->{legend}) {
469             my $longest_legend = 0;
470             foreach my $record (@{$self->{records}}) {
471             $longest_legend = length $record->{Label}
472             if ( $record->{Label} && length $record->{Label} > $longest_legend );
473             }
474             my ($legendX, $legendY) = (
475             ($width / 2) - (6 * (length "Legend") / 2) - ($x_radius * 0.75),
476             ($height - ($legend_height + 20))
477             );
478             $self->{_im}->string($self->{fonts}->{Legend},$legendX,$legendY,"Legend",$colours{$scale{Colour}});
479             my $legendX2 = $legendX - (($longest_legend * 5) + 2);
480             $legendY += 15;
481             $r = 0;
482              
483             foreach my $record (@{$self->{records}}) {
484             $self->{_im}->string($self->{fonts}->{Label},$legendX2,$legendY,$record->{Label},$colours{$record->{Colour}}) if($record->{Label});
485             $self->{_im}->line($legendX+10,$legendY+4,$legendX + 35,$legendY+4,$colours{$record->{Colour}});
486             $self->draw_shape($legendX+22,$legendY+4,$colours{$record->{Colour}},$r);
487             $legendY += 15;
488             $r++;
489             }
490             }
491              
492             # draw title
493             if($self->{title}) {
494             my ($titleX, $titleY) = ( ($width / 2) - (6 * (length $self->{title}) / 2),20);
495             $self->{_im}->string($self->{fonts}->{Title},$titleX,$titleY,$self->{title},$colours{$scale{Colour}});
496             }
497             return 1;
498             }
499              
500             =head2 png
501              
502             returns a PNG image for output to a file or wherever.
503              
504             open(IMG, '>test.png') or die $!;
505             binmode IMG;
506             print IMG $chart->png;
507             close IMG
508              
509             =cut
510              
511             sub png {
512             my $self = shift;
513             return unless($self->{_im}->can('png'));
514             return $self->{_im}->png();
515             }
516              
517             =head2 jpg
518              
519             returns a JPEG image for output to a file or elsewhere, see png.
520              
521             =cut
522              
523             sub jpg {
524             my $self = shift;
525             return unless($self->{_im}->can('jpeg'));
526             return $self->{_im}->jpeg(95);
527             }
528              
529             =head2 gif
530              
531             returns a GIF image for output to a file or elsewhere, see png.
532              
533             =cut
534              
535             sub gif {
536             my $self = shift;
537             return unless($self->{_im}->can('gif'));
538             return $self->{_im}->gif();
539             }
540              
541             =head2 gd
542              
543             returns a GD image for output to a file or elsewhere, see png.
544              
545             =cut
546              
547             sub gd {
548             my $self = shift;
549             return unless($self->{_im}->can('gd'));
550             return $self->{_im}->gd();
551             }
552              
553             ##########################################################
554              
555             =head2 Internal Methods
556              
557             In order to draw the points on the chart, the following 6 shape drawing
558             functions are used:
559              
560             =over 4
561              
562             =item draw_shape
563              
564             =item draw_diamond
565              
566             =item draw_square
567              
568             =item draw_circle
569              
570             =item draw_triangle
571              
572             =item draw_cross
573              
574             =back
575              
576             =cut
577              
578             sub draw_shape {
579             my ($self,$x,$y,$colour,$i) = @_;
580             my $shape;
581             if (exists $self->{records}->[$i]->{Shape} ) {
582             $shape = $self->{records}->[$i]->{Shape};
583             } else {
584             $shape = ($i > 4) ? int ($i % 5) : $i ;
585             $self->{records}->[$i]->{Shape} = $shape;
586             }
587              
588             if ($shape == 0) {
589             $self->draw_diamond($x,$y,$colour);
590             return 1;
591             }
592             if ($shape == 1) {
593             $self->draw_square($x,$y,$colour);
594             return 1;
595             }
596             if ($shape == 2) {
597             $self->draw_circle($x,$y,$colour);
598             return 1;
599             }
600             if ($shape == 3) {
601             $self->draw_triangle($x,$y,$colour);
602             return 1;
603             }
604             if ($shape == 4) {
605             $self->draw_cross($x,$y,$colour);
606             return 1;
607             }
608             }
609              
610             sub draw_diamond {
611             my ($self,$x,$y,$colour) = @_;
612             $x-=3;
613             my $poly = new GD::Polygon;
614             $poly->addPt($x,$y);
615             $poly->addPt($x+3,$y-3);
616             $poly->addPt($x+6,$y);
617             $poly->addPt($x+3,$y+3);
618             $poly->addPt($x,$y);
619             $self->{_im}->filledPolygon($poly,$colour);
620             return 1;
621             }
622              
623             sub draw_square {
624             my ($self,$x,$y,$colour) = @_;
625             $x-=3;
626             $y-=3;
627             my $poly = new GD::Polygon;
628             $poly->addPt($x,$y);
629             $poly->addPt($x+6,$y);
630             $poly->addPt($x+6,$y+6);
631             $poly->addPt($x,$y+6);
632             $poly->addPt($x,$y);
633             $self->{_im}->filledPolygon($poly,$colour);
634             return 1;
635             }
636              
637             sub draw_circle {
638             my ($self,$x,$y,$colour) = @_;
639             $self->{_im}->arc($x,$y,7,7,0,360,$colour);
640             $self->{_im}->fillToBorder($x,$y,$colour,$colour);
641             return 1;
642             }
643              
644             sub draw_triangle {
645             my ($self,$x,$y,$colour) = @_;
646             $x-=3;
647             $y+=3;
648             my $poly = new GD::Polygon;
649             $poly->addPt($x,$y);
650             $poly->addPt($x+3,$y-6);
651             $poly->addPt($x+6,$y);
652             $poly->addPt($x,$y);
653             $self->{_im}->filledPolygon($poly,$colour);
654             return 1;
655             }
656              
657             sub draw_cross {
658             my ($self,$x,$y,$colour) = @_;
659             $self->{_im}->line($x-3,$y,$x+3,$y,$colour);
660             $self->{_im}->line($x,$y-3,$x,$y+3,$colour);
661             return 1;
662             }
663              
664             sub _font_size {
665             my $scale = shift || 1;
666             my $radius = int((shift || $FONT[0]) / 100 );
667             $radius = $FONT[0] if($radius < $FONT[0]);
668             $radius = $FONT[-1] if($radius > $FONT[-1]);
669              
670             return $FONT{$radius}->[$scale];
671             }
672              
673             sub _font_offset {
674             my $radius = int((shift || $FONT[0]) / 100 );
675              
676             return $FONT{$radius}->[0];
677             }
678              
679             1;
680             __END__