File Coverage

blib/lib/Color/Spectrum.pm
Criterion Covered Total %
statement 85 86 98.8
branch 32 46 69.5
condition 1 3 33.3
subroutine 10 10 100.0
pod 4 4 100.0
total 132 149 88.5


line stmt bran cond sub pod time code
1             package Color::Spectrum;
2 2     2   21324 use strict;
  2         5  
  2         57  
3 2     2   11 use warnings FATAL => 'all';
  2         4  
  2         104  
4             our $VERSION = '1.13';
5              
6 2     2   1586 use POSIX;
  2         14129  
  2         12  
7 2     2   7162 use Carp;
  2         4  
  2         111  
8              
9 2     2   10 use Exporter 'import';
  2         4  
  2         92  
10             our @EXPORT_OK = qw( generate rgb2hsi hsi2rgb );
11              
12 2     2   1543 use Color::Library;
  2         412720  
  2         2203  
13              
14             sub new {
15 1     1 1 73 my $class = shift;
16 1         4 my $self = {};
17 1         2 bless $self, $class;
18 1         4 return $self;
19             }
20              
21             sub generate {
22 10 100   10 1 6945 my $self = shift if ref($_[0]) eq __PACKAGE__;
23 10 50       28 croak "ColorCount and at least one color needed" if @_ < 2;
24 10         16 my $cnt = $_[0];
25 10         19 my $col1 = $_[1];
26 10   33     31 $_[2] ||= $_[1];
27 10         16 my $col2 = $_[2];
28              
29             # expand 3 hex chars to 6
30 10         34 $col1 =~ s/^([a-f0-9])([a-f0-9])([a-f0-9])$/$1$1$2$2$3$3/i;
31 10         21 $col2 =~ s/^([a-f0-9])([a-f0-9])([a-f0-9])$/$1$1$2$2$3$3/i;
32              
33             # look up hex color if not a hex color
34 10 100       59 $col1 = Color::Library->color( $col1 ) unless $col1 =~ /^#?[a-f0-9]{6}$/i;
35 10 100       1111650 $col2 = Color::Library->color( $col2 ) unless $col2 =~ /^#?[a-f0-9]{6}$/i;
36              
37 10 100       2325 croak "Invalid color $_[1]" unless $col1;
38 9 100       171 croak "Invalid color $_[2]" unless $col2;
39              
40             # remove leading hash (we'll add it back later)
41 8         35 $col1 =~s/^#//;
42 8         34 $col2 =~s/^#//;
43              
44 8         27 my $clockwise = 0;
45 8 50       20 $clockwise++ if ( $cnt < 0 );
46 8         15 $cnt = int( abs( $cnt ) );
47              
48 8         21 my @murtceps = ( uc "#$col1" );
49 8 50       26 return ( wantarray() ? @murtceps : \@murtceps ) if $cnt <= 1;
    100          
50 7 50       26 return ( wantarray() ? (uc "#$col1","#$col2") : [uc "#$col1","#$col2"] ) if $cnt == 2;
    100          
51              
52             # The RGB values need to be on the decimal scale,
53             # so we divide em by 255 enpassant.
54 6         24 my ( $h1, $s1, $i1 ) = rgb2hsi( map { hex() / 255 } unpack( 'a2a2a2', $col1 ) );
  18         47  
55 6         25 my ( $h2, $s2, $i2 ) = rgb2hsi( map { hex() / 255 } unpack( 'a2a2a2', $col2 ) );
  18         40  
56 6         13 $cnt--;
57 6         27 my $sd = ( $s2 - $s1 ) / $cnt;
58 6         20 my $id = ( $i2 - $i1 ) / $cnt;
59 6         10 my $hd = $h2 - $h1;
60 6 50       18 if ( uc( $col1 ) eq uc( $col2 ) ) {
61 0 0       0 $hd = ( $clockwise ? -1 : 1 ) / $cnt;
62             } else {
63 6 50       18 $hd = ( ( $hd < 0 ? 1 : 0 ) + $hd - $clockwise) / $cnt;
64             }
65              
66 6         15 while (--$cnt) {
67 36         53 $s1 += $sd;
68 36         52 $i1 += $id;
69 36         45 $h1 += $hd;
70 36 50       79 $h1 -= 1 if $h1>1;
71 36 50       75 $h1 += 1 if $h1<0;
72             push @murtceps, sprintf "#%02X%02X%02X",
73 36         74 map { int( $_ * 255 +.5) } hsi2rgb( $h1, $s1, $i1 );
  108         331  
74             }
75 6         15 push @murtceps, uc "#$col2";
76 6 50       51 return wantarray() ? @murtceps : \@murtceps;
77             }
78              
79             sub rgb2hsi {
80 12     12 1 21 my ( $r, $g, $b ) = @_;
81 12         17 my ( $h, $s, $i ) = ( 0, 0, 0 );
82              
83 12         25 $i = ( $r + $g + $b ) / 3;
84 12 100       36 return ( $h, $s, $i ) if $i == 0;
85              
86 6         14 my $x = $r - 0.5 * ( $g + $b );
87 6         9 my $y = 0.866025403 * ( $g - $b );
88 6         24 $s = ( $x ** 2 + $y ** 2 ) ** 0.5;
89 6 100       23 return ( $h, $s, $i ) if $s == 0;
90              
91 1         16 $h = POSIX::atan2( $y , $x ) / ( 2 * 3.1415926535 );
92 1         245 return ( $h, $s, $i );
93             }
94              
95             sub hsi2rgb {
96 36     36 1 57 my ( $h, $s, $i ) = @_;
97 36         46 my ( $r, $g, $b ) = ( 0, 0, 0 );
98              
99             # degenerate cases. If !intensity it's black, if !saturation it's grey
100 36 50       84 return ( $r, $g, $b ) if ( $i == 0 );
101 36 100       110 return ( $i, $i, $i ) if ( $s == 0 );
102              
103 8         13 $h = $h * 2 * 3.1415926535;
104 8         23 my $x = $s * cos( $h );
105 8         13 my $y = $s * sin( $h );
106              
107 8         14 $r = $i + ( 2 / 3 * $x );
108 8         17 $g = $i - ( $x / 3 ) + ( $y / 2 / 0.866025403 );
109 8         13 $b = $i - ( $x / 3 ) - ( $y / 2 / 0.866025403 );
110              
111             # limit 0<=x<=1 ## YUCK but we go outta range without it.
112 8 50       42 ( $r, $b, $g ) = map { $_ < 0 ? 0 : $_ > 1 ? 1 : $_ } ( $r, $b, $g );
  24 50       80  
113              
114 8         20 return ( $r, $g, $b );
115             }
116              
117             1;
118              
119             __END__