File Coverage

lib/Graphics/Toolkit/Color.pm

Criterion	Covered	Total	%
statement	136	150	90.6
branch	56	74	75.6
condition	25	31	80.6
subroutine	34	38	89.4
pod	19	29	65.5
total	270	322	83.8

# read only color holding object with methods for relation, mixing and transitions

package Graphics::Toolkit::Color;
our $VERSION = '1.61';
use v5.12;

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

use Exporter 'import';
our @EXPORT_OK = qw/color/;

my $new_help = 'constructor of Graphics::Toolkit::Color object needs either:'.
        ' 1. hash or ref (RGB, HSL or any other): ->new(r => 255, g => 0, b => 0), ->new({ h => 0, s => 100, l => 50 })'.
        ' 2. RGB array or ref: ->new( [255, 0, 0 ]) or >new( 255, 0, 0 )'.
        ' 3. hex form "#FF0000" or "#f00" 4. a name: "red" or "SVG:red".';

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

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

sub new {
    my ($pkg, @args) = @_;
    @args = ([@args]) if @args == 3 or Graphics::Toolkit::Color::Space::Hub::is_space( $args[0]);
    @args = ({ @args }) if @args == 6 or @args == 8;
    return carp $new_help unless @args == 1;
    _new_from_scalar($args[0]);
}
sub _new_from_scalar {
    my ($color_def) = shift;
    my ($value_obj, @rgb, $name, $origin);
    # strings that are not '#112233' or 'rgb: 23,34,56'
    if (not ref $color_def and substr($color_def, 0, 1) =~ /\w/ and $color_def !~ /,/){
        $name = $color_def;
        $origin = 'name';
        my $i = index( $color_def, ':');
        if ($i > -1 ){                        # resolve pallet:name
            my $pallet_name = substr $color_def, 0, $i;
            my $color_name = Graphics::Toolkit::Color::Name::_clean(substr $color_def, $i+1);
            my $module_base = 'Graphics::ColorNames';
            eval "use $module_base";
            return carp "$module_base is not installed, but it's needed to load external colors" if $@;
            my $module = $module_base.'::'.$pallet_name;
            eval "use $module";
            return carp "$module is not installed, but needed to load color '$pallet_name:$color_name'" if $@;

            my $pallet = Graphics::ColorNames->new( $pallet_name );
            @rgb = $pallet->rgb( $color_name );
            return carp "color '$color_name' was not found, propably not part of $module" unless @rgb == 3;
        } else {                              # resolve name ->
            @rgb = Graphics::Toolkit::Color::Name::rgb_from_name( $color_def );
            return carp "'$color_def' is an unknown color name, please check Graphics::Toolkit::Color::Name::all()." unless @rgb == 3;
        }
        $value_obj = Graphics::Toolkit::Color::Values->new( [@rgb] );
    } elsif (ref $color_def eq __PACKAGE__) { # enables color objects to be passed as arguments
        $name = $color_def->name;
        $value_obj = Graphics::Toolkit::Color::Values->new( $color_def->{'values'}->string );
    } else {                                  # define color by numbers in any format
        my $value_obj = Graphics::Toolkit::Color::Values->new( $color_def );
        return unless ref $value_obj;
        return _new_from_value_obj($value_obj);
    }
    bless {name => $name, values => $value_obj};
}
sub _new_from_value_obj {
    my ($value_obj) = @_;
    return unless ref $value_obj eq 'Graphics::Toolkit::Color::Values';
    bless {name => scalar Graphics::Toolkit::Color::Name::name_from_rgb( $value_obj->get() ), values => $value_obj};
}

## getter ##############################################################

sub name        { $_[0]{'name'} }

    sub string      { $_[0]{'name'} || $_[0]->{'values'}->string }
    sub rgb         { $_[0]->values( ) }
    sub red         {($_[0]->values( in => 'rgb'))[0] }
    sub green       {($_[0]->values( in => 'rgb'))[1] }
    sub blue        {($_[0]->values( in => 'rgb'))[2] }
    sub rgb_hex     { $_[0]->values( in => 'rgb', as => 'hex') }
    sub rgb_hash    { $_[0]->values( in => 'rgb', as => 'hash') }
    sub hsl         { $_[0]->values( in => 'hsl') }
    sub hue         {($_[0]->values( in => 'hsl'))[0] }
    sub saturation  {($_[0]->values( in => 'hsl'))[1] }
    sub lightness   {($_[0]->values( in => 'hsl'))[2] }
    sub hsl_hash    { $_[0]->values( in => 'hsl', as => 'hash') }

sub values      {
    my ($self) = shift;
    my %args = (not @_ % 2) ? @_ :
               (@_ == 1)    ? (in => $_[0])
                            : return carp "accept three optional, named arguments: in => 'HSL', as => 'css_string', range => 16";
    $self->{'values'}->get( $args{'in'}, $args{'as'}, $args{'range'} );
}

## measurement methods ##############################################################

