File Coverage

blib/lib/ICC/Profile/mBA_.pm

Criterion	Covered	Total	%
statement	206	458	44.9
branch	49	220	22.2
condition	11	98	11.2
subroutine	11	35	31.4
pod	2	21	9.5
total	279	832	33.5

package ICC::Profile::mBA_;

use strict;
use Carp;

our $VERSION = 2.51;

# revised 2018-08-07
#
# Copyright © 2004-2020 by William B. Birkett

# inherit from Shared
use parent qw(ICC::Shared);

# use POSIX math
use POSIX ();

# create new mBA_ object
# hash may contain pointers to B-curves, matrix, M-curves, CLUT, or A-curves
# keys are: ('b_curves', 'matrix', 'm_curves', 'clut', 'a_curves')
# tag elements not specified in the hash are left empty
# parameters: ()
# parameters: (ref_to_attribute_hash)
# parameters: (ref_to_matrix-based_profile_object)
# returns: (ref_to_object)
sub new {

	# get object class
	my $class = shift();

	# create empty mBA_ object
	my $self = [
		{},     # object header
		[],     # processing elements
		0x00,   # transform mask
		0x00    # clipping mask
	];

	# if there are parameters
	if (@_) {

		# if one parameter, a hash reference
		if (@_ == 1 && ref($_[0]) eq 'HASH') {

			# make new mBA_ tag from attribute hash
			_new_from_hash($self, @_);

		# if one parameter, an ICC::Profile object
		} elsif (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile')) {

			# make new mAB_ tag from ICC::Profile object
			_newICCmatrix($self, @_);

		} else {

			# error
			croak('parameter must be a hash reference or a display matrix profile');

		}

	}

	# bless object
	bless($self, $class);

	# return object reference
	return($self);

}

# get/set reference to header hash
# parameters: ([ref_to_new_hash])
# returns: (ref_to_hash)
sub header {

	# get object reference
	my $self = shift();

	# if there are parameters
	if (@_) {

		# if one parameter, a hash reference
		if (@_ == 1 && ref($_[0]) eq 'HASH') {

			# set header to new hash
			$self->[0] = shift();

		} else {

			# error
			croak('parameter must be a hash reference');

		}

	}

	# return reference
	return($self->[0]);

}

# get/set processing element array reference
# parameters: ([ref_to_array])
# returns: (ref_to_array)
sub array {

	# get object reference
	my $self = shift();

	# if parameter
	if (@_) {

		# verify array reference
		(ref($_[0]) eq 'ARRAY') or croak('not an array reference');

		# set array reference
		$self->[1] = [@{shift()}];

	}

	# return array reference
	return($self->[1]);

}

# get/set reference to B-curves 'cvst' object
# parameters: ([ref_to_new_object])
# returns: (ref_to_object)
sub b_curves {

	# get object reference
	my $self = shift();

	# if there are parameters
	if (@_) {

		# if one parameter, a 'cvst' object
		if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::cvst')) {

			# set B-curves to new object
			$self->[1][0] = shift();

			# set transform mask bit
			$self->[2] |= 0x01;

		} else {

			# error
			croak('parameter must be a \'cvst\' object');

		}

	}

	# return object reference
	return($self->[1][0]);

}

# get/set reference to matrix 'matf' object
# parameters: ([ref_to_new_object])
# returns: (ref_to_object)
sub matrix {

	# get object reference
	my $self = shift();

	# if there are parameters
	if (@_) {

		# if one parameter, an 'matf' object
		if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::matf')) {

			# set matrix to new object
			$self->[1][1] = shift();

			# set transform mask bit
			$self->[2] |= 0x02;

		} else {

			# error
			croak('parameter must be an \'matf\' object');

		}

	}

	# return object reference
	return($self->[1][1]);

}

# get/set reference to M-curves 'cvst' object
# parameters: ([ref_to_new_object])
# returns: (ref_to_object)
sub m_curves {

	# get object reference
	my $self = shift();

	# if there are parameters
	if (@_) {

		# if one parameter, a 'cvst' object
		if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::cvst')) {

			# set M-curves to new object
			$self->[1][2] = shift();

			# set transform mask bit
			$self->[2] |= 0x04;

		} else {

			# error
			croak('parameter must be a \'cvst\' object');

		}

	}

	# return object reference
	return($self->[1][2]);

}

