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.21';
6 5     5   383641 use v5.12;
  5         13  
7 5     5   19 use warnings;
  5         5  
  5         257  
8 5     5   1432 use Graphics::Toolkit::Color::Error qw/error/;
  5         10  
  5         257  
9 5     5   1134 use Graphics::Toolkit::Color::Space::Util qw/is_nr/;
  5         9  
  5         306  
10 5     5   2021 use Graphics::Toolkit::Color::SetCalculator;
  5         17  
  5         202  
11              
12             ## import export, error handling #######################################
13 5     5   32 use Exporter;
  5         7  
  5         23052  
14             our @ISA = qw(Exporter);
15             our @EXPORT_OK = qw/color is_in_gamut/;
16              
17             sub import {
18 10     10   5721 my ($class, @args) = @_;
19 10         18 my @export_symbols;
20 10   100     86 push @export_symbols, shift @args while @args and lc $args[0] ne 'error';
21 10         46 Graphics::Toolkit::Color::Error::change_mode( $args[1] );
22 10         10129 $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 5738 my ($pkg, @args) = @_;
29 75         124 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         105 my ($color_def, $space_name, $range_def, $is_raw);
32 75 100 100     347 if (@args > 0 and not @args % 2){
33 32         81 my %h = @args;
34 32 100       82 return error('got an argument twice') if int(%h) * 2 < int(@args);
35 31   100     161 ($color_def, $space_name, $range_def, $is_raw) = ($h{'color'}, $h{'in'}, $h{'range'}, $h{'raw'} // 0);
36             }
37 74 100       167 $color_def = _color_def_into_scalar( @args ) unless defined $color_def;
38 74 100       112 return error($help) unless defined $color_def;
39 73         140 my $self = _new_from_scalar_def( $color_def, $space_name, $range_def, $is_raw );
40 73 100       393 return (ref $self) ? $self : error($self);
41             }
42             sub color {
43 25     25 0 567436 my $self = _new_from_scalar_def( _color_def_into_scalar( @_ ) );
44 25 100       79 return (ref $self) ? $self : error($self);
45             }
46             sub _color_def_into_scalar {
47 100     100   145 my (@args) = @_;
48 100 50 66     428 return if @args < 1 or @args > 8 or @args == 7;
      66        
49 97 100       262 return $args[0] if @args == 1; # pass names
50 39 100       165 return [@args] if @args <= 5; # lists and named lists --> array and named array
51 17         45 return {@args}; # hashes without curly braces --> hash
52             }
53             sub _new_from_scalar_def {
54 148     148   293 my ($color_def, $space_name, $range_def, $is_raw) = @_;
55 148 100       309 return $color_def if ref $color_def eq __PACKAGE__;
56 137         457 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   366 my ($value_obj) = @_;
60 315 100       470 return $value_obj unless ref $value_obj eq 'Graphics::Toolkit::Color::Values';
61 265         1098 return bless {values => $value_obj};
62             }
63 254 50   254 0 1274 sub values_object { $_[0]->{'values'} if ref $_[0] eq __PACKAGE__}
64              
65             sub is_in_gamut {
66 13     13 1 1053 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     24 $space_name = $named_arg if defined $space_name and $space_name eq 'in' and defined $named_arg;
      66        
71 5         10 my $space = Graphics::Toolkit::Color::Space::Hub::get_space( $space_name );
72 5 50 66     25 return error($help) if defined $space_name and not ref $space;
73 5 100       10 $self->values_object->is_in_gamut( (ref $space) ? $space->name : undef );
74             }
75             sub is_in_gamut_sub {
76 8     8 0 15 my (@color) = @_;
77 8         18 my $values = Graphics::Toolkit::Color::Values->new_from_any_input(
78             _color_def_into_scalar( @_ ), undef, undef, 1
79             );
80 8 100       21 return error($values.$POD_link) unless ref $values;
81 7         23 $values->is_in_gamut( );
82             }
83              
84             ########################################################################
85             sub _split_named_args {
86 191     191   375 my ($raw_args, $only_parameter, $required_parameter, $optional_parameter, $parameter_alias) = @_;
87 191 50 66     588 @$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     449 if (@$raw_args == 1 and defined $only_parameter and $only_parameter){
      66        
91 35 50       58 return "The one default argument can not cover multiple, required parameter !" if @$required_parameter > 1;
92 35 50 66     74 return "The default argument does not cover the required argument!"
93             if @$required_parameter and $required_parameter->[0] ne $only_parameter;
94              
95 35         114 my %defaults = %$optional_parameter;
96 35         64 delete $defaults{$only_parameter};
97 35         150 return {$only_parameter => $raw_args->[0], %defaults};
98             }
99 156         177 my %clean_arg;
100 156 100       298 if (@$raw_args % 2) {
101 2 50 33     9 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         289 my %arg_hash = @$raw_args;
106 154         278 for my $parameter_name (@$required_parameter){
107 83 100 100     319 if (ref $parameter_alias eq 'HASH' and exists $parameter_alias->{ $parameter_name }
      100        
108             and exists $arg_hash{ $parameter_alias->{$parameter_name} }){
109 25         43 $arg_hash{ $parameter_name } = delete $arg_hash{ $parameter_alias->{$parameter_name} };
110             }
111 83 100       169 return "Argument '$parameter_name' is missing!\n" unless exists $arg_hash{$parameter_name};
112 75         182 $clean_arg{ $parameter_name } = delete $arg_hash{ $parameter_name };
113             }
114 146         361 for my $parameter_name (keys %$optional_parameter){
115 538 100 100     874 if (ref $parameter_alias eq 'HASH' and exists $parameter_alias->{ $parameter_name }
      100        
116             and exists $arg_hash{ $parameter_alias->{$parameter_name} }){
117 10         24 $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       1108 : $optional_parameter->{ $parameter_name };
122             }
123 146 100       306 return "Inserted unknown argument(s): ".(join ',', keys %arg_hash)."\n" if %arg_hash;
124 139         283 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 24876 my ($self, @args) = @_;
131 70         501 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         169 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       132 return error($arg.$help.$POD_link) unless ref $arg;
137 70         192 my @result = $self->values_object->formatted( @$arg{qw/in as suffix range precision raw/} );
138 70 50       164 return error(${$result[0]}.$help.$POD_link) if ref $result[0] eq 'SCALAR';
  0         0  
139 70 100       511 return wantarray ? @result : $result[0];
140             }
141              
142             sub name {
143 37     37 1 7087 my ($self, @args) = @_;
144 37 100       108 return $self->values_object->name unless @args;
145 2         13 my $arg = _split_named_args( \@args, 'from', [], {from => 'default', all => 0, full => 0, distance => 0}, {distance => 'd'});
146 2         5 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       5 return error($arg.$help.$POD_link) unless ref $arg;
149 2         5 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 9223 my ($self, @args) = @_;
154 11         54 my $arg = _split_named_args( \@args, 'from', [], {from => 'default', all => 0, full => 0});
155 11         18 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       17 return error($arg.$help.$POD_link) unless ref $arg;
159             my ($name, $distance) = Graphics::Toolkit::Color::Name::closest_from_values(
160 11         22 $self->values_object->shaped, @$arg{qw/from all full/});
161 11 100       63 return wantarray ? ($name, $distance) : $name;
162             }
163              
164             sub distance {
165 10     10 1 1824 my ($self, @args) = @_;
166 10         56 my $arg = _split_named_args( \@args, 'to', ['to'], {in => $default_space_name, only => undef, range => undef}, {only => 'select'});
167 10         26 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       24 return error($arg.$help.$POD_link) unless ref $arg;
170 7         16 my $target_color = _new_from_scalar_def( $arg->{'to'} );
171 7 50       12 return error("target color definition: $arg->{to} is ill formed".$help.$POD_link) unless ref $target_color;
172 7         16 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
173 7 50       11 return error($color_space.$help.$POD_link) unless ref $color_space;
174 7 100       13 if (defined $arg->{'only'}){
175 3 100       9 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       7 unless $color_space->is_axis_role( $arg->{'only'} );
178             } elsif (ref $arg->{'only'} eq 'ARRAY'){
179 1         1 for my $axis_name (@{$arg->{'only'}}) {
  1         3  
180 2 50       4 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         13 my $range_def = $color_space->shape->try_check_range_definition( $arg->{'range'} );
187 7 50       12 return error($range_def.$help.$POD_link) unless ref $range_def;
188             Graphics::Toolkit::Color::Space::Hub::distance(
189 7         14 $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         19 my $arg = _split_named_args( \@args, undef, ['gamma'], {in => 'LinearRGB'} );
240 4         10 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       5 return error($arg.$help.$POD_link) unless ref $arg;
243 4         10 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
244 4 50       8 return error($color_space.$help.$POD_link) unless ref $color_space;
245 4         8 my $result = Graphics::Toolkit::Color::Calculator::apply_gamma( $self->values_object, $arg->{'gamma'}, $color_space );
246 4 50       8 return error($result.$help.$POD_link) unless ref $result;
247 4         7 return _new_from_value_obj( $result );
248             }
249 4     4 0 1109 sub apply { tone_curve(@_) }
250              
251             sub set_value {
252 10     10 1 4004 my ($self, @args) = @_;
253 10 50 33     41 @args = %{$args[0]} if @args == 1 and ref $args[0] eq 'HASH';
  0         0  
254 10         17 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     53 return error($help.$POD_link) if @args % 2 or not @args or @args > 10;
      66        
257 9         25 my $partial_color = { @args };
258 9         12 my $space_name = delete $partial_color->{'in'};
259 9         21 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $space_name );
260 9 50 33     37 return error($color_space.$help.$POD_link) if defined $color_space and not ref $color_space;
261 9         20 my $result = Graphics::Toolkit::Color::Calculator::set_value( $self->values_object, $partial_color, $space_name );
262 9 100       23 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 2319 my ($self, @args) = @_;
267 10 50 33     27 @args = %{$args[0]} if @args == 1 and ref $args[0] eq 'HASH';
  0         0  
268 10         16 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     50 return error($help.$POD_link) if @args % 2 or not @args or @args > 10;
      66        
271 9         24 my $partial_color = { @args };
272 9         16 my $space_name = delete $partial_color->{'in'};
273 9         20 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $space_name );
274 9 50 33     25 return error($color_space.$help.$POD_link) if defined $color_space and not ref $color_space;
275 9         16 my $result = Graphics::Toolkit::Color::Calculator::add_value( $self->values_object, $partial_color, $space_name );
276 9 100       25 return error($result.' '.$help.$POD_link) unless ref $result;
277 6         13 return _new_from_value_obj( $result );
278             }
279              
280             sub mix {
281 24     24 1 5387 my ($self, @args) = @_;
282 24         117 my $arg = _split_named_args( \@args, 'to', ['to'], {in => 'OKLAB', by => undef}, {by => 'amount'});
283 24         49 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       43 return error($arg.' '.$help.$POD_link) unless ref $arg;
286 22         182 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( delete $arg->{'in'} );
287 22 100       43 return error($color_space.' '.$help.$POD_link) unless ref $color_space;
288 21         42 my $second_color = _new_from_scalar_def($arg->{'to'});
289 21 100       30 if (ref $second_color){ $arg->{'to'} = [$second_color->values_object] }
  10         18  
290             else {
291 11 100       24 if (ref $arg->{'to'} ne 'ARRAY'){
292 2         21 return error("Target color definition (argument 'to'): '$arg->{to}' is ill formed. $second_color. ".$POD_link);
293             } else {
294 9         14 my @to = ();
295 9         10 for my $color_def (@{$arg->{'to'}}){
  9         18  
296 15 100       26 if (ref $color_def eq __PACKAGE__) { push @to, $color_def->values_object }
  9         13  
297             else {
298 6         18 $second_color = Graphics::Toolkit::Color::Values->new_from_any_input( $color_def );
299 6 50       13 return error("target color definition (argument 'to'). '$color_def' is ill formed: $second_color. ".$POD_link)
300             unless ref $second_color;
301 6         13 push @to, $second_color;
302             }
303             }
304 9         19 $arg->{'to'} = \@to;
305             }
306             }
307             # backward compatibility: 'by' > 1 is read as percent (0 .. 100) and mapped to 0 .. 1
308 19 100       54 if (defined $arg->{'by'}){
309 9 100 66     23 if (ref $arg->{'by'} eq 'ARRAY') {
    100          
310 5 100 66     5 for (@{$arg->{'by'}}) { $_ /= 100 if is_nr($_) and $_ > 1 }
  5         9  
  8         14  
311 2         5 } elsif (is_nr($arg->{'by'}) and $arg->{'by'} > 1) { $arg->{'by'} /= 100 }
312             }
313 19         34 my $result = Graphics::Toolkit::Color::Calculator::mix( $self->values_object, $arg->{'to'}, $arg->{'by'}, $color_space );
314 19 100       41 return error($result.' '.$help.$POD_link) unless ref $result;
315 17         27 return _new_from_value_obj( $result );
316             }
317              
318             sub invert {
319 16     16 1 1069 my ($self, @args) = @_;
320 16         65 my $arg = _split_named_args( \@args, 'only', [], {in => undef, only => undef});
321 16         33 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     63 return error($arg.$help.$POD_link) unless ref $arg and (not ref $arg->{'only'} or ref $arg->{'only'} eq 'ARRAY');
      100        
324 15         32 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
325 15 50 66     46 return error($color_space.$help.$POD_link) if defined $arg->{'in'} and not ref $color_space;
326 15 100       29 $arg->{'in'} = $color_space if defined $arg->{'in'};
327 15         18 my $default_space = Graphics::Toolkit::Color::Space::Hub::get_space( 'OKHSL' );
328 15         27 my $result = Graphics::Toolkit::Color::Calculator::invert( $self->values_object, $arg->{'only'}, $arg->{'in'}, $default_space );
329 15 100       28 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 639 my ($self, @args) = @_;
336 13         68 my $arg = _split_named_args( \@args, 'steps', [], {steps => 1, tilt => 0, skew => 0, target => {}, in => $design_default});
337 13         27 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       28 return error($arg.$help.$POD_link) unless ref $arg;
340 12 100       35 return error('Optional argument "steps" has to be a number ! '.$help.$POD_link) unless is_nr($arg->{'steps'});
341 10 50       29 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       20 return error('Optional argument "tilt" has to be a number! '.$help.$POD_link) unless is_nr($arg->{'tilt'});
343 9 100       13 return error('Optional argument "skew" has to be a number! '.$help.$POD_link) unless is_nr($arg->{'skew'});
344 8 100       25 return error('Optional argument "target" has to be a HASH ref! '.$help.$POD_link) if ref $arg->{'target'} ne 'HASH';
345 7         10 my ($target_delta, $space_name);
346 7 100       5 if (keys %{$arg->{'target'}}){
  7         15  
347 2         11 ($target_delta, $space_name) = Graphics::Toolkit::Color::Space::Hub::deformat_search_partial_hash( $arg->{'target'}, 'HSL' );
348 2 100       7 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         6 } else { $target_delta = [] }
350 6         15 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
351 6 50       11 return error($color_space.$help.$POD_link) unless ref $color_space;
352 6 50       15 return error("Need a cylindrical space from the HSL family! ".$help.$POD_link) unless $color_space->family eq 'HSL';
353              
354 6         15 my @result = Graphics::Toolkit::Color::SetCalculator::complement( $self->values_object, $target_delta, @$arg{qw/steps tilt skew/}, $color_space );
355 6 50       11 return error($result[0].$help.$POD_link) unless ref $result[0];
356 6         9 map {_new_from_value_obj( $_ )} @result;
  13         20  
357             }
358              
359             sub analogous {
360 11     11 1 4331 my ($self, @args) = @_;
361 11         54 my $arg = _split_named_args( \@args, 'to', ['to'], {steps => 4, tilt => 0, in => $design_default});
362 11         29 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       33 return error($arg.$help.$POD_link) unless ref $arg;
365 8         60 my $next_color = _new_from_scalar_def( $arg->{'to'} );
366 8 50       16 if (ref $next_color) { $arg->{'to'} = $next_color->values_object }
  8         14  
367 0         0 else { return error('Argument "to" contains malformed color definition! '.$next_color.$POD_link) }
368 8 100       14 return error('Optional argument "steps" has to be a number ! '.$help.$POD_link) unless is_nr($arg->{'steps'});
369 6 50 33     15 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       10 return error('Optional argument "tilt" has to be a number! '.$help.$POD_link) unless is_nr($arg->{'tilt'});
371 4         10 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
372 4 100       13 return error($color_space.$help.$POD_link) unless ref $color_space;
373            
374 3         6 my @result = Graphics::Toolkit::Color::SetCalculator::analogous( $self->values_object, $arg->{'to'}, @$arg{qw/steps tilt/}, $color_space);
375 3 50       7 return error($result[0].$help.$POD_link) unless ref $result[0];
376 3         5 map {_new_from_value_obj( $_ )} @result;
  9         13  
377             }
378              
379             sub gradient {
380 10     10 1 4256 my ($self, @args) = @_;
381 10         73 my $arg = _split_named_args( \@args, 'to', ['to'], {steps => 10, tilt => 0, in => 'OKLAB'});
382 10         22 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       26 return error($arg.$help.$POD_link) unless ref $arg;
385 9         23 my @colors = ($self->values_object);
386 9         30 my $target_color = _new_from_scalar_def( $arg->{'to'} );
387 9 100       15 if (ref $target_color) {
388 6         12 push @colors, $target_color->values_object }
389             else {
390 3 100 66     17 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       17 return error('Argument "to" contains malformed color definition: '.$color_def.'! '.$help.$POD_link) unless ref $target_color;
394 4         9 push @colors, $target_color->values_object;
395             }
396             }
397 7 50 33     19 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         13 $arg->{'steps'} = int $arg->{'steps'};
399 7 50       13 return error('Argument "tilt" has to be a number! '.$help.$POD_link) unless is_nr($arg->{'tilt'});
400 7         20 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
401 7 50       14 return error($color_space.$help.$POD_link) unless ref $color_space;
402            
403 7         32 my @result = Graphics::Toolkit::Color::SetCalculator::gradient( \@colors, @$arg{qw/steps tilt/}, $color_space);
404 7 50       16 return error($result[0].$help.$POD_link) unless ref $result[0];
405 7         13 map {_new_from_value_obj( $_ )} @result;
  53         61  
406             }
407              
408             sub cluster {
409 20     20 1 7554 my ($self, @args) = @_;
410 20         95 my $arg = _split_named_args( \@args, undef, ['radius', 'minimal_distance'], {in => 'OKLAB'}, {radius => 'r', minimal_distance => 'min_d'});
411 20         43 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       44 return error($arg.$help.$POD_link) unless ref $arg;
414 14         39 my $color_space = Graphics::Toolkit::Color::Space::Hub::try_get_space( $arg->{'in'} );
415 14 100       26 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     27 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     19 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     17 if $color_space->axis_count > 3 and not ref $arg->{'radius'};
422              
423 6         13 my @result = Graphics::Toolkit::Color::SetCalculator::cluster( $self->values_object, @$arg{qw/radius minimal_distance/}, $color_space);
424 6 50       14 return error($result[0].$help.$POD_link) unless ref $result[0];
425 6         8 map {_new_from_value_obj( $_ )} @result;
  55         54  
426             }
427              
428             1;
429              
430             __END__