view release on metacpan or  search on metacpan

lib/Acme/Colour.pm  view on Meta::CPAN

        # 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__

=head1 NAME

Acme::Colour - additive and subtractive human-readable colours

=head1 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

=head1 DESCRIPTION

lib/Acme/Colour.pm  view on Meta::CPAN

=head2 new()

The new() method creates a new colour. It takes an optional argument
which is the initial colour used:

  $c = Acme::Colour->new("black");

=head2 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";

=head2 add()

The add() method performs additive mixing on the colour. It takes in
the colour to add in:

  $c->add("red");

=head2 mix()

The mix() method performs subtractive mixing on the colour. It takes
in the colour to mix in:

  $c->mix("cyan");

=head2 default()

The default() method returns the default colour, white. You may
override this in a subclass.

  $c = Acme::Colour->new(); # white by default

=head1 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

=head1 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.

=head1 AUTHOR

Leon Brocard E<lt>F<acme@astray.com>E<gt>

=head1 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.

=cut