# get/set reference to CLUT 'clut' object
# parameters: ([ref_to_new_object])
# returns: (ref_to_object)
sub clut {

	# get object reference
	my $self = shift();

	# if there are parameters
	if (@_) {

		# if one parameter, a 'clut' object
		if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::clut')) {

			# set CLUT to new object
			$self->[1][3] = shift();

			# set transform mask bit
			$self->[2] |= 0x08;

		} else {

			# error
			croak('parameter must be a \'clut\' object');

		}

	}

	# return object reference
	return($self->[1][3]);

}

# get/set reference to A-curves 'cvst' object
# parameters: ([ref_to_new_object])
# returns: (ref_to_object)
sub a_curves {

	# get object reference
	my $self = shift();

	# if there are parameters
	if (@_) {

		# if one parameter, a 'cvst' object
		if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::cvst')) {

			# set A-curves to new object
			$self->[1][4] = shift();

			# set transform mask bit
			$self->[2] |= 0x10;

		} else {

			# error
			croak('parameter must be a \'cvst\' object');

		}

	}

	# return object reference
	return($self->[1][4]);

}

# get/set transform mask
# bits 4-3-2-1-0 correpsond to A-CLUT-M-MATRIX-B
# parameters: ([new_mask_value])
# returns: (mask_value)
sub mask {

	# get object reference
	my $self = shift();

	# if there are parameters
	if (@_) {

		# if one parameter
		if (@_ == 1) {

			# set object transform mask value
			$self->[2] = shift();

		} else {

			# error
			croak('more than one parameter');

		}

	}

	# return transform mask value
	return($self->[2]);

}

# get/set clipping mask
# bits 4-3-2-1-0 correpsond to A-CLUT-M-MATRIX-B
# parameters: ([new_mask_value])
# returns: (mask_value)
sub clip {

	# get object reference
	my $self = shift();

	# if there are parameters
	if (@_) {

		# if one parameter
		if (@_ == 1) {

			# set object clipping mask value
			$self->[3] = shift();

		} else {

			# error
			croak('more than one parameter');

		}

	}

	# return clipping mask value
	return($self->[3]);

}

# create mBA_ tag object from ICC profile
# parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
# returns: (ref_to_object)
sub new_fh {

	# get object class
	my $class = shift();

	# create empty mBA_ object
	my $self = [
		{},     # object header
		[],     # processing elements
		0x00,   # transform mask
		0x00    # clipping mask
	];

	# verify 3 parameters
	(@_ == 3) or croak('wrong number of parameters');

	# read mBA_ data from profile
	_readICCmBA_($self, @_);

	# bless object
	bless($self, $class);

	# return object reference
	return($self);

}

# writes mBA_ tag object to ICC profile
# parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
sub write_fh {

	# verify 4 parameters
	(@_ == 4) or croak('wrong number of parameters');

	# write mBA_ data to profile
	goto &_writeICCmBA_;

}

# get tag size (for writing to profile)
# returns: (tag_clut_size)
sub size {

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

	# local variables
	my ($size);

	# set header size
	$size = 32;

	# for each B-curve
	for my $curve (@{$self->[1][0]->array()}) {

		# add curve size
		$size += $curve->size;

		# pad to 4-bytes
		$size += (-$size % 4);

	}

	# if matrix defined
	if (defined($self->[1][1])) {

		# add matrix size (48 bytes)
		$size += 48;

	}

	# if M-curves defined
	if (defined($self->[1][2])) {

		# for each M-curve
		for my $curve (@{$self->[1][2]->array()}) {

			# add curve size
			$size += $curve->size;

			# pad to 4-bytes
			$size += (-$size % 4);

		}

	}

	# if CLUT defined
	if (defined($self->[1][3])) {

		# add CLUT size (nCLUT object)
		$size += 20 + $self->[1][3]->_clut_size($self->[1][3][0]{'clut_bytes'} || 2);

		# pad to 4-byte boundary
		$size += (-$size % 4);

	}

	# if A-curves defined
	if (defined($self->[1][4])) {

		# for each A-curve
		for my $curve (@{$self->[1][4]->array()}) {

			# add curve size
			$size += $curve->size;

			# pad to 4-bytes
			$size += (-$size % 4);

		}

	}

	# return size
	return($size);

}

# get number of input channels
# returns: (number)
sub cin {

	# get object reference
	my $self = shift();

	# return
	return($self->[1][0]->cin());

}

# get number of output channels
# returns: (number)
sub cout {

	# get object reference
	my $self = shift();

	# return
	return($self->[1][-1]->cout());

}

