File Coverage

lib/Graphics/Toolkit/Color.pm

Criterion	Covered	Total	%
statement	205	219	93.6
branch	92	128	71.8
condition	29	45	64.4
subroutine	34	38	89.4
pod	19	29	65.5
total	379	459	82.5

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

package Graphics::Toolkit::Color;
our $VERSION = '1.70';
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, $select, $range) = ($args{'to'}, $args{'in'}, $args{'select'}, $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, $select, $range );
}

## 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 { # $to ~in + steps +dynamic +variance --> @_
    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;
}


my $comp_help = 'set constructor "complement" accepts 4 named args: "steps" (positive int), '.
                '"hue_tilt" or "h" (-180 .. 180), '.
                '"saturation_tilt or "s" (-100..100) or { s => (-100..100), h => (-180..180)} and '.
                '"lightness_tilt or "l" (-100..100) or { l => (-100..100), h => (-180..180)}';
    sub complementary { complement(@_) }
sub complement { # +steps +hue_tilt +saturation_tilt +lightness_tilt --> @_
    my ($self) = shift;
    my %arg = (not @_ % 2) ? @_ :
              (@_ == 1)    ? (steps => $_[0]) : return carp $comp_help;
    my $steps = int abs($arg{'steps'} // 1);
    my $hue_tilt = (exists $arg{'h'}) ? (delete $arg{'h'}) :
                   (exists $arg{'hue_tilt'}) ? (delete $arg{'hue_tilt'}) : 0;
    return carp $comp_help if ref $hue_tilt;
    my $saturation_tilt = (exists $arg{'s'}) ? (delete $arg{'s'}) :
                          (exists $arg{'saturation_tilt'}) ? (delete $arg{'saturation_tilt'}) : 0;
    return carp $comp_help if ref $saturation_tilt and ref $saturation_tilt ne 'HASH';
    my $saturation_axis_offset = 0;
    if (ref $saturation_tilt eq 'HASH'){
        my ($pos_hash, $space_name) = Graphics::Toolkit::Color::Space::Hub::partial_hash_deformat( $saturation_tilt );
        return carp $comp_help if not defined $space_name or $space_name ne 'HSL' or not exists $pos_hash->{1};
        $saturation_axis_offset = $pos_hash->{0} if exists $pos_hash->{0};
        $saturation_tilt = $pos_hash->{1};
    }
    my $lightness_tilt = (exists $arg{'l'}) ? (delete $arg{'l'}) :
                         (exists $arg{'lightness_tilt'}) ? (delete $arg{'lightness_tilt'}) : 0;
    return carp $comp_help if ref $lightness_tilt and ref $lightness_tilt ne 'HASH';
    my $lightness_axis_offset = 0;
    if (ref $lightness_tilt eq 'HASH'){
        my ($pos_hash, $space_name) = Graphics::Toolkit::Color::Space::Hub::partial_hash_deformat( $lightness_tilt );
        return carp $comp_help if not defined $space_name or $space_name ne 'HSL' or not exists $pos_hash->{2};
        $lightness_axis_offset = $pos_hash->{0} if exists $pos_hash->{0};
        $lightness_tilt = $pos_hash->{2};
    }

    my @hsl2 = my @hsl = $self->values('HSL');
    my @hue_turn_point = ($hsl[0] + 90, $hsl[0] + 270, 800); # Dmax, Dmin and Pseudo-Inf
    my @sat_turn_point  = ($hsl[0] + 90, $hsl[0] + 270, 800);
    my @light_turn_point = ($hsl[0] + 90, $hsl[0] + 270, 800);
    my $sat_max_hue = $hsl[0] + 90 + $saturation_axis_offset;
    my $sat_step = $saturation_tilt * 4 / $steps;
    my $light_max_hue = $hsl[0] + 90 + $lightness_axis_offset;
    my $light_step = $lightness_tilt * 4 / $steps;
    if ($saturation_axis_offset){
        $sat_max_hue -= 360 while $sat_max_hue > $hsl[0]; # putting dmax in range
        $sat_max_hue += 360 while $sat_max_hue <= $hsl[0]; # above c1->hue
        my $dmin_first = $sat_max_hue > $hsl[0] + 180;
        @sat_turn_point =  $dmin_first ? ($sat_max_hue - 180, $sat_max_hue, 800)
                                       : ($sat_max_hue, $sat_max_hue + 180, 800);
        $sat_step = - $sat_step if $dmin_first;
        my $sat_start_delta = $dmin_first ? ((($sat_max_hue - 180 - $hsl[0]) / 90 * $saturation_tilt) - $saturation_tilt)
                                          : (-(($sat_max_hue -      $hsl[0]) / 90 * $saturation_tilt) + $saturation_tilt);
        $hsl[1] += $sat_start_delta;
        $hsl2[1] -= $sat_start_delta;
    }
    if ($lightness_axis_offset){
        $light_max_hue -= 360 while $light_max_hue > $hsl[0];
        $light_max_hue += 360 while $light_max_hue <= $hsl[0];
        my $dmin_first = $light_max_hue > $hsl[0] + 180;
        @light_turn_point =  $dmin_first ? ($light_max_hue - 180, $light_max_hue, 800)
                                         : ($light_max_hue, $light_max_hue + 180, 800);
        $light_step = - $light_step if $dmin_first;
        my $light_start_delta = $dmin_first ? ((($light_max_hue - 180 - $hsl[0]) / 90 * $lightness_tilt) - $lightness_tilt)
                                            : (-(($light_max_hue -      $hsl[0]) / 90 * $lightness_tilt) + $lightness_tilt);
        $hsl[2] += $light_start_delta;
        $hsl2[2] -= $light_start_delta;
    }
    my $c1 = _new_from_scalar( [ 'HSL', @hsl ] );
    $hsl2[0] += 180 + $hue_tilt;
    my $c2 = _new_from_scalar( [ 'HSL', @hsl2 ] ); # main complementary color
    return $c2 if $steps < 2;
    return $c1, $c2 if $steps == 2;

    my (@result) = $c1;
    my $hue_avg_step = 360 / $steps;
    my $hue_c2_distance = $self->distance( to => $c2, in => 'HSL', select => 'hue');
    my $hue_avg_tight_step = $hue_c2_distance * 2 / $steps;
    my $hue_sec_deg_delta = 8 * ($hue_avg_step - $hue_avg_tight_step) / $steps; # second degree delta
    $hue_sec_deg_delta = -$hue_sec_deg_delta if $hue_tilt < 0; # if c2 on right side
    my $hue_last_step = my $hue_ak_step = $hue_avg_step; # bar height of pseudo integral
    my $hue_current = my $hue_current_naive = $hsl[0];
    my $saturation_current = $hsl[1];
    my $lightness_current = $hsl[2];
    my $hi = my $si = my $li = 0; # index of next turn point where hue step increase gets flipped (at Dmax and Dmin)
    for my $i (1 .. $steps - 1){
        $hue_current_naive += $hue_avg_step;

        if ($hue_current_naive >= $hue_turn_point[$hi]){
            my $bar_width = ($hue_turn_point[$hi] - $hue_current_naive + $hue_avg_step) / $hue_avg_step;
            $hue_ak_step += $hue_sec_deg_delta * $bar_width;
            $hue_current += ($hue_ak_step + $hue_last_step) / 2 * $bar_width;
            $hue_last_step = $hue_ak_step;
            $bar_width = 1 - $bar_width;
            $hue_sec_deg_delta = -$hue_sec_deg_delta;
            $hue_ak_step += $hue_sec_deg_delta * $bar_width;
            $hue_current += ($hue_ak_step + $hue_last_step) / 2 * $bar_width;
            $hi++;
        } else {
            $hue_ak_step += $hue_sec_deg_delta;
            $hue_current += ($hue_ak_step + $hue_last_step) / 2;
        }
        $hue_last_step = $hue_ak_step;

        if ($hue_current_naive >= $sat_turn_point[$si]){
            my $bar_width = ($sat_turn_point[$si] - $hue_current_naive + $hue_avg_step) / $hue_avg_step;
            $saturation_current += $sat_step * ((2 * $bar_width) - 1);
            $sat_step = -$sat_step;
            $si++;
        } else {
            $saturation_current += $sat_step;
        }

        if ($hue_current_naive >= $light_turn_point[$li]){
            my $bar_width = ($light_turn_point[$li] - $hue_current_naive + $hue_avg_step) / $hue_avg_step;
            $lightness_current += $light_step * ((2 * $bar_width) - 1);
            $light_step = -$light_step;
            $li++;
        } else {
            $lightness_current += $light_step;
        }

        $result[$i] = _new_from_scalar( [ HSL => $hue_current, $saturation_current, $lightness_current ] );
    }

    return @result;
}

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

}

1;

__END__