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


line stmt bran cond sub pod time code
1 6     6   719 use v5.12;
  6         20  
2 6     6   28 use warnings;
  6         10  
  6         268  
3              
4             # value objects with cache of original values
5              
6             package Graphics::Toolkit::Color::Values;
7 6     6   2745 use Graphics::Toolkit::Color::Space::Hub;
  6         15  
  6         208  
8 6     6   38 use Carp;
  6         9  
  6         6587  
9              
10             sub new {
11 237     237 1 5188 my ($pkg, $color_val) = @_;
12 237         518 my ($values, $space_name) = Graphics::Toolkit::Color::Space::Hub::deformat( $color_val );
13 237 100       634 return carp "could not recognize color values" unless ref $values;
14 227         390 my $space = Graphics::Toolkit::Color::Space::Hub::get_space( $space_name );
15 227         453 my $std_space = Graphics::Toolkit::Color::Space::Hub::base_space();
16 227         349 my $self = {};
17 227         459 $self->{'origin'} = $space->name;
18 227         493 $values = [$space->clamp( $values )];
19 227         512 $values = [$space->normalize( $values )];
20 227         495 $self->{$space->name} = $values;
21 227 100       754 $self->{$std_space->name} = [$space->convert($values, $std_space->name)] if $space ne $std_space;
22 227         775 bless $self;
23             }
24              
25             sub get { # get a value tuple in any color space, range and format
26 583     583 1 2651 my ($self, $space_name, $format_name, $range_def) = @_;
27 583 50       1052 Graphics::Toolkit::Color::Space::Hub::check_space_name( $space_name ) and return;
28 583         806 my $std_space_name = $Graphics::Toolkit::Color::Space::Hub::base_package;
29 583   66     1231 $space_name //= $std_space_name;
30 583         894 my $space = Graphics::Toolkit::Color::Space::Hub::get_space( $space_name );
31             my $values = (exists $self->{$space->name})
32             ? $self->{$space->name}
33 583 100       1217 : [$space->deconvert( $self->{$std_space_name}, $std_space_name)];
34 583         1422 $values = [ $space->denormalize( $values, $range_def) ];
35 583         1645 Graphics::Toolkit::Color::Space::Hub::format( $values, $space_name, $format_name);
36             }
37 40     40 0 89 sub string { $_[0]->get( $_[0]->{'origin'}, 'string' ) }
38              
39             ########################################################################
40              
41             sub set { # %val --> _
42 8     8 1 16 my ($self, $val_hash) = @_;
43 8         20 my ($pos_hash, $space_name) = Graphics::Toolkit::Color::Space::Hub::partial_hash_deformat( $val_hash );
44 8 100       28 return carp 'key names: '.join(', ', keys %$val_hash). ' do not correlate to any supported color space' unless defined $space_name;
45 7         17 my @values = $self->get( $space_name );
46 7         22 for my $pos (keys %$pos_hash){
47 7         16 $values[$pos] = $pos_hash->{ $pos };
48             }
49 7         25 __PACKAGE__->new([$space_name, @values]);
50             }
51              
52             sub add { # %val --> _
53 7     7 1 14 my ($self, $val_hash) = @_;
54 7         18 my ($pos_hash, $space_name) = Graphics::Toolkit::Color::Space::Hub::partial_hash_deformat( $val_hash );
55 7 100       37 return carp 'key names: '.join(', ', keys %$val_hash). ' do not correlate to any supported color space' unless defined $space_name;
56 5         14 my @values = $self->get( $space_name );
57 5         17 for my $pos (keys %$pos_hash){
58 5         14 $values[$pos] += $pos_hash->{ $pos };
59             }
60 5         19 __PACKAGE__->new([$space_name, @values]);
61             }
62              
63             sub blend { # _c1 _c2 -- +factor ~space --> _
64 16     16 1 33 my ($self, $c2, $factor, $space_name ) = @_;
65 16 50       37 return carp "need value object as second argument" unless ref $c2 eq __PACKAGE__;
66 16   100     36 $factor //= 0.5;
67 16   100     31 $space_name //= 'HSL';
68 16 50       27 Graphics::Toolkit::Color::Space::Hub::check_space_name( $space_name ) and return;
69 16         35 my @values1 = $self->get( $space_name );
70 16         54 my @values2 = $c2->get( $space_name );
71 16         31 my @rvalues = map { ((1-$factor) * $values1[$_]) + ($factor * $values2[$_]) } 0 .. $#values1;
  49         94  
72 16         45 __PACKAGE__->new([$space_name, @rvalues]);
73             }
74              
75             ########################################################################
76              
77             sub distance { # _c1 _c2 -- ~space ~select @range --> +
78 96     96 1 1473 my ($self, $c2, $space_name, $select, $range) = @_;
79 96 100       222 return carp "need value object as second argument" unless ref $c2 eq __PACKAGE__;
80 94   100     205 $space_name //= 'HSL';
81 94 50       224 Graphics::Toolkit::Color::Space::Hub::check_space_name( $space_name ) and return;
82 94         169 my $space = Graphics::Toolkit::Color::Space::Hub::get_space( $space_name );
83 94 100       223 $select = $space->basis->key_shortcut($select) if $space->basis->is_key( $select );
84 94         191 my @values1 = $self->get( $space_name, 'list', 'normal' );
85 94         193 my @values2 = $c2->get( $space_name, 'list', 'normal' );
86 94 50 33     297 return unless defined $values1[0] and defined $values2[0];
87 94         226 my @delta = $space->delta( \@values1, \@values2 );
88              
89 94         269 @delta = $space->denormalize_range( \@delta, $range);
90 94 50 33     270 return unless defined $delta[0] and @delta == $space->dimensions;
91              
92             # grep values for individual select / subspace distance
93 94 100 66     262 if (defined $select and $select){
94 65         168 my @components = split( '', $select );
95 65         117 my $pos = $space->basis->key_pos( $select );
96             @components = defined( $pos )
97             ? ($pos)
98 90         148 : (map { $space->basis->shortcut_pos($_) }
99 65 50       143 grep { defined $space->basis->shortcut_pos($_) } @components);
  90         136  
100 65 50       136 return - carp "called 'distance' for select $select that does not fit color space $space_name!" unless @components;
101 65         92 @delta = map { $delta [$_] } @components;
  90         235  
102             }
103              
104             # Euclidean distance:
105 94         128 @delta = map {$_ * $_} @delta;
  178         282  
106 94         129 my $d = 0;
107 94         154 for (@delta) {$d += $_}
  178         249  
108 94         757 return sqrt $d;
109             }
110              
111             1;
112              
113             __END__