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;