view release on metacpan or  search on metacpan

lib/ICC/Profile/vcgt.pm  view on Meta::CPAN

		
		# transform input vector and copy to output
		@{$out} = _transform($self, $dir, @{$in});
		
	} else {
		
		# for each input element
		for my $i (0 .. $#{$in}) {
			
			# if an array reference
			if (ref($in->[$i]) eq 'ARRAY') {
				
				# transform next level
				_crawl($self, $dir, $in->[$i], $out->[$i] = []);
				
			} else {
				
				# error
				croak('invalid transform input');
				
			}
			
		}
		
	}
	
}

# transform input value array (vector)
# direction: 0 - normal, 1 - inverse
# parameters: (object_reference, direction, input_value_array)
# returns: (output_value_array)
sub _transform {

	# get parameters
	my ($self, $dir, @in) = @_;

	# local variables
	my (@out);

	# verify inputs are all scalars
	(@in == grep {! ref()} @in) || croak('invalid transform input');

	# verify number of inputs equals number of channels
	(@in == @{$self->[1]}) || croak('wrong number of input values');

	# for each channel
	for my $i (0 .. $#{$self->[1]}) {
		
		# if 'curv' object
		if (UNIVERSAL::isa($self->[1][$i], 'ICC::Profile::curv')) {
			
			# transform using 'curv' method
			$out[$i] = $self->[1][$i]->_transform($dir, $in[$i]);
			
		} else {
			
			# if normal direction
			if ($dir == 0) {
				
				# forward transform using formula (out = min + (max - min) * input^gamma)
				$out[$i] = $self->[1][$i][1] + ($self->[1][$i][2] - $self->[1][$i][1]) * $in[$i]**$self->[1][$i][0];
				
			} else {
				
				# reverse transform using formula (out = ((input - min)/(max - min))^(1/gamma))
				$out[$i] = (($in[$i] - $self->[1][$i][1])/($self->[1][$i][2] - $self->[1][$i][1]))**(1/$self->[1][$i][0]);
				
			}
			
		}
		
	}

	# return output array
	return(@out);

}

# read vcgt tag from ICC profile
# parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
sub _readICCvcgt {

	# get parameters
	my ($self, $parent, $fh, $tag) = @_;

	# local variables
	my ($tagType, $buf, $channels, $count, $size, @table);

	# save tag signature
	$self->[0]{'signature'} = $tag->[0];

	# seek start of tag
	seek($fh, $tag->[1], 0);

	# read first 12 bytes
	read($fh, $buf, 12);

	# unpack tagType (0 = cmVideoCardGammaTableType, 1 = cmVideoCardGammaFormulaType)
	$tagType = unpack('x8 N', $buf);

	# if table
	if ($tagType == 0) {
		
		# read 6 bytes
		read($fh, $buf, 6);
		
		# unpack channels, entryCount, entrySize
		($channels, $count, $size) = unpack('n3', $buf);
		
		# save entrySize in header hash
		$self->[0]{'entrySize'} = $size;
		
		# for each channel (gray or RGB)
		for my $i (0 .. $channels - 1) {
			
			# read table data
			read($fh, $buf, $count * $size);
			
			# if 8-bit
			if ($size == 1) {
				
				# unpack table
				@table = unpack('C*', $buf);
				
				# save as 'curv' object
				$self->[1][$i] = ICC::Profile::curv->new([map {$_/255} @table]);
				
			# else 16-bit
			} else {
				
				# unpack table
				@table = unpack('n*', $buf);
				
				# save as 'curv' object
				$self->[1][$i] = ICC::Profile::curv->new([map {$_/65535} @table]);
				
			}
			
		}
		
	# if formula
	} elsif ($tagType == 1) {
		
		# for each RGB
		for my $i (0 .. 2) {
			
			# read 12 bytes
			read($fh, $buf, 12);
			
			# unpack gamma, min, max (s15Fixed16Number values)
			$self->[1][$i] = [ICC::Shared::s15f162v(unpack('N3', $buf))];
			
		}
		
	} else {
		
		# error
		croak('invalid \'vcgt\' tagType');
		
	}
	
}

# write vcgt tag to ICC profile
# parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
sub _writeICCvcgt {

	# get parameters
	my ($self, $parent, $fh, $tag) = @_;

	# local variables
	my ($tagType, $channels, $count, $size, @table, $gamma);

	# seek start of tag
	seek($fh, $tag->[1], 0);

	# determine tagType (0 = cmVideoCardGammaTableType, 1 = cmVideoCardGammaFormulaType)
	$tagType = (UNIVERSAL::isa($self->[1][0], 'ICC::Profile::curv') && @{$self->[1][0]->array()} > 1) ? 0 : 1;

	# write signature and tagType
	print $fh pack('a4 x4 N', 'vcgt', $tagType);

	# if table
	if ($tagType == 0) {
		
		# get channels
		$channels = @{$self->[1]};
		
		# get entryCount
		$count = @{$self->[1][0]->array()};
		
		# if entrySize is 8-bit
		$size = (defined($self->[0]{'entrySize'}) && $self->[0]{'entrySize'} == 1) ? 1 : 2;
		
		# write channels, entryCount, entrySize
		print $fh pack('n3', $channels, $count, $size);
		
		# for each channel (gray or RGB)
		for my $i (0 .. $channels - 1) {
			
			# if 8-bit
			if ($size == 1) {
				
				# write table limiting values, converting to 8-bit, adding 0.5 to round
				print $fh pack('C*', map {$_ < 0 ? 0 : ($_ > 1 ? 255 : $_ * 255 + 0.5)} @{$self->[1][$i]->array()});
				
			# else 16-bit
			} else {
				
				# write table limiting values, converting to 16-bit, adding 0.5 to round
				print $fh pack('n*', map {$_ < 0 ? 0 : ($_ > 1 ? 65535 : $_ * 65535 + 0.5)} @{$self->[1][$i]->array()});
				
			}
			
		}
		
	# if formula
	} else {
		
		# if gamma type 'curv' objects
		if (UNIVERSAL::isa($self->[1][0], 'ICC::Profile::curv')) {
			
			# for each RGB
			for my $i (0 .. 2) {
				
				# get 'curv' object index (could be just one 'curv')
				my $j = defined($self->[1][$i]) ? $i : 0;
				
				# get gamma (use 1.0 if undefined)
				$gamma = defined($self->[1][$j]->array->[0]) ? $self->[1][$j]->array->[0] : 1;
				
				# write gamma, min, max (s15Fixed16Number values)
				print $fh pack('N3', ICC::Shared::v2s15f16($gamma, 0, 1));
				
			}
			
		# if numeric array
		} else {
			
			# for each RGB
			for my $i (0 .. 2) {
				
				# write gamma, min, max (s15Fixed16Number values)
				print $fh pack('N3', ICC::Shared::v2s15f16(@{$self->[1][$i]}));
				
			}
			
		}
		
	}
	
}

1;