line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
|
|
|
|
|
|
# read only color holding object with methods for relation, mixing and transitions |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
package Graphics::Toolkit::Color; |
5
|
|
|
|
|
|
|
our $VERSION = '1.70'; |
6
|
4
|
|
|
4
|
|
281972
|
use v5.12; |
|
4
|
|
|
|
|
62
|
|
7
|
|
|
|
|
|
|
|
8
|
4
|
|
|
4
|
|
20
|
use Carp; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
217
|
|
9
|
4
|
|
|
4
|
|
1638
|
use Graphics::Toolkit::Color::Name; |
|
4
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
207
|
|
10
|
4
|
|
|
4
|
|
39
|
use Graphics::Toolkit::Color::Values; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
93
|
|
11
|
|
|
|
|
|
|
|
12
|
4
|
|
|
4
|
|
19
|
use Exporter 'import'; |
|
4
|
|
|
|
|
5
|
|
|
4
|
|
|
|
|
11464
|
|
13
|
|
|
|
|
|
|
our @EXPORT_OK = qw/color/; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
my $new_help = 'constructor of Graphics::Toolkit::Color object needs either:'. |
16
|
|
|
|
|
|
|
' 1. hash or ref (RGB, HSL or any other): ->new(r => 255, g => 0, b => 0), ->new({ h => 0, s => 100, l => 50 })'. |
17
|
|
|
|
|
|
|
' 2. RGB array or ref: ->new( [255, 0, 0 ]) or >new( 255, 0, 0 )'. |
18
|
|
|
|
|
|
|
' 3. hex form "#FF0000" or "#f00" 4. a name: "red" or "SVG:red".'; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
## constructor ######################################################### |
21
|
|
|
|
|
|
|
|
22
|
10
|
|
|
10
|
1
|
701
|
sub color { Graphics::Toolkit::Color->new ( @_ ) } |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub new { |
25
|
48
|
|
|
48
|
1
|
15420
|
my ($pkg, @args) = @_; |
26
|
48
|
100
|
66
|
|
|
241
|
@args = ([@args]) if @args == 3 or Graphics::Toolkit::Color::Space::Hub::is_space( $args[0]); |
27
|
48
|
100
|
66
|
|
|
201
|
@args = ({ @args }) if @args == 6 or @args == 8; |
28
|
48
|
100
|
|
|
|
163
|
return carp $new_help unless @args == 1; |
29
|
43
|
|
|
|
|
105
|
_new_from_scalar($args[0]); |
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
sub _new_from_scalar { |
32
|
167
|
|
|
167
|
|
250
|
my ($color_def) = shift; |
33
|
167
|
|
|
|
|
250
|
my ($value_obj, @rgb, $name, $origin); |
34
|
|
|
|
|
|
|
# strings that are not '#112233' or 'rgb: 23,34,56' |
35
|
167
|
100
|
100
|
|
|
805
|
if (not ref $color_def and substr($color_def, 0, 1) =~ /\w/ and $color_def !~ /,/){ |
|
|
100
|
66
|
|
|
|
|
36
|
15
|
|
|
|
|
23
|
$name = $color_def; |
37
|
15
|
|
|
|
|
21
|
$origin = 'name'; |
38
|
15
|
|
|
|
|
32
|
my $i = index( $color_def, ':'); |
39
|
15
|
100
|
|
|
|
39
|
if ($i > -1 ){ # resolve pallet:name |
40
|
1
|
|
|
|
|
4
|
my $pallet_name = substr $color_def, 0, $i; |
41
|
1
|
|
|
|
|
5
|
my $color_name = Graphics::Toolkit::Color::Name::_clean(substr $color_def, $i+1); |
42
|
1
|
|
|
|
|
3
|
my $module_base = 'Graphics::ColorNames'; |
43
|
1
|
|
|
1
|
|
241
|
eval "use $module_base"; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
86
|
|
44
|
1
|
50
|
|
|
|
28
|
return carp "$module_base is not installed, but it's needed to load external colors" if $@; |
45
|
0
|
|
|
|
|
0
|
my $module = $module_base.'::'.$pallet_name; |
46
|
0
|
|
|
|
|
0
|
eval "use $module"; |
47
|
0
|
0
|
|
|
|
0
|
return carp "$module is not installed, but needed to load color '$pallet_name:$color_name'" if $@; |
48
|
|
|
|
|
|
|
|
49
|
0
|
|
|
|
|
0
|
my $pallet = Graphics::ColorNames->new( $pallet_name ); |
50
|
0
|
|
|
|
|
0
|
@rgb = $pallet->rgb( $color_name ); |
51
|
0
|
0
|
|
|
|
0
|
return carp "color '$color_name' was not found, propably not part of $module" unless @rgb == 3; |
52
|
|
|
|
|
|
|
} else { # resolve name -> |
53
|
14
|
|
|
|
|
67
|
@rgb = Graphics::Toolkit::Color::Name::rgb_from_name( $color_def ); |
54
|
14
|
100
|
|
|
|
48
|
return carp "'$color_def' is an unknown color name, please check Graphics::Toolkit::Color::Name::all()." unless @rgb == 3; |
55
|
|
|
|
|
|
|
} |
56
|
13
|
|
|
|
|
46
|
$value_obj = Graphics::Toolkit::Color::Values->new( [@rgb] ); |
57
|
|
|
|
|
|
|
} elsif (ref $color_def eq __PACKAGE__) { # enables color objects to be passed as arguments |
58
|
37
|
|
|
|
|
66
|
$name = $color_def->name; |
59
|
37
|
|
|
|
|
126
|
$value_obj = Graphics::Toolkit::Color::Values->new( $color_def->{'values'}->string ); |
60
|
|
|
|
|
|
|
} else { # define color by numbers in any format |
61
|
115
|
|
|
|
|
343
|
my $value_obj = Graphics::Toolkit::Color::Values->new( $color_def ); |
62
|
115
|
100
|
|
|
|
4386
|
return unless ref $value_obj; |
63
|
105
|
|
|
|
|
214
|
return _new_from_value_obj($value_obj); |
64
|
|
|
|
|
|
|
} |
65
|
50
|
|
|
|
|
184
|
bless {name => $name, values => $value_obj}; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
sub _new_from_value_obj { |
68
|
128
|
|
|
128
|
|
1390
|
my ($value_obj) = @_; |
69
|
128
|
100
|
|
|
|
277
|
return unless ref $value_obj eq 'Graphics::Toolkit::Color::Values'; |
70
|
125
|
|
|
|
|
275
|
bless {name => scalar Graphics::Toolkit::Color::Name::name_from_rgb( $value_obj->get() ), values => $value_obj}; |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
## getter ############################################################## |
74
|
|
|
|
|
|
|
|
75
|
81
|
|
|
81
|
1
|
3491
|
sub name { $_[0]{'name'} } |
76
|
|
|
|
|
|
|
|
77
|
3
|
100
|
|
3
|
1
|
22
|
sub string { $_[0]{'name'} || $_[0]->{'values'}->string } |
78
|
24
|
|
|
24
|
1
|
61
|
sub rgb { $_[0]->values( ) } |
79
|
10
|
|
|
10
|
0
|
5442
|
sub red {($_[0]->values( in => 'rgb'))[0] } |
80
|
10
|
|
|
10
|
0
|
33
|
sub green {($_[0]->values( in => 'rgb'))[1] } |
81
|
10
|
|
|
10
|
0
|
36
|
sub blue {($_[0]->values( in => 'rgb'))[2] } |
82
|
8
|
|
|
8
|
1
|
31
|
sub rgb_hex { $_[0]->values( in => 'rgb', as => 'hex') } |
83
|
4
|
|
|
4
|
1
|
12
|
sub rgb_hash { $_[0]->values( in => 'rgb', as => 'hash') } |
84
|
24
|
|
|
24
|
1
|
68
|
sub hsl { $_[0]->values( in => 'hsl') } |
85
|
9
|
|
|
9
|
1
|
30
|
sub hue {($_[0]->values( in => 'hsl'))[0] } |
86
|
9
|
|
|
9
|
1
|
35
|
sub saturation {($_[0]->values( in => 'hsl'))[1] } |
87
|
9
|
|
|
9
|
1
|
32
|
sub lightness {($_[0]->values( in => 'hsl'))[2] } |
88
|
4
|
|
|
4
|
1
|
12
|
sub hsl_hash { $_[0]->values( in => 'hsl', as => 'hash') } |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub values { |
91
|
166
|
|
|
166
|
1
|
2861
|
my ($self) = shift; |
92
|
166
|
50
|
|
|
|
554
|
my %args = (not @_ % 2) ? @_ : |
|
|
100
|
|
|
|
|
|
93
|
|
|
|
|
|
|
(@_ == 1) ? (in => $_[0]) |
94
|
|
|
|
|
|
|
: return carp "accept three optional, named arguments: in => 'HSL', as => 'css_string', range => 16"; |
95
|
166
|
|
|
|
|
650
|
$self->{'values'}->get( $args{'in'}, $args{'as'}, $args{'range'} ); |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
## measurement methods ############################################################## |
99
|
|
|
|
|
|
|
|
100
|
0
|
|
|
0
|
0
|
0
|
sub distance_to { distance(@_) } |
101
|
|
|
|
|
|
|
sub distance { |
102
|
70
|
|
|
70
|
1
|
216
|
my ($self) = shift; |
103
|
70
|
50
|
|
|
|
334
|
my %args = (not @_ % 2) ? @_ : |
|
|
100
|
|
|
|
|
|
104
|
|
|
|
|
|
|
(@_ == 1) ? (to => $_[0]) |
105
|
|
|
|
|
|
|
: return carp "accept four optional, named arguments: to => 'color or color definition', in => 'RGB', metric => 'r', range => 16"; |
106
|
70
|
|
|
|
|
168
|
my ($c2, $space_name, $select, $range) = ($args{'to'}, $args{'in'}, $args{'select'}, $args{'range'}); |
107
|
70
|
50
|
|
|
|
143
|
return carp "missing argument: color object or scalar color definition" unless defined $c2; |
108
|
70
|
|
|
|
|
131
|
$c2 = _new_from_scalar( $c2 ); |
109
|
70
|
50
|
|
|
|
175
|
return carp "second color for distance calculation (named argument 'to') is badly defined" unless ref $c2 eq __PACKAGE__; |
110
|
70
|
|
|
|
|
192
|
$self->{'values'}->distance( $c2->{'values'}, $space_name, $select, $range ); |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
## single color creation methods ####################################### |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub _get_arg_hash { |
116
|
32
|
100
|
|
32
|
|
140
|
my $arg = (ref $_[0] eq 'HASH') ? $_[0] |
|
|
100
|
|
|
|
|
|
117
|
|
|
|
|
|
|
: (not @_ % 2) ? {@_} |
118
|
|
|
|
|
|
|
: {} ; |
119
|
32
|
100
|
|
|
|
119
|
return (keys %$arg) ? $arg : carp "need arguments as hash (with or without braces)"; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub set { |
123
|
8
|
|
|
8
|
1
|
1247
|
my ($self, @args) = @_; |
124
|
8
|
|
|
|
|
14
|
my $arg = _get_arg_hash( @args ); |
125
|
8
|
100
|
|
|
|
1022
|
return unless ref $arg; |
126
|
6
|
|
|
|
|
21
|
_new_from_value_obj( $self->{'values'}->set( $arg ) ); |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub add { |
130
|
6
|
|
|
6
|
1
|
152
|
my ($self, @args) = @_; |
131
|
6
|
|
|
|
|
12
|
my $arg = _get_arg_hash( @args ); |
132
|
6
|
100
|
|
|
|
496
|
return unless ref $arg; |
133
|
5
|
|
|
|
|
15
|
_new_from_value_obj( $self->{'values'}->add( $arg ) ); |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
0
|
|
|
0
|
0
|
0
|
sub blend_with { $_[0]->blend( with => $_[1], pos => $_[2], in => 'HSL') } |
137
|
|
|
|
|
|
|
sub blend { |
138
|
12
|
|
|
12
|
1
|
1391
|
my ($self, @args) = @_; |
139
|
12
|
|
|
|
|
22
|
my $arg = _get_arg_hash( @args ); |
140
|
12
|
50
|
|
|
|
79
|
return unless ref $arg; |
141
|
12
|
|
|
|
|
72
|
my $c2 = _new_from_scalar( $arg->{'with'} ); |
142
|
12
|
50
|
|
|
|
26
|
return croak "need a second color under the key 'with' ( with => { h=>1, s=>2, l=>3 })" unless ref $c2; |
143
|
12
|
|
66
|
|
|
41
|
my $pos = $arg->{'pos'} // $arg->{'position'} // 0.5; |
|
|
|
50
|
|
|
|
|
144
|
12
|
|
100
|
|
|
40
|
my $space_name = $arg->{'in'} // 'HSL'; |
145
|
12
|
50
|
|
|
|
26
|
return carp "color space $space_name is unknown" unless Graphics::Toolkit::Color::Space::Hub::is_space( $space_name ); |
146
|
12
|
|
|
|
|
36
|
_new_from_value_obj( $self->{'values'}->blend( $c2->{'values'}, $pos, $space_name ) ); |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
## color set creation methods ########################################## |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
# for compatibility |
153
|
4
|
|
|
4
|
0
|
14
|
sub gradient_to { hsl_gradient_to( @_ ) } |
154
|
0
|
|
|
0
|
0
|
0
|
sub rgb_gradient_to { $_[0]->gradient( to => $_[1], steps => $_[2], dynamic => $_[3], in => 'RGB' ) } |
155
|
4
|
|
|
4
|
0
|
15
|
sub hsl_gradient_to { $_[0]->gradient( to => $_[1], steps => $_[2], dynamic => $_[3], in => 'HSL' ) } |
156
|
|
|
|
|
|
|
sub gradient { # $to ~in + steps +dynamic +variance --> @_ |
157
|
6
|
|
|
6
|
1
|
31
|
my ($self, @args) = @_; |
158
|
6
|
|
|
|
|
15
|
my $arg = _get_arg_hash( @args ); |
159
|
6
|
50
|
|
|
|
19
|
return unless ref $arg eq 'HASH'; |
160
|
6
|
|
|
|
|
13
|
my $c2 = _new_from_scalar( $arg->{'to'} ); |
161
|
6
|
50
|
|
|
|
25
|
return croak "need a second color under the key 'to' : ( to => ['HSL', 10, 20, 30])" unless ref $c2; |
162
|
6
|
|
100
|
|
|
26
|
my $space_name = $arg->{'in'} // 'HSL'; |
163
|
6
|
|
50
|
|
|
15
|
my $steps = int(abs($arg->{'steps'} // 3)); |
164
|
6
|
|
100
|
|
|
15
|
my $power = $arg->{'dynamic'} // 0; |
165
|
6
|
100
|
|
|
|
15
|
$power = ($power >= 0) ? $power + 1 : -(1/($power-1)); |
166
|
6
|
100
|
|
|
|
26
|
return $self if $steps == 1; |
167
|
5
|
|
|
|
|
13
|
my $space = Graphics::Toolkit::Color::Space::Hub::get_space( $space_name ); |
168
|
5
|
50
|
|
|
|
11
|
return carp "color space $space_name is unknown" unless ref $space; |
169
|
5
|
|
|
|
|
17
|
my @val1 = $self->{'values'}->get( $space_name, 'list', 'normal' ); |
170
|
5
|
|
|
|
|
15
|
my @val2 = $c2->{'values'}->get( $space_name, 'list', 'normal' ); |
171
|
5
|
|
|
|
|
14
|
my @delta_val = $space->delta (\@val1, \@val2 ); |
172
|
5
|
|
|
|
|
10
|
my @colors = (); |
173
|
5
|
|
|
|
|
12
|
for my $nr (1 .. $steps-2){ |
174
|
7
|
|
|
|
|
27
|
my $pos = ($nr / ($steps-1)) ** $power; |
175
|
7
|
|
|
|
|
20
|
my @rval = map {$val1[$_] + ($pos * $delta_val[$_])} 0 .. $space->dimensions - 1; |
|
21
|
|
|
|
|
41
|
|
176
|
7
|
|
|
|
|
18
|
@rval = $space->denormalize ( \@rval ); |
177
|
7
|
|
|
|
|
19
|
push @colors, _new_from_scalar( [ $space_name, @rval ] ); |
178
|
|
|
|
|
|
|
} |
179
|
5
|
|
|
|
|
49
|
return $self, @colors, $c2; |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
my $comp_help = 'set constructor "complement" accepts 4 named args: "steps" (positive int), '. |
184
|
|
|
|
|
|
|
'"hue_tilt" or "h" (-180 .. 180), '. |
185
|
|
|
|
|
|
|
'"saturation_tilt or "s" (-100..100) or { s => (-100..100), h => (-180..180)} and '. |
186
|
|
|
|
|
|
|
'"lightness_tilt or "l" (-100..100) or { l => (-100..100), h => (-180..180)}'; |
187
|
3
|
|
|
3
|
0
|
603
|
sub complementary { complement(@_) } |
188
|
|
|
|
|
|
|
sub complement { # +steps +hue_tilt +saturation_tilt +lightness_tilt --> @_ |
189
|
8
|
|
|
8
|
1
|
18
|
my ($self) = shift; |
190
|
8
|
0
|
|
|
|
75
|
my %arg = (not @_ % 2) ? @_ : |
|
|
50
|
|
|
|
|
|
191
|
|
|
|
|
|
|
(@_ == 1) ? (steps => $_[0]) : return carp $comp_help; |
192
|
8
|
|
100
|
|
|
36
|
my $steps = int abs($arg{'steps'} // 1); |
193
|
|
|
|
|
|
|
my $hue_tilt = (exists $arg{'h'}) ? (delete $arg{'h'}) : |
194
|
8
|
100
|
|
|
|
26
|
(exists $arg{'hue_tilt'}) ? (delete $arg{'hue_tilt'}) : 0; |
|
|
50
|
|
|
|
|
|
195
|
8
|
50
|
|
|
|
18
|
return carp $comp_help if ref $hue_tilt; |
196
|
|
|
|
|
|
|
my $saturation_tilt = (exists $arg{'s'}) ? (delete $arg{'s'}) : |
197
|
8
|
100
|
|
|
|
24
|
(exists $arg{'saturation_tilt'}) ? (delete $arg{'saturation_tilt'}) : 0; |
|
|
100
|
|
|
|
|
|
198
|
8
|
50
|
66
|
|
|
25
|
return carp $comp_help if ref $saturation_tilt and ref $saturation_tilt ne 'HASH'; |
199
|
8
|
|
|
|
|
9
|
my $saturation_axis_offset = 0; |
200
|
8
|
100
|
|
|
|
19
|
if (ref $saturation_tilt eq 'HASH'){ |
201
|
1
|
|
|
|
|
5
|
my ($pos_hash, $space_name) = Graphics::Toolkit::Color::Space::Hub::partial_hash_deformat( $saturation_tilt ); |
202
|
1
|
50
|
33
|
|
|
12
|
return carp $comp_help if not defined $space_name or $space_name ne 'HSL' or not exists $pos_hash->{1}; |
|
|
|
33
|
|
|
|
|
203
|
1
|
50
|
|
|
|
24
|
$saturation_axis_offset = $pos_hash->{0} if exists $pos_hash->{0}; |
204
|
1
|
|
|
|
|
5
|
$saturation_tilt = $pos_hash->{1}; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
my $lightness_tilt = (exists $arg{'l'}) ? (delete $arg{'l'}) : |
207
|
8
|
100
|
|
|
|
21
|
(exists $arg{'lightness_tilt'}) ? (delete $arg{'lightness_tilt'}) : 0; |
|
|
100
|
|
|
|
|
|
208
|
8
|
50
|
66
|
|
|
21
|
return carp $comp_help if ref $lightness_tilt and ref $lightness_tilt ne 'HASH'; |
209
|
8
|
|
|
|
|
14
|
my $lightness_axis_offset = 0; |
210
|
8
|
100
|
|
|
|
14
|
if (ref $lightness_tilt eq 'HASH'){ |
211
|
1
|
|
|
|
|
5
|
my ($pos_hash, $space_name) = Graphics::Toolkit::Color::Space::Hub::partial_hash_deformat( $lightness_tilt ); |
212
|
1
|
50
|
33
|
|
|
10
|
return carp $comp_help if not defined $space_name or $space_name ne 'HSL' or not exists $pos_hash->{2}; |
|
|
|
33
|
|
|
|
|
213
|
1
|
50
|
|
|
|
13
|
$lightness_axis_offset = $pos_hash->{0} if exists $pos_hash->{0}; |
214
|
1
|
|
|
|
|
4
|
$lightness_tilt = $pos_hash->{2}; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
8
|
|
|
|
|
23
|
my @hsl2 = my @hsl = $self->values('HSL'); |
218
|
8
|
|
|
|
|
36
|
my @hue_turn_point = ($hsl[0] + 90, $hsl[0] + 270, 800); # Dmax, Dmin and Pseudo-Inf |
219
|
8
|
|
|
|
|
17
|
my @sat_turn_point = ($hsl[0] + 90, $hsl[0] + 270, 800); |
220
|
8
|
|
|
|
|
15
|
my @light_turn_point = ($hsl[0] + 90, $hsl[0] + 270, 800); |
221
|
8
|
|
|
|
|
16
|
my $sat_max_hue = $hsl[0] + 90 + $saturation_axis_offset; |
222
|
8
|
|
|
|
|
15
|
my $sat_step = $saturation_tilt * 4 / $steps; |
223
|
8
|
|
|
|
|
14
|
my $light_max_hue = $hsl[0] + 90 + $lightness_axis_offset; |
224
|
8
|
|
|
|
|
14
|
my $light_step = $lightness_tilt * 4 / $steps; |
225
|
8
|
100
|
|
|
|
19
|
if ($saturation_axis_offset){ |
226
|
1
|
|
|
|
|
6
|
$sat_max_hue -= 360 while $sat_max_hue > $hsl[0]; # putting dmax in range |
227
|
1
|
|
|
|
|
6
|
$sat_max_hue += 360 while $sat_max_hue <= $hsl[0]; # above c1->hue |
228
|
1
|
|
|
|
|
4
|
my $dmin_first = $sat_max_hue > $hsl[0] + 180; |
229
|
1
|
50
|
|
|
|
5
|
@sat_turn_point = $dmin_first ? ($sat_max_hue - 180, $sat_max_hue, 800) |
230
|
|
|
|
|
|
|
: ($sat_max_hue, $sat_max_hue + 180, 800); |
231
|
1
|
50
|
|
|
|
3
|
$sat_step = - $sat_step if $dmin_first; |
232
|
1
|
50
|
|
|
|
19
|
my $sat_start_delta = $dmin_first ? ((($sat_max_hue - 180 - $hsl[0]) / 90 * $saturation_tilt) - $saturation_tilt) |
233
|
|
|
|
|
|
|
: (-(($sat_max_hue - $hsl[0]) / 90 * $saturation_tilt) + $saturation_tilt); |
234
|
1
|
|
|
|
|
2
|
$hsl[1] += $sat_start_delta; |
235
|
1
|
|
|
|
|
3
|
$hsl2[1] -= $sat_start_delta; |
236
|
|
|
|
|
|
|
} |
237
|
8
|
100
|
|
|
|
15
|
if ($lightness_axis_offset){ |
238
|
1
|
|
|
|
|
5
|
$light_max_hue -= 360 while $light_max_hue > $hsl[0]; |
239
|
1
|
|
|
|
|
5
|
$light_max_hue += 360 while $light_max_hue <= $hsl[0]; |
240
|
1
|
|
|
|
|
3
|
my $dmin_first = $light_max_hue > $hsl[0] + 180; |
241
|
1
|
50
|
|
|
|
5
|
@light_turn_point = $dmin_first ? ($light_max_hue - 180, $light_max_hue, 800) |
242
|
|
|
|
|
|
|
: ($light_max_hue, $light_max_hue + 180, 800); |
243
|
1
|
50
|
|
|
|
3
|
$light_step = - $light_step if $dmin_first; |
244
|
1
|
50
|
|
|
|
6
|
my $light_start_delta = $dmin_first ? ((($light_max_hue - 180 - $hsl[0]) / 90 * $lightness_tilt) - $lightness_tilt) |
245
|
|
|
|
|
|
|
: (-(($light_max_hue - $hsl[0]) / 90 * $lightness_tilt) + $lightness_tilt); |
246
|
1
|
|
|
|
|
2
|
$hsl[2] += $light_start_delta; |
247
|
1
|
|
|
|
|
2
|
$hsl2[2] -= $light_start_delta; |
248
|
|
|
|
|
|
|
} |
249
|
8
|
|
|
|
|
28
|
my $c1 = _new_from_scalar( [ 'HSL', @hsl ] ); |
250
|
8
|
|
|
|
|
21
|
$hsl2[0] += 180 + $hue_tilt; |
251
|
8
|
|
|
|
|
48
|
my $c2 = _new_from_scalar( [ 'HSL', @hsl2 ] ); # main complementary color |
252
|
8
|
100
|
|
|
|
45
|
return $c2 if $steps < 2; |
253
|
4
|
50
|
|
|
|
11
|
return $c1, $c2 if $steps == 2; |
254
|
|
|
|
|
|
|
|
255
|
4
|
|
|
|
|
9
|
my (@result) = $c1; |
256
|
4
|
|
|
|
|
8
|
my $hue_avg_step = 360 / $steps; |
257
|
4
|
|
|
|
|
17
|
my $hue_c2_distance = $self->distance( to => $c2, in => 'HSL', select => 'hue'); |
258
|
4
|
|
|
|
|
9
|
my $hue_avg_tight_step = $hue_c2_distance * 2 / $steps; |
259
|
4
|
|
|
|
|
7
|
my $hue_sec_deg_delta = 8 * ($hue_avg_step - $hue_avg_tight_step) / $steps; # second degree delta |
260
|
4
|
50
|
|
|
|
9
|
$hue_sec_deg_delta = -$hue_sec_deg_delta if $hue_tilt < 0; # if c2 on right side |
261
|
4
|
|
|
|
|
19
|
my $hue_last_step = my $hue_ak_step = $hue_avg_step; # bar height of pseudo integral |
262
|
4
|
|
|
|
|
6
|
my $hue_current = my $hue_current_naive = $hsl[0]; |
263
|
4
|
|
|
|
|
15
|
my $saturation_current = $hsl[1]; |
264
|
4
|
|
|
|
|
7
|
my $lightness_current = $hsl[2]; |
265
|
4
|
|
|
|
|
8
|
my $hi = my $si = my $li = 0; # index of next turn point where hue step increase gets flipped (at Dmax and Dmin) |
266
|
4
|
|
|
|
|
12
|
for my $i (1 .. $steps - 1){ |
267
|
13
|
|
|
|
|
23
|
$hue_current_naive += $hue_avg_step; |
268
|
|
|
|
|
|
|
|
269
|
13
|
100
|
|
|
|
35
|
if ($hue_current_naive >= $hue_turn_point[$hi]){ |
270
|
6
|
|
|
|
|
13
|
my $bar_width = ($hue_turn_point[$hi] - $hue_current_naive + $hue_avg_step) / $hue_avg_step; |
271
|
6
|
|
|
|
|
11
|
$hue_ak_step += $hue_sec_deg_delta * $bar_width; |
272
|
6
|
|
|
|
|
11
|
$hue_current += ($hue_ak_step + $hue_last_step) / 2 * $bar_width; |
273
|
6
|
|
|
|
|
8
|
$hue_last_step = $hue_ak_step; |
274
|
6
|
|
|
|
|
11
|
$bar_width = 1 - $bar_width; |
275
|
6
|
|
|
|
|
8
|
$hue_sec_deg_delta = -$hue_sec_deg_delta; |
276
|
6
|
|
|
|
|
10
|
$hue_ak_step += $hue_sec_deg_delta * $bar_width; |
277
|
6
|
|
|
|
|
8
|
$hue_current += ($hue_ak_step + $hue_last_step) / 2 * $bar_width; |
278
|
6
|
|
|
|
|
8
|
$hi++; |
279
|
|
|
|
|
|
|
} else { |
280
|
7
|
|
|
|
|
13
|
$hue_ak_step += $hue_sec_deg_delta; |
281
|
7
|
|
|
|
|
14
|
$hue_current += ($hue_ak_step + $hue_last_step) / 2; |
282
|
|
|
|
|
|
|
} |
283
|
13
|
|
|
|
|
16
|
$hue_last_step = $hue_ak_step; |
284
|
|
|
|
|
|
|
|
285
|
13
|
100
|
|
|
|
26
|
if ($hue_current_naive >= $sat_turn_point[$si]){ |
286
|
6
|
|
|
|
|
13
|
my $bar_width = ($sat_turn_point[$si] - $hue_current_naive + $hue_avg_step) / $hue_avg_step; |
287
|
6
|
|
|
|
|
10
|
$saturation_current += $sat_step * ((2 * $bar_width) - 1); |
288
|
6
|
|
|
|
|
9
|
$sat_step = -$sat_step; |
289
|
6
|
|
|
|
|
7
|
$si++; |
290
|
|
|
|
|
|
|
} else { |
291
|
7
|
|
|
|
|
31
|
$saturation_current += $sat_step; |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
|
294
|
13
|
100
|
|
|
|
24
|
if ($hue_current_naive >= $light_turn_point[$li]){ |
295
|
5
|
|
|
|
|
9
|
my $bar_width = ($light_turn_point[$li] - $hue_current_naive + $hue_avg_step) / $hue_avg_step; |
296
|
5
|
|
|
|
|
8
|
$lightness_current += $light_step * ((2 * $bar_width) - 1); |
297
|
5
|
|
|
|
|
16
|
$light_step = -$light_step; |
298
|
5
|
|
|
|
|
6
|
$li++; |
299
|
|
|
|
|
|
|
} else { |
300
|
8
|
|
|
|
|
24
|
$lightness_current += $light_step; |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
13
|
|
|
|
|
37
|
$result[$i] = _new_from_scalar( [ HSL => $hue_current, $saturation_current, $lightness_current ] ); |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
4
|
|
|
|
|
55
|
return @result; |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
sub bowl {# +radius +distance|count +variance ~in @range |
310
|
0
|
|
|
0
|
0
|
|
my ($self, @args) = @_; |
311
|
0
|
|
|
|
|
|
my $arg = _get_arg_hash( @args ); |
312
|
0
|
0
|
|
|
|
|
return unless ref $arg eq 'HASH'; |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
1; |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
__END__ |