sub distance_to { distance(@_) }
sub distance {
    my ($self) = shift;
    my %args = (not @_ % 2) ? @_ :
               (@_ == 1)    ? (to => $_[0])
                            : return carp "accept four optional, named arguments: to => 'color or color definition', in => 'RGB', metric => 'r', range => 16";
    my ($c2, $space_name, $metric, $range) = ($args{'to'}, $args{'in'}, $args{'metric'}, $args{'range'});
    return carp "missing argument: color object or scalar color definition" unless defined $c2;
    $c2 = _new_from_scalar( $c2 );
    return carp "second color for distance calculation (named argument 'to') is badly defined" unless ref $c2 eq __PACKAGE__;
    $self->{'values'}->distance( $c2->{'values'}, $space_name, $metric );
}

## single color creation methods #######################################

sub _get_arg_hash {
    my $arg = (ref $_[0] eq 'HASH') ? $_[0]
            : (not @_ % 2)          ? {@_}
            :                         {} ;
    return (keys %$arg) ? $arg : carp "need arguments as hash (with or without braces)";
}

sub set {
    my ($self, @args) = @_;
    my $arg = _get_arg_hash( @args );
    return unless ref $arg;
    _new_from_value_obj( $self->{'values'}->set( $arg ) );
}

sub add {
    my ($self, @args) = @_;
    my $arg = _get_arg_hash( @args );
    return unless ref $arg;
    _new_from_value_obj( $self->{'values'}->add( $arg ) );
}

sub blend_with { $_[0]->blend( with => $_[1], pos => $_[2], in => 'HSL') }
sub blend {
    my ($self, @args) = @_;
    my $arg = _get_arg_hash( @args );
    return unless ref $arg;
    my $c2 = _new_from_scalar( $arg->{'with'} );
    return croak "need a second color under the key 'with' ( with => { h=>1, s=>2, l=>3 })" unless ref $c2;
    my $pos = $arg->{'pos'} // $arg->{'position'} // 0.5;
    my $space_name = $arg->{'in'} // 'HSL';
    return carp "color space $space_name is unknown" unless Graphics::Toolkit::Color::Space::Hub::is_space( $space_name );
    _new_from_value_obj( $self->{'values'}->blend( $c2->{'values'}, $pos, $space_name ) );
}

## color set creation methods ##########################################


# for compatibility
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 gradient {
    my ($self, @args) = @_;
    my $arg = _get_arg_hash( @args );
    return unless ref $arg eq 'HASH';
    my $c2 = _new_from_scalar( $arg->{'to'} );
    return croak "need a second color under the key 'to' : ( to => ['HSL', 10, 20, 30])" unless ref $c2;
    my $space_name = $arg->{'in'} // 'HSL';
    my $steps = int(abs($arg->{'steps'} // 3));
    my $power = $arg->{'dynamic'} // 0;
    $power = ($power >= 0) ? $power + 1 : -(1/($power-1));
    return $self if $steps == 1;
    my $space = Graphics::Toolkit::Color::Space::Hub::get_space( $space_name );
    return carp "color space $space_name is unknown" unless ref $space;
    my @val1 =  $self->{'values'}->get( $space_name, 'list', 'normal' );
    my @val2 =  $c2->{'values'}->get( $space_name, 'list', 'normal' );
    my @delta_val = $space->delta (\@val1, \@val2 );
    my @colors = ();
    for my $nr (1 .. $steps-2){
        my $pos = ($nr / ($steps-1)) ** $power;
        my @rval = map {$val1[$_] + ($pos * $delta_val[$_])} 0 .. $space->dimensions - 1;
        @rval = $space->denormalize ( \@rval );
        push @colors, _new_from_scalar( [ $space_name, @rval ] );
    }
    return $self, @colors, $c2;
}

sub complementary { complement(@_) }
sub complement { # steps => +,  delta => {}
    my ($self) = shift;
    my ($count) = int ((shift // 1) + 0.5);
    my ($saturation_change) = shift // 0;
    my ($lightness_change) = shift // 0;
    my @hsl2 = my @hsl_l = my @hsl_r = $self->values('HSL');
    my $HSL = Graphics::Toolkit::Color::Space::Hub::get_space('HSL');
    $hsl2[0] += 180;
    $hsl2[1] += $saturation_change;
    $hsl2[2] += $lightness_change;
    my $c2 = _new_from_scalar( [ 'HSL', @hsl2 ] );
    return $c2 if $count < 2;
    my (@colors_r, @colors_l);
    my @delta = (360 / $count, (($hsl2[1] - $hsl_r[1]) * 2 / $count), (($hsl2[2] - $hsl_r[2]) * 2 / $count) );
    for (1 .. ($count - 1) / 2){
        $hsl_r[$_] += $delta[$_] for 0..2;
        $hsl_l[0] -= $delta[0];
        $hsl_l[$_] = $hsl_r[$_] for 1,2;
        $hsl_l[0] += 360 if $hsl_l[0] <    0;
        $hsl_r[0] -= 360 if $hsl_l[0] >= 360;
        push    @colors_r, _new_from_scalar( [ 'HSL', @hsl_r ] );
        unshift @colors_l, _new_from_scalar( [ 'HSL', @hsl_l ] );
    }
    push @colors_r, $c2 unless $count % 2;
    $self, @colors_r, @colors_l;
}

sub bowl {
    my ($self, @args) = @_;
    my $arg = _get_arg_hash( @args );
    return unless ref $arg eq 'HASH';
# radius size in
# distance | count
}

1;

__END__