line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package ICC::Support::Color; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
105233
|
use strict; |
|
2
|
|
|
|
|
15
|
|
|
2
|
|
|
|
|
57
|
|
4
|
2
|
|
|
2
|
|
10
|
use Carp; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
150
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
our $VERSION = 0.22; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
# revised 2019-02-05 |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
# Copyright © 2004-2020 by William B. Birkett |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# inherit from Shared |
13
|
2
|
|
|
2
|
|
522
|
use parent qw(ICC::Shared); |
|
2
|
|
|
|
|
349
|
|
|
2
|
|
|
|
|
12
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# support modules |
16
|
2
|
|
|
2
|
|
250
|
use File::Glob; |
|
2
|
|
|
|
|
10
|
|
|
2
|
|
|
|
|
191
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# enable static variables |
19
|
2
|
|
|
2
|
|
18
|
use feature 'state'; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
20869
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# spectral range hash |
22
|
|
|
|
|
|
|
our $srh = {'31' => [400, 700, 10], '36' => [380, 730, 10], '38' => [360, 730, 10], '43' => [360, 780, 10], '81' => [380, 780, 5]}; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# create new Color object |
25
|
|
|
|
|
|
|
# hash keys are: 'illuminant', 'observer', 'increment', 'method', 'imethod', 'bandpass', 'ibandpass', 'status', 'range' |
26
|
|
|
|
|
|
|
# the method used is determined by the hash keys. |
27
|
|
|
|
|
|
|
# for ASTM method, |
28
|
|
|
|
|
|
|
# 'illuminant' value is a scalar, 'A', 'C', 'D50', 'D55', 'D65', 'D75', 'F2', 'F7', or 'F11', default is 'D50' |
29
|
|
|
|
|
|
|
# 'observer' value is a scalar, '2' or '10', default is '2' |
30
|
|
|
|
|
|
|
# 'increment' value is a scalar, '10' or '20', default is '10' |
31
|
|
|
|
|
|
|
# 'bandpass' value is a scalar, 'astm', 'triangle', 'trapezoid' or 'six', default is no bandpass correction |
32
|
|
|
|
|
|
|
# for CIE method, |
33
|
|
|
|
|
|
|
# 'illuminant' value is an array reference, [], ['source', 'id'] or ['nm', 'spd'] |
34
|
|
|
|
|
|
|
# an empty array indicates no illuminant, for emissive measurements |
35
|
|
|
|
|
|
|
# 'source' values are 'CIE', 'Philips', or a measurement file path |
36
|
|
|
|
|
|
|
# 'id' values depend on the 'source' |
37
|
|
|
|
|
|
|
# 'CIE' illuminants are 'A', 'C', 'D50', 'D55', 'D65', 'D75', 'ID50', 'ID65', 'FL1' to 'FL12', 'FL3.1' to 'FL3.15', 'HP1' to 'HP5', 'LED-B1' to 'LED-B5', 'LED-BH1', 'LED-RGB1', 'LED-V1', 'LED-V2', and 'E' (5 nm increment) |
38
|
|
|
|
|
|
|
# 'CIE_HR' illuminants are 'FL1' to 'FL12', 'FL3.1' to 'FL3.15', 'LED-B1' to 'LED-B5', 'LED-BH1', 'LED-RGB1', 'LED-V1', 'LED-V2', and 'E' (1 nm increment) |
39
|
|
|
|
|
|
|
# 'Philips' illuminants are '60_A/W', 'C100S54', 'C100S54C', 'F32T8/TL830', 'F32T8/TL835', 'F32T8/TL841', 'F32T8/TL850', 'F32T8/TL865/PLUS', 'F34/CW/RS/EW', 'F34T12WW/RS/EW', 'F40/C50', 'F40/C75', 'F40/CWX', 'F40/DX', 'F40/DXTP', 'F40/N', 'F34T12/LW/RS/EW', 'H38HT-100', 'H38JA-100/DX', 'MHC100/U/MP/3K', 'MHC100/U/MP/4K', and 'SDW-T_100W/LV' |
40
|
|
|
|
|
|
|
# for a measurement file path, the 'id' is the sample number |
41
|
|
|
|
|
|
|
# 'nm' and 'spd' are vectors, wavelength range and spectral power distribution |
42
|
|
|
|
|
|
|
# 'observer' value is a scalar, '2', '10', '2P' or '10P', default '2' |
43
|
|
|
|
|
|
|
# 'increment' value is a scalar, '1' or '5', default '1' |
44
|
|
|
|
|
|
|
# 'method' value is a scalar, 'linear', 'cspline' or 'lagrange', default is 'cspline' |
45
|
|
|
|
|
|
|
# 'bandpass' value is a scalar, 'astm', 'triangle' or 'trapezoid', default is no bandpass correction |
46
|
|
|
|
|
|
|
# 'imethod' value is a scalar, 'linear', 'cspline' or 'lagrange', default is 'linear' or 'cspline', based on smoothness of the illuminant SPD |
47
|
|
|
|
|
|
|
# 'ibandpass' value is a scalar, 'astm', 'triangle' or 'trapezoid', default is no bandpass correction |
48
|
|
|
|
|
|
|
# for ISO 5-3 method (density), |
49
|
|
|
|
|
|
|
# 'status' value is a scalar, 'A', 'M', 'T', 'E', or 'I', default 'T' |
50
|
|
|
|
|
|
|
# 'increment' value is a scalar, '10' or '20', default '10' |
51
|
|
|
|
|
|
|
# 'range' value is: [start_nm, end_nm, increment], which is added to the spectral range hash ($srh) |
52
|
|
|
|
|
|
|
# parameters: ([ref_to_attribute_hash]) |
53
|
|
|
|
|
|
|
# returns: (object_reference) |
54
|
|
|
|
|
|
|
sub new { |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
# get object class |
57
|
1
|
|
|
1
|
1
|
863
|
my $class = shift(); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# create empty Color object |
60
|
1
|
|
|
|
|
4
|
my $self = [ |
61
|
|
|
|
|
|
|
{}, # object header |
62
|
|
|
|
|
|
|
[], # illuminant (CIE) |
63
|
|
|
|
|
|
|
[], # color-matching functions (CIE) |
64
|
|
|
|
|
|
|
[], # color-weight functions (ASTM and ISO 5-3) |
65
|
|
|
|
|
|
|
[], # color-weight functions (adjusted to input range and cached) |
66
|
|
|
|
|
|
|
[] # white-point |
67
|
|
|
|
|
|
|
]; |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
# if one parameter, a hash reference |
70
|
1
|
50
|
33
|
|
|
8
|
if (@_ == 1 && ref($_[0]) eq 'HASH') { |
|
|
50
|
|
|
|
|
|
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# set object contents from hash |
73
|
0
|
|
|
|
|
0
|
_new_from_hash($self, $_[0]); |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
} elsif (@_) { |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
# error |
78
|
0
|
|
|
|
|
0
|
croak('invalid parameter(s)'); |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
# return blessed object |
83
|
1
|
|
|
|
|
4
|
return(bless($self, $class)); |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# get/set reference to header hash |
88
|
|
|
|
|
|
|
# header contains keys used by 'new' |
89
|
|
|
|
|
|
|
# parameters: ([ref_to_new_hash]) |
90
|
|
|
|
|
|
|
# returns: (ref_to_hash) |
91
|
|
|
|
|
|
|
sub header { |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# get object reference |
94
|
0
|
|
|
0
|
1
|
|
my $self = shift(); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# if there are parameters |
97
|
0
|
0
|
|
|
|
|
if (@_) { |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
# if one parameter, a hash reference |
100
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'HASH') { |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# set header to copy of hash |
103
|
0
|
|
|
|
|
|
$self->[0] = Storable::dclone(shift()); |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
} else { |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
# error |
108
|
0
|
|
|
|
|
|
croak('parameter must be a hash reference'); |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
# return reference |
115
|
0
|
|
|
|
|
|
return($self->[0]); |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
# get/set reference to illuminant structure |
120
|
|
|
|
|
|
|
# structure: [[start_nm, end_nm, increment], spd_vector] |
121
|
|
|
|
|
|
|
# note: set updates the color-weight functions |
122
|
|
|
|
|
|
|
# parameters: ([ref_to_new_structure]) |
123
|
|
|
|
|
|
|
# returns: (ref_to_structure) |
124
|
|
|
|
|
|
|
sub illuminant { |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# get object reference |
127
|
0
|
|
|
0
|
1
|
|
my $self = shift(); |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# local variables |
130
|
0
|
|
|
|
|
|
my ($array, $sx); |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
# if there are parameters |
133
|
0
|
0
|
|
|
|
|
if (@_) { |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# if one parameter, an array reference |
136
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'ARRAY') { |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
# get array reference |
139
|
0
|
|
|
|
|
|
$array = shift(); |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
# initialize data array |
142
|
0
|
|
|
|
|
|
$self->[1] = []; |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
# if array is not empty |
145
|
0
|
0
|
|
|
|
|
if (@{$array}) { |
|
0
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# verify array size |
148
|
0
|
0
|
|
|
|
|
(@{$array} == 2) or croak('invalid illuminant array'); |
|
0
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# verify wavelength range |
151
|
0
|
0
|
0
|
|
|
|
(ref($array->[0]) eq 'ARRAY' && 3 == @{$array->[0]} && (3 == grep {Scalar::Util::looks_like_number($_)} @{$array->[0]}) && $array->[0][2]) or croak('invalid illuminant wavelength range'); |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
# compute upper index of spd array |
154
|
0
|
0
|
|
|
|
|
(($sx = ICC::Shared::round(($array->[0][1] - $array->[0][0])/$array->[0][2])) > 0) or croak('inconsistent illuminant wavelength range'); |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
# verify spd array |
157
|
0
|
0
|
0
|
|
|
|
(ref($array->[1]) eq 'ARRAY' && $#{$array->[1]} == $sx && @{$array->[1]} == grep {Scalar::Util::looks_like_number($_)} @{$array->[1]}) or croak('invalid illuminant spd array'); |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
# copy array contents |
160
|
0
|
|
|
|
|
|
$self->[1] = Storable::dclone($array); |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# if observer array defined |
163
|
0
|
0
|
|
|
|
|
if (defined($self->[2][0])) { |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# update color-weight functions |
166
|
0
|
|
|
|
|
|
_make_cwf($self); |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
} else { |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# error |
175
|
0
|
|
|
|
|
|
croak('parameter must be an array reference'); |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
# return reference |
182
|
0
|
|
|
|
|
|
return($self->[1]); |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# get/set reference to observer structure |
187
|
|
|
|
|
|
|
# structure: [[start_nm, end_nm, increment], cmf_matrix] |
188
|
|
|
|
|
|
|
# note: set updates the color-weight functions |
189
|
|
|
|
|
|
|
# parameters: ([ref_to_new_structure]) |
190
|
|
|
|
|
|
|
# returns: (ref_to_structure) |
191
|
|
|
|
|
|
|
sub observer { |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
# get object reference |
194
|
0
|
|
|
0
|
1
|
|
my $self = shift(); |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# local variables |
197
|
0
|
|
|
|
|
|
my ($array, $sx); |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
# if there are parameters |
200
|
0
|
0
|
|
|
|
|
if (@_) { |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# if one parameter, an array reference |
203
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'ARRAY') { |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# get array reference |
206
|
0
|
|
|
|
|
|
$array = shift(); |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# initialize data array |
209
|
0
|
|
|
|
|
|
$self->[2] = []; |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
# if array is not empty |
212
|
0
|
0
|
|
|
|
|
if (@{$array}) { |
|
0
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# verify array size |
215
|
0
|
0
|
|
|
|
|
(@{$array} == 2) or croak('invalid observer array'); |
|
0
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
# verify wavelength range |
218
|
0
|
0
|
0
|
|
|
|
(ref($array->[0]) eq 'ARRAY' && 3 == @{$array->[0]} && (3 == grep {Scalar::Util::looks_like_number($_)} @{$array->[0]}) && $array->[0][2]) or croak('invalid observer wavelength range'); |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
# compute upper index of observer matrix |
221
|
0
|
0
|
|
|
|
|
(($sx = ICC::Shared::round(($array->[0][1] - $array->[0][0])/$array->[0][2])) > 0) or croak('inconsistent observer wavelength range'); |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
# verify observer matrix |
224
|
0
|
0
|
0
|
|
|
|
((ref($array->[1]) eq 'ARRAY' || UNIVERSAL::isa($array->[1], 'Math::Matrix')) && ref($array->[1][0]) eq 'ARRAY' && $#{$array->[1][0]} == $sx && @{$array->[1][0]} == grep {Scalar::Util::looks_like_number($_)} @{$array->[1][0]}) or croak('invalid observer cmf matrix'); |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
# copy array contents |
227
|
0
|
|
|
|
|
|
$self->[2] = Storable::dclone($array); |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
# if illuminant array defined |
230
|
0
|
0
|
|
|
|
|
if (defined($self->[1][0])) { |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# update color-weight functions |
233
|
0
|
|
|
|
|
|
_make_cwf($self); |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
} else { |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
# error |
242
|
0
|
|
|
|
|
|
croak('parameter must be an array reference'); |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
# return reference |
249
|
0
|
|
|
|
|
|
return($self->[2]); |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
# get/set reference to color-weight function structure |
254
|
|
|
|
|
|
|
# structure: [[start_nm, end_nm, increment], cwf_matrix] |
255
|
|
|
|
|
|
|
# parameters: ([ref_to_new_structure]) |
256
|
|
|
|
|
|
|
# returns: (ref_to_structure) |
257
|
|
|
|
|
|
|
sub cwf { |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
# get object reference |
260
|
0
|
|
|
0
|
1
|
|
my $self = shift(); |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
# local variables |
263
|
0
|
|
|
|
|
|
my ($array, $sx); |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# if there are parameters |
266
|
0
|
0
|
|
|
|
|
if (@_) { |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# if one parameter, an array reference |
269
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'ARRAY') { |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# get array reference |
272
|
0
|
|
|
|
|
|
$array = shift(); |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
# initialize data array |
275
|
0
|
|
|
|
|
|
$self->[3] = []; |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
# if array is not empty |
278
|
0
|
0
|
|
|
|
|
if (@{$array}) { |
|
0
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
# verify array size |
281
|
0
|
0
|
|
|
|
|
(@{$array} == 2) or croak('invalid cwf array'); |
|
0
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
# verify wavelength range |
284
|
0
|
0
|
0
|
|
|
|
(ref($array->[0]) eq 'ARRAY' && 3 == @{$array->[0]} && (3 == grep {Scalar::Util::looks_like_number($_)} @{$array->[0]}) && $array->[0][2]) or croak('invalid cwf wavelength range'); |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
# compute upper index of cwf matrix |
287
|
0
|
0
|
|
|
|
|
(($sx = ICC::Shared::round(($array->[0][1] - $array->[0][0])/$array->[0][2])) > 0) or croak('inconsistent cwf wavelength range'); |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# verify cwf matrix |
290
|
0
|
0
|
0
|
|
|
|
((ref($array->[1]) eq 'ARRAY' || UNIVERSAL::isa($array->[1], 'Math::Matrix')) && ref($array->[1][0]) eq 'ARRAY' && $#{$array->[1][0]} == $sx && @{$array->[1][0]} == grep {Scalar::Util::looks_like_number($_)} @{$array->[1][0]}) or croak('invalid cwf weight matrix'); |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
# copy array contents |
293
|
0
|
|
|
|
|
|
$self->[3] = Storable::dclone($array); |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
# for each weight function (XYZ -or- RGBV) |
296
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$array->[1]}) { |
|
0
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
# update white point array |
299
|
0
|
|
|
|
|
|
$self->[5][$i] = List::Util::sum(@{$array->[1][$i]}); |
|
0
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
} else { |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
# error |
308
|
0
|
|
|
|
|
|
croak('parameter must be an array reference'); |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
# return reference |
315
|
0
|
|
|
|
|
|
return($self->[3]); |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
# get illuminant white point |
320
|
|
|
|
|
|
|
# encoding specified by 'encoding' hash key |
321
|
|
|
|
|
|
|
# 'encoding' values are 'XYZ', 'xyz', 'ICC_XYZ', 'ICC_XYZNumber', and 'density' |
322
|
|
|
|
|
|
|
# parameters: ([hash]) |
323
|
|
|
|
|
|
|
# returns: (XYZ_vector) |
324
|
|
|
|
|
|
|
sub iwtpt { |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
# get parameters |
327
|
0
|
|
|
0
|
1
|
|
my ($self, $hash) = @_; |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
# local variable |
330
|
0
|
|
|
|
|
|
my ($code); |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
# return white point with optional encoding |
333
|
0
|
0
|
|
|
|
|
return(defined($code = _encoding($self, $hash)) ? [&$code(@{$self->[5]})] : $self->[5]); |
|
0
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
# transform data |
338
|
|
|
|
|
|
|
# hash keys are: 'range', and 'encoding' |
339
|
|
|
|
|
|
|
# 'range' value is: [start_nm, end_nm, increment] |
340
|
|
|
|
|
|
|
# 'encoding' values are 'XYZ', 'xyz', 'ICC_XYZ', 'ICC_XYZNumber', 'RGBV', 'rgbv' and 'density' |
341
|
|
|
|
|
|
|
# supported input types: |
342
|
|
|
|
|
|
|
# parameters: (list, [hash]) |
343
|
|
|
|
|
|
|
# parameters: (vector, [hash]) |
344
|
|
|
|
|
|
|
# parameters: (matrix, [hash]) |
345
|
|
|
|
|
|
|
# parameters: (Math::Matrix_object, [hash]) |
346
|
|
|
|
|
|
|
# parameters: (structure, [hash]) |
347
|
|
|
|
|
|
|
# returns: (same_type_as_input) |
348
|
|
|
|
|
|
|
sub transform { |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# set hash value (0 or 1) |
351
|
0
|
0
|
|
0
|
1
|
|
my $h = ref($_[-1]) eq 'HASH' ? 1 : 0; |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
# verify color weight array |
354
|
0
|
0
|
0
|
|
|
|
(defined($_[0]->[3][0]) && defined($_[0]->[3][1])) or croak('color weight array undefined'); |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# if input a 'Math::Matrix' object |
357
|
0
|
0
|
0
|
|
|
|
if (@_ == $h + 2 && UNIVERSAL::isa($_[1], 'Math::Matrix')) { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
# call matrix transform |
360
|
0
|
|
|
|
|
|
&_trans2; |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
# if input an array reference |
363
|
|
|
|
|
|
|
} elsif (@_ == $h + 2 && ref($_[1]) eq 'ARRAY') { |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
# if array contains numbers (vector) |
366
|
0
|
0
|
0
|
|
|
|
if (! ref($_[1][0]) && @{$_[1]} == grep {Scalar::Util::looks_like_number($_)} @{$_[1]}) { |
|
0
|
0
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
# call vector transform |
369
|
0
|
|
|
|
|
|
&_trans1; |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# if array contains vectors (2-D array) |
372
|
0
|
0
|
|
|
|
|
} elsif (ref($_[1][0]) eq 'ARRAY' && @{$_[1]} == grep {ref($_) eq 'ARRAY' && Scalar::Util::looks_like_number($_->[0])} @{$_[1]}) { |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
# call matrix transform |
375
|
0
|
|
|
|
|
|
&_trans2; |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
} else { |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# call structure transform |
380
|
0
|
|
|
|
|
|
&_trans3; |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
# if input a list (of numbers) |
385
|
0
|
|
|
|
|
|
} elsif (@_ == $h + 1 + grep {Scalar::Util::looks_like_number($_)} @_) { |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
# call list transform |
388
|
0
|
|
|
|
|
|
&_trans0; |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
} else { |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
# error |
393
|
0
|
|
|
|
|
|
croak('invalid transform input'); |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
# compute Jacobian matrix |
400
|
|
|
|
|
|
|
# hash keys are: 'range', and 'encoding' |
401
|
|
|
|
|
|
|
# 'range' value is: [start_nm, end_nm, increment] |
402
|
|
|
|
|
|
|
# 'encoding' values are 'XYZ', 'xyz', 'ICC_XYZ', 'ICC_XYZNumber', 'RGBV', 'rgbv' and 'density' |
403
|
|
|
|
|
|
|
# parameters: (input_vector, [hash]) |
404
|
|
|
|
|
|
|
# returns: (Jacobian_matrix, [output_vector]) |
405
|
|
|
|
|
|
|
sub jacobian { |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
# get parameters |
408
|
0
|
|
|
0
|
1
|
|
my ($self, $in, $hash) = @_; |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
# local variables |
411
|
0
|
|
|
|
|
|
my ($range, $encoding, $jac, $out, $sf); |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
414
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
# get input spectral range |
417
|
0
|
0
|
0
|
|
|
|
($range = $hash->{'range'} || $srh->{@{$in}}) or croak('spectral range must be specified'); |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
# if data increment == cwf increment |
420
|
0
|
0
|
|
|
|
|
if ($range->[2] == $self->[3][0][2]) { |
|
|
0
|
|
|
|
|
|
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
# use adjusted cwf |
423
|
0
|
|
|
|
|
|
$jac = Storable::dclone(_adjust_cwf($self, $range)); |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
# if data increment > cwf increment |
426
|
|
|
|
|
|
|
} elsif ($range->[2] > $self->[3][0][2]) { |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
# use reduced cwf |
429
|
0
|
|
|
|
|
|
$jac = Storable::dclone(_reduce_cwf($self, $range)); |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
} else { |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
# error |
434
|
0
|
|
|
|
|
|
croak('data increment < cwf increment'); |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
# if hash contain 'encoding' other than 'XYZ' or 'RGBV' |
439
|
0
|
0
|
0
|
|
|
|
if (defined($encoding = $hash->{'encoding'}) && $encoding ne 'XYZ' && $encoding ne 'RGBV') { |
|
|
|
0
|
|
|
|
|
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
# if encoding is 'ICC_XYZ' |
442
|
0
|
0
|
0
|
|
|
|
if ($encoding eq 'ICC_XYZ' && @{$jac} == 3) { |
|
0
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
# for each XYZ |
445
|
0
|
|
|
|
|
|
for my $i (0 .. 2) { |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
# for each spectral value |
448
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$jac->[0]}) { |
|
0
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
# adjust value |
451
|
0
|
|
|
|
|
|
$jac->[$i][$j] *= 327.68/65535; |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
# if encoding is 'ICC_XYZNumber' |
458
|
0
|
|
|
|
|
|
} elsif ($encoding eq 'ICC_XYZNumber' && @{$jac} == 3) { |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
# for each XYZ |
461
|
0
|
|
|
|
|
|
for my $i (0 .. 2) { |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
# for each spectral value |
464
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$jac->[0]}) { |
|
0
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
# adjust value |
467
|
0
|
|
|
|
|
|
$jac->[$i][$j] /= 100; |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
# if encoding is 'xyz' |
474
|
0
|
|
|
|
|
|
} elsif ($encoding eq 'xyz' && @{$jac} == 3) { |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
# verify white point |
477
|
0
|
0
|
0
|
|
|
|
($self->[5][0] && $self->[5][1] && $self->[5][2]) or croak('invalid illuminant white point'); |
|
|
|
0
|
|
|
|
|
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
# for each XYZ |
480
|
0
|
|
|
|
|
|
for my $i (0 .. 2) { |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
# for each spectral value |
483
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$jac->[0]}) { |
|
0
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
# adjust value |
486
|
0
|
|
|
|
|
|
$jac->[$i][$j] /= $self->[5][$i]; |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# if encoding is 'unit' |
493
|
0
|
|
|
|
|
|
} elsif ($encoding eq 'unit' && @{$jac} == 4) { |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
# for each RGBV |
496
|
0
|
|
|
|
|
|
for my $i (0 .. 3) { |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
# for each spectral value |
499
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$jac->[0]}) { |
|
0
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
# adjust value |
502
|
0
|
|
|
|
|
|
$jac->[$i][$j] /= 100; |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
# if encoding is 'density' |
509
|
0
|
|
|
|
|
|
} elsif ($encoding eq 'density' && @{$jac} == 4) { |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
# delete encoding |
512
|
0
|
|
|
|
|
|
delete($hash->{'encoding'}); |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
# get the output values (RGBV) |
515
|
0
|
|
|
|
|
|
$out = _trans1($self, $in, $hash); |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
# verify output |
518
|
0
|
0
|
0
|
|
|
|
($out->[0] && $out->[1] && $out->[2] && $out->[3]) or croak('invalid density value'); |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
# for each RGBV |
521
|
0
|
|
|
|
|
|
for my $i (0 .. 3) { |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
# compute scale factor |
524
|
0
|
|
|
|
|
|
$sf = - $out->[$i] * ICC::Shared::ln10; |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
# for each spectral value |
527
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$jac->[0]}) { |
|
0
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
# adjust value |
530
|
0
|
|
|
|
|
|
$jac->[$i][$j] /= $sf; |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
# restore encoding |
537
|
0
|
|
|
|
|
|
$hash->{'encoding'} = 'density'; |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
} else { |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
# error |
542
|
0
|
|
|
|
|
|
croak('unsupported XYZ/RGBV encoding'); |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
} |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
# if output vector wanted |
548
|
0
|
0
|
|
|
|
|
if (wantarray) { |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
# return Jacobian and output vector |
551
|
0
|
|
|
|
|
|
return($jac, _trans1($self, $in, $hash)); |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
} else { |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
# return Jacobian only |
556
|
0
|
|
|
|
|
|
return($jac); |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
# print object contents to string !!! needs work !!! |
563
|
|
|
|
|
|
|
# format is an array structure |
564
|
|
|
|
|
|
|
# parameter: ([format]) |
565
|
|
|
|
|
|
|
# returns: (string) |
566
|
|
|
|
|
|
|
sub sdump { |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
# get parameters |
569
|
0
|
|
|
0
|
1
|
|
my ($self, $p) = @_; |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
# local variables |
572
|
0
|
|
|
|
|
|
my ($s, $fmt); |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
# resolve parameter to an array reference |
575
|
0
|
0
|
|
|
|
|
$p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : []; |
|
|
0
|
|
|
|
|
|
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
# get format string |
578
|
0
|
0
|
0
|
|
|
|
$fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 'undef'; |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
# set string to object ID |
581
|
0
|
|
|
|
|
|
$s = sprintf("'%s' object, (0x%x)\n", ref($self), $self); |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
# return |
584
|
0
|
|
|
|
|
|
return($s); |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
# transform list |
589
|
|
|
|
|
|
|
# parameters: (object_reference, list, [hash]) |
590
|
|
|
|
|
|
|
# returns: (list) |
591
|
|
|
|
|
|
|
sub _trans0 { |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
# local variables |
594
|
0
|
|
|
0
|
|
|
my ($self, $hash); |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
# get object reference |
597
|
0
|
|
|
|
|
|
$self = shift(); |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
# get optional hash |
600
|
0
|
0
|
|
|
|
|
$hash = pop() if (ref($_[-1]) eq 'HASH'); |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
# return |
603
|
0
|
|
|
|
|
|
return(@{_trans1($self, \@_, $hash)}); |
|
0
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
} |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
# transform vector |
608
|
|
|
|
|
|
|
# parameters: (object_reference, vector, [hash]) |
609
|
|
|
|
|
|
|
# returns: (vector) |
610
|
|
|
|
|
|
|
sub _trans1 { |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
# get parameters |
613
|
0
|
|
|
0
|
|
|
my ($self, $in, $hash) = @_; |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
# local variables |
616
|
0
|
|
|
|
|
|
my ($range, $cwf, $out, $code); |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
619
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
# get input spectral range |
622
|
0
|
0
|
0
|
|
|
|
($range = $hash->{'range'} || $srh->{@{$in}}) or croak('spectral range must be specified'); |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
# if data increment == cwf increment |
625
|
0
|
0
|
|
|
|
|
if ($range->[2] == $self->[3][0][2]) { |
|
|
0
|
|
|
|
|
|
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
# adjust cwf to match data range |
628
|
0
|
|
|
|
|
|
$cwf = _adjust_cwf($self, $range); |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
# if data increment > cwf increment |
631
|
|
|
|
|
|
|
} elsif ($range->[2] > $self->[3][0][2]) { |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
# adjust cwf to match data range |
634
|
0
|
|
|
|
|
|
$cwf = _reduce_cwf($self, $range); |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
} else { |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
# error |
639
|
0
|
|
|
|
|
|
croak('data increment < cwf increment'); |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
# if ICC::Support::Lapack module is loaded |
644
|
0
|
0
|
|
|
|
|
if ($lapack) { |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
# compute output matrix using BLAS dgemv function |
647
|
0
|
|
|
|
|
|
$out = ICC::Support::Lapack::matf_vec_trans($in, $cwf); |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
} else { |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
# for each XYZ or RGBV |
652
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$cwf}) { |
|
0
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
# compute dot product |
655
|
0
|
|
|
|
|
|
$out->[$i] = ICC::Shared::dotProduct($in, $cwf->[$i]); |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
} |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
# return with optional encoding |
662
|
0
|
0
|
|
|
|
|
return(defined($code = _encoding($self, $hash)) ? [&$code(@{$out})] : $out); |
|
0
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
} |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
# transform matrix (2-D array -or- Math::Matrix object) |
667
|
|
|
|
|
|
|
# parameters: (object_reference, matrix, [hash]) |
668
|
|
|
|
|
|
|
# returns: (matrix) |
669
|
|
|
|
|
|
|
sub _trans2 { |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
# get parameters |
672
|
0
|
|
|
0
|
|
|
my ($self, $in, $hash) = @_; |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
# local variables |
675
|
0
|
|
|
|
|
|
my ($range, $cwf, $out, $code); |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
678
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
# get input spectral range |
681
|
0
|
0
|
0
|
|
|
|
($range = $hash->{'range'} || $srh->{@{$in->[0]}}) or croak('spectral range must be specified'); |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
# if data increment == cwf increment |
684
|
0
|
0
|
|
|
|
|
if ($range->[2] == $self->[3][0][2]) { |
|
|
0
|
|
|
|
|
|
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
# adjust cwf to match data range |
687
|
0
|
|
|
|
|
|
$cwf = _adjust_cwf($self, $range); |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
# if data increment > cwf increment |
690
|
|
|
|
|
|
|
} elsif ($range->[2] > $self->[3][0][2]) { |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
# adjust cwf to match data range |
693
|
0
|
|
|
|
|
|
$cwf = _reduce_cwf($self, $range); |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
} else { |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
# error |
698
|
0
|
|
|
|
|
|
croak('data increment < cwf increment'); |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
# if ICC::Support::Lapack module is loaded |
703
|
0
|
0
|
|
|
|
|
if ($lapack) { |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
# compute output matrix using BLAS dgemm function |
706
|
0
|
|
|
|
|
|
$out = ICC::Support::Lapack::matf_mat_trans($in, $cwf); |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
} else { |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
# for each sample |
711
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$in}) { |
|
0
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
# for each XYZ or RGBV |
714
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$cwf}) { |
|
0
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
# compute dot product |
717
|
0
|
|
|
|
|
|
$out->[$i][$j] = ICC::Shared::dotProduct($in->[$i], $cwf->[$j]); |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
} |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
} |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
# if encoding enabled |
726
|
0
|
0
|
|
|
|
|
if ($code = _encoding($self, $hash)) { |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
# for each sample |
729
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$out}) { |
|
0
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
# apply encoding |
732
|
0
|
|
|
|
|
|
@{$out->[$i]} = &$code(@{$out->[$i]}); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
} |
735
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
} |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
# return output (Math::Matrix object or 2-D array) |
739
|
0
|
0
|
|
|
|
|
return(UNIVERSAL::isa($in, 'Math::Matrix') ? bless($out, 'Math::Matrix') : $out); |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
} |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
# transform structure |
744
|
|
|
|
|
|
|
# parameters: (object_reference, structure, [hash]) |
745
|
|
|
|
|
|
|
# returns: (structure) |
746
|
|
|
|
|
|
|
sub _trans3 { |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
# get parameters |
749
|
0
|
|
|
0
|
|
|
my ($self, $in, $hash) = @_; |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
# transform the array structure |
752
|
0
|
|
|
|
|
|
_crawl($self, \&_trans1, $in, my $out = [], $hash); |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
# return output structure |
755
|
0
|
|
|
|
|
|
return($out); |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
} |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
# recursive transform |
760
|
|
|
|
|
|
|
# array structure is traversed until all vectors are found and transformed |
761
|
|
|
|
|
|
|
# parameters: (object_reference, subroutine_reference, input_array_reference, output_array_reference, hash) |
762
|
|
|
|
|
|
|
sub _crawl { |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
# get parameters |
765
|
0
|
|
|
0
|
|
|
my ($self, $sub, $in, $out, $hash) = @_; |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
# if input is a vector (reference to a numeric array) |
768
|
0
|
0
|
|
|
|
|
if (@{$in} == grep {Scalar::Util::looks_like_number($_)} @{$in}) { |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
# transform input vector and copy to output |
771
|
0
|
|
|
|
|
|
@{$out} = @{$sub->($self, $in, $hash)}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
} else { |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
# for each input element |
776
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$in}) { |
|
0
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
# if an array reference |
779
|
0
|
0
|
|
|
|
|
if (ref($in->[$i]) eq 'ARRAY') { |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
# transform next level |
782
|
0
|
|
|
|
|
|
_crawl($self, $sub, $in->[$i], $out->[$i] = [], $hash); |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
} else { |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
# error |
787
|
0
|
|
|
|
|
|
croak('invalid input structure'); |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
} |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
} |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
} |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
} |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
# reduce cwf matrix to match data range |
798
|
|
|
|
|
|
|
# the reduced cwf and data range is cached |
799
|
|
|
|
|
|
|
# parameters: (object_reference, data_range) |
800
|
|
|
|
|
|
|
# returns: (reduced_cwf) |
801
|
|
|
|
|
|
|
sub _reduce_cwf { |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
# get parameters |
804
|
0
|
|
|
0
|
|
|
my ($self, $range_data) = @_; |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
# local variables |
807
|
0
|
|
|
|
|
|
my ($method, $bandpass, $range_cwf, $cwf, $mat); |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
# if cached CWF matches data range |
810
|
0
|
0
|
0
|
|
|
|
if (defined($self->[4][0]) && $self->[4][0][0] == $range_data->[0] && $self->[4][0][1] == $range_data->[1] && $self->[4][0][2] == $range_data->[2]) { |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
# return cached CWF |
813
|
0
|
|
|
|
|
|
return($self->[4][1]); |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
} |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
818
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
# get interpolation method |
821
|
0
|
|
0
|
|
|
|
$method = $self->[0]{'method'} // 'cspline'; |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
# get bandpass correction |
824
|
0
|
|
0
|
|
|
|
$bandpass = $self->[0]{'bandpass'} // 0; |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
# get cwf range |
827
|
0
|
|
|
|
|
|
$range_cwf = $self->[3][0]; |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
# if method is linear |
830
|
0
|
0
|
|
|
|
|
if ($method eq 'linear') { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
# compute linear interpolation matrix |
833
|
0
|
|
|
|
|
|
$mat = ICC::Shared::linear_matrix($range_data, $range_cwf, 'copy'); |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
# if method is cubic spline |
836
|
|
|
|
|
|
|
} elsif ($method eq 'cspline') { |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
# compute cubic spline interpolation matrix |
839
|
0
|
|
|
|
|
|
$mat = ICC::Shared::cspline_matrix($range_data, $range_cwf, 'copy'); |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
# if method is Lagrange |
842
|
|
|
|
|
|
|
} elsif ($method eq 'lagrange') { |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
# compute Lagrange interpolation matrix |
845
|
0
|
|
|
|
|
|
$mat = ICC::Shared::lagrange_matrix($range_data, $range_cwf, 'copy'); |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
} else { |
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
# error |
850
|
0
|
|
|
|
|
|
croak('invalid interpolation method'); |
851
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
} |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
# if ICC::Support::Lapack module is loaded |
855
|
0
|
0
|
|
|
|
|
if ($lapack) { |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
# compute cwf using BLAS dgemm function |
858
|
0
|
|
|
|
|
|
$cwf = ICC::Support::Lapack::mat_xplus($self->[3][1], $mat); |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
# if bandpass correction is enabled |
861
|
0
|
0
|
|
|
|
|
if ($bandpass) { |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
# apply correction matrix |
864
|
0
|
|
|
|
|
|
$cwf = ICC::Support::Lapack::mat_xplus($cwf, _bandpass($range_data, $method, $bandpass)); |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
} |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
} else { |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
# compute cwf using Math::Matrix module |
871
|
0
|
|
|
|
|
|
$cwf = bless(Storable::dclone($self->[3][1]), 'Math::Matrix') * $mat; |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
# if bandpass correction is enabled |
874
|
0
|
0
|
|
|
|
|
if ($bandpass) { |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
# apply correction matrix |
877
|
0
|
|
|
|
|
|
$cwf = $cwf * _bandpass($range_data, $method, $bandpass); |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
} |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
} |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
# cache reduced CWF |
884
|
0
|
|
|
|
|
|
$self->[4][0] = $range_data; |
885
|
0
|
|
|
|
|
|
$self->[4][1] = $cwf; |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
# return |
888
|
0
|
|
|
|
|
|
return($cwf); |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
} |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
# make bandpass correction matrix |
893
|
|
|
|
|
|
|
# per ASTM E 2729 or deconvolution |
894
|
|
|
|
|
|
|
# parameters: (data_range, interpolation_method, bandpass_method) |
895
|
|
|
|
|
|
|
# returns: (matrix) |
896
|
|
|
|
|
|
|
sub _bandpass { |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
# get parameters |
899
|
0
|
|
|
0
|
|
|
my ($range_data, $method, $bandpass) = @_; |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
# local variables |
902
|
0
|
|
|
|
|
|
my ($ix, $jx, $range_mat, $mati, $matc, $bpf, $info, $matrix); |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
# compute bandpass matrix upper index |
905
|
0
|
|
|
|
|
|
$ix = ($range_data->[1] - $range_data->[0])/$range_data->[2]; |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
# set bandpass function upper index |
908
|
0
|
|
|
|
|
|
$jx = 20; |
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
# if bandpass value if 'astm' |
911
|
0
|
0
|
|
|
|
|
if ($bandpass eq 'astm') { |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
# return ASTM E 2729 bandpass rectification matrix |
914
|
0
|
|
|
|
|
|
return(_bandpass_astm($ix)); |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
} else { |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
# compute interpolation matrix range |
919
|
0
|
|
|
|
|
|
$range_mat = [$range_data->[0] - $range_data->[2], $range_data->[1] + $range_data->[2], $range_data->[2]/10]; |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
# if method is linear |
922
|
0
|
0
|
|
|
|
|
if ($method eq 'linear') { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
# compute linear interpolation matrix |
925
|
0
|
|
|
|
|
|
$mati = ICC::Shared::linear_matrix($range_data, $range_mat, 'linear'); |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
# if method is cubic spline |
928
|
|
|
|
|
|
|
} elsif ($method eq 'cspline') { |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
# compute cubic spline interpolation matrix |
931
|
0
|
|
|
|
|
|
$mati = ICC::Shared::cspline_matrix($range_data, $range_mat, 'linear'); |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
# if method is Lagrange |
934
|
|
|
|
|
|
|
} elsif ($method eq 'lagrange') { |
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
# compute Lagrange interpolation matrix |
937
|
0
|
|
|
|
|
|
$mati = ICC::Shared::lagrange_matrix($range_data, $range_mat, 'linear'); |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
} else { |
940
|
|
|
|
|
|
|
|
941
|
|
|
|
|
|
|
# error |
942
|
0
|
|
|
|
|
|
croak('invalid interpolation method'); |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
} |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
# if bandpass value if 'triangle' |
947
|
0
|
0
|
0
|
|
|
|
if ($bandpass eq 'triangle') { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
# compute bandpass function array |
950
|
0
|
|
|
|
|
|
$bpf = _bandpass_fn(1, $jx); |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
# if bandpass value if 'trapezoid' (combination of three triangular sub-bands) |
953
|
|
|
|
|
|
|
} elsif ($bandpass eq 'trapezoid') { |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
# compute bandpass function array |
956
|
0
|
|
|
|
|
|
$bpf = _bandpass_fn(1/3, $jx); |
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
# if bandpass value is an array reference |
959
|
0
|
|
|
|
|
|
} elsif (ref($bandpass) eq 'ARRAY' && $#{$bandpass} == $jx) { |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
# set value |
962
|
0
|
|
|
|
|
|
$bpf = $bandpass; |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
} else { |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
# error |
967
|
0
|
|
|
|
|
|
croak('invalid bandpass correction'); |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
} |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
# compute convolution matrix |
972
|
0
|
|
|
|
|
|
$matc = _conv_matrix($bpf, $ix); |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
975
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
# if Lapack module loaded |
978
|
0
|
0
|
|
|
|
|
if ($lapack) { |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
# multiply matrices and invert using Lapack module |
981
|
0
|
|
|
|
|
|
($info, $matrix) = ICC::Support::Lapack::inv(ICC::Support::Lapack::mat_xplus($matc, $mati)); |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
# return deconvolution matrix |
984
|
0
|
|
|
|
|
|
return(bless($matrix, 'Math::Matrix')); |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
} else { |
987
|
|
|
|
|
|
|
|
988
|
|
|
|
|
|
|
# return deconvolution matrix |
989
|
0
|
|
|
|
|
|
return(($matc * $mati)->invert()); |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
} |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
} |
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
} |
996
|
|
|
|
|
|
|
|
997
|
|
|
|
|
|
|
# make ASTM E 2729 bandpass rectification matrix |
998
|
|
|
|
|
|
|
# parameter: (upper_index) |
999
|
|
|
|
|
|
|
# returns: (matrix) |
1000
|
|
|
|
|
|
|
sub _bandpass_astm { |
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
# get upper index |
1003
|
0
|
|
|
0
|
|
|
my $ix = shift(); |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
# local variables |
1006
|
0
|
|
|
|
|
|
my ($matrix, @zeros); |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
# make array of zeros |
1009
|
0
|
|
|
|
|
|
@zeros = (0) x ($ix + 1); |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
# for each matrix row |
1012
|
0
|
|
|
|
|
|
for my $i (0 .. $ix) { |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
# set the row to zeros |
1015
|
0
|
|
|
|
|
|
$matrix->[$i] = [@zeros]; |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
# for each matrix column |
1018
|
0
|
|
|
|
|
|
for my $j (0 .. $ix) { |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
# if main diagonal |
1021
|
0
|
0
|
0
|
|
|
|
if ($i == $j) { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
1022
|
|
|
|
|
|
|
|
1023
|
0
|
0
|
0
|
|
|
|
if ($i == 0 || $i == $ix) { |
|
|
0
|
0
|
|
|
|
|
1024
|
|
|
|
|
|
|
|
1025
|
0
|
|
|
|
|
|
$matrix->[$i][$j] = 1; |
1026
|
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
|
} elsif ($i == 1 || $i == $ix - 1) { |
1028
|
|
|
|
|
|
|
|
1029
|
0
|
|
|
|
|
|
$matrix->[$i][$j] = 1.21; |
1030
|
|
|
|
|
|
|
|
1031
|
|
|
|
|
|
|
} else { |
1032
|
|
|
|
|
|
|
|
1033
|
0
|
|
|
|
|
|
$matrix->[$i][$j] = 1.22; |
1034
|
|
|
|
|
|
|
|
1035
|
|
|
|
|
|
|
} |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
# if +/- 1 diagonal, and not the first or last rows |
1038
|
|
|
|
|
|
|
} elsif (abs($i - $j) == 1 && $i > 0 && $i < $ix) { |
1039
|
|
|
|
|
|
|
|
1040
|
0
|
0
|
0
|
|
|
|
if ($j == 0 || $j == $ix) { |
1041
|
|
|
|
|
|
|
|
1042
|
0
|
|
|
|
|
|
$matrix->[$i][$j] = -0.10; |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
} else { |
1045
|
|
|
|
|
|
|
|
1046
|
0
|
|
|
|
|
|
$matrix->[$i][$j] = -0.12; |
1047
|
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
|
} |
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
# if +/- 2 diagonal, and not the first or last rows |
1051
|
|
|
|
|
|
|
} elsif (abs($i - $j) == 2 && $i > 0 && $i < $ix) { |
1052
|
|
|
|
|
|
|
|
1053
|
0
|
|
|
|
|
|
$matrix->[$i][$j] = 0.01; |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
} |
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
} |
1058
|
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
|
} |
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
# return Math::Matrix object |
1062
|
0
|
|
|
|
|
|
return(bless($matrix, 'Math::Matrix')); |
1063
|
|
|
|
|
|
|
|
1064
|
|
|
|
|
|
|
} |
1065
|
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
|
# make simple bandpass function |
1067
|
|
|
|
|
|
|
# shape ranges from 0 to 1 (rectangular to triangular) |
1068
|
|
|
|
|
|
|
# upper index must be divisible by 4 |
1069
|
|
|
|
|
|
|
# parameters: (shape, upper_index) |
1070
|
|
|
|
|
|
|
# returns: (bandpass_array) |
1071
|
|
|
|
|
|
|
sub _bandpass_fn { |
1072
|
|
|
|
|
|
|
|
1073
|
|
|
|
|
|
|
# get parameters |
1074
|
0
|
|
|
0
|
|
|
my ($shape, $ix) = @_; |
1075
|
|
|
|
|
|
|
|
1076
|
|
|
|
|
|
|
# local variables |
1077
|
0
|
|
|
|
|
|
my ($m, $v, @array, $sum); |
1078
|
|
|
|
|
|
|
|
1079
|
|
|
|
|
|
|
# verify shape |
1080
|
0
|
0
|
0
|
|
|
|
($shape >= 0 && $shape <= 1) or croak('invalid shape parameter'); |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
# verify upper index |
1083
|
0
|
0
|
0
|
|
|
|
($ix == int($ix) && ! ($ix % 4)) or croak('invalid upper index'); |
1084
|
|
|
|
|
|
|
|
1085
|
|
|
|
|
|
|
# if shape not rectangular |
1086
|
0
|
0
|
|
|
|
|
if ($shape) { |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
# compute slope |
1089
|
0
|
|
|
|
|
|
$m = 2/($shape * $ix); |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
} else { |
1092
|
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
|
# set slope to big number |
1094
|
0
|
|
|
|
|
|
$m = 1E100; |
1095
|
|
|
|
|
|
|
|
1096
|
|
|
|
|
|
|
} |
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
# for each array element |
1099
|
0
|
|
|
|
|
|
for my $i (0 .. $ix/2) { |
1100
|
|
|
|
|
|
|
|
1101
|
|
|
|
|
|
|
# compute value |
1102
|
0
|
|
|
|
|
|
$v = ($i - $ix/4) * $m + 0.5; |
1103
|
|
|
|
|
|
|
|
1104
|
|
|
|
|
|
|
# set array elements to limited value |
1105
|
0
|
0
|
|
|
|
|
$array[$i] = $array[$ix - $i] = $v < 0 ? 0 : $v > 1 ? 1 : $v; |
|
|
0
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
|
} |
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
# compute array sum |
1110
|
0
|
|
|
|
|
|
$sum = List::Util::sum(@array); |
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
# return normalized array |
1113
|
0
|
|
|
|
|
|
return([map {$_/$sum} @array]); |
|
0
|
|
|
|
|
|
|
1114
|
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
|
} |
1116
|
|
|
|
|
|
|
|
1117
|
|
|
|
|
|
|
# make convolution matrix |
1118
|
|
|
|
|
|
|
# parameters: (bandpass_function_vector, row_upper_index) |
1119
|
|
|
|
|
|
|
# returns: (convolution_matrix) |
1120
|
|
|
|
|
|
|
sub _conv_matrix { |
1121
|
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
# get parameters |
1123
|
0
|
|
|
0
|
|
|
my ($bpf, $ix) = @_; |
1124
|
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
# local variables |
1126
|
0
|
|
|
|
|
|
my ($n, $p, @zeros, $mat); |
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
# verify bandpass function |
1129
|
0
|
0
|
|
|
|
|
(@{$bpf} % 2) or croak('bandpass function must have odd number of elements'); |
|
0
|
|
|
|
|
|
|
1130
|
|
|
|
|
|
|
|
1131
|
|
|
|
|
|
|
# verify row upper index |
1132
|
0
|
0
|
0
|
|
|
|
($ix == int($ix) && $ix >= 0) or croak('row upper index must be an integer >= 0'); |
1133
|
|
|
|
|
|
|
|
1134
|
|
|
|
|
|
|
# compute upper column index |
1135
|
0
|
|
|
|
|
|
$n = $#{$bpf} * ($ix + 2)/2; |
|
0
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
# compute bandpass increment |
1138
|
0
|
|
|
|
|
|
$p = $#{$bpf}/2; |
|
0
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
|
1140
|
|
|
|
|
|
|
# make array of zeros |
1141
|
0
|
|
|
|
|
|
@zeros = (0) x ($n + 1); |
1142
|
|
|
|
|
|
|
|
1143
|
|
|
|
|
|
|
# for each row |
1144
|
0
|
|
|
|
|
|
for my $i (0 .. $ix) { |
1145
|
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
|
# add row of zeros |
1147
|
0
|
|
|
|
|
|
$mat->[$i] = [@zeros]; |
1148
|
|
|
|
|
|
|
|
1149
|
|
|
|
|
|
|
# for each bandpass value |
1150
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$bpf}) { |
|
0
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
|
1152
|
|
|
|
|
|
|
# copy bandpass value |
1153
|
0
|
|
|
|
|
|
$mat->[$i][$i * $p + $j] = $bpf->[$j]; |
1154
|
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
|
} |
1156
|
|
|
|
|
|
|
|
1157
|
|
|
|
|
|
|
} |
1158
|
|
|
|
|
|
|
|
1159
|
|
|
|
|
|
|
# return |
1160
|
0
|
|
|
|
|
|
return(bless($mat, 'Math::Matrix')); |
1161
|
|
|
|
|
|
|
|
1162
|
|
|
|
|
|
|
} |
1163
|
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
|
# adjust cwf matrix to match data range |
1165
|
|
|
|
|
|
|
# the adjusted cwf and data range is cached |
1166
|
|
|
|
|
|
|
# parameters: (object_reference, data_range) |
1167
|
|
|
|
|
|
|
# returns: (adjusted_cwf) |
1168
|
|
|
|
|
|
|
sub _adjust_cwf { |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
# get parameters |
1171
|
0
|
|
|
0
|
|
|
my ($self, $range_data) = @_; |
1172
|
|
|
|
|
|
|
|
1173
|
|
|
|
|
|
|
# local variables |
1174
|
0
|
|
|
|
|
|
my ($bandpass, $off, $cwf); |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
# if cached CWF matches data range |
1177
|
0
|
0
|
0
|
|
|
|
if (defined($self->[4][0]) && $self->[4][0][0] == $range_data->[0] && $self->[4][0][1] == $range_data->[1] && $self->[4][0][2] == $range_data->[2]) { |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
1178
|
|
|
|
|
|
|
|
1179
|
|
|
|
|
|
|
# return cached CWF |
1180
|
0
|
|
|
|
|
|
return($self->[4][1]); |
1181
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
} |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
1185
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
1186
|
|
|
|
|
|
|
|
1187
|
|
|
|
|
|
|
# get bandpass correction |
1188
|
0
|
|
0
|
|
|
|
$bandpass = $self->[0]{'bandpass'} // 0; |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
# compute range offset |
1191
|
0
|
|
|
|
|
|
$off = abs(($range_data->[0] - $self->[3][0][0])/$range_data->[2]); |
1192
|
|
|
|
|
|
|
|
1193
|
|
|
|
|
|
|
# verify offset is an integer |
1194
|
0
|
0
|
|
|
|
|
(abs($off - ICC::Shared::round($off)) < 1E-12) or croak('range offset not an integer'); |
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
# adjust CWF matrix |
1197
|
0
|
|
|
|
|
|
$cwf = _adjust_matrix($self->[3][1], $self->[3][0], $range_data); |
1198
|
|
|
|
|
|
|
|
1199
|
|
|
|
|
|
|
# if bandpass correction enabled, and not table 6 |
1200
|
0
|
0
|
0
|
|
|
|
if ($bandpass && $bandpass ne 'six') { |
1201
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
# if ICC::Support::Lapack module is loaded |
1203
|
0
|
0
|
|
|
|
|
if ($lapack) { |
1204
|
|
|
|
|
|
|
|
1205
|
|
|
|
|
|
|
# apply correction matrix |
1206
|
0
|
|
|
|
|
|
$cwf = ICC::Support::Lapack::mat_xplus($cwf, _bandpass($range_data, 'lagrange', $bandpass)); |
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
} else { |
1209
|
|
|
|
|
|
|
|
1210
|
|
|
|
|
|
|
# apply correction matrix |
1211
|
0
|
|
|
|
|
|
$cwf = bless($cwf, 'Math::Matrix') * _bandpass($range_data, 'lagrange', $bandpass); |
1212
|
|
|
|
|
|
|
|
1213
|
|
|
|
|
|
|
} |
1214
|
|
|
|
|
|
|
|
1215
|
|
|
|
|
|
|
} |
1216
|
|
|
|
|
|
|
|
1217
|
|
|
|
|
|
|
# cache adjusted CWF |
1218
|
0
|
|
|
|
|
|
$self->[4][0] = $range_data; |
1219
|
0
|
|
|
|
|
|
$self->[4][1] = $cwf; |
1220
|
|
|
|
|
|
|
|
1221
|
|
|
|
|
|
|
# return |
1222
|
0
|
|
|
|
|
|
return($cwf); |
1223
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
} |
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
# adjust matrix to match data range |
1227
|
|
|
|
|
|
|
# parameters: (matrix, matrix_range, data_range) |
1228
|
|
|
|
|
|
|
# returns: (adjusted_matrix) |
1229
|
|
|
|
|
|
|
sub _adjust_matrix { |
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
# get parameters |
1232
|
0
|
|
|
0
|
|
|
my ($matrix, $range_matrix, $range_data) = @_; |
1233
|
|
|
|
|
|
|
|
1234
|
|
|
|
|
|
|
# local variables |
1235
|
0
|
|
|
|
|
|
my ($adj, $j); |
1236
|
|
|
|
|
|
|
|
1237
|
|
|
|
|
|
|
# clone matrix |
1238
|
0
|
|
|
|
|
|
$adj = Storable::dclone($matrix); |
1239
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
# for each function |
1241
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$adj}) { |
|
0
|
|
|
|
|
|
|
1242
|
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
|
# if cwf start < data start |
1244
|
0
|
0
|
|
|
|
|
if ($range_matrix->[0] < $range_data->[0]) { |
|
|
0
|
|
|
|
|
|
1245
|
|
|
|
|
|
|
|
1246
|
|
|
|
|
|
|
# compute number of elements to combine |
1247
|
0
|
|
|
|
|
|
$j = int(($range_data->[0] - $range_matrix->[0])/$range_data->[2] + 1.5); |
1248
|
|
|
|
|
|
|
|
1249
|
|
|
|
|
|
|
# combine elements |
1250
|
0
|
|
|
|
|
|
splice(@{$adj->[$i]}, 0, $j, List::Util::sum(@{$adj->[$i]}[0 .. ($j - 1)])); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1251
|
|
|
|
|
|
|
|
1252
|
|
|
|
|
|
|
# if cwf start > data start |
1253
|
|
|
|
|
|
|
} elsif ($range_matrix->[0] > $range_data->[0]) { |
1254
|
|
|
|
|
|
|
|
1255
|
|
|
|
|
|
|
# compute number of zeros to add |
1256
|
0
|
|
|
|
|
|
$j = int(($range_matrix->[0] - $range_data->[0])/$range_data->[2] + 0.5); |
1257
|
|
|
|
|
|
|
|
1258
|
|
|
|
|
|
|
# add zeros |
1259
|
0
|
|
|
|
|
|
unshift(@{$adj->[$i]}, (0) x $j); |
|
0
|
|
|
|
|
|
|
1260
|
|
|
|
|
|
|
|
1261
|
|
|
|
|
|
|
} |
1262
|
|
|
|
|
|
|
|
1263
|
|
|
|
|
|
|
# if cwf end > data end |
1264
|
0
|
0
|
|
|
|
|
if ($range_matrix->[1] > $range_data->[1]) { |
|
|
0
|
|
|
|
|
|
1265
|
|
|
|
|
|
|
|
1266
|
|
|
|
|
|
|
# compute number of elements to combine |
1267
|
0
|
|
|
|
|
|
$j = int(($range_matrix->[1] - $range_data->[1])/$range_data->[2] + 1.5); |
1268
|
|
|
|
|
|
|
|
1269
|
|
|
|
|
|
|
# combine elements |
1270
|
0
|
|
|
|
|
|
splice(@{$adj->[$i]}, -$j, $j, List::Util::sum(@{$adj->[$i]}[-$j .. -1])); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1271
|
|
|
|
|
|
|
|
1272
|
|
|
|
|
|
|
# if cwf end < data end |
1273
|
|
|
|
|
|
|
} elsif ($range_matrix->[1] < $range_data->[1]) { |
1274
|
|
|
|
|
|
|
|
1275
|
|
|
|
|
|
|
# compute number of zeros to add |
1276
|
0
|
|
|
|
|
|
$j = int(($range_data->[1] - $range_matrix->[1])/$range_data->[2] + 0.5); |
1277
|
|
|
|
|
|
|
|
1278
|
|
|
|
|
|
|
# add zeros |
1279
|
0
|
|
|
|
|
|
push(@{$adj->[$i]}, (0) x $j); |
|
0
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
} |
1282
|
|
|
|
|
|
|
|
1283
|
|
|
|
|
|
|
} |
1284
|
|
|
|
|
|
|
|
1285
|
|
|
|
|
|
|
# return |
1286
|
0
|
|
|
|
|
|
return($adj); |
1287
|
|
|
|
|
|
|
|
1288
|
|
|
|
|
|
|
} |
1289
|
|
|
|
|
|
|
|
1290
|
|
|
|
|
|
|
# compute CIE color-weight functions |
1291
|
|
|
|
|
|
|
# parameters: (object_reference) |
1292
|
|
|
|
|
|
|
# results are saved in the object |
1293
|
|
|
|
|
|
|
# cwf cache is cleared |
1294
|
|
|
|
|
|
|
sub _make_cwf { |
1295
|
|
|
|
|
|
|
|
1296
|
|
|
|
|
|
|
# get parameters |
1297
|
0
|
|
|
0
|
|
|
my $self = shift(); |
1298
|
|
|
|
|
|
|
|
1299
|
|
|
|
|
|
|
# local variables |
1300
|
0
|
|
|
|
|
|
my ($range, $obs, $inc, $smooth, $method, $bandpass, $matc, $illum, $spd, $ks, @k, @Wx, @Wy, @Wz); |
1301
|
|
|
|
|
|
|
|
1302
|
|
|
|
|
|
|
# if cwf_range key defined |
1303
|
0
|
0
|
0
|
|
|
|
if (defined($self->[0]{'cwf_range'})) { |
|
|
0
|
|
|
|
|
|
1304
|
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
|
# use supplied range |
1306
|
0
|
|
|
|
|
|
$range = $self->[0]{'cwf_range'}; |
1307
|
|
|
|
|
|
|
|
1308
|
|
|
|
|
|
|
# interpolate observer functions, with linear extrapolation |
1309
|
0
|
|
|
|
|
|
$obs = ICC::Support::Lapack::matf_mat_trans($self->[2][1], ICC::Shared::cspline_matrix($self->[2][0], $range, 'linear')); |
1310
|
|
|
|
|
|
|
|
1311
|
|
|
|
|
|
|
# if observer requires interpolation |
1312
|
|
|
|
|
|
|
} elsif ($self->[2][0][2] != ($inc = $self->[0]{'increment'} // 1)) { |
1313
|
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
|
# use observer range, changing increment |
1315
|
0
|
|
|
|
|
|
$range = [$self->[2][0][0], $self->[2][0][1], $inc]; |
1316
|
|
|
|
|
|
|
|
1317
|
|
|
|
|
|
|
# interpolate observer functions |
1318
|
0
|
|
|
|
|
|
$obs = ICC::Support::Lapack::matf_mat_trans($self->[2][1], ICC::Shared::cspline_matrix($self->[2][0], $range)); |
1319
|
|
|
|
|
|
|
|
1320
|
|
|
|
|
|
|
} else { |
1321
|
|
|
|
|
|
|
|
1322
|
|
|
|
|
|
|
# use observer range |
1323
|
0
|
|
|
|
|
|
$range = $self->[2][0]; |
1324
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
# get observer functions |
1326
|
0
|
|
|
|
|
|
$obs = $self->[2][1]; |
1327
|
|
|
|
|
|
|
|
1328
|
|
|
|
|
|
|
} |
1329
|
|
|
|
|
|
|
|
1330
|
|
|
|
|
|
|
# if observer requires exponentiation |
1331
|
0
|
0
|
|
|
|
|
if ($self->[0]{'observer_exp'}) { |
1332
|
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
|
# for each spectral value |
1334
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$obs->[0]}) { |
|
0
|
|
|
|
|
|
|
1335
|
|
|
|
|
|
|
|
1336
|
|
|
|
|
|
|
# exponentiate |
1337
|
0
|
|
|
|
|
|
$obs->[0][$i] = exp($obs->[0][$i]); |
1338
|
0
|
|
|
|
|
|
$obs->[1][$i] = exp($obs->[1][$i]); |
1339
|
0
|
|
|
|
|
|
$obs->[2][$i] = exp($obs->[2][$i]); |
1340
|
|
|
|
|
|
|
|
1341
|
|
|
|
|
|
|
} |
1342
|
|
|
|
|
|
|
|
1343
|
|
|
|
|
|
|
} |
1344
|
|
|
|
|
|
|
|
1345
|
|
|
|
|
|
|
# if illuminant is defined |
1346
|
0
|
0
|
|
|
|
|
if (defined($self->[1][0])) { |
1347
|
|
|
|
|
|
|
|
1348
|
|
|
|
|
|
|
# compute illuminant smoothness |
1349
|
0
|
|
|
|
|
|
$smooth = _smoothness($self->[1][1]); |
1350
|
|
|
|
|
|
|
|
1351
|
|
|
|
|
|
|
# get illuminant interpolation method |
1352
|
0
|
0
|
0
|
|
|
|
$method = $self->[0]{'imethod'} // ($smooth == 0 || $smooth > 0.001) ? 'linear' : 'cspline'; |
|
|
|
0
|
|
|
|
|
1353
|
|
|
|
|
|
|
|
1354
|
|
|
|
|
|
|
# if illuminant bandpass correction enabled |
1355
|
0
|
0
|
|
|
|
|
if (defined($bandpass = $self->[0]{'ibandpass'})) { |
1356
|
|
|
|
|
|
|
|
1357
|
|
|
|
|
|
|
# compute bandpass correction matrix |
1358
|
0
|
|
|
|
|
|
$matc = _bandpass($self->[1][0], $method, $bandpass); |
1359
|
|
|
|
|
|
|
|
1360
|
|
|
|
|
|
|
# apply bandpass correction matrix |
1361
|
0
|
|
|
|
|
|
$illum = [map {ICC::Shared::dotProduct($self->[1][1], $_)} @{$matc}]; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1362
|
|
|
|
|
|
|
|
1363
|
|
|
|
|
|
|
} else { |
1364
|
|
|
|
|
|
|
|
1365
|
|
|
|
|
|
|
# use illuminant as is |
1366
|
0
|
|
|
|
|
|
$illum = $self->[1][1]; |
1367
|
|
|
|
|
|
|
|
1368
|
|
|
|
|
|
|
} |
1369
|
|
|
|
|
|
|
|
1370
|
|
|
|
|
|
|
# if method is linear |
1371
|
0
|
0
|
|
|
|
|
if ($method eq 'linear') { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1372
|
|
|
|
|
|
|
|
1373
|
|
|
|
|
|
|
# interpolate illuminant data |
1374
|
0
|
|
|
|
|
|
$spd = ICC::Shared::linear($illum, $self->[1][0], $range, 'copy'); |
1375
|
|
|
|
|
|
|
|
1376
|
|
|
|
|
|
|
# if method is cubic spline |
1377
|
|
|
|
|
|
|
} elsif ($method eq 'cspline') { |
1378
|
|
|
|
|
|
|
|
1379
|
|
|
|
|
|
|
# interpolate illuminant data |
1380
|
0
|
|
|
|
|
|
$spd = ICC::Shared::cspline($illum, $self->[1][0], $range, 'copy'); |
1381
|
|
|
|
|
|
|
|
1382
|
|
|
|
|
|
|
# if method is Lagrange -or- ASTM E 2022 |
1383
|
|
|
|
|
|
|
} elsif ($method eq 'lagrange') { |
1384
|
|
|
|
|
|
|
|
1385
|
|
|
|
|
|
|
# interpolate illuminant data |
1386
|
0
|
|
|
|
|
|
$spd = ICC::Shared::lagrange($illum, $self->[1][0], $range, 'copy'); |
1387
|
|
|
|
|
|
|
|
1388
|
|
|
|
|
|
|
} else { |
1389
|
|
|
|
|
|
|
|
1390
|
|
|
|
|
|
|
# error |
1391
|
0
|
|
|
|
|
|
croak('invalid illuminant interpolation method'); |
1392
|
|
|
|
|
|
|
|
1393
|
|
|
|
|
|
|
} |
1394
|
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
|
# get or compute summation constant |
1396
|
0
|
|
0
|
|
|
|
$ks = $self->[0]{'cwf_ks'} // 100/ICC::Shared::dotProduct($spd, $obs->[1]); |
1397
|
|
|
|
|
|
|
|
1398
|
|
|
|
|
|
|
# for each spectral value |
1399
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$obs->[0]}) { |
|
0
|
|
|
|
|
|
|
1400
|
|
|
|
|
|
|
|
1401
|
|
|
|
|
|
|
# compute spectral products (k * illuminant * observer) |
1402
|
0
|
|
|
|
|
|
$Wx[$i] = $ks * $spd->[$i] * $obs->[0][$i]; |
1403
|
0
|
|
|
|
|
|
$Wy[$i] = $ks * $spd->[$i] * $obs->[1][$i]; |
1404
|
0
|
|
|
|
|
|
$Wz[$i] = $ks * $spd->[$i] * $obs->[2][$i]; |
1405
|
|
|
|
|
|
|
|
1406
|
|
|
|
|
|
|
} |
1407
|
|
|
|
|
|
|
|
1408
|
|
|
|
|
|
|
} else { |
1409
|
|
|
|
|
|
|
|
1410
|
|
|
|
|
|
|
# compute summation constants (slightly different for X, Y, Z) |
1411
|
0
|
|
|
|
|
|
$k[0] = 100/List::Util::sum(@{$obs->[0]}); |
|
0
|
|
|
|
|
|
|
1412
|
0
|
|
|
|
|
|
$k[1] = 100/List::Util::sum(@{$obs->[1]}); |
|
0
|
|
|
|
|
|
|
1413
|
0
|
|
|
|
|
|
$k[2] = 100/List::Util::sum(@{$obs->[2]}); |
|
0
|
|
|
|
|
|
|
1414
|
|
|
|
|
|
|
|
1415
|
|
|
|
|
|
|
# for each spectral value |
1416
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$obs->[0]}) { |
|
0
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
|
|
1418
|
|
|
|
|
|
|
# compute spectral products (k * observer) |
1419
|
0
|
|
|
|
|
|
$Wx[$i] = $k[0] * $obs->[0][$i]; |
1420
|
0
|
|
|
|
|
|
$Wy[$i] = $k[1] * $obs->[1][$i]; |
1421
|
0
|
|
|
|
|
|
$Wz[$i] = $k[2] * $obs->[2][$i]; |
1422
|
|
|
|
|
|
|
|
1423
|
|
|
|
|
|
|
} |
1424
|
|
|
|
|
|
|
|
1425
|
|
|
|
|
|
|
} |
1426
|
|
|
|
|
|
|
|
1427
|
|
|
|
|
|
|
# set wavelength range (start, end, and increment) |
1428
|
0
|
|
|
|
|
|
$self->[3][0] = [@{$range}]; |
|
0
|
|
|
|
|
|
|
1429
|
|
|
|
|
|
|
|
1430
|
|
|
|
|
|
|
# set color-weight functions |
1431
|
0
|
|
|
|
|
|
$self->[3][1][0] = [@Wx]; |
1432
|
0
|
|
|
|
|
|
$self->[3][1][1] = [@Wy]; |
1433
|
0
|
|
|
|
|
|
$self->[3][1][2] = [@Wz]; |
1434
|
|
|
|
|
|
|
|
1435
|
|
|
|
|
|
|
# set illuminant white point (XYZ) |
1436
|
0
|
|
|
|
|
|
$self->[5][0] = List::Util::sum(@Wx); |
1437
|
0
|
|
|
|
|
|
$self->[5][1] = List::Util::sum(@Wy); |
1438
|
0
|
|
|
|
|
|
$self->[5][2] = List::Util::sum(@Wz); |
1439
|
|
|
|
|
|
|
|
1440
|
|
|
|
|
|
|
# clear adjusted CWF cache |
1441
|
0
|
|
|
|
|
|
$self->[4] = []; |
1442
|
|
|
|
|
|
|
|
1443
|
|
|
|
|
|
|
} |
1444
|
|
|
|
|
|
|
|
1445
|
|
|
|
|
|
|
# read CIE illuminant and color-matching functions |
1446
|
|
|
|
|
|
|
# compute color-weight functions (k * illuminant * observer) and white point |
1447
|
|
|
|
|
|
|
# illuminant, observer and increment specified in hash |
1448
|
|
|
|
|
|
|
# parameters: (object_reference, hash) |
1449
|
|
|
|
|
|
|
# results are saved in the object |
1450
|
|
|
|
|
|
|
sub _cie { |
1451
|
|
|
|
|
|
|
|
1452
|
|
|
|
|
|
|
# get parameters |
1453
|
0
|
|
|
0
|
|
|
my ($self, $hash) = @_; |
1454
|
|
|
|
|
|
|
|
1455
|
|
|
|
|
|
|
# local variables |
1456
|
0
|
|
|
|
|
|
my ($array, @files, $illum, $s, $w, $sx); |
1457
|
0
|
|
|
|
|
|
my ($inc, $obs, $cmf, $key); |
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
# get copy of illuminant array |
1460
|
0
|
|
|
|
|
|
$array = Storable::dclone($hash->{'illuminant'}); |
1461
|
|
|
|
|
|
|
|
1462
|
|
|
|
|
|
|
# if empty array (emissive) |
1463
|
0
|
0
|
|
|
|
|
if (! @{$array}) { |
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1464
|
|
|
|
|
|
|
|
1465
|
|
|
|
|
|
|
# clear illuminant |
1466
|
0
|
|
|
|
|
|
$self->[1] = []; |
1467
|
|
|
|
|
|
|
|
1468
|
|
|
|
|
|
|
# if a measured illuminant (file path) |
1469
|
0
|
|
|
|
|
|
} elsif (@files = grep {-f} File::Glob::bsd_glob($array->[0])) { |
1470
|
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
|
# make new chart object |
1472
|
0
|
|
|
|
|
|
$illum = ICC::Support::Chart->new($files[0]); |
1473
|
|
|
|
|
|
|
|
1474
|
|
|
|
|
|
|
# get sample from hash (default is 1) |
1475
|
0
|
0
|
|
|
|
|
$s = defined($array->[1]) ? $array->[1] : 1; |
1476
|
|
|
|
|
|
|
|
1477
|
|
|
|
|
|
|
# verify sample |
1478
|
0
|
0
|
0
|
|
|
|
(Scalar::Util::looks_like_number($s) && $s == int($s) && $s > 0 && $s <= $illum->size()) or croak('invalid sample number'); |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
1479
|
|
|
|
|
|
|
|
1480
|
|
|
|
|
|
|
# set wavelength range |
1481
|
0
|
|
|
|
|
|
$self->[1][0] = $illum->nm(); |
1482
|
|
|
|
|
|
|
|
1483
|
|
|
|
|
|
|
# set spectral values |
1484
|
0
|
0
|
|
|
|
|
($self->[1][1] = $illum->spectral([$s])->[0]) or croak('illuminant chart has no spectral data'); |
1485
|
|
|
|
|
|
|
|
1486
|
|
|
|
|
|
|
# if a standard illuminant (YAML file in data folder) |
1487
|
0
|
|
|
|
|
|
} elsif (@files = grep {-f} File::Glob::bsd_glob(ICC::Shared::getICCPath("Data/$array->[0]_illums_*.yml"))) { |
1488
|
|
|
|
|
|
|
|
1489
|
|
|
|
|
|
|
# load standard illuminants (YAML format) |
1490
|
0
|
|
|
|
|
|
$illum = YAML::Tiny->read($files[0])->[0]; |
1491
|
|
|
|
|
|
|
|
1492
|
|
|
|
|
|
|
# get wavelength vector |
1493
|
0
|
|
|
|
|
|
$w = $illum->{'nm'}; |
1494
|
|
|
|
|
|
|
|
1495
|
|
|
|
|
|
|
# set wavelength range |
1496
|
0
|
|
|
|
|
|
$self->[1][0] = [$w->[0], $w->[-1], $w->[1] - $w->[0]]; |
1497
|
|
|
|
|
|
|
|
1498
|
|
|
|
|
|
|
# set spectral values |
1499
|
0
|
0
|
|
|
|
|
($self->[1][1] = $illum->{$array->[1]}) or croak('standard illuminant not found'); |
1500
|
|
|
|
|
|
|
|
1501
|
|
|
|
|
|
|
# if illuminant is two array references (wavelength range and spd vectors) |
1502
|
0
|
|
|
|
|
|
} elsif (@{$array} == grep {ref() eq 'ARRAY'} @{$array}) { |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1503
|
|
|
|
|
|
|
|
1504
|
|
|
|
|
|
|
# verify wavelength range |
1505
|
0
|
0
|
0
|
|
|
|
(ref($array->[0]) eq 'ARRAY' && 3 == @{$array->[0]} && (3 == grep {Scalar::Util::looks_like_number($_)} @{$array->[0]}) && $array->[0][2]) or croak('invalid illuminant wavelength range'); |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1506
|
|
|
|
|
|
|
|
1507
|
|
|
|
|
|
|
# compute upper index of spd array |
1508
|
0
|
0
|
|
|
|
|
(($sx = ICC::Shared::round(($array->[0][1] - $array->[0][0])/$array->[0][2])) > 0) or croak('inconsistent illuminant wavelength range'); |
1509
|
|
|
|
|
|
|
|
1510
|
|
|
|
|
|
|
# verify spd array |
1511
|
0
|
0
|
0
|
|
|
|
(ref($array->[1]) eq 'ARRAY' && $#{$array->[1]} == $sx && @{$array->[1]} == grep {Scalar::Util::looks_like_number($_)} @{$array->[1]}) or croak('invalid illuminant spd array'); |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1512
|
|
|
|
|
|
|
|
1513
|
|
|
|
|
|
|
# copy array contents |
1514
|
0
|
|
|
|
|
|
$self->[1] = Storable::dclone($array); |
1515
|
|
|
|
|
|
|
|
1516
|
|
|
|
|
|
|
} else { |
1517
|
|
|
|
|
|
|
|
1518
|
|
|
|
|
|
|
# error |
1519
|
0
|
|
|
|
|
|
croak("invalid illuminant [@{$array}]"); |
|
0
|
|
|
|
|
|
|
1520
|
|
|
|
|
|
|
|
1521
|
|
|
|
|
|
|
} |
1522
|
|
|
|
|
|
|
|
1523
|
|
|
|
|
|
|
# get increment from hash (default is 1) |
1524
|
0
|
0
|
|
|
|
|
$inc = defined($hash->{'increment'}) ? $hash->{'increment'} : 1; |
1525
|
|
|
|
|
|
|
|
1526
|
|
|
|
|
|
|
# if increment is 1 nm |
1527
|
0
|
0
|
|
|
|
|
if ($inc == 1) { |
|
|
0
|
|
|
|
|
|
1528
|
|
|
|
|
|
|
|
1529
|
|
|
|
|
|
|
# set wavelength range |
1530
|
0
|
|
|
|
|
|
$self->[2][0] = [360, 830, 1]; |
1531
|
|
|
|
|
|
|
|
1532
|
|
|
|
|
|
|
# load CIE color matching functions (YAML format) |
1533
|
0
|
|
|
|
|
|
$cmf = YAML::Tiny->read(ICC::Shared::getICCPath('Data/CIE_cmfs_360-830_x_1.yml'))->[0]; |
1534
|
|
|
|
|
|
|
|
1535
|
|
|
|
|
|
|
# if increment is 5 nm |
1536
|
|
|
|
|
|
|
} elsif ($inc == 5) { |
1537
|
|
|
|
|
|
|
|
1538
|
|
|
|
|
|
|
# set wavelength range |
1539
|
0
|
|
|
|
|
|
$self->[2][0] = [380, 780, 5]; |
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
# load CIE color matching functions (YAML format) |
1542
|
0
|
|
|
|
|
|
$cmf = YAML::Tiny->read(ICC::Shared::getICCPath('Data/CIE_cmfs_380-780_x_5.yml'))->[0]; |
1543
|
|
|
|
|
|
|
|
1544
|
|
|
|
|
|
|
} else { |
1545
|
|
|
|
|
|
|
|
1546
|
|
|
|
|
|
|
# error |
1547
|
0
|
|
|
|
|
|
croak('invalid spectral increment'); |
1548
|
|
|
|
|
|
|
|
1549
|
|
|
|
|
|
|
} |
1550
|
|
|
|
|
|
|
|
1551
|
|
|
|
|
|
|
# get observer from hash (default is 2) |
1552
|
0
|
0
|
|
|
|
|
$obs = defined($hash->{'observer'}) ? $hash->{'observer'} : 2; |
1553
|
|
|
|
|
|
|
|
1554
|
|
|
|
|
|
|
# if observer is an array reference |
1555
|
0
|
0
|
|
|
|
|
if (ref($obs) eq 'ARRAY') { |
1556
|
|
|
|
|
|
|
|
1557
|
|
|
|
|
|
|
# verify array size |
1558
|
0
|
0
|
|
|
|
|
(@{$obs} == 2) or croak('invalid observer array'); |
|
0
|
|
|
|
|
|
|
1559
|
|
|
|
|
|
|
|
1560
|
|
|
|
|
|
|
# verify range |
1561
|
0
|
|
|
|
|
|
(ref($obs->[0]) eq 'ARRAY' && (@{$obs->[0]} == grep {Scalar::Util::looks_like_number($_)} @{$obs->[0]}) && |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1562
|
0
|
0
|
0
|
|
|
|
@{$obs->[0]} == 3 && $obs->[0][2] && ! (($obs->[0][1] - $obs->[0][0]) % $obs->[0][2])) or croak('invalid observer wavelength range'); |
|
0
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
1563
|
|
|
|
|
|
|
|
1564
|
|
|
|
|
|
|
# compute upper index of observer matrix |
1565
|
0
|
0
|
|
|
|
|
(($sx = ICC::Shared::round(($obs->[0][1] - $obs->[0][0])/$obs->[0][2])) > 0) or croak('inconsistent observer wavelength range'); |
1566
|
|
|
|
|
|
|
|
1567
|
|
|
|
|
|
|
# verify observer matrix |
1568
|
|
|
|
|
|
|
((ref($obs->[1]) eq 'ARRAY' || UNIVERSAL::isa($obs->[1], 'Math::Matrix')) && ref($obs->[1][0]) eq 'ARRAY' && |
1569
|
0
|
0
|
0
|
|
|
|
$#{$obs->[1][0]} == $sx && @{$obs->[1][0]} == grep {Scalar::Util::looks_like_number($_)} @{$obs->[1][0]}) or croak('invalid observer cmf matrix'); |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1570
|
|
|
|
|
|
|
|
1571
|
|
|
|
|
|
|
# copy array contents |
1572
|
0
|
|
|
|
|
|
$self->[2] = Storable::dclone($obs); |
1573
|
|
|
|
|
|
|
|
1574
|
|
|
|
|
|
|
} else { |
1575
|
|
|
|
|
|
|
|
1576
|
|
|
|
|
|
|
# get observer key |
1577
|
0
|
0
|
|
|
|
|
($key = {'2' => 'CIE1931', '10' => 'CIE1964', '2P' => 'CIE2012D2', '10P' => 'CIE2012D10'}->{$obs}) or croak('invalid observer key'); |
1578
|
|
|
|
|
|
|
|
1579
|
|
|
|
|
|
|
# set CIE color-matching functions |
1580
|
0
|
|
|
|
|
|
$self->[2][1][0] = $cmf->{$key . 'x'}; |
1581
|
0
|
|
|
|
|
|
$self->[2][1][1] = $cmf->{$key . 'y'}; |
1582
|
0
|
|
|
|
|
|
$self->[2][1][2] = $cmf->{$key . 'z'}; |
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
} |
1585
|
|
|
|
|
|
|
|
1586
|
|
|
|
|
|
|
# compute color-weight functions |
1587
|
0
|
|
|
|
|
|
_make_cwf($self); |
1588
|
|
|
|
|
|
|
|
1589
|
|
|
|
|
|
|
# set object type |
1590
|
0
|
|
|
|
|
|
$self->[0]{'type'} = 'CIE'; |
1591
|
|
|
|
|
|
|
|
1592
|
|
|
|
|
|
|
} |
1593
|
|
|
|
|
|
|
|
1594
|
|
|
|
|
|
|
# read ASTM color weight functions and white point |
1595
|
|
|
|
|
|
|
# illuminant, observer, increment and bandpass specified in hash |
1596
|
|
|
|
|
|
|
# parameters: (object_reference, hash) |
1597
|
|
|
|
|
|
|
# results are saved in the object |
1598
|
|
|
|
|
|
|
sub _astm { |
1599
|
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
|
# get parameters |
1601
|
0
|
|
|
0
|
|
|
my ($self, $hash) = @_; |
1602
|
|
|
|
|
|
|
|
1603
|
|
|
|
|
|
|
# local variables |
1604
|
0
|
|
|
|
|
|
my ($table, $id, @bpc, @inc, @obs, @illum, @m, $nm); |
1605
|
|
|
|
|
|
|
|
1606
|
|
|
|
|
|
|
# initialize id |
1607
|
0
|
|
|
|
|
|
$id = 1; |
1608
|
|
|
|
|
|
|
|
1609
|
|
|
|
|
|
|
# if increment key in hash |
1610
|
0
|
0
|
|
|
|
|
if (defined($hash->{'increment'})) { |
1611
|
|
|
|
|
|
|
|
1612
|
|
|
|
|
|
|
# enumerate ASTM increments |
1613
|
0
|
|
|
|
|
|
@inc = qw(10 20); |
1614
|
|
|
|
|
|
|
|
1615
|
|
|
|
|
|
|
# match observer value |
1616
|
0
|
0
|
|
|
|
|
(@m = grep {$hash->{'increment'} eq $inc[$_]} (0 .. $#inc)) || warn('invalid increment value - using 10 nm'); |
|
0
|
|
|
|
|
|
|
1617
|
|
|
|
|
|
|
|
1618
|
|
|
|
|
|
|
# adjust id for increment |
1619
|
0
|
0
|
|
|
|
|
$id += @m ? $m[0] : 0; |
1620
|
|
|
|
|
|
|
|
1621
|
|
|
|
|
|
|
} |
1622
|
|
|
|
|
|
|
|
1623
|
|
|
|
|
|
|
# if observer key in hash |
1624
|
0
|
0
|
|
|
|
|
if (defined($hash->{'observer'})) { |
1625
|
|
|
|
|
|
|
|
1626
|
|
|
|
|
|
|
# enumerate ASTM observers |
1627
|
0
|
|
|
|
|
|
@obs = qw(2 10); |
1628
|
|
|
|
|
|
|
|
1629
|
|
|
|
|
|
|
# match observer value |
1630
|
0
|
0
|
|
|
|
|
(@m = grep {$hash->{'observer'} eq $obs[$_]} (0 .. $#obs)) || warn('invalid observer value - using 1931 2º'); |
|
0
|
|
|
|
|
|
|
1631
|
|
|
|
|
|
|
|
1632
|
|
|
|
|
|
|
# adjust id for observer |
1633
|
0
|
0
|
|
|
|
|
$id += @m ? 2 * $m[0] : 0; |
1634
|
|
|
|
|
|
|
|
1635
|
|
|
|
|
|
|
} |
1636
|
|
|
|
|
|
|
|
1637
|
|
|
|
|
|
|
# if illuminant key in hash |
1638
|
0
|
0
|
|
|
|
|
if (defined($hash->{'illuminant'})) { |
1639
|
|
|
|
|
|
|
|
1640
|
|
|
|
|
|
|
# enumerate ASTM illuminants |
1641
|
0
|
|
|
|
|
|
@illum = qw(A C D50 D55 D65 D75 F2 F7 F11); |
1642
|
|
|
|
|
|
|
|
1643
|
|
|
|
|
|
|
# match illuminant value |
1644
|
0
|
0
|
|
|
|
|
(@m = grep {$hash->{'illuminant'} eq $illum[$_]} (0 .. $#illum)) || warn('invalid illuminant value - using D50'); |
|
0
|
|
|
|
|
|
|
1645
|
|
|
|
|
|
|
|
1646
|
|
|
|
|
|
|
# adjust id for illuminant |
1647
|
0
|
0
|
|
|
|
|
$id += @m ? 4 * $m[0] : 8; |
1648
|
|
|
|
|
|
|
|
1649
|
|
|
|
|
|
|
} else { |
1650
|
|
|
|
|
|
|
|
1651
|
|
|
|
|
|
|
# adjust id for D50 illuminant |
1652
|
0
|
|
|
|
|
|
$id += 8; |
1653
|
|
|
|
|
|
|
|
1654
|
|
|
|
|
|
|
} |
1655
|
|
|
|
|
|
|
|
1656
|
|
|
|
|
|
|
# set table: 5 (no bpc) -or- 6 (with bpc) |
1657
|
|
|
|
|
|
|
# note: table 6 is deprecated in ASTM E 2729 |
1658
|
0
|
0
|
0
|
|
|
|
$table = (defined($hash->{'bandpass'}) && $hash->{'bandpass'} eq 'six') ? 6 : 5; |
1659
|
|
|
|
|
|
|
|
1660
|
|
|
|
|
|
|
# combine table and id |
1661
|
0
|
|
|
|
|
|
$table .= '.' . $id; |
1662
|
|
|
|
|
|
|
|
1663
|
|
|
|
|
|
|
# load ASTM weight functions (YAML format) |
1664
|
0
|
|
|
|
|
|
state $ASTM = YAML::Tiny->read(ICC::Shared::getICCPath('Data/ASTM_E308_data.yml'))->[0]; |
1665
|
|
|
|
|
|
|
|
1666
|
|
|
|
|
|
|
# get wavelength vector |
1667
|
0
|
|
|
|
|
|
$nm = $ASTM->{$table . 'nm'}; |
1668
|
|
|
|
|
|
|
|
1669
|
|
|
|
|
|
|
# set wavelength start, end, and increment |
1670
|
0
|
|
|
|
|
|
$self->[3][0] = [$nm->[0], $nm->[-1], $nm->[1] - $nm->[0]]; |
1671
|
|
|
|
|
|
|
|
1672
|
|
|
|
|
|
|
# set color-weight functions |
1673
|
0
|
|
|
|
|
|
$self->[3][1][0] = $ASTM->{$table . 'x'}; |
1674
|
0
|
|
|
|
|
|
$self->[3][1][1] = $ASTM->{$table . 'y'}; |
1675
|
0
|
|
|
|
|
|
$self->[3][1][2] = $ASTM->{$table . 'z'}; |
1676
|
|
|
|
|
|
|
|
1677
|
|
|
|
|
|
|
# set illuminant white point |
1678
|
0
|
|
|
|
|
|
$self->[5] = $ASTM->{$table . 'wp'}; |
1679
|
|
|
|
|
|
|
|
1680
|
|
|
|
|
|
|
# set object type |
1681
|
0
|
|
|
|
|
|
$self->[0]{'type'} = 'ASTM'; |
1682
|
|
|
|
|
|
|
|
1683
|
|
|
|
|
|
|
} |
1684
|
|
|
|
|
|
|
|
1685
|
|
|
|
|
|
|
# read ISO 5-3 density weight functions |
1686
|
|
|
|
|
|
|
# status and increment specified in hash |
1687
|
|
|
|
|
|
|
# parameters: (object_reference, hash) |
1688
|
|
|
|
|
|
|
# results are saved in the object |
1689
|
|
|
|
|
|
|
sub _iso { |
1690
|
|
|
|
|
|
|
|
1691
|
|
|
|
|
|
|
# get parameters |
1692
|
0
|
|
|
0
|
|
|
my ($self, $hash) = @_; |
1693
|
|
|
|
|
|
|
|
1694
|
|
|
|
|
|
|
# local variables |
1695
|
0
|
|
|
|
|
|
my ($status, $inc, @m, $nm); |
1696
|
|
|
|
|
|
|
|
1697
|
|
|
|
|
|
|
# initialize table selectors |
1698
|
0
|
|
|
|
|
|
$status = 'T'; |
1699
|
0
|
|
|
|
|
|
$inc = '10'; |
1700
|
|
|
|
|
|
|
|
1701
|
|
|
|
|
|
|
# if status key in hash |
1702
|
0
|
0
|
|
|
|
|
if (defined($hash->{'status'})) { |
1703
|
|
|
|
|
|
|
|
1704
|
|
|
|
|
|
|
# match status value |
1705
|
0
|
0
|
|
|
|
|
(@m = grep {$hash->{'status'} eq $_} qw(A M T E I)) || warn('invalid status value - using T'); |
|
0
|
|
|
|
|
|
|
1706
|
|
|
|
|
|
|
|
1707
|
|
|
|
|
|
|
# set status |
1708
|
0
|
0
|
|
|
|
|
$status = @m ? $m[0] : 'T'; |
1709
|
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
|
} |
1711
|
|
|
|
|
|
|
|
1712
|
|
|
|
|
|
|
# if increment key in hash |
1713
|
0
|
0
|
|
|
|
|
if (defined($hash->{'increment'})) { |
1714
|
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
|
# match observer value |
1716
|
0
|
0
|
|
|
|
|
(@m = grep {$hash->{'increment'} eq $_} qw(10 20)) || warn('invalid increment value - using 10 nm'); |
|
0
|
|
|
|
|
|
|
1717
|
|
|
|
|
|
|
|
1718
|
|
|
|
|
|
|
# set increment |
1719
|
0
|
0
|
|
|
|
|
$inc = @m ? $m[0] : '10'; |
1720
|
|
|
|
|
|
|
|
1721
|
|
|
|
|
|
|
} |
1722
|
|
|
|
|
|
|
|
1723
|
|
|
|
|
|
|
# load ISO 5-3 weight functions (YAML format) |
1724
|
0
|
|
|
|
|
|
state $ISO = YAML::Tiny->read(ICC::Shared::getICCPath('Data/ISO_5-3_data.yml'))->[0]; |
1725
|
|
|
|
|
|
|
|
1726
|
|
|
|
|
|
|
# get wavelength vector |
1727
|
0
|
|
|
|
|
|
$nm = $ISO->{$inc . 'nm'}; |
1728
|
|
|
|
|
|
|
|
1729
|
|
|
|
|
|
|
# set wavelength start, end, and increment |
1730
|
0
|
|
|
|
|
|
$self->[3][0] = [$nm->[0], $nm->[-1], $nm->[1] - $nm->[0]]; |
1731
|
|
|
|
|
|
|
|
1732
|
|
|
|
|
|
|
# set density weight functions |
1733
|
0
|
|
|
|
|
|
$self->[3][1][0] = $ISO->{$inc . $status . 'r'}; |
1734
|
0
|
|
|
|
|
|
$self->[3][1][1] = $ISO->{$inc . $status . 'g'}; |
1735
|
0
|
|
|
|
|
|
$self->[3][1][2] = $ISO->{$inc . $status . 'b'}; |
1736
|
0
|
|
|
|
|
|
$self->[3][1][3] = $ISO->{$inc . 'vis'}; |
1737
|
|
|
|
|
|
|
|
1738
|
|
|
|
|
|
|
# set density weight function sums |
1739
|
0
|
|
|
|
|
|
$self->[5][0] = List::Util::sum(@{$self->[3][1][0]}); |
|
0
|
|
|
|
|
|
|
1740
|
0
|
|
|
|
|
|
$self->[5][1] = List::Util::sum(@{$self->[3][1][1]}); |
|
0
|
|
|
|
|
|
|
1741
|
0
|
|
|
|
|
|
$self->[5][2] = List::Util::sum(@{$self->[3][1][2]}); |
|
0
|
|
|
|
|
|
|
1742
|
0
|
|
|
|
|
|
$self->[5][3] = List::Util::sum(@{$self->[3][1][3]}); |
|
0
|
|
|
|
|
|
|
1743
|
|
|
|
|
|
|
|
1744
|
|
|
|
|
|
|
# set object type |
1745
|
0
|
|
|
|
|
|
$self->[0]{'type'} = 'ISO'; |
1746
|
|
|
|
|
|
|
|
1747
|
|
|
|
|
|
|
} |
1748
|
|
|
|
|
|
|
|
1749
|
|
|
|
|
|
|
# compute vector smoothness |
1750
|
|
|
|
|
|
|
# (returns 0 if vector is linear) |
1751
|
|
|
|
|
|
|
# parameter: (vector) |
1752
|
|
|
|
|
|
|
# returns: (linearity) |
1753
|
|
|
|
|
|
|
sub _smoothness { |
1754
|
|
|
|
|
|
|
|
1755
|
|
|
|
|
|
|
# get parameter |
1756
|
0
|
|
|
0
|
|
|
my $v = shift(); |
1757
|
|
|
|
|
|
|
|
1758
|
|
|
|
|
|
|
# local variables |
1759
|
0
|
|
|
|
|
|
my ($d, $s); |
1760
|
|
|
|
|
|
|
|
1761
|
|
|
|
|
|
|
# return if < 3 vector elements |
1762
|
0
|
0
|
|
|
|
|
return(0) if (@{$v} < 3); |
|
0
|
|
|
|
|
|
|
1763
|
|
|
|
|
|
|
|
1764
|
|
|
|
|
|
|
# for each triplet |
1765
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$v} - 2) { |
|
0
|
|
|
|
|
|
|
1766
|
|
|
|
|
|
|
|
1767
|
|
|
|
|
|
|
# add linear deviation |
1768
|
0
|
|
|
|
|
|
$d += (2 * $v->[$i + 1] - $v->[$i] - $v->[$i + 2])**2; |
1769
|
|
|
|
|
|
|
|
1770
|
|
|
|
|
|
|
# add outer magnitudes |
1771
|
0
|
|
|
|
|
|
$s += abs($v->[$i]) + abs($v->[$i + 2]); |
1772
|
|
|
|
|
|
|
|
1773
|
|
|
|
|
|
|
} |
1774
|
|
|
|
|
|
|
|
1775
|
|
|
|
|
|
|
# return relative rms value |
1776
|
0
|
0
|
|
|
|
|
return($s ? sqrt($d)/$s : 0); |
1777
|
|
|
|
|
|
|
|
1778
|
|
|
|
|
|
|
} |
1779
|
|
|
|
|
|
|
|
1780
|
|
|
|
|
|
|
# get encoding CODE reference |
1781
|
|
|
|
|
|
|
# parameter(object_reference, hash) |
1782
|
|
|
|
|
|
|
# returns: (CODE_reference) |
1783
|
|
|
|
|
|
|
sub _encoding { |
1784
|
|
|
|
|
|
|
|
1785
|
|
|
|
|
|
|
# get parameters |
1786
|
0
|
|
|
0
|
|
|
my ($self, $hash) = @_; |
1787
|
|
|
|
|
|
|
|
1788
|
|
|
|
|
|
|
# local variables |
1789
|
0
|
|
|
|
|
|
my ($encoding, $size); |
1790
|
|
|
|
|
|
|
|
1791
|
|
|
|
|
|
|
# if hash contain 'encoding' value, but not 'XYZ', 'RGBV' or 'linear' |
1792
|
0
|
0
|
0
|
|
|
|
if (defined($encoding = $hash->{'encoding'}) && $encoding !~ m/^(XYZ|RGBV|linear)$/) { |
1793
|
|
|
|
|
|
|
|
1794
|
|
|
|
|
|
|
# get output size |
1795
|
0
|
|
|
|
|
|
$size = @{$self->[3][1]}; |
|
0
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
|
|
1797
|
|
|
|
|
|
|
# if encoding is 'ICC_XYZ' |
1798
|
0
|
0
|
0
|
|
|
|
if ($encoding eq 'ICC_XYZ' && $size == 3) { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
1799
|
|
|
|
|
|
|
|
1800
|
|
|
|
|
|
|
# return code reference |
1801
|
0
|
|
|
0
|
|
|
return(sub {map {$_ * 327.68/65535} @_}); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1802
|
|
|
|
|
|
|
|
1803
|
|
|
|
|
|
|
# if encoding is 'ICC_XYZNumber' |
1804
|
|
|
|
|
|
|
} elsif ($encoding eq 'ICC_XYZNumber' && $size == 3) { |
1805
|
|
|
|
|
|
|
|
1806
|
|
|
|
|
|
|
# return code reference |
1807
|
0
|
|
|
0
|
|
|
return(sub {map {$_/100} @_}); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1808
|
|
|
|
|
|
|
|
1809
|
|
|
|
|
|
|
# if encoding is 'xyz' |
1810
|
|
|
|
|
|
|
} elsif ($encoding eq 'xyz' && $size == 3) { |
1811
|
|
|
|
|
|
|
|
1812
|
|
|
|
|
|
|
# verify white point |
1813
|
0
|
0
|
0
|
|
|
|
($self->[5][0] && $self->[5][1] && $self->[5][2]) or croak('invalid illuminant white point'); |
|
|
|
0
|
|
|
|
|
1814
|
|
|
|
|
|
|
|
1815
|
|
|
|
|
|
|
# return code reference |
1816
|
0
|
|
|
0
|
|
|
return(sub {$_[0]/$self->[5][0], $_[1]/$self->[5][1], $_[2]/$self->[5][2]}); |
|
0
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
|
|
1818
|
|
|
|
|
|
|
# if encoding is 'unit' |
1819
|
|
|
|
|
|
|
} elsif ($encoding eq 'unit' && $size == 4) { |
1820
|
|
|
|
|
|
|
|
1821
|
|
|
|
|
|
|
# return code reference |
1822
|
0
|
|
|
0
|
|
|
return(sub {map {$_/100} @_}); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1823
|
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
|
# if encoding is 'density' |
1825
|
|
|
|
|
|
|
} elsif ($encoding eq 'density' && $size == 4) { |
1826
|
|
|
|
|
|
|
|
1827
|
|
|
|
|
|
|
# return code reference |
1828
|
0
|
0
|
|
0
|
|
|
return(sub {map {$_ > 0 ? -POSIX::log10($_/100) : 99} @_}); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1829
|
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
|
} else { |
1831
|
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
|
# error |
1833
|
0
|
|
|
|
|
|
croak('unsupported XYZ/RGBV encoding'); |
1834
|
|
|
|
|
|
|
|
1835
|
|
|
|
|
|
|
} |
1836
|
|
|
|
|
|
|
|
1837
|
|
|
|
|
|
|
} else { |
1838
|
|
|
|
|
|
|
|
1839
|
|
|
|
|
|
|
# return empty |
1840
|
0
|
|
|
|
|
|
return(); |
1841
|
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
|
} |
1843
|
|
|
|
|
|
|
|
1844
|
|
|
|
|
|
|
} |
1845
|
|
|
|
|
|
|
|
1846
|
|
|
|
|
|
|
# set object contents from parameter hash |
1847
|
|
|
|
|
|
|
# parameters: (object_reference, ref_to_parameter_hash) |
1848
|
|
|
|
|
|
|
sub _new_from_hash { |
1849
|
|
|
|
|
|
|
|
1850
|
|
|
|
|
|
|
# get parameters |
1851
|
0
|
|
|
0
|
|
|
my ($self, $hash) = @_; |
1852
|
|
|
|
|
|
|
|
1853
|
|
|
|
|
|
|
# local variables |
1854
|
0
|
|
|
|
|
|
my ($range, $ox); |
1855
|
|
|
|
|
|
|
|
1856
|
|
|
|
|
|
|
# save colorimetry hash in object header |
1857
|
0
|
|
|
|
|
|
$self->[0] = Storable::dclone($hash); |
1858
|
|
|
|
|
|
|
|
1859
|
|
|
|
|
|
|
# if 'range' is defined |
1860
|
0
|
0
|
|
|
|
|
if (defined($range = $hash->{'range'})) { |
1861
|
|
|
|
|
|
|
|
1862
|
|
|
|
|
|
|
# verify wavelength range structure |
1863
|
0
|
0
|
0
|
|
|
|
(ref($range) eq 'ARRAY' && 3 == @{$range} && (3 == grep {Scalar::Util::looks_like_number($_)} @{$range})) or croak('invalid wavelength range structure'); |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1864
|
|
|
|
|
|
|
|
1865
|
|
|
|
|
|
|
# compute upper index |
1866
|
0
|
|
|
|
|
|
$ox = ICC::Shared::round(($range->[1] - $range->[0])/$range->[2]); |
1867
|
|
|
|
|
|
|
|
1868
|
|
|
|
|
|
|
# verify wavelength range values |
1869
|
0
|
0
|
0
|
|
|
|
($ox > 0 && abs($ox * $range->[2] - $range->[1] + $range->[0]) < 1E-12 && $range->[2] > 0) or croak('invalid wavelength range values'); |
|
|
|
0
|
|
|
|
|
1870
|
|
|
|
|
|
|
|
1871
|
|
|
|
|
|
|
# add range to hash |
1872
|
0
|
|
|
|
|
|
$srh->{$ox + 1} = $range; |
1873
|
|
|
|
|
|
|
|
1874
|
|
|
|
|
|
|
} |
1875
|
|
|
|
|
|
|
|
1876
|
|
|
|
|
|
|
# if 'status' is defined, a scalar |
1877
|
0
|
0
|
0
|
|
|
|
if (defined($hash->{'status'}) && ! ref($hash->{'status'})) { |
|
|
0
|
0
|
|
|
|
|
1878
|
|
|
|
|
|
|
|
1879
|
|
|
|
|
|
|
# read ISO 5-3 color-weight functions (density) |
1880
|
0
|
|
|
|
|
|
_iso($self, $hash); |
1881
|
|
|
|
|
|
|
|
1882
|
|
|
|
|
|
|
# if 'illuminant' is defined, an ARRAY ref |
1883
|
|
|
|
|
|
|
} elsif (defined($hash->{'illuminant'}) && ref($hash->{'illuminant'}) eq 'ARRAY') { |
1884
|
|
|
|
|
|
|
|
1885
|
|
|
|
|
|
|
# read CIE illuminant and color-matching functions, compute color-weight functions |
1886
|
0
|
|
|
|
|
|
_cie($self, $hash); |
1887
|
|
|
|
|
|
|
|
1888
|
|
|
|
|
|
|
} else { |
1889
|
|
|
|
|
|
|
|
1890
|
|
|
|
|
|
|
# read ASTM color-weight functions |
1891
|
0
|
|
|
|
|
|
_astm($self, $hash); |
1892
|
|
|
|
|
|
|
|
1893
|
|
|
|
|
|
|
} |
1894
|
|
|
|
|
|
|
|
1895
|
|
|
|
|
|
|
} |
1896
|
|
|
|
|
|
|
|
1897
|
|
|
|
|
|
|
1; |
1898
|
|
|
|
|
|
|
|