File Coverage

lib/Graphics/Toolkit/Color.pm
Criterion Covered Total %
statement 264 298 88.5
branch 166 218 76.1
condition 81 116 69.8
subroutine 30 37 81.0
pod 21 26 80.7
total 562 695 80.8


line stmt bran cond sub pod time code
1              
2             # public user level API: doc summary, help msg and arg cleaning
3              
4             package Graphics::Toolkit::Color;
5             our $VERSION = '2.20';
6 5     5   378888 use v5.12;
  5         14  
7 5     5   21 use warnings;
  5         6  
  5         258  
8 5     5   1542 use Graphics::Toolkit::Color::Error qw/error/;
  5         11  
  5         304  
9 5     5   1348 use Graphics::Toolkit::Color::Space::Util qw/is_nr/;
  5         9  
  5         286  
10 5     5   2289 use Graphics::Toolkit::Color::SetCalculator;
  5         17  
  5         247  
11              
12             ## import export, error handling #######################################
13 5     5   38 use Exporter;
  5         10  
  5         24381  
14             our @ISA = qw(Exporter);
15             our @EXPORT_OK = qw/color is_in_gamut/;
16              
17             sub import {
18 10     10   3521 my ($class, @args) = @_;
19 10         15 my @export_symbols;
20 10   100     76 push @export_symbols, shift @args while @args and lc $args[0] ne 'error';
21 10         37 Graphics::Toolkit::Color::Error::change_mode( $args[1] );
22 10         12530 $class->Exporter::export_to_level(1, $class, @export_symbols);
23             }
24              
25             ## constructor #########################################################
26             my $POD_link = ' Type "perldoc Graphics::Toolkit::Color" for more help.';
27             sub new {
28 75     75 0 6884 my ($pkg, @args) = @_;
29 75         148 my $help = 'method "new" accepts the arguments: "color" (color definition), "raw", '.
30             '"range" and "in" (space name). "color" is the required and default argument.'.$POD_link;
31 75         132 my ($color_def, $space_name, $range_def, $is_raw);
32 75 100 100     394 if (@args > 0 and not @args % 2){
33 32         89 my %h = @args;
34 32 100       79 return error('got an argument twice') if int(%h) * 2 < int(@args);
35 31   100     181 ($color_def, $space_name, $range_def, $is_raw) = ($h{'color'}, $h{'in'}, $h{'range'}, $h{'raw'} // 0);
36             }
37 74 100       195 $color_def = _color_def_into_scalar( @args ) unless defined $color_def;
38 74 100       120 return error($help) unless defined $color_def;
39 73         136 my $self = _new_from_scalar_def( $color_def, $space_name, $range_def, $is_raw );
40 73 100       331 return (ref $self) ? $self : error($self);
41             }
42             sub color {
43 25     25 0 571374 my $self = _new_from_scalar_def( _color_def_into_scalar( @_ ) );
44 25 100       103 return (ref $self) ? $self : error($self);
45             }
46             sub _color_def_into_scalar {
47 100     100   173 my (@args) = @_;
48 100 50 66     459 return if @args < 1 or @args > 8 or @args == 7;
      66        
49 97 100       258 return $args[0] if @args == 1; # pass names
50 39 100       137 return [@args] if @args <= 5; # lists and named lists --> array and named array
51 17         49 return {@args}; # hashes without curly braces --> hash
52             }
53             sub _new_from_scalar_def {
54 148     148   378 my ($color_def, $space_name, $range_def, $is_raw) = @_;
55 148 100       368 return $color_def if ref $color_def eq __PACKAGE__;
56 137         518 return _new_from_value_obj( Graphics::Toolkit::Color::Values->new_from_any_input( $color_def, $space_name, $range_def, $is_raw ) );
57             }
58             sub _new_from_value_obj {
59 315     315   365 my ($value_obj) = @_;
60 315 100       507 return $value_obj unless ref $value_obj eq 'Graphics::Toolkit::Color::Values';
61 265         1113 return bless {values => $value_obj};
62             }
63 254 50   254 0 1407 sub values_object { $_[0]->{'values'} if ref $_[0] eq __PACKAGE__}
64              
65             sub is_in_gamut {
66 13     13 1 444 my ($self, $space_name, $named_arg) = @_;
67 13 100       48 return is_in_gamut_sub (@_) if ref $self ne __PACKAGE__;
68 5         11 my $help = 'The method "is_in_gamut" accepts one optional, positional argument, a color space name, '.
69             'which defaults to the space the color was defined in'.$POD_link;
70 5 100 100     26 $space_name = $named_arg if defined $space_name and $space_name eq 'in' and defined $named_arg;
      66        
71 5         15 my $space = Graphics::Toolkit::Color::Space::Hub::get_space( $space_name );
72 5 50 66     20 return error($help) if defined $space_name and not ref $space;
73 5 100       30 $self->values_object->is_in_gamut( (ref $space) ? $space->name : undef );
74             }
75             sub is_in_gamut_sub {
76 8     8 0 11 my (@color) = @_;
77 8         31 my $values = Graphics::Toolkit::Color::Values->new_from_any_input(
78             _color_def_into_scalar( @_ ), undef, undef, 1
79             );
80 8 100       32 return error($values.$POD_link) unless ref $values;
81 7         37 $values->is_in_gamut( );
82             }
83              
84             ########################################################################
85             sub _split_named_args {
86 191     191   590 my ($raw_args, $only_parameter, $required_parameter, $optional_parameter, $parameter_alias) = @_;
87 191 50 66     771 @$raw_args = %{$raw_args->[0]} if @$raw_args == 1 and ref $raw_args->[0] eq 'HASH' and not
  0   0     0  
      33        
88             (defined $only_parameter and $only_parameter eq 'to' and ref _new_from_scalar_def( $raw_args ) );
89              
90 191 100 100     588 if (@$raw_args == 1 and defined $only_parameter and $only_parameter){
      66        
91 35 50       74 return "The one default argument can not cover multiple, required parameter !" if @$required_parameter > 1;
92 35 50 66     99 return "The default argument does not cover the required argument!"
93             if @$required_parameter and $required_parameter->[0] ne $only_parameter;
94              
95 35         164 my %defaults = %$optional_parameter;
96 35         78 delete $defaults{$only_parameter};
97 35         213 return {$only_parameter => $raw_args->[0], %defaults};
98             }
99 156         217 my %clean_arg;
100 156 100       436 if (@$raw_args % 2) {
101 2 50 33     33 return (defined $only_parameter and $only_parameter)
102             ? "Got odd number of arguments, please use key value pairs as arguments or one default argument !\n"
103             : "Got odd number of values, please use key value pairs as arguments !\n"
104             }
105 154         431 my %arg_hash = @$raw_args;
106 154         323 for my $parameter_name (@$required_parameter){
107 83 100 100     502 if (ref $parameter_alias eq 'HASH' and exists $parameter_alias->{ $parameter_name }
      100        
108             and exists $arg_hash{ $parameter_alias->{$parameter_name} }){
109 25         69 $arg_hash{ $parameter_name } = delete $arg_hash{ $parameter_alias->{$parameter_name} };
110             }
111 83 100       262 return "Argument '$parameter_name' is missing!\n" unless exists $arg_hash{$parameter_name};
112 75         238 $clean_arg{ $parameter_name } = delete $arg_hash{ $parameter_name };
113             }
114 146         449 for my $parameter_name (keys %$optional_parameter){
115 538 100 100     1247 if (ref $parameter_alias eq 'HASH' and exists $parameter_alias->{ $parameter_name }
      100        
116             and exists $arg_hash{ $parameter_alias->{$parameter_name} }){
117 10         36 $arg_hash{ $parameter_name } = delete $arg_hash{ $parameter_alias->{$parameter_name} };
118             }
119             $clean_arg{ $parameter_name } = exists $arg_hash{$parameter_name}
120             ? delete $arg_hash{ $parameter_name }
121 538 100       1384 : $optional_parameter->{ $parameter_name };
122             }
123 146 100       399 return "Inserted unknown argument(s): ".(join ',', keys %arg_hash)."\n" if %arg_hash;
124 139         362 return \%clean_arg;
125             }
126              
127             ### getter #############################################################
128             my $default_space_name = Graphics::Toolkit::Color::Space::Hub::default_space_name();
129             sub values {
130 70     70 1 24536 my ($self, @args) = @_;
131 70         517 my $arg = _split_named_args( \@args, 'in', [],
132             { in => $default_space_name, as => 'list', raw => 0,
133             precision => undef, range => undef, suffix => undef } );
134 70         229 my $help = 'The method "values" returns numeric color values and accepts six named, optional arguments: '.
135             '"in" (color space name - default arg), "as" (color definition format), "raw", "range", "precision" and "suffix"!';
136 70 50       192 return error($arg.$help.$POD_link) unless ref $arg;
137 70         209 my @result = $self->values_object->formatted( @$arg{qw/in as suffix range precision raw/} );
138 70 50       135 return error(${$result[0]}.$help.$POD_link) if ref $result[0] eq 'SCALAR';
  0         0  
139 70 100       458 return wantarray ? @result : $result[0];
140             }
141              
142             sub name {
143 37     37 1 8126 my ($self, @args) = @_;
144 37 100       128 return $self->values_object->name unless @args;
145 2         19 my $arg = _split_named_args( \@args, 'from', [], {from => 'default', all => 0, full => 0, distance => 0}, {distance => 'd'});
146 2         9 my $help = 'The method "name" returns one, several or no (empty) color name strings and accepts four named, optional arguments: '.
147             '"from" (scheme name - default arg), "all" (color names), "full" (name) and "distance" (or "d")!';
148 2 50       7 return error($arg.$help.$POD_link) unless ref $arg;
149 2         7 Graphics::Toolkit::Color::Name::from_values( $self->values_object->shaped, @$arg{qw/from all full distance/});
150             }
151              
152             sub closest_name {
153 11     11 1 8492 my ($self, @args) = @_;
154 11         73 my $arg = _split_named_args( \@args, 'from', [], {from => 'default', all => 0, full => 0});
155 11         36 my $help = 'The method "closest_name" returns one or several (in an ARRAY) color name strings and in list context also '.
156             'the numeric distance and accepts three named, optional arguments: '.
157             '"from" (scheme name - default arg), "all" (color names) and "full" (name)!';
158 11 50       30 return error($arg.$help.$POD_link) unless ref $arg;
159             my ($name, $distance) = Graphics::Toolkit::Color::Name::closest_from_values(
160 11         31 $self->values_object->shaped, @$arg{qw/from all full/});
161 11 100       59 return wantarray ? ($name, $distance) : $name;
162             }
163              
164             sub distance {
165 10     10 1 1653 my ($self, @args) = @_;
166 10         74 my $arg = _split_named_args( \@args, 'to', ['to'], {in => $default_space_name, only => undef, range => undef}, {only => 'select'});
167 10         37 my $help = 'The method "distance" returns one numeric distance value and accepts four named arguments, the first being default '.
168             'and required: "to" (definition of second color), "in" (color space name), "only" (axis selection) and "range"!';
169 10 100       38 return error($arg.$help.$POD_link) unless ref $arg;
170 7         23 my $target_color = _new_from_scalar_def( $arg->{'to'} );
171 7 50       38 return error("target color definition: $arg->{to} is ill formed".$help.$POD_link) unless ref $target_color;
172 7         26 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
173 7 50       17 return error($color_space.$help.$POD_link) unless ref $color_space;
174 7 100       18 if (defined $arg->{'only'}){
175 3 100       15 if (not ref $arg->{'only'}){
    50          
176             return error($arg->{'only'}." is not an axis name or role in color space: ".$color_space->name.$help.$POD_link)
177 2 50       9 unless $color_space->is_axis_role( $arg->{'only'} );
178             } elsif (ref $arg->{'only'} eq 'ARRAY'){
179 1         2 for my $axis_name (@{$arg->{'only'}}) {
  1         4  
180 2 50       6 return error( $axis_name." is not an axis name or role in color space: ".$color_space->name.$help.$POD_link)
181             unless $color_space->is_axis_role( $axis_name );
182             }
183 0         0 } else { return error('The "only" argument needs one axis name or an ARRAY with several axis names from '.
184             'the same color space!'.$help.$POD_link) }
185             }
186 7         29 my $range_def = $color_space->shape->try_check_range_definition( $arg->{'range'} );
187 7 50       19 return error($range_def.$help.$POD_link) unless ref $range_def;
188             Graphics::Toolkit::Color::Space::Hub::distance(
189 7         20 $self->values_object->normalized, $target_color->values_object->normalized, $color_space->name, $arg->{'only'}, $range_def );
190             }
191              
192             ## single color creation methods #######################################
193             # lightweight designer API
194             my $design_default = 'OKHSL';
195             sub lighten {
196 0     0 1 0 my ($self, @args) = @_;
197 0         0 my $arg = _split_named_args( \@args, 'by', ['by'], {in => $design_default});
198 0 0       0 return "The only argument or named argument 'by' has to be a number between 0 and 1!" unless ref $arg;
199 0         0 _new_from_value_obj( Graphics::Toolkit::Color::Calculator::lighten( $self->values_object, $arg->{'by'}, $arg->{'in'} ) );
200             }
201             sub darken {
202 0     0 1 0 my ($self, @args) = @_;
203 0         0 my $arg = _split_named_args( \@args, 'by', ['by'], {in => $design_default});
204 0 0       0 return "The only argument or named argument 'by' has to be a number between 0 and 1!" unless ref $arg;
205 0         0 _new_from_value_obj( Graphics::Toolkit::Color::Calculator::darken( $self->values_object, $arg->{'by'}, $arg->{'in'} ) );
206             }
207             sub saturate {
208 0     0 1 0 my ($self, @args) = @_;
209 0         0 my $arg = _split_named_args( \@args, 'by', ['by'], {in => $design_default});
210 0 0       0 return "The only argument or named argument 'by' has to be a number between 0 and 1!" unless ref $arg;
211 0         0 _new_from_value_obj( Graphics::Toolkit::Color::Calculator::saturate( $self->values_object, $arg->{'by'}, $arg->{'in'} ) );
212             }
213             sub desaturate {
214 0     0 1 0 my ($self, @args) = @_;
215 0         0 my $arg = _split_named_args( \@args, 'by', ['by'], {in => $design_default});
216 0 0       0 return "The only argument or named argument 'by' has to be a number between 0 and 1!" unless ref $arg;
217 0         0 _new_from_value_obj( Graphics::Toolkit::Color::Calculator::desaturate( $self->values_object, $arg->{'by'}, $arg->{'in'} ) );
218             }
219             sub tint {
220 0     0 1 0 my ($self, @args) = @_;
221 0         0 my $arg = _split_named_args( \@args, 'by', ['by'], {in => $design_default});
222 0 0       0 return "The only argument or named argument 'by' has to be a number between 0 and 1!" unless ref $arg;
223 0         0 _new_from_value_obj( Graphics::Toolkit::Color::Calculator::tint( $self->values_object, $arg->{'by'}, $arg->{'in'} ) );
224             }
225             sub tone {
226 0     0 1 0 my ($self, @args) = @_;
227 0         0 my $arg = _split_named_args( \@args, 'by', ['by'], {in => $design_default});
228 0 0       0 return "The only argument or named argument 'by' has to be a number between 0 and 1!" unless ref $arg;
229 0         0 _new_from_value_obj( Graphics::Toolkit::Color::Calculator::tone( $self->values_object, $arg->{'by'}, $arg->{'in'} ) );
230             }
231             sub shade {
232 0     0 1 0 my ($self, @args) = @_;
233 0         0 my $arg = _split_named_args( \@args, 'by', ['by'], {in => $design_default});
234 0 0       0 return "The only argument or named argument 'by' has to be a number between 0 and 1!" unless ref $arg;
235 0         0 _new_from_value_obj( Graphics::Toolkit::Color::Calculator::shade( $self->values_object, $arg->{'by'}, $arg->{'in'} ) );
236             }
237             sub tone_curve {
238 4     4 1 9 my ($self, @args) = @_;
239 4         30 my $arg = _split_named_args( \@args, undef, ['gamma'], {in => 'LinearRGB'} );
240 4         8 my $help = 'The method "tone_curve" returns a GTC object with gamma corrected values and accepts two named arguments, '.
241             'the first being required: "gamma", "in" (color space name - default LinearRGB)!';
242 4 50       7 return error($arg.$help.$POD_link) unless ref $arg;
243 4         11 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
244 4 50       27 return error($color_space.$help.$POD_link) unless ref $color_space;
245 4         10 my $result = Graphics::Toolkit::Color::Calculator::apply_gamma( $self->values_object, $arg->{'gamma'}, $color_space );
246 4 50       9 return error($result.$help.$POD_link) unless ref $result;
247 4         9 return _new_from_value_obj( $result );
248             }
249 4     4 0 1166 sub apply { tone_curve(@_) }
250              
251             sub set_value {
252 10     10 1 2271 my ($self, @args) = @_;
253 10 50 33     24 @args = %{$args[0]} if @args == 1 and ref $args[0] eq 'HASH';
  0         0  
254 10         13 my $help = 'The method "set_value" returns a GTC object with some values replaced. Arguments are selected axis '.
255             'names of target space and optionally "in" for color space disambiguation!';
256 10 100 66     49 return error($help.$POD_link) if @args % 2 or not @args or @args > 10;
      66        
257 9         19 my $partial_color = { @args };
258 9         14 my $space_name = delete $partial_color->{'in'};
259 9         18 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $space_name );
260 9 50 33     25 return error($color_space.$help.$POD_link) if defined $color_space and not ref $color_space;
261 9         19 my $result = Graphics::Toolkit::Color::Calculator::set_value( $self->values_object, $partial_color, $space_name );
262 9 100       20 return error($result.' '.$help.$POD_link) unless ref $result;
263 7         14 return _new_from_value_obj( $result );
264             }
265             sub add_value {
266 10     10 1 1083 my ($self, @args) = @_;
267 10 50 33     25 @args = %{$args[0]} if @args == 1 and ref $args[0] eq 'HASH';
  0         0  
268 10         14 my $help = 'The method "add_value" returns a GTC object with some values different. Arguments are selected axis '.
269             'names of target space and optionally "in" for color space disambiguation!';
270 10 100 66     49 return error($help.$POD_link) if @args % 2 or not @args or @args > 10;
      66        
271 9         16 my $partial_color = { @args };
272 9         15 my $space_name = delete $partial_color->{'in'};
273 9         19 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $space_name );
274 9 50 33     23 return error($color_space.$help.$POD_link) if defined $color_space and not ref $color_space;
275 9         20 my $result = Graphics::Toolkit::Color::Calculator::add_value( $self->values_object, $partial_color, $space_name );
276 9 100       23 return error($result.' '.$help.$POD_link) unless ref $result;
277 6         14 return _new_from_value_obj( $result );
278             }
279              
280             sub mix {
281 24     24 1 5229 my ($self, @args) = @_;
282 24         157 my $arg = _split_named_args( \@args, 'to', ['to'], {in => 'OKLAB', by => undef}, {by => 'amount'});
283 24         71 my $help = 'The method "mix" returns a GTC object, which is a blend between given colors. Arguments are: '.
284             '"to" (other color[s]-required and default), "by" (mix amounts) and "in"(color space name, default OKLAB)!';
285 24 100       102 return error($arg.' '.$help.$POD_link) unless ref $arg;
286 22         93 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( delete $arg->{'in'} );
287 22 100       50 return error($color_space.' '.$help.$POD_link) unless ref $color_space;
288 21         65 my $second_color = _new_from_scalar_def($arg->{'to'});
289 21 100       49 if (ref $second_color){ $arg->{'to'} = [$second_color->values_object] }
  10         26  
290             else {
291 11 100       31 if (ref $arg->{'to'} ne 'ARRAY'){
292 2         13 return error("Target color definition (argument 'to'): '$arg->{to}' is ill formed. $second_color. ".$POD_link);
293             } else {
294 9         13 my @to = ();
295 9         13 for my $color_def (@{$arg->{'to'}}){
  9         17  
296 15 100       25 if (ref $color_def eq __PACKAGE__) { push @to, $color_def->values_object }
  9         12  
297             else {
298 6         31 $second_color = Graphics::Toolkit::Color::Values->new_from_any_input( $color_def );
299 6 50       14 return error("target color definition (argument 'to'). '$color_def' is ill formed: $second_color. ".$POD_link)
300             unless ref $second_color;
301 6         15 push @to, $second_color;
302             }
303             }
304 9         27 $arg->{'to'} = \@to;
305             }
306             }
307             # backward compatibility: 'by' > 1 is read as percent (0 .. 100) and mapped to 0 .. 1
308 19 100       62 if (defined $arg->{'by'}){
309 9 100 66     33 if (ref $arg->{'by'} eq 'ARRAY') {
    100          
310 5 100 66     5 for (@{$arg->{'by'}}) { $_ /= 100 if is_nr($_) and $_ > 1 }
  5         11  
  8         13  
311 2         8 } elsif (is_nr($arg->{'by'}) and $arg->{'by'} > 1) { $arg->{'by'} /= 100 }
312             }
313 19         47 my $result = Graphics::Toolkit::Color::Calculator::mix( $self->values_object, $arg->{'to'}, $arg->{'by'}, $color_space );
314 19 100       44 return error($result.' '.$help.$POD_link) unless ref $result;
315 17         34 return _new_from_value_obj( $result );
316             }
317              
318             sub invert {
319 16     16 1 1288 my ($self, @args) = @_;
320 16         88 my $arg = _split_named_args( \@args, 'only', [], {in => undef, only => undef});
321 16         77 my $help = 'The method "invert" returns a GTC object with inverted ($max - $_) values. Optional arguments are: '.
322             '"only" (axis selection, default is all) and "in" (color space name)!';
323 16 100 66     115 return error($arg.$help.$POD_link) unless ref $arg and (not ref $arg->{'only'} or ref $arg->{'only'} eq 'ARRAY');
      100        
324 15         70 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
325 15 50 66     72 return error($color_space.$help.$POD_link) if defined $arg->{'in'} and not ref $color_space;
326 15 100       49 $arg->{'in'} = $color_space if defined $arg->{'in'};
327 15         31 my $default_space = Graphics::Toolkit::Color::Space::Hub::get_space( 'OKHSL' );
328 15         44 my $result = Graphics::Toolkit::Color::Calculator::invert( $self->values_object, $arg->{'only'}, $arg->{'in'}, $default_space );
329 15 100       33 return error($result.$help.$POD_link) unless ref $result;
330 14         29 return _new_from_value_obj( $result );
331             }
332              
333             ## color set creation methods ##########################################
334             sub complement {
335 13     13 1 762 my ($self, @args) = @_;
336 13         81 my $arg = _split_named_args( \@args, 'steps', [], {steps => 1, tilt => 0, skew => 0, target => {}, in => $design_default});
337 13         33 my $help = 'The method "complement" returns a list of GTC objects with complementary colors. Optional arguments are: '.
338             '"steps" (color count, default 1 - default argument), "in" (color space name, default "OKHSL", "tilt", "skew" and "target")!';
339 13 100       36 return error($arg.$help.$POD_link) unless ref $arg;
340 12 100       39 return error('Optional argument "steps" has to be a number ! '.$help.$POD_link) unless is_nr($arg->{'steps'});
341 10 50       35 return error('Optional argument "steps" is zero or negative, no complement colors will be computed! '.$help.$POD_link) if $arg->{'steps'} < 1;
342 10 100       19 return error('Optional argument "tilt" has to be a number! '.$help.$POD_link) unless is_nr($arg->{'tilt'});
343 9 100       22 return error('Optional argument "skew" has to be a number! '.$help.$POD_link) unless is_nr($arg->{'skew'});
344 8 100       28 return error('Optional argument "target" has to be a HASH ref! '.$help.$POD_link) if ref $arg->{'target'} ne 'HASH';
345 7         12 my ($target_delta, $space_name);
346 7 100       9 if (keys %{$arg->{'target'}}){
  7         21  
347 2         10 ($target_delta, $space_name) = Graphics::Toolkit::Color::Space::Hub::deformat_search_partial_hash( $arg->{'target'}, 'HSL' );
348 2 100       8 return error('Optional argument "target" got HASH keys that do not fit HSL roles ("h","s","l")! '.$help.$POD_link) unless ref $target_delta;
349 5         7 } else { $target_delta = [] }
350 6         20 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
351 6 50       17 return error($color_space.$help.$POD_link) unless ref $color_space;
352 6 50       18 return error("Need a cylindrical space from the HSL family! ".$help.$POD_link) unless $color_space->family eq 'HSL';
353              
354 6         23 my @result = Graphics::Toolkit::Color::SetCalculator::complement( $self->values_object, $target_delta, @$arg{qw/steps tilt skew/}, $color_space );
355 6 50       17 return error($result[0].$help.$POD_link) unless ref $result[0];
356 6         9 map {_new_from_value_obj( $_ )} @result;
  13         24  
357             }
358              
359             sub analogous {
360 11     11 1 4935 my ($self, @args) = @_;
361 11         67 my $arg = _split_named_args( \@args, 'to', ['to'], {steps => 4, tilt => 0, in => $design_default});
362 11         32 my $help = 'The method "analogous" returns a list of GTC objects with analogous colors. Arguments are: "to" (next color - default arg. and required), '.
363             '"steps" (max. color count, default 4), "in" (color space name, default "OKHSL" and "tilt"!';
364 11 100       41 return error($arg.$help.$POD_link) unless ref $arg;
365 8         34 my $next_color = _new_from_scalar_def( $arg->{'to'} );
366 8 50       12 if (ref $next_color) { $arg->{'to'} = $next_color->values_object }
  8         21  
367 0         0 else { return error('Argument "to" contains malformed color definition! '.$next_color.$POD_link) }
368 8 100       17 return error('Optional argument "steps" has to be a number ! '.$help.$POD_link) unless is_nr($arg->{'steps'});
369 6 50 33     10 return error('Optional argument "steps" has to be a number greater equal two! '.$help.$POD_link) unless is_nr($arg->{'steps'}) and $arg->{'steps'} >= 2;
370 6 100       11 return error('Optional argument "tilt" has to be a number! '.$help.$POD_link) unless is_nr($arg->{'tilt'});
371 4         11 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
372 4 100       9 return error($color_space.$help.$POD_link) unless ref $color_space;
373            
374 3         7 my @result = Graphics::Toolkit::Color::SetCalculator::analogous( $self->values_object, $arg->{'to'}, @$arg{qw/steps tilt/}, $color_space);
375 3 50       9 return error($result[0].$help.$POD_link) unless ref $result[0];
376 3         5 map {_new_from_value_obj( $_ )} @result;
  9         12  
377             }
378              
379             sub gradient {
380 10     10 1 5034 my ($self, @args) = @_;
381 10         85 my $arg = _split_named_args( \@args, 'to', ['to'], {steps => 10, tilt => 0, in => 'OKLAB'});
382 10         31 my $help = 'The method "gradient" returns a list of GTC objects with a gradual transition between colors. Arguments are: '.
383             '"to" (next color - default arg. and required), "steps" (color count, default 10), "in" (color space name, default "OKLAB" and "tilt")!';
384 10 100       36 return error($arg.$help.$POD_link) unless ref $arg;
385 9         36 my @colors = ($self->values_object);
386 9         38 my $target_color = _new_from_scalar_def( $arg->{'to'} );
387 9 100       20 if (ref $target_color) {
388 6         19 push @colors, $target_color->values_object }
389             else {
390 3 100 66     15 return error('Argument "to" contains malformed color definition! '.$help.$POD_link) if ref $arg->{'to'} ne 'ARRAY' or not @{$arg->{'to'}};
  2         8  
391 2         3 for my $color_def (@{$arg->{'to'}}){
  2         5  
392 5         7 my $target_color = _new_from_scalar_def( $color_def );
393 5 100       15 return error('Argument "to" contains malformed color definition: '.$color_def.'! '.$help.$POD_link) unless ref $target_color;
394 4         10 push @colors, $target_color->values_object;
395             }
396             }
397 7 50 33     20 return error('Argument "steps" has to be a number greater equel two! '.$help.$POD_link) unless is_nr($arg->{'steps'}) and $arg->{'steps'} >= 2;
398 7         19 $arg->{'steps'} = int $arg->{'steps'};
399 7 50       14 return error('Argument "tilt" has to be a number! '.$help.$POD_link) unless is_nr($arg->{'tilt'});
400 7         24 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
401 7 50       15 return error($color_space.$help.$POD_link) unless ref $color_space;
402            
403 7         42 my @result = Graphics::Toolkit::Color::SetCalculator::gradient( \@colors, @$arg{qw/steps tilt/}, $color_space);
404 7 50       18 return error($result[0].$help.$POD_link) unless ref $result[0];
405 7         11 map {_new_from_value_obj( $_ )} @result;
  53         60  
406             }
407              
408             sub cluster {
409 20     20 1 9292 my ($self, @args) = @_;
410 20         159 my $arg = _split_named_args( \@args, undef, ['radius', 'minimal_distance'], {in => 'OKLAB'}, {radius => 'r', minimal_distance => 'min_d'});
411 20         67 my $help = 'The method "cluster" returns a list of GTC objects with similar but distinct colors. The arguments are: '.
412             '"radius" (max. distance from center, alias "r", required), "minimal_distance" (between colors, required) and "in" (color space name, default "OKLAB")!';
413 20 100       84 return error($arg.$help.$POD_link) unless ref $arg;
414 14         54 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
415 14 100       41 return error($color_space.$help.$POD_link) unless ref $color_space;
416             return error('Argument "radius" has to be a non-negative number or an ARRAY of numbers that holds for each space axis a radius value. '.$help.$POD_link)
417 13 100 100     46 unless (is_nr($arg->{'radius'}) and $arg->{'radius'} >= 0) or $color_space->is_number_tuple( $arg->{'radius'} );
      100        
418             return error('Argument "minimal_distance" (or "min_d") has to be a number greater zero! '.$help.$POD_link)
419 9 100 100     29 unless is_nr($arg->{'minimal_distance'}) and $arg->{'minimal_distance'} > 0;
420             return error('Ball shaped cluster works only in spaces with three dimensions! '.$help.$POD_link)
421 7 100 100     23 if $color_space->axis_count > 3 and not ref $arg->{'radius'};
422              
423 6         21 my @result = Graphics::Toolkit::Color::SetCalculator::cluster( $self->values_object, @$arg{qw/radius minimal_distance/}, $color_space);
424 6 50       17 return error($result[0].$help.$POD_link) unless ref $result[0];
425 6         19 map {_new_from_value_obj( $_ )} @result;
  55         61  
426             }
427              
428             1;
429              
430             __END__