File Coverage

lib/Graphics/Toolkit/Color/Values.pm

Criterion	Covered	Total	%
statement	83	83	100.0
branch	24	32	75.0
condition	12	18	66.6
subroutine	11	11	100.0
pod	6	7	85.7
total	136	151	90.0

use v5.12;
use warnings;

# value objects with cache of original values

package Graphics::Toolkit::Color::Values;
use Graphics::Toolkit::Color::Space::Hub;
use Carp;

sub new {
    my ($pkg, $color_val) = @_;
    my ($values, $space_name) = Graphics::Toolkit::Color::Space::Hub::deformat( $color_val );
    return carp "could not recognize color values" unless ref $values;
    my $space = Graphics::Toolkit::Color::Space::Hub::get_space( $space_name );
    my $std_space = Graphics::Toolkit::Color::Space::Hub::base_space();
    my $self = {};
    $self->{'origin'} = $space->name;
    $values = [$space->clamp( $values )];
    $values = [$space->normalize( $values )];
    $self->{$space->name} = $values;
    $self->{$std_space->name} = [$space->convert($values, $std_space->name)] if $space ne $std_space;
    bless $self;
}

sub get { # get a value tuple in any color space, range and format
    my ($self, $space_name, $format_name, $range_def) = @_;
    Graphics::Toolkit::Color::Space::Hub::check_space_name( $space_name ) and return;
    my $std_space_name = $Graphics::Toolkit::Color::Space::Hub::base_package;
    $space_name //= $std_space_name;
    my $space = Graphics::Toolkit::Color::Space::Hub::get_space( $space_name );
    my $values = (exists $self->{$space->name})
               ? $self->{$space->name}
               : [$space->deconvert( $self->{$std_space_name}, $std_space_name)];
    $values = [ $space->denormalize( $values, $range_def) ];
    Graphics::Toolkit::Color::Space::Hub::format( $values, $space_name, $format_name);
}
sub string { $_[0]->get( $_[0]->{'origin'}, 'string' ) }

########################################################################

sub set { # %val --> _
    my ($self, $val_hash) = @_;
    my ($pos_hash, $space_name) = Graphics::Toolkit::Color::Space::Hub::partial_hash_deformat( $val_hash );
    return carp 'key names: '.join(', ', keys %$val_hash). ' do not correlate to any supported color space' unless defined $space_name;
    my @values = $self->get( $space_name );
    for my $pos (keys %$pos_hash){
        $values[$pos] = $pos_hash->{ $pos };
    }
    __PACKAGE__->new([$space_name, @values]);
}

sub add { # %val --> _
    my ($self, $val_hash) = @_;
    my ($pos_hash, $space_name) = Graphics::Toolkit::Color::Space::Hub::partial_hash_deformat( $val_hash );
    return carp 'key names: '.join(', ', keys %$val_hash). ' do not correlate to any supported color space' unless defined $space_name;
    my @values = $self->get( $space_name );
    for my $pos (keys %$pos_hash){
        $values[$pos] += $pos_hash->{ $pos };
    }
    __PACKAGE__->new([$space_name, @values]);
}

sub blend { # _c1 _c2 -- +factor ~space --> _
    my ($self, $c2, $factor, $space_name ) = @_;
    return carp "need value object as second argument" unless ref $c2 eq __PACKAGE__;
    $factor //= 0.5;
    $space_name //= 'HSL';
    Graphics::Toolkit::Color::Space::Hub::check_space_name( $space_name ) and return;
    my @values1 = $self->get( $space_name );
    my @values2 = $c2->get( $space_name );
    my @rvalues = map { ((1-$factor) * $values1[$_]) + ($factor * $values2[$_]) } 0 .. $#values1;
    __PACKAGE__->new([$space_name, @rvalues]);
}

########################################################################

sub distance { # _c1 _c2 -- ~space ~metric @range --> +
    my ($self, $c2, $space_name, $metric, $range) = @_;
#say "distance ";
    return carp "need value object as second argument" unless ref $c2 eq __PACKAGE__;
    $space_name //= 'HSL';
    Graphics::Toolkit::Color::Space::Hub::check_space_name( $space_name ) and return;
    my $space = Graphics::Toolkit::Color::Space::Hub::get_space( $space_name );
    $metric = $space->basis->key_shortcut($metric) if $space->basis->is_key( $metric );
    my @values1 = $self->get( $space_name, 'list', 'normal' );
    my @values2 = $c2->get( $space_name, 'list', 'normal' );
#say "values: @values1   @values2 $space_name";
    return unless defined $values1[0] and defined $values2[0];
    my @delta = $space->delta( \@values1, \@values2 );
#say "normalized:  @delta $metric" if defined $metric;

    @delta = $space->denormalize_range( \@delta, $range);
#say "denormal :  @delta " if defined $metric;
    return unless defined $delta[0] and @delta == $space->dimensions;

    # grep values for individual metric / subspace distance
    if (defined $metric and $metric){
        my @components = split( '', $metric );
        my $pos = $space->basis->key_pos( $metric );
        @components = defined( $pos )
                    ? ($pos)
                    : (map  { $space->basis->shortcut_pos($_) }
                       grep { defined $space->basis->shortcut_pos($_) } @components);
        return - carp "called 'distance' for metric $metric that does not fit color space $space_name!" unless @components;
        @delta = map { $delta [$_] } @components;
    }

    # Euclidean distance:
    @delta = map {$_ * $_} @delta;
    my $d = 0;
    for (@delta) {$d += $_}
    return sqrt $d;
}

1;

__END__