File Coverage

blib/lib/Graphics/ColorDeficiency.pm

Criterion	Covered	Total	%
statement	68	71	95.7
branch	14	14	100.0
condition	3	3	100.0
subroutine	14	15	93.3
pod	10	13	76.9
total	109	116	93.9

package Graphics::ColorDeficiency;

use Graphics::ColorObject;
use Graphics::ColorDeficiency::Data;

@ISA = ('Graphics::ColorObject');
$VERSION = 0.05;

sub Clone {
	my ($self) = @_;
	my ($r,$g,$b) = $self->asRGB;
	return Graphics::ColorDeficiency->newRGB($r, $g, $b);
}

sub asProtanomaly {
	my ($self, $ratio) = @_;
	$ratio = 0.5 unless defined $ratio;
	my $temp = $self->asProtanopia;
	return $self->asMix($temp, $ratio);
}

sub asDeuteranomaly {
	my ($self, $ratio) = @_;
	$ratio = 0.5 unless defined $ratio;
	my $temp = $self->asDeutanopia;
	return $self->asMix($temp, $ratio);
}

sub asTritanomaly {
	my ($self, $ratio) = @_;
	$ratio = 0.5 unless defined $ratio;
	my $temp = $self->asTritanopia;
	return $self->asMix($temp, $ratio);
}

sub asProtanopia {
	return shift->asHash(0);
}

sub asDeutanopia {
	return shift->asHash(1);
}

sub asTritanopia {
	return shift->asHash(2);
}

sub asTypicalMonochrome {
	my ($self) = @_;
	my $val = $self->asGrey2;
	my ($h1, $s1, $v1) = $self->asHSV;
	my $temp = Graphics::ColorObject->newRGB($val, $val, $val);
	my ($h2, $s2, $v2) = $temp->asHSV;
	$temp->setHSV($h2, $s2, ($v1+$v2)/2);
	return $temp;
}

sub asAtypicalMonochrome {
	my ($self, $ratio) = @_;
	$ratio = 0.2 unless defined $ratio;
	my $temp = $self->asTypicalMonochrome;
	return $self->asMix($temp, 1 - $ratio);
}

sub asHash {
	my ($self, $id) = @_;

	my ($r, $g, $b) = $self->asRGB();

	my ($lo_r, $hi_r) = $self->getColorBounds($r);
	my ($lo_r_rat, $hi_r_rat) = $self->getMixRatios($r, $hi_r, $lo_r);

	my ($lo_g, $hi_g) = $self->getColorBounds($g);
	my ($lo_g_rat, $hi_g_rat) = $self->getMixRatios($g, $hi_g, $lo_g);

	my ($lo_b, $hi_b) = $self->getColorBounds($b);
	my ($lo_b_rat, $hi_b_rat) = $self->getMixRatios($b, $hi_b, $lo_b);

	my $lo_col = Graphics::ColorObject->newRGB($lo_r, $lo_g, $lo_b);
	my $hi_col = Graphics::ColorObject->newRGB($hi_r, $hi_g, $hi_b);

	my $from_lo = $Graphics::ColorDeficiency::Data::HASH->{substr(lc $lo_col->asHex,1)}[$id];
	my $from_hi = $Graphics::ColorDeficiency::Data::HASH->{substr(lc $hi_col->asHex,1)}[$id];

	my ($f_l_r, $f_l_g, $f_l_b) = map{hex($_) / 255} ($from_lo =~ /../g);
	my ($f_h_r, $f_h_g, $f_h_b) = map{hex($_) / 255} ($from_hi =~ /../g);

	my $r_out = ($f_l_r * $lo_r_rat) + ($f_h_r * $hi_r_rat);
	my $g_out = ($f_l_g * $lo_g_rat) + ($f_h_g * $hi_g_rat);
	my $b_out = ($f_l_b * $lo_b_rat) + ($f_h_b * $hi_b_rat);

	return Graphics::ColorObject->newRGB($r_out, $g_out, $b_out);
}

sub asMix {
	my ($self, $mix, $rat2) = @_;
	my $rat1 = 1 - $rat2;
	my ($r1, $g1, $b1) = $self->asRGB();
	my ($r2, $g2, $b2) = $mix->asRGB();
	return Graphics::ColorDeficiency->newRGB( ($r1*$rat1)+($r2*$rat2), ($g1*$rat1)+($g2*$rat2), ($b1*$rat1)+($b2*$rat2) );
}

sub getColorBounds {
	my ($self, $val) = @_;
	$val *= 10;
	my ($lo, $hi) = (0, 10);
	for(my $i=0; $i<=10; $i+=2){
		$lo = $i if $val >= $i;
		$hi = $i if $val <= $i && $i < $hi;
	}
	return ($lo/10, $hi/10);
}

sub getMixRatios {
	my ($self, $val, $hi, $lo) = @_;

	return (0.5, 0.5) if ($hi == $val);

	$r1 = ($val - $lo) / 0x33;
	return ($r1, 1-$r1);
}

=head1 NAME

Graphics::ColorDeficiency - Color Deficiency Simulation

=head1 SYNOPSIS

  use Graphics::ColorDeficiency;

  my $col = Graphics::ColorDeficiency->newRGB(0.5, 0.7, 1);

  my $col2 = $col->asProtanopia;

  print $col2->asHex;

=head1 DESCRIPTION

This module allows easy transformation of colors for color deficiency
simulation. All the known and theorhetical color deficiencies are
represented here, with the exception of 4-cone vision (tetrachromatism).

Each of the transformation methods returns a C object,
with the internal color values set. This can then be used to return the
color in many different formats (see the C manpage).

=head1 METHODS

=over 4

=item C

=item C

=item C

The three dichromat methods return a C object,
simulated for the three dichromatic vision modes.

=item C

=item C

=item C

The three anomalous trichromat methods return a C object,
simulated for the three anomalous trichromatic vision modes. The optional
C<$amount> agrument allows you to specify the severity of anomaly, ranging
from 0 (trichromatic) to 1 (dichromatic). If not specified, it defaults to
0.5.

=item C

Returns a C object in Typical Monochromatic (Rod
Monochromat) mode.

=item C

Returns a C object in Atypical Monochromatic (Cone
Monochromat) mode. The amount specified in C<$amount> can vary between 1
(trichromatic) and 0 (monochromatic). The default is 0.2 (four fifths gray).

=item C

Clones the current object, returning a C object
with the same color values as the current object.

=item C

Returns a new C, consisting of the current color
values, mixed with the values of the C<$color> object. C<$amount> specifies
the amount of the new color to mix in, from 0 (which is equal to
C<$self.Clone()>), up to 1 (which is equal to C<$color.Clone()>). The mix
is a linear RGB interpolation.

This method is used internally.

=back

=head1 AUTHOR

Copyright (C) 2003 Cal Henderson

=head1 SEE ALSO

L

L

=cut