File Coverage

lib/Graphics/Toolkit/Color.pm

Criterion	Covered	Total	%
statement	186	212	87.7
branch	114	134	85.0
condition	62	90	68.8
subroutine	21	42	50.0
pod	13	34	38.2
total	396	512	77.3

# public user level API: docs, help and arg cleaning

package Graphics::Toolkit::Color;
our $VERSION = '1.972';

use v5.12;
use warnings;
use Exporter 'import';
use Graphics::Toolkit::Color::Space::Util qw/is_nr/;
use Graphics::Toolkit::Color::SetCalculator;

my $default_space_name = Graphics::Toolkit::Color::Space::Hub::default_space_name();
our @EXPORT_OK = qw/color/;

## constructor #########################################################

sub color { Graphics::Toolkit::Color->new ( @_ ) }

sub new {
    my ($pkg, @args) = @_;
    my $help = <
    constructor new of Graphics::Toolkit::Color object needs either:
    1. a color name: new('red') or new('SVG:red')
    3. RGB hex string new('#FF0000') or new('#f00')
    4. $default_space_name array or ARRAY ref: new( 255, 0, 0 ) or new( [255, 0, 0] )
    5. named array or ARRAY ref:  new( 'HSL', 255, 0, 0 ) or new( ['HSL', 255, 0, 0 ])
    6. named string:  new( 'HSL: 0, 100, 50' ) or new( 'ncol(r0, 0%, 0%)' )
    7. HASH or HASH ref with values from RGB or any other space:
       new(r => 255, g => 0, b => 0) or new({ hue => 0, saturation => 100, lightness => 50 })
EOH
    my $first_arg_is_color_space = Graphics::Toolkit::Color::Space::Hub::is_space_name( $args[0] );
    @args = ([ $args[0], @{$args[1]} ]) if @args == 2 and $first_arg_is_color_space and ref $args[1] eq 'ARRAY';
    @args = ([ @args ])                 if @args == 3 or (@args > 3 and $first_arg_is_color_space);
    @args = ({ @args })                 if @args == 6 or @args == 8;
    return $help unless @args == 1;
    my $self = _new_from_scalar_def( $args[0] );
    return (ref $self) ? $self : $help;
}
sub _new_from_scalar_def { # color defs of method arguments
    my ($color_def) = shift;
    return $color_def if ref $color_def eq __PACKAGE__;
    return _new_from_value_obj( Graphics::Toolkit::Color::Values->new_from_any_input( $color_def ) );
}
sub _new_from_value_obj {
    my ($value_obj) = @_;
    return $value_obj unless ref $value_obj eq 'Graphics::Toolkit::Color::Values';
    return bless {values => $value_obj};
}


## deprecated methods - deleted with 2.0
    sub string      { $_[0]{'name'} || $_[0]->{'values'}->string }
    sub rgb         { $_[0]->values( ) }
    sub red         {($_[0]->values( ))[0] }
    sub green       {($_[0]->values( ))[1] }
    sub blue        {($_[0]->values( ))[2] }
    sub rgb_hex     { $_[0]->values( as => 'hex') }
    sub rgb_hash    { $_[0]->values( as => 'hash') }
    sub hsl         { $_[0]->values( in => 'hsl') }
    sub hue         {($_[0]->values( in => 'hsl'))[0] }
    sub set         { shift->set_value( @_ ) }
    sub add         { shift->add_value( @_ ) }
    sub saturation  {($_[0]->values( in => 'hsl'))[1] }
    sub lightness   {($_[0]->values( in => 'hsl'))[2] }
    sub hsl_hash    { $_[0]->values( in => 'hsl', as => 'hash') }
    sub distance_to { distance(@_) }
    sub blend       { mix( @_ ) }
    sub blend_with  { $_[0]->mix( with => $_[1], amount => $_[2], in => 'HSL') }
    sub gradient_to     { hsl_gradient_to( @_ ) }
    sub rgb_gradient_to { $_[0]->gradient( to => $_[1], steps => $_[2], dynamic => $_[3], in => 'RGB' ) }
    sub hsl_gradient_to { $_[0]->gradient( to => $_[1], steps => $_[2], dynamic => $_[3], in => 'HSL' ) }
    sub complementary { complement(@_) }

