line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package ICC::Support::nMIX; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
108203
|
use strict; |
|
2
|
|
|
|
|
16
|
|
|
2
|
|
|
|
|
58
|
|
4
|
2
|
|
|
2
|
|
12
|
use Carp; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
150
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
our $VERSION = 0.31; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
# revised 2016-05-17 |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# Copyright © 2004-2019 by William B. Birkett |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# add development directory |
13
|
2
|
|
|
2
|
|
477
|
use lib 'lib'; |
|
2
|
|
|
|
|
781
|
|
|
2
|
|
|
|
|
14
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# inherit from Shared |
16
|
2
|
|
|
2
|
|
673
|
use parent qw(ICC::Shared); |
|
2
|
|
|
|
|
325
|
|
|
2
|
|
|
|
|
12
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# enable static variables |
19
|
2
|
|
|
2
|
|
141
|
use feature 'state'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
9294
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# create new nMIX object |
22
|
|
|
|
|
|
|
# parameter may be a hash -or- an ICC::Support::Chart object |
23
|
|
|
|
|
|
|
# columns is an optional column slice for the chart clut data |
24
|
|
|
|
|
|
|
# hash may contain references to clut array or delta array |
25
|
|
|
|
|
|
|
# hash keys are: ('array', 'delta') |
26
|
|
|
|
|
|
|
# parameter: () |
27
|
|
|
|
|
|
|
# parameter: (ref_to_attribute_hash) |
28
|
|
|
|
|
|
|
# parameter: (chart_object, [columns]) |
29
|
|
|
|
|
|
|
# returns: (ref_to_object) |
30
|
|
|
|
|
|
|
sub new { |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# get object class |
33
|
1
|
|
|
1
|
0
|
969
|
my $class = shift(); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# create empty nMIX object |
36
|
1
|
|
|
|
|
4
|
my $self = [ |
37
|
|
|
|
|
|
|
{}, # object header |
38
|
|
|
|
|
|
|
[], # clut |
39
|
|
|
|
|
|
|
[], # delta |
40
|
|
|
|
|
|
|
[], # clut exp |
41
|
|
|
|
|
|
|
undef, # clut exp cache (for Lapack) |
42
|
|
|
|
|
|
|
]; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
# if there are parameters |
45
|
1
|
50
|
|
|
|
5
|
if (@_) { |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# if one parameter, a hash reference |
48
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 && ref($_[0]) eq 'HASH') { |
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
# make new nMIX object from attribute hash |
51
|
0
|
|
|
|
|
0
|
_new_from_hash($self, @_); |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# if one or two parameters, first parameter an ICC::Support::Chart object |
54
|
|
|
|
|
|
|
} elsif ((@_ == 1 || @_ == 2) && UNIVERSAL::isa($_[0], 'ICC::Support::Chart')) { |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
# make new nMIX object from chart |
57
|
0
|
|
|
|
|
0
|
_new_from_chart($self, @_); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
} else { |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# error |
62
|
0
|
|
|
|
|
0
|
croak('parameter must be a hash reference or ICC::Support::Chart object'); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
# bless object |
69
|
1
|
|
|
|
|
2
|
bless($self, $class); |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
# return object reference |
72
|
1
|
|
|
|
|
3
|
return($self); |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# get/set reference to header hash |
77
|
|
|
|
|
|
|
# parameters: ([ref_to_new_hash]) |
78
|
|
|
|
|
|
|
# returns: (ref_to_hash) |
79
|
|
|
|
|
|
|
sub header { |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# get object reference |
82
|
0
|
|
|
0
|
0
|
|
my $self = shift(); |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# if there are parameters |
85
|
0
|
0
|
|
|
|
|
if (@_) { |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# if one parameter, a hash reference |
88
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'HASH') { |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# set header to copy of hash |
91
|
0
|
|
|
|
|
|
$self->[0] = {%{$_[0]}}; |
|
0
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
} else { |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# error |
96
|
0
|
|
|
|
|
|
croak('parameter must be a hash reference'); |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# return reference |
103
|
0
|
|
|
|
|
|
return($self->[0]); |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
# get/set reference to clut array |
108
|
|
|
|
|
|
|
# parameters: ([ref_to_new_array]) |
109
|
|
|
|
|
|
|
# returns: (ref_to_array) |
110
|
|
|
|
|
|
|
sub array { |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# get object reference |
113
|
0
|
|
|
0
|
0
|
|
my $self = shift(); |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
# if there are parameters |
116
|
0
|
0
|
|
|
|
|
if (@_) { |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
# if one parameter, a 2-D array reference |
119
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'ARRAY' && @{$_[0]} == grep {ref() eq 'ARRAY'} @{$_[0]}) { |
|
0
|
0
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# copy array to object and bless |
122
|
0
|
|
|
|
|
|
$self->[1] = bless(Storable::dclone($_[0]), 'Math::Matrix'); |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
# if one parameter, a Math::Matrix object |
125
|
|
|
|
|
|
|
} elsif (@_ == 1 && UNIVERSAL::isa($_[0], 'Math::Matrix')) { |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
# copy matrix to object |
128
|
0
|
|
|
|
|
|
$self->[1] = Storable::dclone($_[0]); |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
} else { |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
# error |
133
|
0
|
|
|
|
|
|
croak('clut must be a 2-D array reference or Math::Matrix object'); |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# for each corner point |
138
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$self->[1]}) { |
|
0
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
# for each spectral value |
141
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$self->[1][$i]}) { |
|
0
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# set value to zero, if negative |
144
|
0
|
0
|
|
|
|
|
$self->[1][$i][$j] = 0 if ($self->[1][$i][$j] < 0); |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# update arrays |
151
|
0
|
|
|
|
|
|
_update_clut_exp($self); |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# return reference |
156
|
0
|
|
|
|
|
|
return($self->[1]); |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# get/set reference to delta array |
161
|
|
|
|
|
|
|
# scalar value parameter fills array with that value |
162
|
|
|
|
|
|
|
# parameters: ([ref_to_new_array -or- scalar_value]) |
163
|
|
|
|
|
|
|
# returns: (ref_to_array) |
164
|
|
|
|
|
|
|
sub delta { |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# get object reference |
167
|
0
|
|
|
0
|
0
|
|
my $self = shift(); |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# if there are parameters |
170
|
0
|
0
|
|
|
|
|
if (@_) { |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
# if one parameter, a 1-D array reference |
173
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'ARRAY' && @{$_[0]} == grep {Scalar::Util::looks_like_number($_)} @{$_[0]}) { |
|
0
|
0
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
# make delta array |
176
|
0
|
|
|
|
|
|
$self->[2] = [@{$_[0]}]; |
|
0
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# if one parameter, a scalar number |
179
|
|
|
|
|
|
|
} elsif (@_ == 1 && Scalar::Util::looks_like_number($_[0])) { |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
# if array is defined |
182
|
0
|
0
|
|
|
|
|
if (defined($self->[1])) { |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
# make delta array |
185
|
0
|
|
|
|
|
|
$self->[2] = [($_[0]) x @{$self->[1][0]}]; |
|
0
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
} else { |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# error |
190
|
0
|
|
|
|
|
|
croak ('array must be defined when specifying delta as a scalar'); |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
} else { |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# error |
197
|
0
|
|
|
|
|
|
croak('\'delta\' parameter must be a scalar or a 1-D array reference'); |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
# update arrays |
202
|
0
|
|
|
|
|
|
_update_clut_exp($self); |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
# return reference |
207
|
0
|
|
|
|
|
|
return($self->[2]); |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
# get number of input channels |
212
|
|
|
|
|
|
|
# returns: (number) |
213
|
|
|
|
|
|
|
sub cin { |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# get object reference |
216
|
0
|
|
|
0
|
0
|
|
my $self = shift(); |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
# return |
219
|
0
|
|
|
|
|
|
return(int(log(@{$self->[1]})/log(2) + 1E-12)); |
|
0
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
# get number of output channels |
224
|
|
|
|
|
|
|
# returns: (number) |
225
|
|
|
|
|
|
|
sub cout { |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# get object reference |
228
|
0
|
|
|
0
|
0
|
|
my $self = shift(); |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
# return |
231
|
0
|
|
|
|
|
|
return(scalar(@{$self->[1][0]})); |
|
0
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# transform data |
236
|
|
|
|
|
|
|
# supported input types: |
237
|
|
|
|
|
|
|
# parameters: (list, [hash]) |
238
|
|
|
|
|
|
|
# parameters: (vector, [hash]) |
239
|
|
|
|
|
|
|
# parameters: (matrix, [hash]) |
240
|
|
|
|
|
|
|
# parameters: (Math::Matrix_object, [hash]) |
241
|
|
|
|
|
|
|
# parameters: (structure, [hash]) |
242
|
|
|
|
|
|
|
# returns: (same_type_as_input) |
243
|
|
|
|
|
|
|
sub transform { |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
# set hash value (0 or 1) |
246
|
0
|
0
|
|
0
|
0
|
|
my $h = ref($_[-1]) eq 'HASH' ? 1 : 0; |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
# if input a 'Math::Matrix' object |
249
|
0
|
0
|
0
|
|
|
|
if (@_ == $h + 2 && UNIVERSAL::isa($_[1], 'Math::Matrix')) { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
# call matrix transform |
252
|
0
|
|
|
|
|
|
&_trans2; |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# if input an array reference |
255
|
|
|
|
|
|
|
} elsif (@_ == $h + 2 && ref($_[1]) eq 'ARRAY') { |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
# if array contains numbers (vector) |
258
|
0
|
0
|
0
|
|
|
|
if (! ref($_[1][0]) && @{$_[1]} == grep {Scalar::Util::looks_like_number($_)} @{$_[1]}) { |
|
0
|
0
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
# call vector transform |
261
|
0
|
|
|
|
|
|
&_trans1; |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
# if array contains vectors (2-D array) |
264
|
0
|
0
|
|
|
|
|
} elsif (ref($_[1][0]) eq 'ARRAY' && @{$_[1]} == grep {ref($_) eq 'ARRAY' && Scalar::Util::looks_like_number($_->[0])} @{$_[1]}) { |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
# call matrix transform |
267
|
0
|
|
|
|
|
|
&_trans2; |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
} else { |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# call structure transform |
272
|
0
|
|
|
|
|
|
&_trans3; |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
# if input a list (of numbers) |
277
|
0
|
|
|
|
|
|
} elsif (@_ == $h + 1 + grep {Scalar::Util::looks_like_number($_)} @_) { |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# call list transform |
280
|
0
|
|
|
|
|
|
&_trans0; |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
} else { |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
# error |
285
|
0
|
|
|
|
|
|
croak('invalid transform input'); |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
# compute Jacobian matrix |
292
|
|
|
|
|
|
|
# nominal input range is (0 - 1) |
293
|
|
|
|
|
|
|
# hash key 'ubox' enables unit box extrapolation |
294
|
|
|
|
|
|
|
# clipped outputs are extrapolated using Jacobian |
295
|
|
|
|
|
|
|
# parameters: (input_vector, [hash]) |
296
|
|
|
|
|
|
|
# returns: (Jacobian_matrix, [output_vector]) |
297
|
|
|
|
|
|
|
sub jacobian { |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
# get parameters |
300
|
0
|
|
|
0
|
0
|
|
my ($self, $in, $hash) = @_; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
# local variables |
303
|
0
|
|
|
|
|
|
my ($ext, $out, $jac, $jac_bc, $d, $s, $dx); |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
306
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
# if extrapolation required (any input outside the unit box) |
309
|
0
|
0
|
0
|
|
|
|
if ($hash->{'ubox'} && grep {$_ < 0.0 || $_ > 1.0} @{$in}) { |
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
# compute intersection with unit box |
312
|
0
|
|
|
|
|
|
($ext, $in) = _intersect($in); |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
# if ICC::Support::Lapack module is loaded |
317
|
0
|
0
|
|
|
|
|
if ($lapack) { |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
# compute output using Lapack module |
320
|
0
|
|
|
|
|
|
$out = ICC::Support::Lapack::nMIX_vec_trans($in, $self->[4], $self->[2]); |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
# compute Jacobian using Lapack module |
323
|
0
|
|
|
|
|
|
$jac = ICC::Support::Lapack::nMIX_jacobian($in, $self->[4], $self->[2], $out); |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
# bless Jacobian as Math::Matrix object |
326
|
0
|
|
|
|
|
|
bless($jac, 'Math::Matrix'); |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
} else { |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
# compute output values |
331
|
0
|
|
|
|
|
|
$out = _trans1($self, $in); |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# compute the barycentric jacobian |
334
|
0
|
|
|
|
|
|
$jac_bc = _barycentric_jacobian($in); |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
# compute Jacobian (before exponentiation) |
337
|
0
|
|
|
|
|
|
$jac = $self->[3]->transpose * $jac_bc; |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
# for each row (output) |
340
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$jac}) { |
|
0
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
# get delta value |
343
|
0
|
|
|
|
|
|
$d = $self->[2][$i]; |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
# skip if delta is one |
346
|
0
|
0
|
|
|
|
|
next if ($d == 1); |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
# get output value |
349
|
0
|
|
|
|
|
|
$s = $out->[$i]; |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
# compute exponentiation adjustment |
352
|
0
|
0
|
|
|
|
|
$dx = $s ? $d ? abs($s)**(1 - $d)/$d : $s : 0; |
|
|
0
|
|
|
|
|
|
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
# for each column (input) |
355
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$jac->[0]}) { |
|
0
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# adjust for exponentiation |
358
|
0
|
|
|
|
|
|
$jac->[$i][$j] *= $dx; |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
# if output values wanted |
367
|
0
|
0
|
|
|
|
|
if (wantarray) { |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
# if output extrapolated |
370
|
0
|
0
|
|
|
|
|
if (defined($ext)) { |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
# for each output |
373
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$out}) { |
|
0
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# add delta value |
376
|
0
|
|
|
|
|
|
$out->[$i] += ICC::Shared::dotProduct($jac->[$i], $ext); |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
# return Jacobian and output vector |
383
|
0
|
|
|
|
|
|
return($jac, $out); |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
} else { |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
# return Jacobian only |
388
|
0
|
|
|
|
|
|
return($jac); |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
# compute parametric Jacobian matrix |
395
|
|
|
|
|
|
|
# parameters: (input_vector) |
396
|
|
|
|
|
|
|
# returns: (parametric_jacobian_matrix) |
397
|
|
|
|
|
|
|
sub parajac { |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
# get parameters |
400
|
0
|
|
|
0
|
0
|
|
my ($self, $in) = @_; |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
# return Jacobian matrix |
403
|
0
|
|
|
|
|
|
return(Math::Matrix->diagonal(_parametric($self, $in))); |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
# print object contents to string |
408
|
|
|
|
|
|
|
# format is an array structure |
409
|
|
|
|
|
|
|
# parameter: ([format]) |
410
|
|
|
|
|
|
|
# returns: (string) |
411
|
|
|
|
|
|
|
sub sdump { |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
# get parameters |
414
|
0
|
|
|
0
|
1
|
|
my ($self, $p) = @_; |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
# local variables |
417
|
0
|
|
|
|
|
|
my ($s, $fmt); |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
# resolve parameter to an array reference |
420
|
0
|
0
|
|
|
|
|
$p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : []; |
|
|
0
|
|
|
|
|
|
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
# get format string |
423
|
0
|
0
|
0
|
|
|
|
$fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 'undef'; |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
# set string to object ID |
426
|
0
|
|
|
|
|
|
$s = sprintf("'%s' object, (0x%x)\n", ref($self), $self); |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
# return |
429
|
0
|
|
|
|
|
|
return($s); |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
# transform list |
434
|
|
|
|
|
|
|
# parameters: (object_reference, list, [hash]) |
435
|
|
|
|
|
|
|
# returns: (list) |
436
|
|
|
|
|
|
|
sub _trans0 { |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
# local variables |
439
|
0
|
|
|
0
|
|
|
my ($self, $hash); |
440
|
0
|
|
|
|
|
|
my ($coef, $sum, $product, @out); |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
443
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
# get object reference |
446
|
0
|
|
|
|
|
|
$self = shift(); |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
# get optional hash |
449
|
0
|
0
|
|
|
|
|
$hash = pop() if (ref($_[-1]) eq 'HASH'); |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
# if ICC::Support::Lapack module is loaded |
452
|
0
|
0
|
|
|
|
|
if ($lapack) { |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
# compute output using Lapack module |
455
|
0
|
|
|
|
|
|
@out = @{ICC::Support::Lapack::nMIX_vec_trans(\@_, $self->[4], $self->[2])}; |
|
0
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
} else { |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
# compute output using '_trans1' |
460
|
0
|
|
|
|
|
|
@out = @{_trans1($self, \@_)}; |
|
0
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
# return |
465
|
0
|
|
|
|
|
|
return(@out); |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
# transform vector |
470
|
|
|
|
|
|
|
# parameters: (object_reference, vector, [hash]) |
471
|
|
|
|
|
|
|
# returns: (vector) |
472
|
|
|
|
|
|
|
sub _trans1 { |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
# get parameters |
475
|
0
|
|
|
0
|
|
|
my ($self, $in, $hash) = @_; |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
# local variables |
478
|
0
|
|
|
|
|
|
my ($coef, $sum, $out); |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
481
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
# if ICC::Support::Lapack module is loaded |
484
|
0
|
0
|
|
|
|
|
if ($lapack) { |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
# compute output using Lapack module |
487
|
0
|
|
|
|
|
|
$out = ICC::Support::Lapack::nMIX_vec_trans($in, $self->[4], $self->[2]); |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
} else { |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
# compute barycentric coefficients |
492
|
0
|
|
|
|
|
|
$coef = _barycentric($in); |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
# for each output value |
495
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$self->[3][0]}) { |
|
0
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
# initialize sum |
498
|
0
|
|
|
|
|
|
$sum = 0; |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
# for each coefficient |
501
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$coef}) { |
|
0
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
# add product to sum |
504
|
0
|
0
|
|
|
|
|
$sum += $self->[3][$j][$i] * $coef->[$j] if ($coef->[$j]); |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
# save result |
509
|
0
|
|
|
|
|
|
$out->[$i] = _pow1p($sum, $self->[2][$i]); |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
# return |
516
|
0
|
|
|
|
|
|
return($out); |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
# transform matrix (2-D array -or- Math::Matrix object) |
521
|
|
|
|
|
|
|
# parameters: (object_reference, matrix, [hash]) |
522
|
|
|
|
|
|
|
# returns: (matrix) |
523
|
|
|
|
|
|
|
sub _trans2 { |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
# get parameters |
526
|
0
|
|
|
0
|
|
|
my ($self, $in, $hash) = @_; |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
# local variables |
529
|
0
|
|
|
|
|
|
my ($coef, $sum, $product, $mean, $ratio, $out); |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
532
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
# if ICC::Support::Lapack module is loaded |
535
|
0
|
0
|
|
|
|
|
if ($lapack) { |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
# compute output using Lapack module |
538
|
0
|
|
|
|
|
|
$out = ICC::Support::Lapack::nMIX_mat_trans($in, $self->[4], $self->[2]); |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
} else { |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
# for each input vector |
543
|
0
|
|
|
|
|
|
for my $k (0 .. $#{$in}) { |
|
0
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
# compute barycentric coefficients |
546
|
0
|
|
|
|
|
|
$coef = _barycentric($in->[$k]); |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
# for each output value |
549
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$self->[3][0]}) { |
|
0
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
# initialize sum |
552
|
0
|
|
|
|
|
|
$sum = 0; |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
# for each coefficient |
555
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$coef}) { |
|
0
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
# add product to sum |
558
|
0
|
0
|
|
|
|
|
$sum += $self->[3][$j][$i] * $coef->[$j] if ($coef->[$j]); |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
# save result |
563
|
0
|
|
|
|
|
|
$out->[$k][$i] = _pow1p($sum, $self->[2][$i]); |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
# return |
572
|
0
|
0
|
|
|
|
|
return(UNIVERSAL::isa($in, 'Math::Matrix') ? bless($out, 'Math::Matrix') : $out); |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
# transform structure |
577
|
|
|
|
|
|
|
# parameters: (object_reference, structure, [hash]) |
578
|
|
|
|
|
|
|
# returns: (structure) |
579
|
|
|
|
|
|
|
sub _trans3 { |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
# get parameters |
582
|
0
|
|
|
0
|
|
|
my ($self, $in, $hash) = @_; |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
# local variables |
585
|
0
|
|
|
|
|
|
my ($out); |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
# transform the array structure |
588
|
0
|
|
|
|
|
|
_crawl($self, $in, $out = [], $hash); |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
# return |
591
|
0
|
|
|
|
|
|
return($out); |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
# recursive transform |
596
|
|
|
|
|
|
|
# array structure is traversed until scalar arrays are found and transformed |
597
|
|
|
|
|
|
|
# parameters: (ref_to_object, input_array_reference, output_array_reference, hash) |
598
|
|
|
|
|
|
|
sub _crawl { |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
# get parameters |
601
|
0
|
|
|
0
|
|
|
my ($self, $in, $out, $hash) = @_; |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
# if input is a vector (reference to a scalar array) |
604
|
0
|
0
|
|
|
|
|
if (@{$in} == grep {! ref()} @{$in}) { |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
# transform input vector and copy to output |
607
|
0
|
|
|
|
|
|
@{$out} = @{_trans1($self, $in, $hash)}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
} else { |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
# for each input element |
612
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$in}) { |
|
0
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
# if an array reference |
615
|
0
|
0
|
|
|
|
|
if (ref($in->[$i]) eq 'ARRAY') { |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
# transform next level |
618
|
0
|
|
|
|
|
|
_crawl($self, $in->[$i], $out->[$i] = [], $hash); |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
} else { |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
# error |
623
|
0
|
|
|
|
|
|
croak('invalid transform input'); |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
} |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
# update exponentiated CLUT |
634
|
|
|
|
|
|
|
# parameter: (ref_to_object) |
635
|
|
|
|
|
|
|
sub _update_clut_exp { |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
# get object reference |
638
|
0
|
|
|
0
|
|
|
my $self = shift(); |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
# check if ICC::Support::Lapack module is loaded |
641
|
0
|
|
|
|
|
|
state $lapack = defined($INC{'ICC/Support/Lapack.pm'}); |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
# if clut and delta are defined and not null |
644
|
0
|
0
|
0
|
|
|
|
if (defined($self->[1]) && @{$self->[1]} && defined($self->[2]) && @{$self->[2]}) { |
|
0
|
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
# if ICC::Support::Lapack module is loaded |
647
|
0
|
0
|
|
|
|
|
if ($lapack) { |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
# compute mixture array |
650
|
0
|
|
|
|
|
|
$self->[3] = ICC::Support::Lapack::nMIX_power($self->[1], $self->[2]); |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
# create cached mixture array |
653
|
0
|
|
|
|
|
|
$self->[4] = ICC::Support::Lapack::cache_2D($self->[3]); |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
} else { |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
# for each row |
658
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$self->[1]}) { |
|
0
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
# for each column |
661
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$self->[1][0]}) { |
|
0
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
# exponentiate corner point value |
664
|
0
|
|
|
|
|
|
$self->[3][$i][$j] = _powm1($self->[1][$i][$j], $self->[2][$j]); |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
} |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
# bless as Math::Matrix object |
675
|
0
|
|
|
|
|
|
bless($self->[3], 'Math::Matrix'); |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
} |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
# compute barycentric coefficients |
680
|
|
|
|
|
|
|
# parameter: (input_vector) |
681
|
|
|
|
|
|
|
# returns: (coefficient_array) |
682
|
|
|
|
|
|
|
sub _barycentric { |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
# get parameter |
685
|
0
|
|
|
0
|
|
|
my $dev = shift(); |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
# local variables |
688
|
0
|
|
|
|
|
|
my ($devc, $coef); |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
# compute complement values |
691
|
0
|
|
|
|
|
|
$devc = [map {1 - $_} @{$dev}]; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
# initialize coefficient array |
694
|
0
|
|
|
|
|
|
$coef = [(1.0) x 2**@{$dev}]; |
|
0
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
# for each coefficient |
697
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$coef}) { |
|
0
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
# for each device value |
700
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$dev}) { |
|
0
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
# if $j-th bit set |
703
|
0
|
0
|
|
|
|
|
if ($i >> $j & 1) { |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
# multiply by device value |
706
|
0
|
|
|
|
|
|
$coef->[$i] *= $dev->[$j]; |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
} else { |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
# multiply by (1 - device value) |
711
|
0
|
|
|
|
|
|
$coef->[$i] *= $devc->[$j]; |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
# return |
720
|
0
|
|
|
|
|
|
return($coef); |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
# compute barycentric Jacobian matrix |
725
|
|
|
|
|
|
|
# parameter: (input_vector) |
726
|
|
|
|
|
|
|
# returns: (Jacobian_matrix) |
727
|
|
|
|
|
|
|
sub _barycentric_jacobian { |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
# get parameter |
730
|
0
|
|
|
0
|
|
|
my $dev = shift(); |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
# local variables |
733
|
0
|
|
|
|
|
|
my ($devc, $rows, $jac); |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
# compute complement values |
736
|
0
|
|
|
|
|
|
$devc = [map {1 - $_} @{$dev}]; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
# compute matrix rows |
739
|
0
|
|
|
|
|
|
$rows = 2**@{$dev}; |
|
0
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
# for each matrix row |
742
|
0
|
|
|
|
|
|
for my $i (0 .. $rows - 1) { |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
# initialize row |
745
|
0
|
|
|
|
|
|
$jac->[$i] = [(1.0) x @{$dev}]; |
|
0
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
# for each matrix column |
748
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$dev}) { |
|
0
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
# for each device value |
751
|
0
|
|
|
|
|
|
for my $k (0 .. $#{$dev}) { |
|
0
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
# if $k-th bit set |
754
|
0
|
0
|
|
|
|
|
if ($i >> $k & 1) { |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
# multiply by device value -or- 1 (skip) |
757
|
0
|
0
|
|
|
|
|
$jac->[$i][$j] *= $dev->[$k] if ($j != $k); |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
} else { |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
# multiply by (1 - device value) -or- -1 |
762
|
0
|
0
|
|
|
|
|
$jac->[$i][$j] *= ($j != $k) ? $devc->[$k] : -1; |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
} |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
} |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
# return |
773
|
0
|
|
|
|
|
|
return(bless($jac, 'Math::Matrix')); |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
} |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
# find unit box intersection |
778
|
|
|
|
|
|
|
# with line from input to box-center |
779
|
|
|
|
|
|
|
# parameters: (input_vector) |
780
|
|
|
|
|
|
|
# returns: (extrapolation_vector, intersection_vector) |
781
|
|
|
|
|
|
|
sub _intersect { |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
# get input values |
784
|
0
|
|
|
0
|
|
|
my ($in) = shift(); |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
# local variables |
787
|
0
|
|
|
|
|
|
my (@cin, $dmax, $ubox, $ext); |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
# compute input to box-center difference |
790
|
0
|
|
|
|
|
|
@cin = map {$_ - 0.5} @{$in}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
# initialize |
793
|
0
|
|
|
|
|
|
$dmax = 0; |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
# for each difference |
796
|
0
|
|
|
|
|
|
for (@cin) { |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
# if larger absolute value |
799
|
0
|
0
|
|
|
|
|
if (abs($_) > $dmax) { |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
# new max difference |
802
|
0
|
|
|
|
|
|
$dmax = abs($_); |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
} |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
} |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
# multiply max difference by 2 |
809
|
0
|
|
|
|
|
|
$dmax *= 2; |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
# compute intersection vector (on surface of unit box) |
812
|
0
|
|
|
|
|
|
$ubox = [map {$_/$dmax + 0.5} @cin]; |
|
0
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
# compute extrapolation vector (as Math::Matrix object) |
815
|
0
|
|
|
|
|
|
$ext = [map {$in->[$_] - $ubox->[$_]} (0 .. $#{$in})]; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
# return |
818
|
0
|
|
|
|
|
|
return($ext, $ubox); |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
} |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
# compute parametric partial derivatives |
823
|
|
|
|
|
|
|
# parameters: (object_reference, input_vector) |
824
|
|
|
|
|
|
|
# returns: (partial_derivative_vector) |
825
|
|
|
|
|
|
|
sub _parametric { |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
# get parameters |
828
|
0
|
|
|
0
|
|
|
my ($self, $in) = @_; |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
# local variables |
831
|
0
|
|
|
|
|
|
my ($bc, $cp, $d, $s1, $sum1, $sum2, $pj, $dk, $pd, $r); |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
# calculate barycentric coordinates |
834
|
0
|
|
|
|
|
|
$bc = _barycentric($in); |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
# get corner point matrix |
837
|
0
|
|
|
|
|
|
$cp = $self->[1]; |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
# for each delta/output value |
840
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$self->[2]}) { |
|
0
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
# get delta value |
843
|
0
|
|
|
|
|
|
$d = $self->[2][$i]; |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
# if delta non-zeroish |
846
|
0
|
0
|
|
|
|
|
if (abs($d) >= 1E-5) { |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
# initialize sums |
849
|
0
|
|
|
|
|
|
$sum1 = $sum2 = 0; |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
# for each corner point |
852
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$cp}) { |
|
0
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
# accumulate sums |
855
|
0
|
|
|
|
|
|
$sum1 += $s1 = $bc->[$j] * $cp->[$j][$i]**$d; |
856
|
0
|
|
|
|
|
|
$sum2 += $s1 * log($cp->[$j][$i]); |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
} |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
# compute partial derivative |
861
|
0
|
|
|
|
|
|
$pj->[$i] = $sum1**(1/$d) * ($sum2/$sum1 - log($sum1)/$d)/$d; |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
} else { |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
# for delta +/- 1E-5 |
866
|
0
|
|
|
|
|
|
for my $k (0 .. 1) { |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
# set delta |
869
|
0
|
0
|
|
|
|
|
$dk = $k ? -1E-5 : 1E-5; |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
# initialize sums |
872
|
0
|
|
|
|
|
|
$sum1 = $sum2 = 0; |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
# for each corner point |
875
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$cp}) { |
|
0
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
# accumulate sums |
878
|
0
|
|
|
|
|
|
$sum1 += $s1 = $bc->[$j] * $cp->[$j][$i]**$dk; |
879
|
0
|
|
|
|
|
|
$sum2 += $s1 * log($cp->[$j][$i]); |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
} |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
# compute partial derivative |
884
|
0
|
|
|
|
|
|
$pd->[$k] = $sum1**(1/$dk) * ($sum2/$sum1 - log($sum1)/$dk)/$dk; |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
} |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
# compute interpolation ratio |
889
|
0
|
|
|
|
|
|
$r = 0.5 - $d/2E-5; |
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
# interpolate partial derivative |
892
|
0
|
|
|
|
|
|
$pj->[$i] = $r * $pd->[0] + (1 - $r) * $pd->[1]; |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
} |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
} |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
# return array of partial derivatives |
899
|
0
|
|
|
|
|
|
return($pj); |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
} |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
# exponentiate corner point |
904
|
|
|
|
|
|
|
# uses expm1 function for small exponents |
905
|
|
|
|
|
|
|
# parameters: (base, exponent) |
906
|
|
|
|
|
|
|
# returns: (base^exponent) |
907
|
|
|
|
|
|
|
sub _powm1 { |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
# get parameters |
910
|
0
|
|
|
0
|
|
|
my ($base, $exp) = @_; |
911
|
|
|
|
|
|
|
|
912
|
0
|
0
|
|
|
|
|
if ($exp == 0.0) { |
|
|
0
|
|
|
|
|
|
913
|
|
|
|
|
|
|
|
914
|
0
|
0
|
|
|
|
|
if ($base > 0.0) { |
915
|
|
|
|
|
|
|
|
916
|
0
|
|
|
|
|
|
return(log($base)) |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
} else { |
919
|
|
|
|
|
|
|
|
920
|
0
|
|
|
|
|
|
return(-(DBL_MAX)) |
921
|
|
|
|
|
|
|
|
922
|
|
|
|
|
|
|
} |
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
} elsif ($exp < 1.0) { |
925
|
|
|
|
|
|
|
|
926
|
0
|
0
|
|
|
|
|
if ($base > 0.0) { |
927
|
|
|
|
|
|
|
|
928
|
0
|
|
|
|
|
|
return(ICC::Support::Lapack::expm1(log($base) * $exp)) |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
} else { |
931
|
|
|
|
|
|
|
|
932
|
0
|
|
|
|
|
|
return(-1.0) |
933
|
|
|
|
|
|
|
|
934
|
|
|
|
|
|
|
} |
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
} else { |
937
|
|
|
|
|
|
|
|
938
|
0
|
0
|
|
|
|
|
if ($base > 0.0) { |
939
|
|
|
|
|
|
|
|
940
|
0
|
|
|
|
|
|
return(POSIX::pow($base, $exp)) |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
} else { |
943
|
|
|
|
|
|
|
|
944
|
0
|
|
|
|
|
|
return(0) |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
} |
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
} |
949
|
|
|
|
|
|
|
|
950
|
|
|
|
|
|
|
} |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
# exponentiate barycentric sum |
953
|
|
|
|
|
|
|
# uses log1p function for small exponents |
954
|
|
|
|
|
|
|
# parameters: (base, exponent) |
955
|
|
|
|
|
|
|
# returns: (base^(1/exponent)) |
956
|
|
|
|
|
|
|
sub _pow1p { |
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
# get parameters |
959
|
0
|
|
|
0
|
|
|
my ($base, $exp) = @_; |
960
|
|
|
|
|
|
|
|
961
|
0
|
0
|
|
|
|
|
if ($exp == 0.0) { |
|
|
0
|
|
|
|
|
|
962
|
|
|
|
|
|
|
|
963
|
0
|
|
|
|
|
|
return(exp($base)) |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
} elsif ($exp < 1.0) { |
966
|
|
|
|
|
|
|
|
967
|
0
|
0
|
|
|
|
|
if ($base > -1.0) { |
968
|
|
|
|
|
|
|
|
969
|
0
|
|
|
|
|
|
return(exp(ICC::Support::Lapack::log1p($base)/$exp)) |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
} else { |
972
|
|
|
|
|
|
|
|
973
|
0
|
|
|
|
|
|
return(0.0) |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
} |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
} else { |
978
|
|
|
|
|
|
|
|
979
|
0
|
0
|
|
|
|
|
if ($base > 0.0) { |
980
|
|
|
|
|
|
|
|
981
|
0
|
|
|
|
|
|
return(POSIX::pow($base, 1.0/$exp)) |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
} else { |
984
|
|
|
|
|
|
|
|
985
|
0
|
|
|
|
|
|
return(0.0) |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
} |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
} |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
} |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
# make new nMIX object from attribute hash |
994
|
|
|
|
|
|
|
# hash may contain pointers to clut array or delta array |
995
|
|
|
|
|
|
|
# hash keys are: ('array', 'delta') |
996
|
|
|
|
|
|
|
# object elements not specified in the hash are unchanged |
997
|
|
|
|
|
|
|
# parameters: (ref_to_object, ref_to_attribute_hash) |
998
|
|
|
|
|
|
|
sub _new_from_hash { |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
# get parameters |
1001
|
0
|
|
|
0
|
|
|
my ($self, $hash) = @_; |
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
# local variable |
1004
|
0
|
|
|
|
|
|
my ($value); |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
# if 'array' attribute |
1007
|
0
|
0
|
|
|
|
|
if (defined($value = $hash->{'array'})) { |
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
# if reference to a 2-D array |
1010
|
0
|
0
|
0
|
|
|
|
if (ref($value) eq 'ARRAY' && @{$value} == grep {ref() eq 'ARRAY'} @{$value}) { |
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
# copy array to object and bless |
1013
|
0
|
|
|
|
|
|
$self->[1] = bless(Storable::dclone($value), 'Math::Matrix'); |
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
# if reference to a Math::Matrix object |
1016
|
|
|
|
|
|
|
} elsif (UNIVERSAL::isa($value, 'Math::Matrix')) { |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
# copy matrix to object |
1019
|
0
|
|
|
|
|
|
$self->[1] = Storable::dclone($value); |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
} else { |
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
# wrong data type |
1024
|
0
|
|
|
|
|
|
croak('\'array\' must be a 2-D array reference or Math::Matrix object'); |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
} |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
# for each corner point |
1029
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$self->[1]}) { |
|
0
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
|
1031
|
|
|
|
|
|
|
# for each spectral value |
1032
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$self->[1][$i]}) { |
|
0
|
|
|
|
|
|
|
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
# set value to zero, if negative |
1035
|
0
|
0
|
|
|
|
|
$self->[1][$i][$j] = 0 if ($self->[1][$i][$j] < 0); |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
} |
1038
|
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
|
} |
1040
|
|
|
|
|
|
|
|
1041
|
|
|
|
|
|
|
} |
1042
|
|
|
|
|
|
|
|
1043
|
|
|
|
|
|
|
# if 'delta' attribute |
1044
|
0
|
0
|
|
|
|
|
if (defined($value = $hash->{'delta'})) { |
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
# if reference to a 1-D array (vector) |
1047
|
0
|
0
|
0
|
|
|
|
if (ref($value) eq 'ARRAY' && @{$value} == grep {Scalar::Util::looks_like_number($_)} @{$value}) { |
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
|
|
1049
|
|
|
|
|
|
|
# make delta array |
1050
|
0
|
|
|
|
|
|
$self->[2] = [@{$value}]; |
|
0
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
# if scalar number |
1053
|
|
|
|
|
|
|
} elsif (Scalar::Util::looks_like_number($value)) { |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
# if array is defined |
1056
|
0
|
0
|
|
|
|
|
if (defined($self->[1])) { |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
# make delta array |
1059
|
0
|
|
|
|
|
|
$self->[2] = [($value) x @{$self->[1][0]}]; |
|
0
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
} else { |
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
# error |
1064
|
0
|
|
|
|
|
|
croak ('array must be defined when specifying delta as a scalar'); |
1065
|
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
|
} |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
} else { |
1069
|
|
|
|
|
|
|
|
1070
|
|
|
|
|
|
|
# wrong data type |
1071
|
0
|
|
|
|
|
|
croak('\'delta\' must be a scalar or a 1-D array reference'); |
1072
|
|
|
|
|
|
|
|
1073
|
|
|
|
|
|
|
} |
1074
|
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
|
} |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
# update arrays |
1078
|
0
|
|
|
|
|
|
_update_clut_exp($self); |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
} |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
# make new nMIX object from ICC::Support::Chart object |
1083
|
|
|
|
|
|
|
# chart must contain device values and, spectral or XYZ values |
1084
|
|
|
|
|
|
|
# copies corner points into clut array, warns if corner point(s) missing |
1085
|
|
|
|
|
|
|
# parameters: (ref_to_object, ref_to_chart, [columns]) |
1086
|
|
|
|
|
|
|
sub _new_from_chart { |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
# get parameters |
1089
|
0
|
|
|
0
|
|
|
my ($self, $chart, $cols) = @_; |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
# local variables |
1092
|
0
|
|
|
|
|
|
my ($dev, $fmt, $devc, $cs); |
1093
|
|
|
|
|
|
|
|
1094
|
|
|
|
|
|
|
# verify chart has device values |
1095
|
0
|
0
|
|
|
|
|
($dev = $chart->device()) or croak('chart must have device values'); |
1096
|
|
|
|
|
|
|
|
1097
|
|
|
|
|
|
|
# verify clut column slice is defined |
1098
|
0
|
0
|
0
|
|
|
|
(defined($cols) || ($cols = $chart->spectral() || $chart->xyz())) or croak('clut data slice is undefined'); |
|
|
|
0
|
|
|
|
|
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
# get format keys |
1101
|
0
|
|
|
|
|
|
$fmt = $chart->fmt_keys($cols); |
1102
|
|
|
|
|
|
|
|
1103
|
|
|
|
|
|
|
# verify spectral or XYZ data |
1104
|
0
|
0
|
0
|
|
|
|
((@{$fmt} == grep {m/^(?:(.*)\|)?(?:nm|SPECTRAL_NM_|SPECTRAL_NM|SPECTRAL_|NM_|R_)\d{3}$/} @{$fmt}) || (3 == grep {m/^(?:(.*)\|)?XYZ_[XYZ]$/} @{$fmt})) || warn('clut data neither spectral nor XYZ'); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
# for each corner point |
1107
|
0
|
|
|
|
|
|
for my $i (0 .. 2**@{$dev} - 1) { |
|
0
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
# for each device channel |
1110
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$dev}) { |
|
0
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
# get device value |
1113
|
0
|
|
|
|
|
|
$devc->[$j] = $i >> $j & 1; |
1114
|
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
|
} |
1116
|
|
|
|
|
|
|
|
1117
|
|
|
|
|
|
|
# get corner point samples |
1118
|
0
|
0
|
|
0
|
|
|
($cs = $chart->ramp(sub {@{$devc} == grep {$devc->[$_] == $_[$_]} (0 .. $#{$devc})})) or croak("no chart samples for corner point [@{$devc}]\n"); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
# save clut vector |
1121
|
0
|
|
|
|
|
|
$self->[1][$i] = $chart->slice($chart->add_avg($cs), $cols)->[0]; |
1122
|
|
|
|
|
|
|
|
1123
|
|
|
|
|
|
|
# discard avg sample |
1124
|
0
|
|
|
|
|
|
pop(@{$chart->array()}); |
|
0
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
# for each spectral value |
1127
|
0
|
|
|
|
|
|
for my $j (0 .. $#{$self->[1][$i]}) { |
|
0
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
|
# if value is negative |
1130
|
0
|
0
|
|
|
|
|
if ($self->[1][$i][$j] < 0) { |
1131
|
|
|
|
|
|
|
|
1132
|
|
|
|
|
|
|
# set value to zero |
1133
|
0
|
|
|
|
|
|
$self->[1][$i][$j] = 0; |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
# print warning |
1136
|
0
|
|
|
|
|
|
print "clut value [$i][$j] was negative, set to 0\n"; |
1137
|
|
|
|
|
|
|
|
1138
|
|
|
|
|
|
|
} |
1139
|
|
|
|
|
|
|
|
1140
|
|
|
|
|
|
|
} |
1141
|
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
|
} |
1143
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
# bless clut |
1145
|
0
|
|
|
|
|
|
bless($self->[1], 'Math::Matrix'); |
1146
|
|
|
|
|
|
|
|
1147
|
|
|
|
|
|
|
} |
1148
|
|
|
|
|
|
|
|
1149
|
|
|
|
|
|
|
1; |