# transform data
# transform mask enables/disables individual tag elements
# clipping mask enables/disables individual tag output clipping
# supported input types:
# parameters: (list, [hash])
# parameters: (vector, [hash])
# parameters: (matrix, [hash])
# parameters: (Math::Matrix_object, [hash])
# parameters: (structure, [hash])
# returns: (same_type_as_input)
sub transform {

	# set hash value (0 or 1)
	my $h = ref($_[-1]) eq 'HASH' ? 1 : 0;

	# if input a 'Math::Matrix' object
	if (@_ == $h + 2 && UNIVERSAL::isa($_[1], 'Math::Matrix')) {

		# call matrix transform
		&_trans2;

	# if input an array reference
	} elsif (@_ == $h + 2 && ref($_[1]) eq 'ARRAY') {

		# if array contains numbers (vector)
		if (! ref($_[1][0]) && @{$_[1]} == grep {Scalar::Util::looks_like_number($_)} @{$_[1]}) {

			# call vector transform
			&_trans1;

		# if array contains vectors (2-D array)
		} elsif (ref($_[1][0]) eq 'ARRAY' && @{$_[1]} == grep {ref($_) eq 'ARRAY' && Scalar::Util::looks_like_number($_->[0])} @{$_[1]}) {

			# call matrix transform
			&_trans2;

		} else {

			# call structure transform
			&_trans3;

		}

	# if input a list (of numbers)
	} elsif (@_ == $h + 1 + grep {Scalar::Util::looks_like_number($_)} @_) {

		# call list transform
		&_trans0;

	} else {

		# error
		croak('invalid transform input');

	}

}