sub _split_named_args {
    my ($raw_args, $only_parameter, $required_parameter, $optional_parameter, $parameter_alias) = @_;
    @$raw_args = %{$raw_args->[0]} if @$raw_args == 1 and ref $raw_args->[0] eq 'HASH' and not
                  (defined $only_parameter and $only_parameter eq 'to' and ref _new_from_scalar_def( $raw_args ) );

    if (@$raw_args == 1 and defined $only_parameter and $only_parameter){
        return "The one default argument can not cover multiple, required parameter !" if @$required_parameter > 1;
        return "The default argument does not cover the required argument!"
            if @$required_parameter and $required_parameter->[0] ne $only_parameter;

        my %defaults = %$optional_parameter;
        delete $defaults{$only_parameter};
        return {$only_parameter => $raw_args->[0], %defaults};
    }
    my %clean_arg;
    if (@$raw_args % 2) {
        return (defined $only_parameter and $only_parameter)
             ? "Got odd number of values, please use key value pairs as arguments or one default argument !\n"
             : "Got odd number of values, please use key value pairs as arguments !\n"
    }
    my %arg_hash = @$raw_args;
    for my $parameter_name (@$required_parameter){
        if (ref $parameter_alias eq 'HASH' and exists $parameter_alias->{ $parameter_name }
            and exists $arg_hash{ $parameter_alias->{$parameter_name} }){
            $arg_hash{ $parameter_name } = delete $arg_hash{ $parameter_alias->{$parameter_name} };
        }
        return "Argument '$parameter_name' is missing\n" unless exists $arg_hash{$parameter_name};
        $clean_arg{ $parameter_name } = delete $arg_hash{ $parameter_name };
    }
    for my $parameter_name (keys %$optional_parameter){
        if (ref $parameter_alias eq 'HASH' and exists $parameter_alias->{ $parameter_name }
            and exists $arg_hash{ $parameter_alias->{$parameter_name} }){
            $arg_hash{ $parameter_name } = delete $arg_hash{ $parameter_alias->{$parameter_name} };
        }
        $clean_arg{ $parameter_name } = exists $arg_hash{$parameter_name}
                                      ? delete $arg_hash{ $parameter_name }
                                      : $optional_parameter->{ $parameter_name };
    }
    return "Inserted unknown argument(s): ".(join ',', keys %arg_hash)."\n" if %arg_hash;
    return \%clean_arg;
}

