File Coverage

File:blib/lib/Graphics/ColorDeficiency.pm
Coverage:96.1%

linestmtbrancondsubtimecode
1package Graphics::ColorDeficiency;
2
3
4
4
4
4
28
13
45
use Graphics::ColorObject;
4
4
4
4
4
4835
68
47
use Graphics::ColorDeficiency::Data;
5
6@ISA = ('Graphics::ColorObject');
7$VERSION = 0.05;
8
9sub Clone {
10
0
0
0
        my ($self) = @_;
11
0
0
        my ($r,$g,$b) = $self->asRGB;
12
0
0
        return Graphics::ColorDeficiency->newRGB($r, $g, $b);
13}
14
15sub asProtanomaly {
16
3
3
11
        my ($self, $ratio) = @_;
17
3
100
11
        $ratio = 0.5 unless defined $ratio;
18
3
10
        my $temp = $self->asProtanopia;
19
3
12
        return $self->asMix($temp, $ratio);
20}
21
22sub asDeuteranomaly {
23
3
3
10
        my ($self, $ratio) = @_;
24
3
100
11
        $ratio = 0.5 unless defined $ratio;
25
3
9
        my $temp = $self->asDeutanopia;
26
3
12
        return $self->asMix($temp, $ratio);
27}
28
29sub asTritanomaly {
30
3
3
11
        my ($self, $ratio) = @_;
31
3
100
11
        $ratio = 0.5 unless defined $ratio;
32
3
11
        my $temp = $self->asTritanopia;
33
3
12
        return $self->asMix($temp, $ratio);
34}
35
36sub asProtanopia {
37
4
4
17
        return shift->asHash(0);
38}
39
40sub asDeutanopia {
41
4
4
18
        return shift->asHash(1);
42}
43
44sub asTritanopia {
45
4
4
14
        return shift->asHash(2);
46}
47
48sub asTypicalMonochrome {
49
5
5
14
        my ($self) = @_;
50
5
19
        my $val = $self->asGrey2;
51
5
20
        my ($h1, $s1, $v1) = $self->asHSV;
52
5
23
        my $temp = Graphics::ColorObject->newRGB($val, $val, $val);
53
5
18
        my ($h2, $s2, $v2) = $temp->asHSV;
54
5
27
        $temp->setHSV($h2, $s2, ($v1+$v2)/2);
55
5
23
        return $temp;
56}
57
58sub asAtypicalMonochrome {
59
4
4
13
        my ($self, $ratio) = @_;
60
4
100
15
        $ratio = 0.2 unless defined $ratio;
61
4
11
        my $temp = $self->asTypicalMonochrome;
62
4
17
        return $self->asMix($temp, 1 - $ratio);
63}
64
65sub asHash {
66
12
12
31
        my ($self, $id) = @_;
67
68
12
48
        my ($r, $g, $b) = $self->asRGB();
69
70
12
42
        my ($lo_r, $hi_r) = $self->getColorBounds($r);
71
12
43
        my ($lo_r_rat, $hi_r_rat) = $self->getMixRatios($r, $hi_r, $lo_r);
72
73
12
36
        my ($lo_g, $hi_g) = $self->getColorBounds($g);
74
12
44
        my ($lo_g_rat, $hi_g_rat) = $self->getMixRatios($g, $hi_g, $lo_g);
75
76
12
37
        my ($lo_b, $hi_b) = $self->getColorBounds($b);
77
12
40
        my ($lo_b_rat, $hi_b_rat) = $self->getMixRatios($b, $hi_b, $lo_b);
78
79
12
47
        my $lo_col = Graphics::ColorObject->newRGB($lo_r, $lo_g, $lo_b);
80
12
50
        my $hi_col = Graphics::ColorObject->newRGB($hi_r, $hi_g, $hi_b);
81
82
12
55
        my $from_lo = $Graphics::ColorDeficiency::Data::HASH->{substr(lc $lo_col->asHex,1)}[$id];
83
12
52
        my $from_hi = $Graphics::ColorDeficiency::Data::HASH->{substr(lc $hi_col->asHex,1)}[$id];
84
85
12
36
58
123
        my ($f_l_r, $f_l_g, $f_l_b) = map{hex($_) / 255} ($from_lo =~ /../g);
86
12
36
40
110
        my ($f_h_r, $f_h_g, $f_h_b) = map{hex($_) / 255} ($from_hi =~ /../g);
87
88
12
43
        my $r_out = ($f_l_r * $lo_r_rat) + ($f_h_r * $hi_r_rat);
89
12
31
        my $g_out = ($f_l_g * $lo_g_rat) + ($f_h_g * $hi_g_rat);
90
12
36
        my $b_out = ($f_l_b * $lo_b_rat) + ($f_h_b * $hi_b_rat);
91
92
12
53
        return Graphics::ColorObject->newRGB($r_out, $g_out, $b_out);
93}
94
95sub asMix {
96
13
13
38
        my ($self, $mix, $rat2) = @_;
97
13
33
        my $rat1 = 1 - $rat2;
98
13
44
        my ($r1, $g1, $b1) = $self->asRGB();
99
13
46
        my ($r2, $g2, $b2) = $mix->asRGB();
100
13
103
        return Graphics::ColorDeficiency->newRGB( ($r1*$rat1)+($r2*$rat2), ($g1*$rat1)+($g2*$rat2), ($b1*$rat1)+($b2*$rat2) );
101}
102
103sub getColorBounds {
104
36
36
99
        my ($self, $val) = @_;
105
36
66
        $val *= 10;
106
36
88
        my ($lo, $hi) = (0, 10);
107        for(my $i=0; $i<=10; $i+=2){
108
216
100
680
                $lo = $i if $val >= $i;
109
216
100
100
1646
                $hi = $i if $val <= $i && $i < $hi;
110
36
69
        }
111
36
144
        return ($lo/10, $hi/10);
112}
113
114sub getMixRatios {
115
36
36
106
        my ($self, $val, $hi, $lo) = @_;
116
117
36
100
148
        return (0.5, 0.5) if ($hi == $val);
118
119
12
34
        $r1 = ($val - $lo) / 0x33;
120
12
43
        return ($r1, 1-$r1);
121}
122
123 - 210
=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<Graphics::ColorObject> object,
with the internal color values set. This can then be used to return the 
color in many different formats (see the C<Graphics::ColorObject> manpage).

=head1 METHODS

=over 4

=item C<asProtanopia()>

=item C<asDeutanopia()>

=item C<asTritanopia()>

The three dichromat methods return a C<Graphics::ColorObject> object,
simulated for the three dichromatic vision modes.

=item C<asProtanomaly( $amount )>

=item C<asDeuteranomaly( $amount )>

=item C<asTritanomaly( $amount )>

The three anomalous trichromat methods return a C<Graphics::ColorObject> 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<asTypicalMonochrome()>

Returns a C<Graphics::ColorObject> object in Typical Monochromatic (Rod
Monochromat) mode.

=item C<asAtypicalMonochrome( $amount )>

Returns a C<Graphics::ColorObject> 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<Clone()>

Clones the current object, returning a C<Graphics::ColorDeficiency> object
with the same color values as the current object.

=item C<asMix( $color, $amount )>

Returns a new C<Graphics::ColorDeficiency>, 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 <cal@iamcal.com>

=head1 SEE ALSO

L<Graphics::ColorObject>

L<http://www.iamcal.com/toys/colors/>

=cut