File Coverage

blib/lib/ICC/Profile/curv.pm
Criterion Covered Total %
statement 54 150 36.0
branch 14 80 17.5
condition 0 3 0.0
subroutine 11 19 57.8
pod 1 10 10.0
total 80 262 30.5


line stmt bran cond sub pod time code
1             package ICC::Profile::curv;
2              
3 7     7   102494 use strict;
  7         20  
  7         173  
4 7     7   31 use Carp;
  7         12  
  7         455  
5              
6             our $VERSION = 2.11;
7              
8             # revised 2018-08-07
9             #
10             # Copyright © 2004-2020 by William B. Birkett
11              
12             # inherit from Shared
13 7     7   37 use parent qw(ICC::Shared);
  7         11  
  7         34  
14              
15             # use POSIX math
16 7     7   335 use POSIX ();
  7         11  
  7         9020  
17              
18             # create new 'curv' tag object
19             # with no parameters, 'curv' has identity response
20             # if array has one value, 'curv' has gamma response (256 = gamma 1)
21             # if array has multiple values, 'curv' is a linear piecewise function (range 0 - 1)
22             # parameters: ([ref_to_array])
23             # returns: (ref_to_object)
24             sub new {
25              
26             # get object class
27 12     12 0 769 my $class = shift();
28              
29             # create empty curv object
30 12         33 my $self = [
31             {}, # object header
32             [] # curve array
33             ];
34              
35             # if parameter supplied
36 12 100       35 if (@_) {
37            
38             # verify array reference
39 11 50       38 (ref($_[0]) eq 'ARRAY') or croak('not an array reference');
40            
41             # copy array
42 11         15 $self->[1] = [@{shift()}];
  11         1682  
43            
44             }
45              
46             # bless object
47 12         35 bless($self, $class);
48            
49             # return object reference
50 12         1283 return($self);
51              
52             }
53              
54             # create inverse 'curv' object
55             # returns: (ref_to_object)
56             sub inv {
57              
58             # get object
59 0     0 0 0 my $self = shift();
60              
61             # local variable
62 0         0 my ($array);
63              
64             # if identity curve
65 0 0       0 if (@{$self->array()} == 0) {
  0 0       0  
66            
67             # return identity curve
68 0         0 return(ICC::Profile::curv->new());
69            
70             # if gamma curve
71 0         0 } elsif (@{$self->array()} == 1) {
72            
73             # verify gamma > 0
74 0 0       0 ($self->array->[0] > 0) or croak('gamma must be > 0');
75            
76             # return inverse gamma curve
77 0         0 return(ICC::Profile::curv->new([65536/$self->array->[0]]));
78            
79             # if LUT curve
80             } else {
81            
82             # for each point
83 0         0 for my $i (0 .. 4095) {
84            
85             # compute inverse curve value
86 0         0 $array->[$i] = $self->inverse($i/4095);
87            
88             }
89            
90             # return inverse curve
91 0         0 return(ICC::Profile::curv->new($array));
92            
93             }
94            
95             }
96              
97             # get/set array reference
98             # parameters: ([ref_to_array])
99             # returns: (ref_to_array)
100             sub array {
101              
102             # get object reference
103 32     32 0 42 my $self = shift();
104              
105             # if parameter
106 32 50       45 if (@_) {
107            
108             # verify array reference
109 0 0       0 (ref($_[0]) eq 'ARRAY') or croak('not an array reference');
110            
111             # set array reference
112 0         0 $self->[1] = shift();
113            
114             }
115              
116             # return array reference
117 32         153 return($self->[1]);
118              
119             }
120              
121             # compute curve function
122             # domain/range is (0 - 1)
123             # parameters: (input_value)
124             # returns: (output_value)
125             sub transform {
126              
127             # get parameters
128 0     0 0 0 my ($self, $in) = @_;
129              
130             # local variables
131 0         0 my ($array, $upper, $ix, $ir);
132              
133             # get array reference
134 0         0 $array = $self->[1];
135              
136             # get array upper subscript
137 0         0 $upper = $#{$array};
  0         0  
138              
139             # if array size == 0 (identity)
140 0 0       0 if (@{$array} == 0) {
  0 0       0  
141            
142             # return input value
143 0         0 return($in);
144            
145             # if array size == 1 (gamma function)
146 0         0 } elsif (@{$array} == 1) {
147            
148             # if gamma == 1
149 0 0       0 if ($array->[0] == 256) {
150            
151             # return input value
152 0         0 return($in);
153            
154             } else {
155            
156             # return x^gamma
157 0 0       0 return($in > 0 ? $in**($array->[0]/256) : 0);
158            
159             }
160            
161             } else {
162            
163             # compute lower bound index
164 0         0 $ix = POSIX::floor($in * $upper);
165            
166             # limit lower bound index
167 0 0       0 $ix = $ix < 0 ? 0 : ($ix > ($upper - 1) ? $upper - 1 : $ix);
    0          
168            
169             # compute interpolation ratio
170 0         0 $ir = $in * $upper - $ix;
171            
172             # return value (linear interpolation)
173 0         0 return(((1 - $ir) * $array->[$ix] + $ir * $array->[$ix + 1]));
174            
175             }
176            
177             }
178              
179             # compute inverse curve function
180             # domain/range is (0 - 1)
181             # parameters: (input_value)
182             # returns: (output_value)
183             sub inverse {
184              
185             # get parameters
186 0     0 0 0 my ($self, $in) = @_;
187              
188             # local variables
189 0         0 my ($array, $upper, $ix, $ir);
190              
191             # get array reference
192 0         0 $array = $self->[1];
193              
194             # get array upper subscript
195 0         0 $upper = $#{$array};
  0         0  
196              
197             # if array size == 0 (identity)
198 0 0       0 if (@{$array} == 0) {
  0 0       0  
199            
200             # return input value
201 0         0 return($in);
202            
203             # if array size = 1 (gamma function)
204 0         0 } elsif (@{$array} == 1) {
205            
206             # if gamma = 1
207 0 0       0 if ($array->[0] == 256) {
208            
209             # return input value
210 0         0 return($in);
211            
212             } else {
213            
214             # return y^(1/gamma)
215 0 0       0 return($in > 0 ? $in**(256/$array->[0]) : 0);
216            
217             }
218            
219             } else {
220            
221             # find array interval containing input value
222 0         0 $ix = _binsearch($array, $in);
223            
224             # compute array interval ratio
225 0         0 $ir = ($in - $array->[$ix])/($array->[$ix + 1] - $array->[$ix]);
226            
227             # return value
228 0         0 return(($ix + $ir)/$upper);
229            
230             }
231            
232             }
233              
234             # compute curve derivative
235             # domain is (0 - 1)
236             # parameters: (input_value)
237             # returns: (derivative_value)
238             sub derivative {
239              
240             # get parameters
241 0     0 0 0 my ($self, $in) = @_;
242              
243             # local variables
244 0         0 my ($array, $upper, $ix, $ir);
245              
246             # get array reference
247 0         0 $array = $self->[1];
248              
249             # get array upper subscript
250 0         0 $upper = $#{$array};
  0         0  
251              
252             # if array size == 0 (identity)
253 0 0       0 if (@{$array} == 0) {
  0 0       0  
254            
255             # return value
256 0         0 return(1);
257            
258             # if array size == 1 (gamma curve)
259 0         0 } elsif (@{$array} == 1) {
260            
261             # if gamma == 1
262 0 0       0 if ($array->[0] == 256) {
263            
264             # return 1
265 0         0 return(1);
266            
267             } else {
268            
269             # return gamma * x^(gamma - 1)
270 0 0       0 return($in > 0 ? ($array->[0]/256) * $in**($array->[0]/256 - 1) : 0);
271            
272             }
273            
274             } else {
275            
276             # compute lower bound index
277 0         0 $ix = POSIX::floor($in * $upper);
278            
279             # limit lower bound index
280 0 0       0 $ix = $ix < 0 ? 0 : ($ix > ($upper - 1) ? $upper - 1 : $ix);
    0          
281            
282             # return value
283 0         0 return(($array->[$ix + 1] - $array->[$ix]) * $upper);
284            
285             }
286            
287             }
288              
289             # create curv tag object from ICC profile
290             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
291             # returns: (ref_to_object)
292             sub new_fh {
293              
294             # get object class
295 4     4 0 545 my $class = shift();
296              
297             # create empty curv object
298 4         9 my $self = [
299             {}, # object header
300             [] # curve array
301             ];
302              
303             # verify 3 parameters
304 4 50       10 (@_ == 3) or croak('wrong number of parameters');
305              
306             # read curv data from profile
307 4         13 _readICCcurv($self, @_);
308              
309             # bless object
310 4         29 bless($self, $class);
311              
312             # return object reference
313 4         17 return($self);
314              
315             }
316              
317             # writes curv tag object to ICC profile
318             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
319             sub write_fh {
320              
321             # verify 4 parameters
322 4 50   4 0 899 (@_ == 4) or croak('wrong number of parameters');
323              
324             # write curv data to profile
325 4         22 goto &_writeICCcurv;
326              
327             }
328              
329             # get tag size (for writing to profile)
330             # returns: (tag_size)
331             sub size {
332              
333             # get parameters
334 12     12 0 426 my ($self) = @_;
335              
336             # return size
337 12         11 return(12 + @{$self->[1]} * 2);
  12         48  
338              
339             }
340              
341             # print object contents to string
342             # format is an array structure
343             # parameter: ([format])
344             # returns: (string)
345             sub sdump {
346              
347             # get parameters
348 0     0 1 0 my ($self, $p) = @_;
349              
350             # local variables
351 0         0 my ($s, $fmt);
352              
353             # resolve parameter to an array reference
354 0 0       0 $p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : [];
    0          
355              
356             # get format string
357 0 0 0     0 $fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 'undef';
358              
359             # set string to object ID
360 0         0 $s = sprintf("'%s' object, (0x%x)\n", ref($self), $self);
361              
362             # return
363 0         0 return($s);
364              
365             }
366              
367             # directional derivative
368             # nominal domain (0 - 1)
369             # direction: 0 - normal, 1 - inverse
370             # parameters: (object_reference, direction, input_value)
371             # returns: (derivative_value)
372             sub _derivative {
373              
374             # get parameters
375 0     0   0 my ($self, $dir, $in) = @_;
376              
377             # if inverse transform
378 0 0       0 if ($dir) {
379            
380             # compute derivative
381 0         0 my $d = derivative($self, $in);
382            
383             # if non-zero
384 0 0       0 if ($d) {
385            
386             # return inverse
387 0         0 return(1/$d);
388            
389             } else {
390            
391             # error
392 0         0 croak('infinite derivative');
393            
394             }
395            
396             } else {
397            
398             # return derivative
399 0         0 return(derivative($self, $in));
400            
401             }
402            
403             }
404              
405             # directional transform
406             # nominal domain (0 - 1)
407             # direction: 0 - normal, 1 - inverse
408             # parameters: (object_reference, direction, input_value)
409             # returns: (output_value)
410             sub _transform {
411              
412             # get parameters
413 0     0   0 my ($self, $dir, $in) = @_;
414              
415             # if inverse transform
416 0 0       0 if ($dir) {
417            
418             # return inverse
419 0         0 return(inverse($self, $in));
420            
421             } else {
422            
423             # return transform
424 0         0 return(transform($self, $in));
425            
426             }
427            
428             }
429              
430             # binary search
431             # finds array interval containing value
432             # assumes values are monotonic
433             # parameters: (ref_to_array, value)
434             # returns: (lower_index)
435             sub _binsearch {
436              
437             # get parameters
438 0     0   0 my ($xref, $v) = @_;
439              
440             # local variables
441 0         0 my ($k, $klo, $khi);
442              
443             # set low and high indices
444 0         0 $klo = 0;
445 0         0 $khi = $#{$xref};
  0         0  
446              
447             # if values are increasing
448 0 0       0 if ($xref->[-1] > $xref->[0]) {
449            
450             # repeat until interval is found
451 0         0 while (($khi - $klo) > 1) {
452            
453             # compute the midpoint
454 0         0 $k = int(($khi + $klo)/2);
455            
456             # if midpoint value > value
457 0 0       0 if ($xref->[$k] > $v) {
458            
459             # set high index to midpoint
460 0         0 $khi = $k;
461            
462             } else {
463            
464             # set low index to midpoint
465 0         0 $klo = $k;
466            
467             }
468            
469             }
470            
471             # if values are decreasing
472             } else {
473            
474             # repeat until interval is found
475 0         0 while (($khi - $klo) > 1) {
476            
477             # compute the midpoint
478 0         0 $k = int(($khi + $klo)/2);
479            
480             # if midpoint value < value
481 0 0       0 if ($xref->[$k] < $v) {
482            
483             # set high index to midpoint
484 0         0 $khi = $k;
485            
486             } else {
487            
488             # set low index to midpoint
489 0         0 $klo = $k;
490            
491             }
492            
493             }
494            
495             }
496              
497             # return low index
498 0         0 return ($klo);
499              
500             }
501              
502             # read curv tag from ICC profile
503             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
504             sub _readICCcurv {
505              
506             # get parameters
507 4     4   8 my ($self, $parent, $fh, $tag) = @_;
508              
509             # local variables
510 4         6 my ($buf, $cnt);
511              
512             # save tag signature
513 4         8 $self->[0]{'signature'} = $tag->[0];
514              
515             # seek start of tag
516 4         36 seek($fh, $tag->[1], 0);
517              
518             # read tag type signature and count
519 4         28 read($fh, $buf, 12);
520              
521             # unpack count
522 4         12 $cnt = unpack('x8 N', $buf);
523              
524             # if count == 1 (gamma)
525 4 50       19 if ($cnt == 1) {
    100          
526            
527             # read gamma
528 0         0 read($fh, $buf, 2);
529            
530             # unpack gamma
531 0         0 $self->[1] = [unpack('n', $buf)];
532            
533             # if count > 1
534             } elsif ($cnt > 1) {
535            
536             # read array values
537 1         5 read($fh, $buf, 2 * $cnt);
538            
539             # unpack array values
540 1         20 $self->[1] = [map {$_/65535} unpack('n*', $buf)];
  700         845  
541            
542             }
543            
544             }
545              
546             # write curv tag to ICC profile
547             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
548             sub _writeICCcurv {
549              
550             # get parameters
551 4     4   9 my ($self, $parent, $fh, $tag) = @_;
552              
553             # seek start of tag
554 4         23 seek($fh, $tag->[1], 0);
555              
556             # write tag type signature and count
557 4         13 print $fh pack('a4 x4 N', 'curv', scalar(@{$self->[1]}));
  4         30  
558              
559             # if count == 1 (gamma)
560 4 50       7 if (@{$self->[1]} == 1) {
  4 100       11  
561            
562             # write gamma
563 0         0 print $fh pack('n*', $self->[1][0]);
564            
565             # if count > 1
566 4         13 } elsif (@{$self->[1]} > 1){
567            
568             # write array, limiting values and adding 0.5 to round
569 1 50       2 print $fh pack('n*', map {$_ < 0 ? 0 : ($_ > 1 ? 65535 : $_ * 65535 + 0.5)} @{$self->[1]});
  700 50       1179  
  1         4  
570            
571             }
572            
573             }
574              
575             1;