## getter ##############################################################
sub values       {
    my ($self, @args) = @_;
    my $arg = _split_named_args( \@args, 'in', [],
                               { in => $default_space_name, as => 'list',
                                 precision => undef, range => undef, suffix => undef } );
    my $help = <
    GTC method 'values' accepts either no arguments, one color space name or four optional, named args:
    values ( ...
        in => 'HSL',          # color space name, defaults to "$default_space_name"
        as => 'css_string',   # output format name, default is "list"
        range => 1,           # value range (SCALAR or ARRAY), default set by space def
        precision => 3,       # value precision (SCALAR or ARRAY), default set by space
        suffix => '%',        # value suffix (SCALAR or ARRAY), default set by color space

EOH
    return $arg.$help unless ref $arg;
    $self->{'values'}->formatted( @$arg{qw/in as suffix range precision/} );
}

sub name         {
    my ($self, @args) = @_;
    return $self->{'values'}->name unless @args;
    my $arg = _split_named_args( \@args, 'from', [], {from => 'default', all => 0, full => 0, distance => 0});
     my $help = <
    GTC method 'name' accepts three optional, named arguments:
    name ( ...
        'CSS'                 # color naming scheme works as only positional argument
        from => 'CSS'         # same scheme (defaults to internal: X + CSS + PantoneReport)
        from => ['SVG', 'X']  # more color naming schemes at once, without duplicates
        all => 1              # returns list of all names with the object's RGB values (defaults 0)
        full => 1             # adds color scheme name to the color name. 'SVG:red' (defaults 0)
        distance => 3         # color names from within distance of 3 (defaults 0)
EOH
    return Graphics::Toolkit::Color::Name::from_values( $self->{'values'}->shaped, @$arg{qw/from all full distance/});
}

sub closest_name {
    my ($self, @args) = @_;
    my $arg = _split_named_args( \@args, 'from', [], {from => 'default', all => 0, full => 0});
    my $help = <
    GTC method 'name' accepts three optional, named arguments:
    closest_name ( ...
        'CSS'                 # color naming scheme works as only positional argument
        from => 'CSS'         # same scheme (defaults to internal: X + CSS + PantoneReport)
        from => ['SVG', 'X']  # more color naming schemes at once, without duplicates
        all => 1              # returns list of all names with the object's RGB values (defaults 0)
        full => 1             # adds color scheme name to the color name. 'SVG:red' (defaults 0)
EOH
    my ($name, $distance) = Graphics::Toolkit::Color::Name::closest_from_values(
                                $self->{'values'}->shaped, @$arg{qw/from all full/});
    return wantarray ? ($name, $distance) : $name;
}

sub distance {
    my ($self, @args) = @_;
    my $arg = _split_named_args( \@args, 'to', ['to'], {in => $default_space_name, select => undef, range => undef});
    my $help = <
    GTC method 'distance' accepts as arguments either a scalar color definition or
    four named arguments, only the first being required:
    distance ( ...
        to => 'green'         # color object or color definition (required)
        in => 'HSL'           # color space name, defaults to "$default_space_name"
        select => 'red'       # axis name or names (ARRAY ref), default is none
        range => 2**16        # value range definition, defaults come from color space def
EOH
    return $arg.$help unless ref $arg;
    my $target_color = _new_from_scalar_def( $arg->{'to'} );
    return "target color definition: $arg->{to} is ill formed" unless ref $target_color;
    my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
    return "$color_space\n".$help unless ref $color_space;
    if (defined $arg->{'select'}){
        if (not ref $arg->{'select'}){
            return $arg->{'select'}." is not an axis name in color space: ".$color_space->name
                unless $color_space->is_axis_name( $arg->{'select'} );
        } elsif (ref $arg->{'select'} eq 'ARRAY'){
            for my $axis_name (@{$arg->{'select'}}) {
                return "$axis_name is not an axis name in color space: ".$color_space->name
                    unless $color_space->is_axis_name( $axis_name );
            }
        } else { return "The 'select' argument needs one axis name or an ARRAY with several axis names".
                       " from the same color space!" }
    }
    my $range_def = $color_space->shape->try_check_range_definition( $arg->{'range'} );
    return $range_def unless ref $range_def;
    Graphics::Toolkit::Color::Space::Hub::distance(
        $self->{'values'}->normalized, $target_color->{'values'}->normalized, $color_space->name ,$arg->{'select'}, $range_def );
}

## single color creation methods #######################################
sub set_value {
    my ($self, @args) = @_;
    @args = %{$args[0]} if @args == 1 and ref $args[0] eq 'HASH';
    my $help = <
    GTC method 'set_value' needs a value HASH (not a ref) whose keys are axis names or
    short names from one color space. If the chosen axis name(s) is/are ambiguous,
    you might add the "in" argument:
        set_value( green => 20 ) or set( g => 20 ) or
        set_value( hue => 240, in => 'HWB' )
EOH
    return $help if @args % 2 or not @args or @args > 10;
    my $partial_color = { @args };
    my $space_name = delete $partial_color->{'in'};
    my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $space_name );
    return "$color_space\n".$help unless ref $color_space;
    _new_from_value_obj( $self->{'values'}->set( $partial_color, $space_name ) );
}

sub add_value {
    my ($self, @args) = @_;
    @args = %{$args[0]} if @args == 1 and ref $args[0] eq 'HASH';
    my $help = <
    GTC method 'add_value' needs a value HASH (not a ref) whose keys are axis names or
    short names from one color space. If the chosen axis name(s) is/are ambiguous,
    you might add the "in" argument:
        add_value( blue => -10 ) or set( b => -10 )
        add_value( hue => 100 , in => 'HWB' )
EOH
    return $help if @args % 2 or not @args or @args > 10;
    my $partial_color = { @args };
    my $space_name = delete $partial_color->{'in'};
    my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $space_name );
    return "$color_space\n".$help unless ref $color_space;
    _new_from_value_obj( $self->{'values'}->add( $partial_color, $space_name ) );
}

sub mix {
    my ($self, @args) = @_;
    my $arg = _split_named_args( \@args, 'to', ['to'], {in => $default_space_name, amount => 50});
    my $help = <
    GTC method 'mix' accepts three named arguments, only the first being required:
    mix ( ...
        to => ['HSL', 240, 100, 50]    # scalar color definition or ARRAY ref thereof
        amount => 20                   # percentage value or ARRAY ref thereof, default is 50
        in => 'HSL'                    # color space name, defaults to "$default_space_name"
    Please note that either both or none of the first two arguments has to be an ARRAY.
    Both ARRAY have to have the same length. 'amount' refers to the color(s) picked with 'to'.
EOH
    return $arg.$help unless ref $arg;
    my $recipe = _new_from_scalar_def( $arg->{'to'} );
    if (ref $recipe){
        $recipe = [{color => $recipe->{'values'}, percent => 50}];
        return "Amount argument has to be a sacalar value if only one color is mixed !\n".$help if ref $arg->{'amount'};
        $recipe->[0]{'percent'} = $arg->{'amount'} if defined $arg->{'amount'};
    } else {
        if (ref $arg->{'to'} ne 'ARRAY'){
            return "target color definition (argument 'to'): $arg->{to} is ill formed, has to be one color definition or an ARRAY of";
        } else {
            $recipe = [];
            for my $color_def (@{$arg->{'to'}}){
                my $color = _new_from_scalar_def( $color_def );
                return "target color definition: '$color_def' is ill formed" unless ref $color;
                push @$recipe, { color => $color->{'values'}, percent => 50};
            }
            return "Amount argument has to be an ARRAY of same length as argument 'to' (color definitions)!\n".$help
                if ref $arg->{'to'} eq 'ARRAY' and ref $arg->{'amount'} eq 'ARRAY' and @{$arg->{'amount'}} != @{$arg->{'to'}};
            $arg->{'amount'} = [($arg->{'amount'}) x @{$arg->{'to'}}] if ref $arg->{'to'} and not ref $arg->{'amount'};
            $recipe->[$_]{'percent'} = $arg->{'amount'}[$_] for 0 .. $#{$arg->{'amount'}};
        }
    }
    my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( delete $arg->{'in'} );
    return "$color_space\n".$help unless ref $color_space;
    _new_from_value_obj( $self->{'values'}->mix( $recipe, $color_space ) );
}

sub invert {
    my ($self, @args) = @_;
    my $arg = _split_named_args( \@args, 'in', [], {in => $default_space_name});
    my $help = <
    GTC method 'invert' accepts one optional argument, which can be positional or named:
    invert ( ...
        in => 'HSL'                    # color space name, defaults to "$default_space_name"
EOH
    return $arg.$help unless ref $arg;
    my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
    return "$color_space\n".$help unless ref $color_space;
    _new_from_value_obj( $self->{'values'}->invert( $color_space ) );
}

## color set creation methods ##########################################
sub complement {
    my ($self, @args) = @_;
    my $arg = _split_named_args( \@args, 'steps', [], {steps => 1, tilt => 0, target => {}});
    my $help = <
    GTC method 'complement' is computed in HSL and has two named, optional arguments:
    complement ( ...
        steps => 20                                 # count of produced colors, default is 1
        tilt => 10                                  # default is 0
        target => {h => 10, s => 20, l => 3}        # sub-keys are independent, default to 0
EOH
    return $arg.$help unless ref $arg;
    return "Optional argument 'steps' has to be a number !\n".$help unless is_nr($arg->{'steps'});
    return "Optional argument 'steps' is zero, no complement colors will be computed !\n".$help unless $arg->{'steps'};
    return "Optional argument 'tilt' has to be a number !\n".$help unless is_nr($arg->{'tilt'});
    return "Optional argument 'target' has to be a HASH ref !\n".$help if ref $arg->{'target'} ne 'HASH';
    my ($target_values, $space_name);
    if (keys %{$arg->{'target'}}){
        ($target_values, $space_name) = Graphics::Toolkit::Color::Space::Hub::deformat_partial_hash( $arg->{'target'}, 'HSL' );
        return "Optional argument 'target' got HASH keys that do not fit HSL space (use 'h','s','l') !\n".$help
            unless ref $target_values;
    } else { $target_values = [] }
    map {_new_from_value_obj( $_ )}
        Graphics::Toolkit::Color::SetCalculator::complement( $self->{'values'}, @$arg{qw/steps tilt/}, $target_values );
}

sub gradient {
    my ($self, @args) = @_;
    my $arg = _split_named_args( \@args, 'to', ['to'], {steps => 10, tilt => 0, in => $default_space_name});
    my $help = <
    GTC method 'gradient' accepts four named arguments, only the first is required:
    gradient ( ...
        to => 'blue'              # scalar color definition or ARRAY ref thereof
        steps =>  20              # count of produced colors, defaults to 10
        tilt  =>  1               # dynamics of color change, defaults to 0
        in => 'HSL'               # color space name, defaults to "$default_space_name"
EOH
    return $arg.$help unless ref $arg;
    my @colors = ($self->{'values'});
    my $target_color = _new_from_scalar_def( $arg->{'to'} );
    if (ref $target_color) {
        push @colors, $target_color->{'values'} }
    else {
        return "Argument 'to' contains malformed color definition!\n".$help if ref $arg->{'to'} ne 'ARRAY' or not @{$arg->{'to'}};
        for my $color_def (@{$arg->{'to'}}){
            my $target_color = _new_from_scalar_def( $color_def );
            return "Argument 'to' contains malformed color definition: $color_def !\n".$help unless ref $target_color;
            push @colors, $target_color->{'values'};
        }
    }
    return "Argument 'steps' has to be a number greater zero !\n".$help
        unless is_nr($arg->{'steps'}) and $arg->{'steps'} > 0;
    $arg->{'steps'} = int $arg->{'steps'};
    return "Argument 'tilt' has to be a number !\n".$help unless is_nr($arg->{'tilt'});
    my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
    return "$color_space\n".$help unless ref $color_space;
    map {_new_from_value_obj( $_ )}
        Graphics::Toolkit::Color::SetCalculator::gradient( \@colors, @$arg{qw/steps tilt/}, $color_space);
}

sub cluster {
    my ($self, @args) = @_;
    my $arg = _split_named_args( \@args, undef, ['radius', 'minimal_distance'], {in => $default_space_name},
                                 {radius => 'r', minimal_distance => 'min_d'}                              );
    my $help = <
    GTC method 'cluster' accepts three named arguments, the first two being required:
    cluster (  ...
        radius => 3                    # ball shaped cluster with cuboctahedral packing or
        r => [10, 5, 3]                # cuboid shaped cluster with cubical packing
        minimal_distance => 0.5        # minimal distance between colors in cluster
        min_d => 0.5                   # short alias for minimal distance
        in => 'HSL'                    # color space name, defaults to "$default_space_name"
EOH
    return $arg.$help unless ref $arg;
    my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
    return "$color_space\n".$help unless ref $color_space;
    return "Argument 'radius' has to be a number or an ARRAY of numbers".$help
        unless is_nr($arg->{'radius'}) or $color_space->is_number_tuple( $arg->{'radius'} );
    return "Argument 'distance' has to be a number greater zero !\n".$help
        unless is_nr($arg->{'minimal_distance'}) and $arg->{'minimal_distance'} > 0;
    return "Ball shaped cluster works only in spaces with three dimensions !\n".$help
        if $color_space->axis_count > 3 and not ref $arg->{'radius'};
    map {_new_from_value_obj( $_ )}
        Graphics::Toolkit::Color::SetCalculator::cluster( $self->{'values'}, @$arg{qw/radius minimal_distance/}, $color_space);
}

1;

__END__