1#==========================================================================
2#              Copyright (c) 1995-1998 Martien Verbruggen
3#--------------------------------------------------------------------------
4#
5#   Name:
6#       GD::Graph::colour.pm
7#
8#   Description:
9#       Package of colour manipulation routines, to be used
10#       with GD::Graph.
11#
12# $Id: colour.pm,v 1.10 2005/12/14 04:09:40 ben Exp $
13#
14#==========================================================================
15
16
17package GD::Graph::colour;
18
19($GD::Graph::colour::VERSION) = '$Revision: 1.10 $' =~ /\s([\d.]+)/;
20
21=head1 NAME
22
23GD::Graph::colour - Colour manipulation routines for use with GD::Graph
24
25=head1 SYNOPSIS
26
27use GD::Graph::colour qw(:colours :lists :files :convert);
28
29=head1 DESCRIPTION
30
31The B<GD::Graph::colour> package provides a few routines to work with
32colours. The functionality of this package is mainly defined by what is
33needed, now and historically, by the GD::Graph modules.
34
35=cut
36
37use vars qw( @EXPORT_OK %EXPORT_TAGS );
38use strict;
39require Exporter;
40use Carp;
41
42@GD::Graph::colour::ISA = qw( Exporter );
43
44@EXPORT_OK = qw(
45    _rgb _luminance _hue add_colour
46    colour_list sorted_colour_list
47    read_rgb
48    hex2rgb rgb2hex
49);
50%EXPORT_TAGS = (
51    colours => [qw( add_colour _rgb _luminance _hue )],
52    lists => [qw( colour_list sorted_colour_list )],
53    files => [qw( read_rgb )],
54    convert => [qw( hex2rgb rgb2hex )],
55);
56
57my %RGB = (
58    white   => [0xFF,0xFF,0xFF],
59    lgray   => [0xBF,0xBF,0xBF],
60    gray    => [0x7F,0x7F,0x7F],
61    dgray   => [0x3F,0x3F,0x3F],
62    black   => [0x00,0x00,0x00],
63    lblue   => [0x00,0x00,0xFF],
64    blue    => [0x00,0x00,0xBF],
65    dblue   => [0x00,0x00,0x7F],
66    gold    => [0xFF,0xD7,0x00],
67    lyellow => [0xFF,0xFF,0x00],
68    yellow  => [0xBF,0xBF,0x00],
69    dyellow => [0x7F,0x7F,0x00],
70    lgreen  => [0x00,0xFF,0x00],
71    green   => [0x00,0xBF,0x00],
72    dgreen  => [0x00,0x7F,0x00],
73    lred    => [0xFF,0x00,0x00],
74    red     => [0xBF,0x00,0x00],
75    dred    => [0x7F,0x00,0x00],
76    lpurple => [0xFF,0x00,0xFF],
77    purple  => [0xBF,0x00,0xBF],
78    dpurple => [0x7F,0x00,0x7F],
79    lorange => [0xFF,0xB7,0x00],
80    orange  => [0xFF,0x7F,0x00],
81    pink    => [0xFF,0xB7,0xC1],
82    dpink   => [0xFF,0x69,0xB4],
83    marine  => [0x7F,0x7F,0xFF],
84    cyan    => [0x00,0xFF,0xFF],
85    lbrown  => [0xD2,0xB4,0x8C],
86    dbrown  => [0xA5,0x2A,0x2A],
87);
88
89=head1 FUNCTIONS
90
91=head2 colour_list( I<number of colours> )
92
93Returns a list of I<number of colours> colour names known to the package.
94Exported with the :lists tag.
95
96=cut
97
98sub colour_list
99{
100    my $n = ( $_[0] ) ? $_[0] : keys %RGB;
101    return (keys %RGB)[0 .. $n-1];
102}
103
104=head2 sorted_colour_list( I<number of colours> )
105
106Returns a list of I<number of colours> colour names known to the package,
107sorted by luminance or hue.
108B<NB.> Right now it always sorts by luminance. Will add an option in a later
109stage to decide sorting method at run time.
110Exported with the :lists tag.
111
112=cut
113
114sub sorted_colour_list
115{
116    my $n = $_[0] ? $_[0] : keys %RGB;
117    return (sort by_luminance keys %RGB)[0 .. $n-1];
118    # return (sort by_hue keys %rgb)[0..$n-1];
119
120    sub by_luminance { _luminance(@{$RGB{$b}}) <=> _luminance(@{$RGB{$a}}) }
121    sub by_hue       { _hue(@{$RGB{$b}}) <=> _hue(@{$RGB{$a}}) }
122}
123
124=head2 _rgb( I<colour name> )
125
126Returns a list of the RGB values of I<colour name>. if the colour name
127is a string of the form that is acceptable to the hex2rgb sub, then the
128colour will be added to the list dynamically.
129Exported with the :colours tag.
130
131=cut
132
133my %warned_clrs = ();
134
135# return the RGB values of the colour name
136sub _rgb
137{
138    my $clr = shift or return;
139
140    # Try adding the colour if it doesn't exist yet. It may be of a
141    # parseable form
142    add_colour($clr) unless exists $RGB{$clr};
143
144    my $rgb_ref = $RGB{$clr};
145    if (!defined $rgb_ref)
146    {
147        $rgb_ref = $RGB{'black'};
148        unless ($warned_clrs{$clr})
149        {
150            $warned_clrs{$clr}++;
151            carp "Colour $clr is not defined, reverting to black";
152        }
153    };
154
155    @{$rgb_ref};
156}
157
158=head2 _hue( I<R,G,B> )
159
160Returns the hue of the colour with the specified RGB values.
161Exported with the :colours tag.
162
163=head2 _luminance( I<R,G,B> )
164
165Returns the luminance of the colour with the specified RGB values.
166Exported with the :colours tag.
167
168=cut
169
170# return the luminance of the colour (RGB)
171sub _luminance
172{
173    (0.212671 * $_[0] + 0.715160 * $_[1] + 0.072169 * $_[2])/0xFF
174}
175
176# return the hue of the colour (RGB)
177sub _hue
178{
179    ($_[0] + $_[1] + $_[2])/(3 * 0xFF)
180}
181
182=head2 add_colour(colourname => [$r, $g, $b]) or
183add_colour('#7fe310')
184
185Self-explanatory.
186Exported with the :colours tag.
187
188=cut
189
190sub add_colour
191{
192    my $name = shift;
193    my $val  = shift;
194
195    if (!defined $val)
196    {
197        my @rgb = hex2rgb($name) or return;
198        $val = [@rgb];
199    }
200
201    if (ref $val && ref $val eq 'ARRAY')
202    {
203        $RGB{$name} = [@{$val}];
204        return $name;
205    }
206
207    return;
208}
209
210=head2 rgb2hex($red, $green, $blue)
211
212=head2 hex2rgb('#7fe310')
213
214These functions translate a list of RGB values into a hexadecimal
215string, as is commonly used in HTML and the Image::Magick API, and vice
216versa.
217Exported with the :convert tag.
218
219=cut
220
221# Color translation
222sub rgb2hex
223{
224    return unless @_ == 3;
225    my $color = '#';
226    foreach my $cc (@_)
227    {
228        $color .= sprintf("%02x", $cc);
229    }
230    return $color;
231}
232
233sub hex2rgb
234{
235    my $clr = shift;
236    my @rgb = $clr =~ /^#([a-f0-9]{2})([a-f0-9]{2})([a-f0-9]{2})$/i;
237    return unless @rgb;
238    return map { hex $_ } @rgb;
239}
240
241=head2 read_rgb( F<file name> )
242
243Reads in colours from a rgb file as used by the X11 system.
244
245Doing something like:
246
247    use GD::Graph::bars;
248    use GD::Graph::colour;
249
250    GD::Graph::colour::read_rgb("rgb.txt") or die "cannot read colours";
251
252Will allow you to use any colours defined in rgb.txt in your graph.
253Exported with the :files tag.
254
255=cut
256
257#
258# Read a rgb.txt file (X11)
259#
260# Expected format of the file:
261#
262# R G B colour name
263#
264# Fields can be separated by any number of whitespace
265# Lines starting with an exclamation mark (!) are comment and
266# will be ignored.
267#
268# returns number of colours read
269
270sub read_rgb($) # (filename)
271{
272    my $fn = shift;
273    my $n = 0;
274    my $line;
275
276    open(RGB, $fn) or return 0;
277
278    while (defined($line = <RGB>))
279    {
280        next if ($line =~ /\s*!/);
281        chomp($line);
282
283        # remove leading white space
284        $line =~ s/^\s+//;
285
286        # get the colours
287        my ($r, $g, $b, $name) = split(/\s+/, $line, 4);
288
289        # Ignore bad lines
290        next unless (defined $name);
291
292        $RGB{$name} = [$r, $g, $b];
293        $n++;
294    }
295
296    close(RGB);
297
298    return $n;
299}
300
301sub version { $GD::Graph::colour::VERSION }
302
303sub dump_colours
304{
305    my $max = $_[0] ? $_[0] : keys %RGB;
306    my $n = 0;
307
308    my $clr;
309    foreach $clr (sorted_colour_list($max))
310    {
311        last if $n > $max;
312        print "colour: $clr, " .
313            "${$RGB{$clr}}[0], ${$RGB{$clr}}[1], ${$RGB{$clr}}[2]\n"
314    }
315}
316
317
318"Just another true value";
319
320__END__
321
322=head1 PREDEFINED COLOUR NAMES
323
324white,
325lgray,
326gray,
327dgray,
328black,
329lblue,
330blue,
331dblue,
332gold,
333lyellow,
334yellow,
335dyellow,
336lgreen,
337green,
338dgreen,
339lred,
340red,
341dred,
342lpurple,
343purple,
344dpurple,
345lorange,
346orange,
347pink,
348dpink,
349marine,
350cyan,
351lbrown,
352dbrown.
353
354=head1 AUTHOR
355
356Martien Verbruggen E<lt>mgjv@tradingpost.com.auE<gt>
357
358=head2 Copyright
359
360GIFgraph: Copyright (c) 1995-1999 Martien Verbruggen.
361Chart::PNGgraph: Copyright (c) 1999 Steve Bonds.
362GD::Graph: Copyright (c) 1999 Martien Verbruggen.
363
364All rights reserved. This package is free software; you can redistribute
365it and/or modify it under the same terms as Perl itself.
366
367=head1 SEE ALSO
368
369L<GD::Graph>,
370L<GD::Graph::FAQ>
371
372