line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package ICC::Profile::gbd_; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
77207
|
use strict; |
|
2
|
|
|
|
|
10
|
|
|
2
|
|
|
|
|
44
|
|
4
|
2
|
|
|
2
|
|
7
|
use Carp; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
100
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
our $VERSION = 0.12; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
# revised 2018-08-07 |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# Copyright © 2004-2020 by William B. Birkett |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# inherit from Shared |
13
|
2
|
|
|
2
|
|
357
|
use parent qw(ICC::Shared); |
|
2
|
|
|
|
|
270
|
|
|
2
|
|
|
|
|
20
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# create new gbd_ object |
16
|
|
|
|
|
|
|
# hash keys are: ('vertex', 'pcs', 'device') |
17
|
|
|
|
|
|
|
# 'vertex', 'pcs' and 'device' values are 2D array references -or- Math::Matrix objects |
18
|
|
|
|
|
|
|
# each 'vertex' row contains an array of 3 indices defining a gamut face |
19
|
|
|
|
|
|
|
# these indices address the 'pcs' and optional 'device' coordinate arrays |
20
|
|
|
|
|
|
|
# parameters: ([ref_to_attribute_hash]) |
21
|
|
|
|
|
|
|
# returns: (ref_to_object) |
22
|
|
|
|
|
|
|
sub new { |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# get object class |
25
|
1
|
|
|
1
|
0
|
623
|
my $class = shift(); |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# create empty gbd_ object |
28
|
|
|
|
|
|
|
# index 4 reserved for cache |
29
|
|
|
|
|
|
|
# index 5 reserved for index |
30
|
1
|
|
|
|
|
3
|
my $self = [ |
31
|
|
|
|
|
|
|
{}, # header |
32
|
|
|
|
|
|
|
[], # face vertex IDs |
33
|
|
|
|
|
|
|
[], # pcs coordinates |
34
|
|
|
|
|
|
|
[] # device coordinates |
35
|
|
|
|
|
|
|
]; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# local parameter |
38
|
1
|
|
|
|
|
2
|
my ($info); |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# if there are parameters |
41
|
1
|
50
|
|
|
|
3
|
if (@_) { |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
# if one parameter, a hash reference |
44
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 && ref($_[0]) eq 'HASH') { |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# make new gbd_ object from attribute hash |
47
|
0
|
|
|
|
|
0
|
_new_from_hash($self, shift()); |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
} else { |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# error |
52
|
0
|
|
|
|
|
0
|
croak('\'gbd_\' invalid parameter(s)'); |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
# bless object |
59
|
1
|
|
|
|
|
2
|
bless($self, $class); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# return object reference |
62
|
1
|
|
|
|
|
1
|
return($self); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# get/set reference to header hash |
67
|
|
|
|
|
|
|
# parameters: ([ref_to_new_hash]) |
68
|
|
|
|
|
|
|
# returns: (ref_to_hash) |
69
|
|
|
|
|
|
|
sub header { |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
# get object reference |
72
|
0
|
|
|
0
|
0
|
|
my $self = shift(); |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# if there are parameters |
75
|
0
|
0
|
|
|
|
|
if (@_) { |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
# if one parameter, a hash reference |
78
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'HASH') { |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# set header to new hash |
81
|
0
|
|
|
|
|
|
$self->[0] = {%{shift()}}; |
|
0
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
} else { |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# error |
86
|
0
|
|
|
|
|
|
croak('\'gbd_\' header attribute must be a hash reference'); |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# return header reference |
93
|
0
|
|
|
|
|
|
return($self->[0]); |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
# get/set reference to vertex array |
98
|
|
|
|
|
|
|
# parameters: ([ref_to_new_array]) |
99
|
|
|
|
|
|
|
# returns: (ref_to_array) |
100
|
|
|
|
|
|
|
sub vertex { |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# get object reference |
103
|
0
|
|
|
0
|
0
|
|
my $self = shift(); |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
# if there are parameters |
106
|
0
|
0
|
|
|
|
|
if (@_) { |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# if one parameter, a 2-D array reference |
109
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'ARRAY' && @{$_[0]} == grep {ref() eq 'ARRAY'} @{$_[0]}) { |
|
0
|
0
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
# set vertex to clone of array |
112
|
0
|
|
|
|
|
|
$self->[1] = bless(Storable::dclone($_[0]), 'Math::Matrix'); |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
# if one parameter, a Math::Matrix object |
115
|
|
|
|
|
|
|
} elsif (@_ == 1 && UNIVERSAL::isa($_[0], 'Math::Matrix')) { |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
# set vertex to object |
118
|
0
|
|
|
|
|
|
$self->[1] = $_[0]; |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
} else { |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
# error |
123
|
0
|
|
|
|
|
|
croak('gbd_ vertex must be a 2-D array reference or Math::Matrix object'); |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# return object reference |
130
|
0
|
|
|
|
|
|
return($self->[1]); |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
# get/set reference to pcs array |
135
|
|
|
|
|
|
|
# parameters: ([ref_to_new_array]) |
136
|
|
|
|
|
|
|
# returns: (ref_to_array) |
137
|
|
|
|
|
|
|
sub pcs { |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
# get object reference |
140
|
0
|
|
|
0
|
0
|
|
my $self = shift(); |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
# if there are parameters |
143
|
0
|
0
|
|
|
|
|
if (@_) { |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
# if one parameter, a 2-D array reference |
146
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'ARRAY' && @{$_[0]} == grep {ref() eq 'ARRAY'} @{$_[0]}) { |
|
0
|
0
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
# set pcs to clone of array |
149
|
0
|
|
|
|
|
|
$self->[2] = bless(Storable::dclone($_[0]), 'Math::Matrix'); |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# if one parameter, a Math::Matrix object |
152
|
|
|
|
|
|
|
} elsif (@_ == 1 && UNIVERSAL::isa($_[0], 'Math::Matrix')) { |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# set pcs to object |
155
|
0
|
|
|
|
|
|
$self->[2] = $_[0]; |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
} else { |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
# error |
160
|
0
|
|
|
|
|
|
croak('gbd_ pcs must be a 2-D array reference or Math::Matrix object'); |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# return object reference |
167
|
0
|
|
|
|
|
|
return($self->[2]); |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# get/set reference to device array |
172
|
|
|
|
|
|
|
# parameters: ([ref_to_new_array]) |
173
|
|
|
|
|
|
|
# returns: (ref_to_array) |
174
|
|
|
|
|
|
|
sub device { |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# get object reference |
177
|
0
|
|
|
0
|
0
|
|
my $self = shift(); |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# if there are parameters |
180
|
0
|
0
|
|
|
|
|
if (@_) { |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
# if one parameter, a 2-D array reference |
183
|
0
|
0
|
0
|
|
|
|
if (@_ == 1 && ref($_[0]) eq 'ARRAY' && @{$_[0]} == grep {ref() eq 'ARRAY'} @{$_[0]}) { |
|
0
|
0
|
0
|
|
|
|
|
|
0
|
|
0
|
|
|
|
|
|
0
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
# set device to clone of array |
186
|
0
|
|
|
|
|
|
$self->[3] = bless(Storable::dclone($_[0]), 'Math::Matrix'); |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
# if one parameter, a Math::Matrix object |
189
|
|
|
|
|
|
|
} elsif (@_ == 1 && UNIVERSAL::isa($_[0], 'Math::Matrix')) { |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
# set device to object |
192
|
0
|
|
|
|
|
|
$self->[3] = $_[0]; |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
} else { |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# error |
197
|
0
|
|
|
|
|
|
croak('gbd_ device must be a 2-D array reference or Math::Matrix object'); |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# return object reference |
204
|
0
|
|
|
|
|
|
return($self->[3]); |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# test an array of samples against gamut |
209
|
|
|
|
|
|
|
# the point inside the gamut my be supplied, |
210
|
|
|
|
|
|
|
# otherwise it is computed from the gamut data |
211
|
|
|
|
|
|
|
# result is an array, [[radius, intersect_point, face_ID], [...]] |
212
|
|
|
|
|
|
|
# if radius == 1, sample is on the gamut surface |
213
|
|
|
|
|
|
|
# if radius > 1, sample is inside the gamut |
214
|
|
|
|
|
|
|
# if radius < 1, sample is out-of-gamut |
215
|
|
|
|
|
|
|
# parameters: (sample_array, [point_inside_gamut]) |
216
|
|
|
|
|
|
|
# returns: (result_array) |
217
|
|
|
|
|
|
|
sub test { |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
# get parameters |
220
|
0
|
|
|
0
|
0
|
|
my ($self, $samples, $p0) = @_; |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# local variables |
223
|
0
|
|
|
|
|
|
my ($m, $n, $ps, $i, $j, $faces, $info, $r, $px, $result); |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
# if parameter is undefined |
226
|
0
|
0
|
0
|
|
|
|
if (! defined($p0)) { |
|
|
0
|
0
|
|
|
|
|
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
# if defined in header |
229
|
0
|
0
|
0
|
|
|
|
if (defined($self->[0]{'p0'}) && defined($self->[5])) { |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# use header value |
232
|
0
|
|
|
|
|
|
$p0 = $self->[0]{'p0'}; |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
} else { |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
# use mean value of vertices |
237
|
0
|
|
|
|
|
|
$p0 = ICC::Support::Lapack::mean($self->[2]); |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
# if parameter is defined, but different from header value |
242
|
|
|
|
|
|
|
} elsif (defined($self->[0]{'p0'}) && ($self->[0]{'p0'}[0] != $p0->[0] || $self->[0]{'p0'}[1] != $p0->[1] || $self->[0]{'p0'}[2] != $p0->[2])) { |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
# undefine spherical index to force re-calculation |
245
|
0
|
|
|
|
|
|
undef($self->[5]); |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
# if spherical index defined |
250
|
0
|
0
|
|
|
|
|
if (defined($self->[5])) { |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
# get index array size |
253
|
0
|
|
|
|
|
|
$m = @{$self->[5]}; |
|
0
|
|
|
|
|
|
|
254
|
0
|
|
|
|
|
|
$n = @{$self->[5][0]}; |
|
0
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
} else { |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
# compute index grid size |
259
|
0
|
|
|
|
|
|
$m = $n = int(@{$self->[1]}**(1/3)); |
|
0
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
# make spherical index |
262
|
0
|
|
|
|
|
|
_make_index($self, $p0, $m, $n) ; |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
# for each sample |
267
|
0
|
|
|
|
|
|
for my $s (0 .. $#{$samples}) { |
|
0
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
# get sample |
270
|
0
|
|
|
|
|
|
$ps = $samples->[$s]; |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
# compute spherical indices |
273
|
0
|
|
|
|
|
|
$i = int($m * atan2(sqrt(($ps->[1] - $p0->[1])**2 + ($ps->[2] - $p0->[2])**2), $ps->[0] - $p0->[0])/ICC::Shared::PI); |
274
|
0
|
|
|
|
|
|
$j = int($n * (atan2($ps->[2] - $p0->[2], $ps->[1] - $p0->[1])/ICC::Shared::PI + 1)/2); |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
# limit indices |
277
|
0
|
0
|
|
|
|
|
$i = $i < $m ? $i : $m - 1; |
278
|
0
|
0
|
|
|
|
|
$j = $j < $n ? $j : 0; |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
# get face ID list from spherical index |
281
|
0
|
|
|
|
|
|
$faces = $self->[5][$i][$j]; |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
# for each gamut face |
284
|
0
|
|
|
|
|
|
for my $f (@{$faces}) { |
|
0
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
# find intersection, if a new face |
287
|
0
|
|
|
|
|
|
($info, $r, $px) = intersect($self, $f, $p0, $ps); |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# if intersect found |
290
|
0
|
0
|
|
|
|
|
if ($info == 0) { |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
# save result |
293
|
0
|
|
|
|
|
|
$result->[$s] = [$r, $px, $f]; |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
# quit loop |
296
|
0
|
|
|
|
|
|
last; |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
# return |
305
|
0
|
|
|
|
|
|
return($result); |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
# compute intersection of line segment with face triangle |
310
|
|
|
|
|
|
|
# the radius is 0 at point_0, and 1 at point_1 |
311
|
|
|
|
|
|
|
# parameters: (face_ID, point_0, point_1) |
312
|
|
|
|
|
|
|
# returns: (info, radius, point_intersect) |
313
|
|
|
|
|
|
|
sub intersect { |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# get parameters |
316
|
0
|
|
|
0
|
0
|
|
my ($self, $fid, $p0, $p1) = @_; |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# local variables |
319
|
0
|
|
|
|
|
|
my ($v0, $v1, $v2, $u, $v, $n, $dir, $w, $w0, $r, $a, $b); |
320
|
0
|
|
|
|
|
|
my ($px, $uu, $uv, $vv, $wu, $wv, $d, $s, $t); |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
# if face values are cached |
323
|
0
|
0
|
|
|
|
|
if (defined($self->[4][$fid])) { |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
# get face vertex |
326
|
0
|
|
|
|
|
|
$v0 = $self->[2][$self->[1][$fid][0]]; |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
# get face values |
329
|
0
|
|
|
|
|
|
($u, $v, $n, $uu, $uv, $vv) = @{$self->[4][$fid]}; |
|
0
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
} else { |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# get face vertices |
334
|
0
|
|
|
|
|
|
$v0 = $self->[2][$self->[1][$fid][0]]; |
335
|
0
|
|
|
|
|
|
$v1 = $self->[2][$self->[1][$fid][1]]; |
336
|
0
|
|
|
|
|
|
$v2 = $self->[2][$self->[1][$fid][2]]; |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
# compute triangle edge vectors |
339
|
0
|
|
|
|
|
|
$u = [$v1->[0] - $v0->[0], $v1->[1] - $v0->[1], $v1->[2] - $v0->[2]]; |
340
|
0
|
|
|
|
|
|
$v = [$v2->[0] - $v0->[0], $v2->[1] - $v0->[1], $v2->[2] - $v0->[2]]; |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
# compute normal vector |
343
|
0
|
|
|
|
|
|
$n = ICC::Shared::crossProduct($u, $v); |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
# compute barycentric dot products |
346
|
0
|
|
|
|
|
|
$uu = ICC::Shared::dotProduct($u, $u); |
347
|
0
|
|
|
|
|
|
$uv = ICC::Shared::dotProduct($u, $v); |
348
|
0
|
|
|
|
|
|
$vv = ICC::Shared::dotProduct($v, $v); |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# cache face values |
351
|
0
|
|
|
|
|
|
$self->[4][$fid] = [$u, $v, $n, $uu, $uv, $vv]; |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
# check for degenerate triangle |
356
|
0
|
0
|
0
|
|
|
|
return(-1) if ($n->[0] == 0 && $n->[1] == 0 && $n->[2] == 0); |
|
|
|
0
|
|
|
|
|
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
# compute direction vector |
359
|
0
|
|
|
|
|
|
$dir = [$p1->[0] - $p0->[0], $p1->[1] - $p0->[1], $p1->[2] - $p0->[2]]; |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
# compute segment to triangle vector |
362
|
0
|
|
|
|
|
|
$w0 = [$p0->[0] - $v0->[0], $p0->[1] - $v0->[1], $p0->[2] - $v0->[2]]; |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
# compute dot products |
365
|
0
|
|
|
|
|
|
$a = -ICC::Shared::dotProduct($n, $w0); |
366
|
0
|
|
|
|
|
|
$b = ICC::Shared::dotProduct($n, $dir); |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
# if b is a very small number |
369
|
0
|
0
|
|
|
|
|
if (abs($b) < ICC::Shared::DBL_MIN) { |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# return (3 - segment lies in plane, 4 - segment disjoint from plane) |
372
|
0
|
0
|
|
|
|
|
return($a ? 3 : 4); |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
# compute radius |
377
|
0
|
|
|
|
|
|
$r = $a/$b; |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# check if reverse intersection |
380
|
0
|
0
|
|
|
|
|
return(2, $r) if ($r < 0); |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
# compute the intersection point |
383
|
0
|
|
|
|
|
|
$px = [$p0->[0] + $r * $dir->[0], $p0->[1] + $r * $dir->[1], $p0->[2] + $r * $dir->[2]]; |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
# compute barycentric dot products |
386
|
0
|
|
|
|
|
|
$w = [$px->[0] - $v0->[0], $px->[1] - $v0->[1], $px->[2] - $v0->[2]]; |
387
|
0
|
|
|
|
|
|
$wu = ICC::Shared::dotProduct($w, $u); |
388
|
0
|
|
|
|
|
|
$wv = ICC::Shared::dotProduct($w, $v); |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
# compute common denominator |
391
|
0
|
|
|
|
|
|
$d = $uv * $uv - $uu * $vv; |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
# compute barycentric coordinate |
394
|
0
|
|
|
|
|
|
$s = ($uv * $wv - $vv * $wu) / $d; |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
# return if intersect outside triangle |
397
|
0
|
0
|
0
|
|
|
|
return(1, $r, $px) if ($s < 0 || $s > 1); |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
# compute barycentric coordinate |
400
|
0
|
|
|
|
|
|
$t = ($uv * $wu - $uu * $wv) / $d; |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
# return if intersect outside triangle |
403
|
0
|
0
|
0
|
|
|
|
return(1, $r, $px) if ($t < 0 || ($s + $t) > 1); |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
# return intersect within triangle |
406
|
0
|
|
|
|
|
|
return(0, $r, $px); |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
# create gbd_ object from ICC profile |
411
|
|
|
|
|
|
|
# parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry) |
412
|
|
|
|
|
|
|
# returns: (ref_to_object) |
413
|
|
|
|
|
|
|
sub new_fh { |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
# get object class |
416
|
0
|
|
|
0
|
0
|
|
my $class = shift(); |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
# create empty gbd_ object |
419
|
0
|
|
|
|
|
|
my $self = [ |
420
|
|
|
|
|
|
|
{}, # header |
421
|
|
|
|
|
|
|
[], # matrix |
422
|
|
|
|
|
|
|
[] # offset |
423
|
|
|
|
|
|
|
]; |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
# verify 3 parameters |
426
|
0
|
0
|
|
|
|
|
(@_ == 3) or croak('wrong number of parameters'); |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
# read gbd_ data from profile |
429
|
0
|
|
|
|
|
|
_readICCgbd_($self, @_); |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
# bless object |
432
|
0
|
|
|
|
|
|
bless($self, $class); |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
# return object reference |
435
|
0
|
|
|
|
|
|
return($self); |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
# writes gbd_ object to ICC profile |
440
|
|
|
|
|
|
|
# parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry) |
441
|
|
|
|
|
|
|
sub write_fh { |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
# verify 4 parameters |
444
|
0
|
0
|
|
0
|
0
|
|
(@_ == 4) or croak('wrong number of parameters'); |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
# write gbd_ data to profile |
447
|
0
|
|
|
|
|
|
goto &_writeICCgbd_; |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
# get tag size (for writing to profile) |
452
|
|
|
|
|
|
|
# returns: (clut_size) |
453
|
|
|
|
|
|
|
sub size { |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
# get parameter |
456
|
0
|
|
|
0
|
0
|
|
my $self = shift(); |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
# local variables |
459
|
0
|
|
|
|
|
|
my ($p, $q, $size); |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
# get number of pcs channels |
462
|
0
|
|
|
|
|
|
$p = @{$self->[2][0]}; |
|
0
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
# get number of device channels |
465
|
0
|
0
|
|
|
|
|
$q = defined($self->[3][0]) ? @{$self->[3][0]} : 0; |
|
0
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
# set header size |
468
|
0
|
|
|
|
|
|
$size = 20; |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
# add face vertex IDs |
471
|
0
|
|
|
|
|
|
$size += 12 * @{$self->[1]}; |
|
0
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
# add vertex pcs values |
474
|
0
|
|
|
|
|
|
$size += 4 * $p * @{$self->[2]}; |
|
0
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
# add vertex device values (may be 0) |
477
|
0
|
|
|
|
|
|
$size += 4 * $q * @{$self->[3]}; |
|
0
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
# return size |
480
|
0
|
|
|
|
|
|
return($size); |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
# print object contents to string |
485
|
|
|
|
|
|
|
# format is an array structure |
486
|
|
|
|
|
|
|
# parameter: ([format]) |
487
|
|
|
|
|
|
|
# returns: (string) |
488
|
|
|
|
|
|
|
sub sdump { |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
# get parameters |
491
|
0
|
|
|
0
|
1
|
|
my ($self, $p) = @_; |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
# local variables |
494
|
0
|
|
|
|
|
|
my ($s, $fmt, $f, $v, $e); |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
# resolve parameter to an array reference |
497
|
0
|
0
|
|
|
|
|
$p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : []; |
|
|
0
|
|
|
|
|
|
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
# get format string |
500
|
0
|
0
|
0
|
|
|
|
$fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 'undef'; |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
# set string to object ID |
503
|
0
|
|
|
|
|
|
$s = sprintf("'%s' object, (0x%x)\n", ref($self), $self); |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
# get stats |
506
|
0
|
|
|
|
|
|
($f, $v, $e) = _check_faces($self); |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
# append stats |
509
|
0
|
|
|
|
|
|
$s .= "faces: $f vertices: $v edges: $e\n"; |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
# return |
512
|
0
|
|
|
|
|
|
return($s); |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
# check gamut faces |
517
|
|
|
|
|
|
|
# parameters: (ref_to_object) |
518
|
|
|
|
|
|
|
# returns: (faces, vertices, edges) |
519
|
|
|
|
|
|
|
sub _check_faces { |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
# get object reference |
522
|
0
|
|
|
0
|
|
|
my $self = shift(); |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
# local variables |
525
|
0
|
|
|
|
|
|
my (%v, %e, $p0, $p1, $p2); |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
# for each face |
528
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$self->[1]}) { |
|
0
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
# get indices |
531
|
0
|
|
|
|
|
|
$p0 = $self->[1][$i][0]; |
532
|
0
|
|
|
|
|
|
$p1 = $self->[1][$i][1]; |
533
|
0
|
|
|
|
|
|
$p2 = $self->[1][$i][2]; |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
# add vertices |
536
|
0
|
|
|
|
|
|
$v{$p0}++; |
537
|
0
|
|
|
|
|
|
$v{$p1}++; |
538
|
0
|
|
|
|
|
|
$v{$p2}++; |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
# add edges |
541
|
0
|
0
|
|
|
|
|
$e{$p0 > $p1 ? "$p0:$p1" : "$p1:$p0"}++; |
542
|
0
|
0
|
|
|
|
|
$e{$p1 > $p2 ? "$p1:$p2" : "$p2:$p1"}++; |
543
|
0
|
0
|
|
|
|
|
$e{$p0 > $p2 ? "$p0:$p2" : "$p2:$p0"}++; |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
} |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
# return faces, vertices, edges |
548
|
0
|
|
|
|
|
|
return(scalar(@{$self->[1]}), scalar(keys(%v)), scalar(keys(%e))); |
|
0
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
# make spherical index |
553
|
|
|
|
|
|
|
# parameters: (object_ref, point_inside_gamut, latitude_steps, longitude_steps) |
554
|
|
|
|
|
|
|
sub _make_index { |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
# get parameters |
557
|
0
|
|
|
0
|
|
|
my ($self, $p0, $m, $n) = @_; |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
# local variables |
560
|
0
|
|
|
|
|
|
my ($f, $s, $length, $dc, $dot, $dxy); |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
# for each face |
563
|
0
|
|
|
|
|
|
for my $i (0 .. $#{$self->[1]}) { |
|
0
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
# for each coordinate |
566
|
0
|
|
|
|
|
|
for my $j (0 .. 2) { |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
# for each vertex |
569
|
0
|
|
|
|
|
|
for my $k (0 .. 2) { |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
# add value to face centroid |
572
|
0
|
|
|
|
|
|
$f->[$j][$i] += $self->[2][$self->[1][$i][$k]][$j]/3; |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
# subtract internal point value |
577
|
0
|
|
|
|
|
|
$f->[$j][$i] -= $p0->[$j]; |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
} |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
# compute vector length |
582
|
0
|
|
|
|
|
|
$length = sqrt($f->[0][$i]**2 + $f->[1][$i]**2 + $f->[2][$i]**2); |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
# for each coordinate |
585
|
0
|
|
|
|
|
|
for my $j (0 .. 2) { |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
# normalize |
588
|
0
|
|
|
|
|
|
$f->[$j][$i] /= $length; |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
# for each x |
595
|
0
|
|
|
|
|
|
for my $i (0 .. $m - 1) { |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
# for each y |
598
|
0
|
|
|
|
|
|
for my $j (0 .. $n - 1) { |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
# compute spherical unit vector for cell[x][y] |
601
|
0
|
|
|
|
|
|
$dc = sin(ICC::Shared::PI * ($i + 0.5)/$m); |
602
|
0
|
|
|
|
|
|
$s->[$n * $i + $j][0] = cos(ICC::Shared::PI * ($i + 0.5)/$m); |
603
|
0
|
|
|
|
|
|
$s->[$n * $i + $j][1] = -$dc * cos(2 * ICC::Shared::PI * (($j + 0.5)/$n)); |
604
|
0
|
|
|
|
|
|
$s->[$n * $i + $j][2] = -$dc * sin(2 * ICC::Shared::PI * (($j + 0.5)/$n)); |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
# compute dot products [s x 3] * [3 x f] = [s x f] |
611
|
0
|
|
|
|
|
|
$dot = ICC::Support::Lapack::mat_xplus($s, $f); |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
# initialize index |
614
|
0
|
|
|
|
|
|
undef($self->[5]); |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
# for each x |
617
|
0
|
|
|
|
|
|
for my $i (0 .. $m - 1) { |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
# for each y |
620
|
0
|
|
|
|
|
|
for my $j (0 .. $n - 1) { |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
# get dot product list for cell[x][y] |
623
|
0
|
|
|
|
|
|
$dxy = $dot->[$n * $i + $j]; |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
# compute face ID list, sorted by dot product |
626
|
0
|
|
|
|
|
|
$self->[5][$i][$j] = [map {$_->[0]} sort {$b->[1] <=> $a->[1]} map {[$_, $dxy->[$_]]} (0 .. $#{$self->[1]})]; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
# save internal point in header hash |
633
|
0
|
|
|
|
|
|
$self->[0]{'p0'} = $p0; |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
# make new gbd_ object from attribute hash |
638
|
|
|
|
|
|
|
# hash keys are: ('vertex', 'pcs', 'device') |
639
|
|
|
|
|
|
|
# object elements not specified in the hash are unchanged |
640
|
|
|
|
|
|
|
# parameters: (ref_to_object, ref_to_attribute_hash) |
641
|
|
|
|
|
|
|
sub _new_from_hash { |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
# get parameters |
644
|
0
|
|
|
0
|
|
|
my ($self, $hash) = @_; |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
# local variables |
647
|
0
|
|
|
|
|
|
my ($value, $f, $v, $e); |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
# if 'vertex' key defined |
650
|
0
|
0
|
|
|
|
|
if (defined($hash->{'vertex'})) { |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
# get value |
653
|
0
|
|
|
|
|
|
$value = $hash->{'vertex'}; |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
# if reference to a 2-D array |
656
|
0
|
0
|
0
|
|
|
|
if (ref($value) eq 'ARRAY' && @{$value} == grep {ref() eq 'ARRAY'} @{$value}) { |
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
# set vertex to clone of array |
659
|
0
|
|
|
|
|
|
$self->[1] = bless(Storable::dclone($value), 'Math::Matrix'); |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
# if a reference to a Math::Matrix object |
662
|
|
|
|
|
|
|
} elsif (UNIVERSAL::isa($value, 'Math::Matrix')) { |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
# set vertex to object |
665
|
0
|
|
|
|
|
|
$self->[1] = $value; |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
} else { |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
# wrong data type |
670
|
0
|
|
|
|
|
|
croak('wrong \'vertex\' data type'); |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
# verify number of faces |
675
|
0
|
0
|
|
|
|
|
(@{$self->[1]} >= 4) or croak('number of faces < 4'); |
|
0
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
# verify number of vertices per face |
678
|
0
|
0
|
|
|
|
|
(@{$self->[1]} == 3) or croak('number of vertices per face <> 3'); |
|
0
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
# check gamut faces |
681
|
0
|
|
|
|
|
|
($f, $v, $e) = _check_faces($self); |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
# verify closed shape using Euler's formula |
684
|
0
|
0
|
|
|
|
|
($f + $v - $e == 2) or carp('not a closed shape'); |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
} |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
# if 'pcs' key defined |
689
|
0
|
0
|
|
|
|
|
if (defined($hash->{'pcs'})) { |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
# get value |
692
|
0
|
|
|
|
|
|
$value = $hash->{'pcs'}; |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
# if reference to a 2-D array |
695
|
0
|
0
|
0
|
|
|
|
if (ref($value) eq 'ARRAY' && @{$value} == grep {ref() eq 'ARRAY'} @{$value}) { |
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
# set pcs to clone of array |
698
|
0
|
|
|
|
|
|
$self->[1] = bless(Storable::dclone($value), 'Math::Matrix'); |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
# if a reference to a Math::Matrix object |
701
|
|
|
|
|
|
|
} elsif (UNIVERSAL::isa($value, 'Math::Matrix')) { |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
# set pcs to object |
704
|
0
|
|
|
|
|
|
$self->[2] = $value; |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
} else { |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
# wrong data type |
709
|
0
|
|
|
|
|
|
croak('wrong \'pcs\' data type'); |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
# verify number of vertices |
714
|
0
|
0
|
|
|
|
|
(@{$self->[2]} >= 4) or croak('number of vertices < 4'); |
|
0
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
# verify number of pcs channels |
717
|
0
|
0
|
|
|
|
|
(@{$self->[2][0]} >= 3) or croak('number of pcs channels < 3'); |
|
0
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
} |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
# if 'device' key defined |
722
|
0
|
0
|
|
|
|
|
if (defined($hash->{'device'})) { |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
# get value |
725
|
0
|
|
|
|
|
|
$value = $hash->{'device'}; |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
# if reference to a 2-D array |
728
|
0
|
0
|
0
|
|
|
|
if (ref($value) eq 'ARRAY' && @{$value} == grep {ref() eq 'ARRAY'} @{$value}) { |
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
# set device to clone of array |
731
|
0
|
|
|
|
|
|
$self->[1] = bless(Storable::dclone($value), 'Math::Matrix'); |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
# if a reference to a Math::Matrix object |
734
|
|
|
|
|
|
|
} elsif (UNIVERSAL::isa($value, 'Math::Matrix')) { |
735
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
# set device to object |
737
|
0
|
|
|
|
|
|
$self->[3] = $value; |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
} else { |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
# wrong data type |
742
|
0
|
|
|
|
|
|
croak('wrong \'device\' data type'); |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
} |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
# verify number of vertices |
747
|
0
|
0
|
|
|
|
|
(@{$self->[3]} >= 4) or croak('number of vertices < 4'); |
|
0
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
# verify number of pcs channels |
750
|
0
|
0
|
0
|
|
|
|
(@{$self->[3][0]} >= 1 && @{$self->[3][0]} <= 16) or croak('number of device channels < 1 or > 16'); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
} |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
# verify pcs array size |
755
|
0
|
0
|
0
|
|
|
|
(@{$self->[2]} == 0 || @{$self->[2]} == $v) or croak('pcs and face arrays have different number of vertices'); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
# if both pcs and device arrays were supplied |
758
|
0
|
0
|
0
|
|
|
|
if (defined($hash->{'pcs'}) && defined($hash->{'device'})) { |
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
# verify pcs and device arrays have same number of vertices |
761
|
0
|
0
|
|
|
|
|
(@{$self->[2]} == @{$self->[3]}) or croak('pcs and device arrays are different sizes'); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
} |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
# read gbd_ tag from ICC profile |
768
|
|
|
|
|
|
|
# parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry) |
769
|
|
|
|
|
|
|
sub _readICCgbd_ { |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
# get parameters |
772
|
0
|
|
|
0
|
|
|
my ($self, $parent, $fh, $tag) = @_; |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
# local variables |
775
|
0
|
|
|
|
|
|
my ($buf, $p, $q, $v, $f, $bytes); |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
# save tag signature |
778
|
0
|
|
|
|
|
|
$self->[0]{'signature'} = $tag->[0]; |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
# seek start of tag |
781
|
0
|
|
|
|
|
|
seek($fh, $tag->[1], 0); |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
# read tag header |
784
|
0
|
|
|
|
|
|
read($fh, $buf, 20); |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
# unpack header |
787
|
0
|
|
|
|
|
|
($p, $q, $v, $f) = unpack('x8 n2 N2', $buf); |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
# for each face |
790
|
0
|
|
|
|
|
|
for my $i (0 .. $f - 1) { |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
# read vertex IDs |
793
|
0
|
|
|
|
|
|
read($fh, $buf, 12); |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
# unpack the values |
796
|
0
|
|
|
|
|
|
$self->[1][$i] = [unpack('N3', $buf)]; |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
} |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
# bless to Math::Matrix object |
801
|
0
|
|
|
|
|
|
bless($self->[1], 'Math::Matrix'); |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
# compute the buffer size |
804
|
0
|
|
|
|
|
|
$bytes = 4 * $p; |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
# for each vertex |
807
|
0
|
|
|
|
|
|
for my $i (0 .. $v - 1) { |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
# read vertex PCS values |
810
|
0
|
|
|
|
|
|
read($fh, $buf, $bytes); |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
# unpack the values |
813
|
0
|
|
|
|
|
|
$self->[2][$i] = [unpack('f>*', $buf)]; |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
} |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
# bless to Math::Matrix object |
818
|
0
|
|
|
|
|
|
bless($self->[2], 'Math::Matrix'); |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
# if there are device values |
821
|
0
|
0
|
|
|
|
|
if ($bytes = 4 * $q) { |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
# for each vertex |
824
|
0
|
|
|
|
|
|
for my $i (0 .. $v - 1) { |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
# read vertex device values |
827
|
0
|
|
|
|
|
|
read($fh, $buf, $bytes); |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
# unpack the values |
830
|
0
|
|
|
|
|
|
$self->[3][$i] = [unpack('f>*', $buf)]; |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
} |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
# bless to Math::Matrix object |
835
|
0
|
|
|
|
|
|
bless($self->[3], 'Math::Matrix'); |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
} |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
} |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
# write gbd_ tag to ICC profile |
842
|
|
|
|
|
|
|
# parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry) |
843
|
|
|
|
|
|
|
sub _writeICCgbd_ { |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
# get parameters |
846
|
0
|
|
|
0
|
|
|
my ($self, $parent, $fh, $tag) = @_; |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
# local variables |
849
|
0
|
|
|
|
|
|
my ($p, $q, $v, $f); |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
# get number of PCS channels |
852
|
0
|
|
|
|
|
|
$p = @{$self->[2][0]}; |
|
0
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
# get number of device channels |
855
|
0
|
0
|
|
|
|
|
$q = defined($self->[3][0]) ? @{$self->[3][0]} : 0; |
|
0
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
# get number of vertices |
858
|
0
|
|
|
|
|
|
$v = @{$self->[2]}; |
|
0
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
# get number of faces |
861
|
0
|
|
|
|
|
|
$f = @{$self->[1]}; |
|
0
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
# validate number PCS channels (3 and up) |
864
|
0
|
0
|
|
|
|
|
($p >= 3) or croak('unsupported number of input channels'); |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
# validate number device channels (1 to 15) |
867
|
0
|
0
|
0
|
|
|
|
($q > 0 && $q < 16) or croak('unsupported number of output channels'); |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
# seek start of tag |
870
|
0
|
|
|
|
|
|
seek($fh, $tag->[1], 0); |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
# write tag header |
873
|
0
|
|
|
|
|
|
print $fh pack('a4 x4 n2 N2', 'gbd ', $p, $q, $v, $f); |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
# for each face |
876
|
0
|
|
|
|
|
|
for my $i (0 .. $f - 1) { |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
# write face vertex IDs |
879
|
0
|
|
|
|
|
|
print $fh pack('N3', @{$self->[1][$i]}); |
|
0
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
} |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
# for each vertex |
884
|
0
|
|
|
|
|
|
for my $i (0 .. $v - 1) { |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
# write vertex PCS values |
887
|
0
|
|
|
|
|
|
print $fh pack('f>*', @{$self->[2][$i]}); |
|
0
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
} |
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
# if there are vertex device values |
892
|
0
|
0
|
|
|
|
|
if ($q) { |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
# for each vertex |
895
|
0
|
|
|
|
|
|
for my $i (0 .. $v - 1) { |
896
|
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
# write vertex device values |
898
|
0
|
|
|
|
|
|
print $fh pack('f>*', @{$self->[3][$i]}); |
|
0
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
} |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
} |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
1; |