File Coverage

lib/Graphics/Toolkit/Color/Name.pm

Criterion	Covered	Total	%
statement	95	100	95.0
branch	72	88	81.8
condition	11	18	61.1
subroutine	17	17	100.0
pod	9	9	100.0
total	204	232	87.9

use v5.12;

# named colors from X11, HTML (SVG) standard and Pantone report

package Graphics::Toolkit::Color::Name;
use Graphics::Toolkit::Color::Values;
use Carp;

my $RGB = Graphics::Toolkit::Color::Space::Hub::get_space('RGB');
my $HSL = Graphics::Toolkit::Color::Space::Hub::get_space('HSL');
my $constants = require Graphics::Toolkit::Color::Name::Constant;
our (@name_from_rgb, @name_from_hsl); # search caches
_add_color_to_reverse_search( $_, @{$constants->{$_}} ) for all();

sub all   { sort keys %$constants }
sub taken { exists  $constants->{ _clean($_[0]) } }

sub rgb_from_name {
    my $name = _clean(shift);
    @{$constants->{$name}}[0..2] if taken( $name );
}

sub hsl_from_name {
    my $name = _clean(shift);
    @{$constants->{$name}}[3..5] if taken( $name );
}

sub name_from_rgb {
    my (@rgb) = @_;
    @rgb  = @{$rgb[0]} if (ref $rgb[0] eq 'ARRAY');
    $RGB->check( [@rgb] ) and return; # return if sub did carp
    my @names = _names_from_rgb( @rgb );
    wantarray ? @names : $names[0];
}

sub name_from_hsl {
    my (@hsl) = @_;
    @hsl  = @{$hsl[0]} if (ref $hsl[0] eq 'ARRAY');
    $HSL->check( [ @hsl ] ) and return;
    my @names = _names_from_hsl( @hsl );
    wantarray ? @names : $names[0];
}

sub names_in_hsl_range { # @center, (@d | $d) --> @names
    my $help = 'need two arguments: 1. array with h s l values '.
               '2. radius (real number) or array with tolerances in h s l direction';
    return carp  $help if @_ != 2;
    my ($hsl_center, $radius) = @_;
    $HSL->check( $hsl_center ) and return;
    my $hsl_delta = (ref $radius eq 'ARRAY') ? $radius : [$radius, $radius, $radius];
    $HSL->check( $hsl_delta ) and return;

    $hsl_delta->[0] = 180 if $hsl_delta->[0] > 180;        # enough to search complete HSL space (prevent double results)
    my (@min, @max, @names, $minhrange, $maxhrange);
    $min[$_] = $hsl_center->[$_] - $hsl_delta->[$_]  for 0..2;
    $max[$_] = $hsl_center->[$_] + $hsl_delta->[$_]  for 0..2;
    $min[1] =   0 if $min[1] <   0;
    $min[2] =   0 if $min[2] <   0;
    $max[1] = 100 if $max[1] > 100;
    $max[2] = 100 if $max[2] > 100;
    my @hrange = ($min[0] <   0) ? ( 0 .. $max[0]    , $min[0]+360 .. 359)
               : ($max[0] > 360) ? ( 0 .. $max[0]-360, $min[0]     .. 359)
                                 :                    ($min[0]     .. $max[0]);
    for my $h (@hrange){
        next unless defined $name_from_hsl[ $h ];
        for my $s ($min[1] .. $max[1]){
            next unless defined $name_from_hsl[ $h ][ $s ];
            for my $l ($min[2] .. $max[2]){
                my $name = $name_from_hsl[ $h ][ $s ][ $l ];
                next unless defined $name;
                push @names, (ref $name ? $name->[0] : $name);
             }
        }
    }
    @names = grep {Graphics::Toolkit::Color::Values->new(['HSL',@$hsl_center])->distance(
                   Graphics::Toolkit::Color::Values->new(['HSL',hsl_from_name($_)])     ) <= $radius} @names if not ref $radius;
    @names;
}

sub add_rgb {
    my ($name, @rgb) = @_;
    @rgb  = @{$rgb[0]} if (ref $rgb[0] eq 'ARRAY');
    return carp "missing first argument: color name" unless defined $name and $name;
    $RGB->check( [@rgb] ) and return;
    my @hsl = $HSL->deconvert( [$RGB->normalize( \@rgb )], 'RGB');
    _add_color( $name, @rgb, $HSL->denormalize(\@hsl) );
}

sub add_hsl {
    my ($name, @hsl) = @_;
    @hsl  = @{$hsl[0]} if (ref $hsl[0] eq 'ARRAY');
    return carp "missing first argument: color name" unless defined $name and $name;
    $HSL->check( \@hsl ) and return;
    my @rgb = $HSL->convert( [$HSL->normalize( \@hsl )], 'RGB');
    _add_color( $name, $RGB->denormalize( \@rgb ), @hsl );
}

sub _add_color {
    my ($name, @rgb, @hsl) = @_;
    $name = _clean( $name );
    return carp "there is already a color named '$name' in store of ".__PACKAGE__ if taken( $name );
    _add_color_to_reverse_search( $name, @rgb, @hsl);
    my $ret = $constants->{$name} = [@rgb, @hsl]; # add to foreward search
    (ref $ret) ? [@$ret] : '';                         # make returned ref not transparent
}

sub _clean {
    my $name = shift;
    $name =~ tr/_//d;
    lc $name;
}

sub _names_from_rgb { # each of AoAoA cells (if exists) contains name or array with names (shortes first)
    return '' unless exists $name_from_rgb[ $_[0] ]
              and exists $name_from_rgb[ $_[0] ][ $_[1] ] and exists $name_from_rgb[ $_[0] ][ $_[1] ][ $_[2] ];
    my $cell = $name_from_rgb[ $_[0] ][ $_[1] ][ $_[2] ];
    ref $cell ? @$cell : $cell;
}

sub _names_from_hsl {
    return '' unless exists $name_from_hsl[ $_[0] ]
              and exists $name_from_hsl[ $_[0] ][ $_[1] ] and exists $name_from_hsl[ $_[0] ][ $_[1] ][ $_[2] ];
    my $cell = $name_from_hsl[ $_[0] ][ $_[1] ][ $_[2] ];
    ref $cell ? @$cell : $cell;
}

sub _add_color_to_reverse_search { #     my ($name, @rgb, @hsl) = @_;
    my $name = $_[0];
    my $cell = $name_from_rgb[ $_[1] ][ $_[2] ][ $_[3] ];
    if (defined $cell) {
        if (ref $cell) {
            if (length $name < length $cell->[0] ) { unshift @$cell, $name }
            else                                   { push @$cell, $name    }
        } else {
            $name_from_rgb[ $_[1] ][ $_[2] ][ $_[3] ] =
                (length $name < length $cell) ? [ $name, $cell ]
                                              : [ $cell, $name ] ;
        }
    } else { $name_from_rgb[ $_[1] ][ $_[2] ][ $_[3] ] = $name  }

    $cell = $name_from_hsl[ $_[4] ][ $_[5] ][ $_[6] ];
    if (defined $cell) {
        if (ref $cell) {
            if (length $name < length $cell->[0] ) { unshift @$cell, $name }
            else                                   { push @$cell, $name    }
        } else {
            $name_from_hsl[ $_[4] ][ $_[5] ][ $_[6] ] =
                (length $name < length $cell) ? [ $name, $cell ]
                                              : [ $cell, $name ] ;
        }
    } else { $name_from_hsl[ $_[4] ][ $_[5] ][ $_[6] ] = $name  }
}

1;

__END__