# inverse transform
# note: number of undefined output values must equal number of defined input values
# note: the input and output vectors contain the final solution on return
# hash key 'init' specifies initial value vector
# hash key 'ubox' enables unit box extrapolation
# parameters: (input_vector, output_vector, [hash])
# returns: (RMS_error_value)
sub inverse {

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

	# local variables
	my ($i, $j, @si, @so, $init);
	my ($int, $jac, $mat, $delta);
	my ($max, $elim, $dlim, $accum, $error);

	# initialize indices
	$i = $j = -1;

	# build slice arrays while validating input and output arrays
	((grep {$i++; defined() && push(@si, $i)} @{$in}) == (grep {$j++; ! defined() && push(@so, $j)} @{$out})) or croak('wrong number of undefined values');

	# get init array
	$init = $hash->{'init'};

	# for each undefined output value
	for my $i (@so) {

		# set to supplied initial value or 0.5
		$out->[$i] = defined($init->[$i]) ? $init->[$i] : 0.5;

	}

	# set maximum loop count
	$max = $hash->{'inv_max'} || 10;

	# loop error limit
	$elim = $hash->{'inv_elim'} || 1E-6;

	# set delta limit
	$dlim = $hash->{'inv_dlim'} || 0.5;

	# create empty solution matrix
	$mat = Math::Matrix->new([]);

	# compute initial transform values
	($jac, $int) = jacobian($self, $out, $hash);

	# solution loop
	for (1 .. $max) {

		# for each input
		for my $i (0 .. $#si) {

			# for each output
			for my $j (0 .. $#so) {

				# copy Jacobian value to solution matrix
				$mat->[$i][$j] = $jac->[$si[$i]][$so[$j]];

			}

			# save residual value to solution matrix
			$mat->[$i][$#si + 1] = $in->[$si[$i]] - $int->[$si[$i]];

		}

		# solve for delta values
		$delta = $mat->solve;

		# for each output value
		for my $i (0 .. $#so) {

			# add delta (limited using hyperbolic tangent)
			$out->[$so[$i]] += POSIX::tanh($delta->[$i][0]/$dlim) * $dlim;

		}

		# compute updated transform values
		($jac, $int) = jacobian($self, $out, $hash);

		# initialize error accumulator
		$accum = 0;

		# for each input
		for my $i (0 .. $#si) {

			# accumulate delta squared
			$accum += ($in->[$si[$i]] - $int->[$si[$i]])**2;

		}

		# compute RMS error
		$error = sqrt($accum/@si);

		# if error less than limit
		last if ($error < $elim);

	}

	# update input vector with final values
	@{$in} = @{$int};

	# return
	return($error);

}

# compute Jacobian matrix
# transform mask enables/disables individual tag elements
# parameters: (input_vector, [hash])
# returns: (Jacobian_matrix, [output_vector])
sub jacobian {

	# get parameters
	my ($self, $data, $hash) = @_;

	# local variables
	my ($jac, $jaci);

	# for each processing element
	for my $i (0 .. $#{$self->[1]}) {

		# if processing element defined, and transform mask bit set
		if (defined($self->[1][$i]) && $self->[2] & 0x01 << $i) {

			# compute Jacobian matrix and transform data
			($jaci, $data) = $self->[1][$i]->jacobian($data, $hash);

			# multiply Jacobian matrices
			$jac = defined($jac) ? $jaci * $jac : $jaci;

		}

	}

	# if Jacobian matrix is undefined, use identity matrix
	$jac = Math::Matrix->diagonal((1) x @{$data}) if (! defined($jac));

	# if output values wanted
	if (wantarray) {

		# return Jacobian and output values
		return($jac, $data);

	} else {

		# return Jacobian only
		return($jac);

	}

}

# get/set PCS encoding
# for use with ICC::Support::PCS objects
# parameters: ([PCS_encoding])
# returns: (PCS_encoding)
sub pcs {

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

	# if PCS parameter is supplied
	if (defined($pcs)) {

		# if a valid PCS encoding
		if (grep {$pcs == $_} (3, 8)) {

			# copy to tag header hash
			$self->[0]{'pcs_encoding'} = $pcs;

			# return PCS encoding
			return($pcs);

		} else {

			# error
			croak('invalid PCS encoding');

		}

	} else {

		# if PCS is defined in tag header
		if (defined($self->[0]{'pcs_encoding'})) {

			# return PCS encoding
			return($self->[0]{'pcs_encoding'});

		} else {

			# error
			croak('can\'t determine PCS encoding');

		}

	}

}

# get/set white point
# parameters: ([white_point])
# returns: (white_point)
sub wtpt {

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

	# if white point parameter is supplied
	if (defined($wtpt)) {

		# if an array of three scalars
		if (@{$wtpt} == 3 && 3 == grep {! ref()} @{$wtpt}) {

			# copy to tag header hash
			$self->[0]{'wtpt'} = $wtpt;

			# return white point
			return($wtpt);

		} else {

			# error
			croak('invalid white point');

		}

	} else {

		# if white point is defined in tag header
		if (defined($self->[0]{'wtpt'})) {

			# return return white point
			return($self->[0]{'wtpt'});

		} else {

			# error
			croak('can\'t determine white point');

		}

	}

}

# print object contents to string
# format is an array structure
# parameter: ([format])
# returns: (string)
sub sdump {

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

	# local variables
	my ($element, $fmt, $s, $pt, $st);

	# resolve parameter to an array reference
	$p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : [];

	# get format string
	$fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 's';

	# set string to object ID
	$s = sprintf("'%s' object, (0x%x)\n", ref($self), $self);

	# if format contains 'o'
	if ($fmt =~ m/s/) {

		# get default parameter
		$pt = $p->[-1];

		# for each processing element
		for my $i (0 .. $#{$self->[1]}) {

			# get element reference
			$element = $self->[1][$i];

			# if processing element is undefined
			if (! defined($element)) {

				# append message
				$s .= "\tprocessing element is undefined\n";

			# if processing element is not a blessed object
			} elsif (! Scalar::Util::blessed($element)) {

				# append message
				$s .= "\tprocessing element is not a blessed object\n";

			# if processing element has an 'sdump' method
			} elsif ($element->can('sdump')) {

				# get 'sdump' string
				$st = $element->sdump(defined($p->[$i + 1]) ? $p->[$i + 1] : $pt);

				# prepend tabs to each line
				$st =~ s/^/\t/mg;

				# append 'sdump' string
				$s .= $st;

			# processing element is object without an 'sdump' method
			} else {

				# append object info
				$s .= sprintf("\t'%s' object, (0x%x)\n", ref($element), $element);

			}

		}

	}

	# return
	return($s);

}

# transform list
# parameters: (object_reference, list, [hash])
# returns: (list)
sub _trans0 {

	# local variables
	my ($self, $hash, $data);

	# get object reference
	$self = shift();

	# get optional hash
	$hash = pop() if (ref($_[-1]) eq 'HASH');

	# process data
	$data = _trans1($self, [@_], $hash);

	# return list
	return(@{$data});

}

# transform vector
# parameters: (object_reference, vector, [hash])
# returns: (vector)
sub _trans1 {

	# get parameters
	my ($self, $data, $hash) = @_;

	# for each processing element
	for my $i (0 .. $#{$self->[1]}) {

		# if processing element defined, and transform mask bit set
		if (defined($self->[1][$i]) && $self->[2] & 0x01 << $i) {

			# transform data
			$data = $self->[1][$i]->_trans1($data, $hash);

			# clip output values if clipping mask bit set
			ICC::Shared::clip_struct($data) if ($self->[3] & 0x01 << $i);

		}

	}

	# return
	return($data);

}

# transform matrix (2-D array -or- Math::Matrix object)
# parameters: (object_reference, matrix, [hash])
# returns: (matrix)
sub _trans2 {

	# get parameters
	my ($self, $data, $hash) = @_;

	# for each processing element
	for my $i (0 .. $#{$self->[1]}) {

		# if processing element defined, and transform mask bit set
		if (defined($self->[1][$i]) && $self->[2] & 0x01 << $i) {

			# transform data
			$data = $self->[1][$i]->_trans2($data, $hash);

			# clip output values if clipping mask bit set
			ICC::Shared::clip_struct($data) if ($self->[3] & 0x01 << $i);

		}

	}

	# return
	return($data);

}

# transform structure
# parameters: (object_reference, structure, [hash])
# returns: (structure)
sub _trans3 {

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

	# transform the array structure
	_crawl($self, $in, my $out = [], $hash);

	# return
	return($out);

}

# recursive transform
# array structure is traversed until scalar arrays are found and transformed
# parameters: (ref_to_object, input_array_reference, output_array_reference, hash)
sub _crawl {

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

	# if input is a vector (reference to a scalar array)
	if (@{$in} == grep {! ref()} @{$in}) {

		# transform input vector and copy to output
		@{$out} = @{_trans1($self, $in, $hash)};

	} 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, $in->[$i], $out->[$i] = [], $hash);

			} else {

				# error
				croak('invalid transform input');

			}

		}

	}

}

