Acme::Colour - additive and subtractive human-readable colours
Index
Code Index:
NAME
Acme::Colour - additive and subtractive human-readable colours
SYNOPSIS
# light
$c = Acme::Colour->new("black");
$colour = $c->colour; # black
$c->add("red"); # $c->colour now red
$c->add("green"); # $c->colour now yellow
# pigment
$c = Acme::Colour->new("white");
$c->mix("cyan"); # $c->colour now cyan
$c->mix("magenta"); # $c->colour now blue
DESCRIPTION
The Acme::Colour module mixes colours with human-readable names.
There are two types of colour mixing: the mixing of lights and the
mixing of pigments. If one take two differently coloured beams of
light and projects them on to a screen, the mixing of these lights
occurs according to the principle of additive colour mixing. If one
mixes two differently coloured paints they mix according to the
principle of subtractive colour mixing.
METHODS
new()
The new() method creates a new colour. It takes an optional argument
which is the initial colour used:
$c = Acme::Colour->new("black");
colour()
The colour() method returns the current colour. Note that
stringification of the colour object magically returns the colour too:
$colour = $c->colour; # black
print "The colour is $c!\n";
add()
The add() method performs additive mixing on the colour. It takes in
the colour to add in:
$c->add("red");
mix()
The mix() method performs subtractive mixing on the colour. It takes
in the colour to mix in:
$c->mix("cyan");
default()
The default() method returns the default colour, white. You may
override this in a subclass.
$c = Acme::Colour->new(); # white by default
ALTERNATIVE INTERFACE
There is an alternative interface to this module which overloads
string quoting. This is very cute, but is not recommended in
production code. Strings containing colour names magically get
converted into Acme::Colour objects and additive and subtractive
mixing is performed on these "strings" using "+" and "-":
use Acme::Colour constants => 1; # note special invocation
my $red = "red"; # now an Acme::Colour object
my $green = "green"; # likewise
my $yellow = $red + $green; # add()s the two colours
my $cyan = "cyan"; # now an Acme::Colour object
my $magenta = "magenta"; # likewise
my $blue = $cyan - $magenta; # mix()es the two colours
NOTES
A good explanation of colour and colour mixing is available at:
http://www.photoshopfocus.com/cool_tips/tips_color_basics_p1.htm
This module throws an exception upon unknown colours.
No, "colour" is not a typo.
AUTHOR
Leon Brocard <acme@astray.com>
COPYRIGHT
Copyright (C) 2002-3, Leon Brocard
This module is free software; you can redistribute it or modify it
under the same terms as Perl itself.
package Acme::Colour;
use strict;
use warnings;
use Error;
use Graphics::ColorNames;
use List::Util qw(max min);
use vars qw($VERSION);
$VERSION = '1.06';
use overload
'""' => \&colour,
'+' => \&_oadd,
'-' => \&_osub;
my ( %r, %g, %b );
sub import {
my $class = shift;
my $hash = {@_};
$class->_build_colours();
if ( $hash->{constants} ) {
overload::constant( 'q' => \&_createnew );
} else {
# do nothing for now
}
}
sub _build_colours {
my $class = shift;
if ( scalar( keys %r ) == 0 ) {
tie my %COLOURS, 'Graphics::ColorNames', 'X';
foreach my $colour ( keys %COLOURS ) {
next if $colour =~ /\d/;
my ( $r, $g, $b )
= map { hex($_) / 255 }
( $COLOURS{$colour}
=~ /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i
);
$r{$colour} = $r;
$g{$colour} = $g;
$b{$colour} = $b;
# print "$colour: $r/$g/$b\n";
}
}
}
sub _createnew {
my $colour = shift;
my $interp = shift;
if ( exists $r{$interp} ) {
return Acme::Colour->new($interp);
} else {
return $interp;
}
}
sub _oadd {
my $a = shift;
my $b = shift;
$a->add($b);
return $a;
}
sub _osub {
my $a = shift;
my $b = shift;
$a->mix($b);
return $a;
}
sub new {
my ( $class, $colour ) = @_;
my $self = {};
bless $self, $class;
if ( defined $colour ) {
unless ( exists $r{$colour} ) {
throw Error::Simple("Colour $colour is unknown");
}
$self->{colour} = $colour;
} else {
$self->{colour} = $self->default;
}
return $self;
}
sub default {
return "white";
}
sub colour {
my $self = shift;
return $self->{colour};
}
sub add {
my $self = shift;
my $add = shift;
my $factor = shift;
$factor = 1 unless defined $factor;
my $colour = $self->colour;
throw Error::Simple("Colour $colour is unknown")
unless exists $r{$colour};
throw Error::Simple("Colour $add is unknown")
unless exists $r{$add};
my ( $r1, $g1, $b1 ) = ( $r{$colour}, $g{$colour}, $b{$colour} );
my ( $r2, $g2, $b2 ) = ( $r{$add}, $g{$add}, $b{$add} );
$r1 += $r2 * $factor;
$g1 += $g2 * $factor;
$b1 += $b2 * $factor;
$r1 = 1 if $r1 > 1;
$g1 = 1 if $g1 > 1;
$b1 = 1 if $b1 > 1;
my $closest = $self->_closest( $r1, $g1, $b1 );
$self->{colour} = $closest;
}
sub mix {
my $self = shift;
my $add = shift;
my $factor = shift;
$factor = 1 unless defined $factor;
my $colour = $self->colour;
throw Error::Simple("Colour $colour is unknown")
unless exists $r{$colour};
throw Error::Simple("Colour $add is unknown")
unless exists $r{$add};
my ( $r1, $g1, $b1 ) = ( $r{$colour}, $g{$colour}, $b{$colour} );
my ( $r2, $g2, $b2 ) = ( $r{$add}, $g{$add}, $b{$add} );
( $r1, $g1, $b1 ) = ( 1 - $r1, 1 - $g1, 1 - $b1 );
( $r2, $g2, $b2 ) = ( 1 - $r2, 1 - $g2, 1 - $b2 );
$r1 += $r2 * $factor;
$g1 += $g2 * $factor;
$b1 += $b2 * $factor;
$r1 = 1 if $r1 > 1;
$g1 = 1 if $g1 > 1;
$b1 = 1 if $b1 > 1;
( $r1, $g1, $b1 ) = ( 1 - $r1, 1 - $g1, 1 - $b1 );
my $closest = $self->_closest( $r1, $g1, $b1 );
$self->{colour} = $closest;
}
sub _closest {
my ( $self, $r1, $g1, $b1 ) = @_;
my $bestdelta = 100;
my $closest;
foreach my $colour ( sort keys %r ) {
my ( $r2, $g2, $b2 ) = ( $r{$colour}, $g{$colour}, $b{$colour} );
my $delta
= sqrt( ( $r1 - $r2 )**2 + ( $g1 - $g2 )**2 + ( $b1 - $b2 )**2 );
if ( $delta < $bestdelta ) {
$closest = $colour;
$bestdelta = $delta;
}
}
return $closest;
}
1;
__END__