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

package Color::Spectrum;
use strict;
use warnings FATAL => 'all';
our $VERSION = '1.16';

use POSIX;
use Carp;

use Exporter 'import';
our @EXPORT_OK = qw( generate rgb2hsi hsi2rgb );

use Color::Library;

sub new {
    my $class = shift;
    my $self  = {};
    bless $self, $class;
    return $self;
}

sub generate {
    my $self = shift if ref($_[0]) eq __PACKAGE__;
    croak "ColorCount and at least one color needed" if @_ < 2;
    my $cnt  = $_[0];
    my $col1 = $_[1];
    $_[2]  ||= $_[1];
    my $col2 = $_[2];

    # expand 3 hex chars to 6
    $col1 =~ s/^([a-f0-9])([a-f0-9])([a-f0-9])$/$1$1$2$2$3$3/i;
    $col2 =~ s/^([a-f0-9])([a-f0-9])([a-f0-9])$/$1$1$2$2$3$3/i;

    # look up hex color if not a hex color
    $col1 = Color::Library->color( $col1 ) unless $col1 =~ /^#?[a-f0-9]{6}$/i;
    $col2 = Color::Library->color( $col2 ) unless $col2 =~ /^#?[a-f0-9]{6}$/i;

    croak "Invalid color $_[1]" unless $col1;
    croak "Invalid color $_[2]" unless $col2;

    # remove leading hash (we'll add it back later)
    $col1 =~s/^#//;
    $col2 =~s/^#//;

    my $clockwise = 0;
    $clockwise++ if ( $cnt < 0 );
    $cnt = int( abs( $cnt ) );

    my @murtceps = ( uc "#$col1" );
    return ( wantarray() ? @murtceps : \@murtceps ) if $cnt <= 1;
    return ( wantarray() ? (uc "#$col1","#$col2") : [uc "#$col1","#$col2"] ) if $cnt == 2;

    # The RGB values need to be on the decimal scale,
    # so we divide em by 255 enpassant.
    my ( $h1, $s1, $i1 ) = rgb2hsi( map { hex() / 255 } unpack( 'a2a2a2', $col1 ) );
    my ( $h2, $s2, $i2 ) = rgb2hsi( map { hex() / 255 } unpack( 'a2a2a2', $col2 ) );
    $cnt--;
    my $sd = ( $s2 - $s1 ) / $cnt;
    my $id = ( $i2 - $i1 ) / $cnt;
    my $hd = $h2 - $h1;
    if ( uc( $col1 ) eq uc( $col2 ) ) {
        $hd = ( $clockwise ? -1 : 1 ) / $cnt;
    } else {
        $hd = ( ( $hd < 0 ? 1 : 0 ) + $hd - $clockwise) / $cnt;
    }

    while (--$cnt) {
        $s1 += $sd;
        $i1 += $id;
        $h1 += $hd;
        $h1 -= 1 if $h1>1;
        $h1 += 1 if $h1<0;
        push @murtceps, sprintf "#%02X%02X%02X",
            map { int( $_ * 255 +.5) } hsi2rgb( $h1, $s1, $i1 );
    }
    push @murtceps, uc "#$col2";
    return wantarray() ? @murtceps : \@murtceps;
}

sub rgb2hsi {
    my ( $r, $g, $b ) = @_;
    my ( $h, $s, $i ) = ( 0, 0, 0 );

    $i = ( $r + $g + $b ) / 3;
    return ( $h, $s, $i ) if $i == 0;

    my $x = $r - 0.5 * ( $g + $b );
    my $y = 0.866025403 * ( $g - $b );
    $s = ( $x ** 2 + $y ** 2 ) ** 0.5;
    return ( $h, $s, $i ) if $s == 0;

    $h = POSIX::atan2( $y , $x ) / ( 2 * 3.1415926535 );
    return ( $h, $s, $i );
}

sub hsi2rgb {
    my ( $h, $s, $i ) =  @_;
    my ( $r, $g, $b ) = ( 0, 0, 0 );

    # degenerate cases. If !intensity it's black, if !saturation it's grey
    return ( $r, $g, $b ) if ( $i == 0 );
    return ( $i, $i, $i ) if ( $s == 0 );

    $h = $h * 2 * 3.1415926535;
    my $x = $s * cos( $h );
    my $y = $s * sin( $h );

    $r = $i + ( 2 / 3 * $x );
    $g = $i - ( $x / 3 ) + ( $y / 2 / 0.866025403 );
    $b = $i - ( $x / 3 ) - ( $y / 2 / 0.866025403 );

    # limit 0<=x<=1  ## YUCK but we go outta range without it.
    ( $r, $b, $g ) = map { $_ < 0 ? 0 : $_ > 1 ? 1 : $_ } ( $r, $b, $g );

    return ( $r, $g, $b );
}

1;

__END__