# check object structure
# parameter: (ref_to_object)
# returns: (number_input_channels, number_output_channels)
sub _check {

	# get object reference
	my $self = shift();

	# local variables
	my (@class, $ci, $co);

	# make object class array
	@class = qw(ICC::Profile::cvst ICC::Profile::matf ICC::Profile::cvst ICC::Profile::clut ICC::Profile::cvst);

	# verify number of processing elements
	($#{$self->[1]} <= 4) or croak('\'mBA_\' object has too many processing elements');

	# for each processing element
	for my $i (0 .. $#{$self->[1]}) {

		# if element is defined (matrix and M-curves to may be undefined)
		if (defined($self->[1][$i])) {

			# verify element has correct class
			(ref($self->[1][$i]) eq $class[$i]) or croak("'mBA_' processing element $i has wrong class");

			# if element has 'cin' method
			if ($self->[1][$i]->can('cin')) {

				# if number of input channels is undefined
				if (! defined($ci)) {

					# set number of input channels
					$ci = $self->[1][$i]->cin();

				}

				# if number of output channels is defined
				if (defined($co)) {

					# verify input channels of this element match output channels of previous element
					($self->[1][$i]->cin() == $co) or croak("'mBA_' processing element $i has wrong number of channels");

				}

			}

			# if element has 'cout' method
			if ($self->[1][$i]->can('cout')) {

				# set number of output channels
				$co = $self->[1][$i]->cout();

			}

		}

	}

	# verify B-curves are defined
	(defined($self->[1][0])) or croak('B-curves are required');

	# verify matrix and M-curves are both defined, or neither
	(defined($self->[1][1]) xor defined($self->[1][2])) && croak('matrix and M-curves must both be defined, or neither');

	# verify CLUT and A-curves are both defined, or neither
	(defined($self->[1][3]) xor defined($self->[1][4])) && croak('CLUT and A-curves must both be defined, or neither');

	# if matrix defined
	if (defined($self->[1][1])) {

		# verify object has 3 output channels
		($ci == 3) or croak("matrix processing element not permitted with $ci input channels");

		# verify matrix size (3x3)
		($self->[1][1]->cin() == 3 && $self->[1][1]->cout() == 3) or croak('matrix processing element matrix wrong size');

		# verify offset size (undefined, 0 or 3)
		(! defined($self->[1][1][2]) || @{$self->[1][1][2]} == 0 || @{$self->[1][1][2]} == 3) or croak('matrix processing element offset wrong size');

	}

	# return
	return($ci, $co);

}

# set M-curves, matrix, and B-curves
# equivalent to inverse of a matrix-based display profile
# parameters: (ref_to_mAB_object, ref_to_profile_object)
sub _newICCmatrix {

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

	# local variables
	my (@XYZ, @TRC, $wtpt, $bkpt, $id, $mat);

	# verify an RGB/XYZ display profile
	(UNIVERSAL::isa($disp, 'ICC::Profile') && $disp->profile_header->[3] eq 'mntr' && $disp->profile_header->[4] eq 'RGB ' && $disp->profile_header->[5] eq 'XYZ ') or croak('not an RGB-XYZ display profile');

	# get primary tags
	@XYZ = $disp->tag(qw(rXYZ gXYZ bXYZ));

	# get TRC tags
	@TRC = $disp->tag(qw(rTRC gTRC bTRC));

	# verify a matrix profile
	(@XYZ == 3 && @TRC == 3) or croak('not a matrix profile');

	# set input colorspace
	$self->[0]{'input_cs'} = 'XYZ ';

	# set output colorspace
	$self->[0]{'output_cs'} = 'RGB ';

	# set PCS encoding
	$self->[0]{'pcs_encoding'} = 7;

	# get white point tag
	$wtpt = $disp->tag('wtpt');

	# set white point value
	$self->[0]{'wtpt'} = [@{$wtpt->XYZ}] if (defined($wtpt));

	# get black point tag
	$bkpt = $disp->tag('bkpt');

	# set black point value
	$self->[0]{'bkpt'} = [@{$bkpt->XYZ}] if (defined($bkpt));

	# make identity curve
	$id = ICC::Profile::curv->new();

	# make Math::Matrix object from primary tags (inverse)
	$mat = Math::Matrix->new(map {$_->XYZ()} @XYZ)->transpose->invert->multiply_scalar(65535/32768);

	# set B-curves
	$self->[1][0] = ICC::Profile::cvst->new([$id, $id, $id]);

	# set matrix (inverse)
	$self->[1][1] = ICC::Profile::matf->new({'matrix' => $mat});

	# set M-curves (inverse)
	$self->[1][2] = ICC::Profile::cvst->new([map {$_->inv()} @TRC]);

	# set transform mask
	$self->[2] = 0x07;

}

# make new mBA_ tag from attribute hash
# hash may contain pointers to B-curves, matrix, M-curves, CLUT, or A-curves
# keys are: ('b_curves', 'matrix', 'm_curves', 'clut', 'a_curves')
# tag elements not specified in the hash are left empty
# parameters: (ref_to_object, ref_to_attribute_hash)
sub _new_from_hash {

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

	# set attribute list (key => [reference_type, array_index])
	my %list = ('b_curves' => ['ICC::Profile::cvst', 0], 'matrix' => ['ICC::Profile::matf', 1], 'm_curves' => ['ICC::Profile::cvst', 2], 'clut' => ['ICC::Profile::clut', 3], 'a_curves' => ['ICC::Profile::cvst', 4]);

	# for each attribute
	for my $attr (keys(%{$hash})) {

		# if value defined
		if (defined($hash->{$attr})) {

			# if correct reference type
			if (ref($hash->{$attr}) eq $list{$attr}[0]) {

				# set tag element
				$self->[1][$list{$attr}[1]] = $hash->{$attr};

				# set transform mask bit
				$self->[2] |= (0x01 << $list{$attr}[1]);

			} else {

				# error
				croak("wrong object type for $attr key");

			}

		}

	}

}

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

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

	# local variables
	my ($buf, @mft, $pel, $mark, @mat, $bytes, $gsa);

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

	# set input colorspace
	$self->[0]{'input_cs'} = $parent->[1][5];

	# set output colorspace
	$self->[0]{'output_cs'} = $parent->[1][4];

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

	# read tag header
	read($fh, $buf, 32);

	# unpack header
	@mft = unpack('a4 x4 C2 x2 N5', $buf);

	# verify tag signature
	($mft[0] eq 'mBA ') or croak('wrong tag type');

	# verify number input channels (1 to 15)
	($mft[1] > 0 && $mft[1] < 16) or croak('unsupported number of input channels');

	# verify number output channels (1 to 15)
	($mft[2] > 0 && $mft[2] < 16) or croak('unsupported number of output channels');

	# if B-curves are defined
	if ($mft[3]) {

		# make 'cvst' object for B-curves
		$pel = ICC::Profile::cvst->new();

		# set file pointer to start of first B-curve
		$mark = $tag->[1] + $mft[3];

		# for each input channel
		for my $i (0 .. $mft[1] - 1) {

			# adjust file pointer to 4-byte boundary
			$mark += (-$mark % 4);

			# seek to start of curve
			seek($fh, $mark, 0);

			# read curve type
			read($fh, $buf, 4);

			# if 'curv' type
			if ($buf eq 'curv') {

				# parse 'curv' object
				$pel->[1][$i] = ICC::Profile::curv->new_fh($self, $fh, ['cvst', $mark, 0, 0]);

			} elsif ($buf eq 'para') {

				# parse 'para' object
				$pel->[1][$i] = ICC::Profile::para->new_fh($self, $fh, ['cvst', $mark, 0, 0]);

			} else {

				# error
				croak('unsupported curve type or invalid tag structure');

			}

			# mark current file pointer location
			$mark = tell($fh);

		}

		# set signature
		$pel->[0]{'signature'} = 'mBA_';

		# add processing element
		$self->[1][0] = $pel;

		# set transform mask
		$self->[2] |= 0x01;

	}

	# if matrix is defined
	if ($mft[4]) {

		# make 'matf' object for matrix
		$pel = ICC::Profile::matf->new();

		# seek to start of matrix
		seek($fh, $tag->[1] + $mft[4], 0);

		# read matrix
		$pel->_read_matf($fh, 3, 3, 1, 2);

		# set signature
		$pel->[0]{'signature'} = 'mBA_';

		# add processing element
		$self->[1][1] = $pel;

		# set transform mask
		$self->[2] |= 0x02;

	}

	# if M-curves are defined
	if ($mft[5]) {

		# make 'cvst' object for M-curves
		$pel = ICC::Profile::cvst->new();

		# set file pointer to start of first M-curve
		$mark = $tag->[1] + $mft[5];

		# for each input channel
		for my $i (0 .. $mft[1] - 1) {

			# adjust file pointer to 4-byte boundary
			$mark += (-$mark % 4);

			# seek to start of curve
			seek($fh, $mark, 0);

			# read curve type
			read($fh, $buf, 4);

			# if 'curv' type
			if ($buf eq 'curv') {

				# parse 'curv' object
				$pel->[1][$i] = ICC::Profile::curv->new_fh($self, $fh, ['cvst', $mark, 0, 0]);

			} elsif ($buf eq 'para') {

				# parse 'para' object
				$pel->[1][$i] = ICC::Profile::para->new_fh($self, $fh, ['cvst', $mark, 0, 0]);

			} else {

				# error
				croak('unsupported curve type or invalid tag structure');

			}

			# mark current file pointer location
			$mark = tell($fh);

		}

		# set signature
		$pel->[0]{'signature'} = 'mBA_';

		# add processing element
		$self->[1][2] = $pel;

		# set transform mask
		$self->[2] |= 0x04;

	}

	# if CLUT defined
	if ($mft[6]) {

		# make 'clut' object for CLUT
		$pel = ICC::Profile::clut->new();

		# seek to start of CLUT
		seek($fh, $tag->[1] + $mft[6], 0);

		# read header
		read($fh, $buf, 20);

		# unpack header
		@mat = unpack('C17', $buf);

		# get CLUT byte width
		$bytes = pop(@mat);

		# save CLUT byte width
		$pel->[0]{'clut_bytes'} = $bytes;

		# set number of input channels
		$pel->[0]{'input_channels'} = $mft[1];

		# set number of output channels
		$pel->[0]{'output_channels'} = $mft[2];

		# make grid size array
		$gsa = [grep {$_} @mat];

		# read 'clut' data
		$pel->_read_clut($fh, $mft[2], $gsa, $bytes);

		# save grid size array
		$pel->[2] = [@{$gsa}];

		# set signature
		$pel->[0]{'signature'} = 'mBA_';

		# add processing element
		$self->[1][3] = $pel;

		# set transform mask
		$self->[2] |= 0x08;

	}

	# if A-curves are defined
	if ($mft[7]) {

		# make 'cvst' object for A-curves
		$pel = ICC::Profile::cvst->new();

		# set file pointer to start of first A-curve
		$mark = $tag->[1] + $mft[7];

		# for each output channel
		for my $i (0 .. $mft[2] - 1) {

			# adjust file pointer to 4-byte boundary
			$mark += (-$mark % 4);

			# seek to start of curve
			seek($fh, $mark, 0);

			# read curve type
			read($fh, $buf, 4);

			# if 'curv' type
			if ($buf eq 'curv') {

				# parse 'curv' object
				$pel->[1][$i] = ICC::Profile::curv->new_fh($self, $fh, ['cvst', $mark, 0, 0]);

			} elsif ($buf eq 'para') {

				# parse 'para' object
				$pel->[1][$i] = ICC::Profile::para->new_fh($self, $fh, ['cvst', $mark, 0, 0]);

			} else {

				# error
				croak('unsupported curve type or invalid tag structure');

			}

			# mark current file pointer location
			$mark = tell($fh);

		}

		# set signature
		$pel->[0]{'signature'} = 'mBA_';

		# add processing element
		$self->[1][4] = $pel;

		# set transform mask
		$self->[2] |= 0x10;

	}

}

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

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

	# local variables
	my (@mft, $offset, @mat, $bytes, $size);

	# set tag type
	$mft[0] = 'mBA ';

	# check object structure
	@mft[1, 2] = _check($self);

	# initialize offset
	$offset = 32;

	# set offset to B-curves
	$mft[3] = 32;

	# if B-curves defined
	if (defined($self->[1][0])) {

		# for each B-curve
		for my $curve (@{$self->[1][0]->array()}) {

			# add curve size
			$offset += $curve->size;

			# pad to 4-bytes
			$offset += (-$offset % 4);

		}

	} else {

		# error
		croak('B-curves are required');

	}

	# if matrix is defined
	if (defined($self->[1][1])) {

		# verify output channels
		($mft[2] == 3) or croak('3 output channels required for matrix');

		# set offset
		$mft[4] = $offset;

		# increment offset for matrix size
		$offset += 48;

	} else {

		# set offset
		$mft[4] = 0;

	}

	# if M-curves defined
	if (defined($self->[1][2])) {

		# verify output channels
		($mft[2] == 3) or croak('3 output channels required for M-curves');

		# set offset
		$mft[5] = $offset;

		# for each M-curve
		for my $curve (@{$self->[1][2]->array()}) {

			# add curve size
			$offset += $curve->size;

			# pad to 4-bytes
			$offset += (-$offset % 4);

		}

	} else {

		# set offset
		$mft[5] = 0;

	}

	# if CLUT defined
	if (defined($self->[1][3])) {

		# set offset
		$mft[6] = $offset;

		# get CLUT data size
		$bytes = $self->[1][3][0]{'clut_bytes'} || 2;

		# add CLUT size to offset
		$offset += 20 + $self->[1][3]->_clut_size($bytes);

		# pad to 4-byte boundary
		$offset += (-$offset % 4);

	} else {

		# set offset
		$mft[6] = 0;

	}

	# if A-curves defined
	if (defined($self->[1][4])) {

		# set offset
		$mft[7] = $offset;

	} else {

		# set offset
		$mft[7] = 0;

	}

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

	# write header
	print $fh pack('a4 x4 C2 x2 N5', @mft);

	# seek start of B-curves
	seek($fh, $tag->[1] + $mft[3], 0);

	# for each B-curve
	for my $curve (@{$self->[1][0]->array()}) {

		# write curve object
		$curve->write_fh($self->[1][0], $fh, ['cvst', tell($fh), 0, 0]);

		# add padding to 4-byte boundary
		seek($fh, (-tell($fh) % 4), 1);

	}

	# if matrix is defined
	if (defined($self->[1][1])) {

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

		# write matrix
		$self->[1][1]->_write_matf($fh, 1, 2);

	}

	# if M-curves are defined
	if (defined($self->[1][2])) {

		# seek start of M-curves
		seek($fh, $tag->[1] + $mft[5], 0);

		# for each M-curve
		for my $curve (@{$self->[1][2]->array()}) {

			# write curve object
			$curve->write_fh($self->[1][2], $fh, ['cvst', tell($fh), 0, 0]);

			# add padding to 4-byte boundary
			seek($fh, (-tell($fh) % 4), 1);

		}

	}

	# if CLUT is defined
	if (defined($self->[1][3])) {

		# for each possible input channel
		for my $i (0 .. 15) {

			# set grid size
			$mat[$i] = $self->[1][3]->gsa->[$i] || 0;

		}

		# set CLUT byte width
		$mat[16] = $bytes;

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

		# write CLUT header
		print $fh pack('C17 x3', @mat);

		# write CLUT
		$self->[1][3]->_write_clut($fh, $self->[1][3]->gsa(), $bytes);

	}

	# if A-curves are defined
	if (defined($self->[1][4])) {

		# seek start of A-curves
		seek($fh, $tag->[1] + $mft[7], 0);

		# for each M-curve
		for my $curve (@{$self->[1][4]->array()}) {

			# write curve object
			$curve->write_fh($self->[1][4], $fh, ['cvst', tell($fh), 0, 0]);

			# add padding to 4-byte boundary
			seek($fh, (-tell($fh) % 4), 1);

		}

	}

}

1;