Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

First commit of Color::Similarity, the

generalization of Color::Similarity::HCL.
  • Loading branch information...
commit a95af45c5cc98edaed2064ac6761ccc09fe19c2c 1 parent 380eb29
@mbarbon authored
View
18 Build.PL
@@ -0,0 +1,18 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Module::Build;
+
+my $build = Module::Build->new
+ ( module_name => 'Color::Similarity',
+ license => 'perl',
+ dist_author => 'Mattia Barbon <mbarbon@cpan.org>',
+ requires => { 'perl' => '5.6.0',
+ 'Module::Build' => '0.2607',
+ 'Test::More' => '0.48',
+ 'Graphics::ColorObject' => '0.5.0',
+ },
+ create_makefile_pl => 'passthrough',
+ );
+$build->create_build_script;
View
4 Changes
@@ -0,0 +1,4 @@
+Revision history for Perl extension Color::Similarity.
+
+0.01 Sun Oct 14 19:04:55 CEST 2007
+ - First public release.
View
15 MANIFEST
@@ -0,0 +1,15 @@
+Build.PL
+Changes
+MANIFEST
+MANIFEST.SKIP
+META.yml
+Makefile.PL
+lib/Color/Similarity.pm
+lib/Color/Similarity/Lab.pm
+lib/Color/Similarity/RGB.pm
+t/001_load.t
+t/002_sanity_lab.t
+t/002_sanity_rgb.t
+t/003_api.t
+t/zzy_pod_coverage.t
+t/zzz_pod.t
View
39 MANIFEST.SKIP
@@ -0,0 +1,39 @@
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+,v$
+\B\.svn\b
+\B\.cvsignore$
+
+# Avoid Makemaker generated and utility files.
+\bMakefile$
+\bblib
+\bMakeMaker-\d
+\bpm_to_blib$
+\bblibdirs$
+^MANIFEST\.SKIP$
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\bBuild.bat$
+\b_build
+
+# Avoid Devel::Cover generated files
+\bcover_db
+
+# Avoid temp and backup files.
+~$
+\.tmp$
+\.old$
+\.bak$
+\#$
+\.#
+\.rej$
+
+# Avoid OS-specific files/dirs
+# Mac OSX metadata
+\B\.DS_Store
+# Mac OSX SMB mount metadata files
+\B\._
+# Avoid archives of this distribution
+\bColor-Similarity-[\d\.\_]+
View
103 lib/Color/Similarity.pm
@@ -0,0 +1,103 @@
+package Color::Similarity;
+
+=head1 NAME
+
+Color::Similarity - common interface to different Color::Similarity::* modules
+
+=head1 SYNOPSIS
+
+ use Color::Similarity;
+
+ my $package = ...; # for example Color::Similarity::HCL
+
+ my $s = Color::Similarity->new( $package );
+
+ my $d1 = $s->distance( [ $r1, $g1, $b1 ], [ $r2, $g2, $b2 ] );
+
+=cut
+
+use strict;
+
+our $VERSION = '0.01';
+
+=head1 METHODS
+
+=head2 new
+
+ my $s = Color::Similarity->new( $package );
+
+Constructs a new C<Color::Similarity> object wrapping the given
+C<$package>. The module will not try to load the package, so the
+caller must have done it already.
+
+=cut
+
+sub new {
+ my( $class, $package ) = @_;
+
+ bless $package->_vtable, $class;
+}
+
+=head2 distance_rgb
+
+ my $d = $s->distance_rgb( [ $r1, $g1, $b1 ], [ $r2, $g2, $b2 ] );
+
+Converts the RGB triplets to the appropriate representation (usually a
+different colorspace) and computes their distance.
+
+=cut
+
+sub distance_rgb {
+ my( $self, $t1, $t2 ) = @_;
+
+ return &{$self->{distance_rgb}}( $t1, $t2 );
+}
+
+=head2 convert_rgb
+
+ my $c = $s->convert_rgb( $r, $g, $b );
+
+Converts the given RGB triplet to a representation suitable for
+passing it to C<distance>.
+
+=cut
+
+sub convert_rgb {
+ my( $self, $r, $g, $b ) = @_;
+
+ return &{$self->{convert_rgb}}( $r, $g, $b );
+}
+
+=head2 distance
+
+ my $d = $s->distance( $c1, $c2 );
+
+Computes the distance between two colors already in an appropriate
+representation (either using C<convert_rgb> or by alternate means).
+
+=cut
+
+sub distance {
+ my( $self, $t1, $t2 ) = @_;
+
+ return &{$self->{distance}}( $t1, $t2 );
+}
+
+=head1 SEE ALSO
+
+L<Color::Similarity::Lab>, L<Color::Similarity::RGB>, L<Color::Similarity::HCL>
+
+=head1 AUTHOR
+
+Mattia Barbon, C<< <mbarbon@cpan.org> >>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2007, Mattia Barbon
+
+This program is free software; you can redistribute it or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
View
104 lib/Color/Similarity/Lab.pm
@@ -0,0 +1,104 @@
+package Color::Similarity::Lab;
+
+=head1 NAME
+
+Color::Similarity::Lab - compute color similarity using the L*a*b* color space
+
+=head1 SYNOPSIS
+
+ use Color::Similarity::Lab qw(distance rgb2lab distance_lab);
+ # the greater the distance, more different the colors
+ my $distance = distance( [ $r1, $g1, $b1 ], [ $r2, $g2, $b2 ] );
+
+=head1 DESCRIPTION
+
+Computes color similarity using the L*a*b* color space and Euclidean
+distance metric.
+
+The RGB -> L*a*b* conversion is just a wrapper around
+L<Graphics::ColorObject>.
+
+=cut
+
+use strict;
+use base qw(Exporter);
+
+our $VERSION = '0.01';
+our @EXPORT_OK = qw(rgb2lab distance distance_lab);
+
+use Graphics::ColorObject qw(RGB_to_Lab);
+
+=head1 FUNCTIONS
+
+=head2 distance
+
+ my $distance = distance( [ $r1, $g1, $b1 ], [ $r2, $g2, $b2 ] );
+
+Converts the colors to the L*a*b* space and computes their distance.
+
+=cut
+
+sub distance {
+ my( $t1, $t2 ) = @_;
+
+ return distance_lab( RGB_to_Lab( $t1 ), RGB_to_Lab( $t2 ) );
+}
+
+=head2 rgb2lab
+
+ [ $l, $a, $b ] = rgb2lab( $r, $g, $b );
+
+Converts between RGB and L*a*b* color spaces (using
+L<Graphics::ColorObject>).
+
+=cut
+
+sub rgb2lab {
+ my( $r, $g, $b ) = @_;
+
+ return RGB_to_Lab( [ $r, $g, $b ] );
+}
+
+=head2 distance_lab
+
+ my $distance = distance_lab( [ $l1, $a1, $b1 ], [ $l2, $a2, $b2 ] );
+
+Computes the Euclidean distance between two colors in the L*a*b* color space.
+
+=cut
+
+sub distance_lab {
+ my( $t1, $t2 ) = @_;
+ my( $L1, $a1, $b1 ) = @$t1;
+ my( $L2, $a2, $b2 ) = @$t2;
+
+ return sqrt( ( $L2 - $L1 ) ** 2
+ + ( $a2 - $a1 ) ** 2
+ + ( $b2 - $b1 ) ** 2 );
+}
+
+=head1 SEE ALSO
+
+L<Color::Similarity>, L<Color::Similarity::RGB>, L<Color::Similarity::HCL>
+
+=head1 AUTHOR
+
+Mattia Barbon, C<< <mbarbon@cpan.org> >>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2007, Mattia Barbon
+
+This program is free software; you can redistribute it or modify it
+under the same terms as Perl itself.
+
+=cut
+
+sub _vtable {
+ return { distance_rgb => \&distance,
+ convert_rgb => \&rgb2lab,
+ distance => \&distance_lab,
+ };
+}
+
+1;
View
96 lib/Color/Similarity/RGB.pm
@@ -0,0 +1,96 @@
+package Color::Similarity::RGB;
+
+=head1 NAME
+
+Color::Similarity::RGB - compute color similarity using the RGB color space
+
+=head1 SYNOPSIS
+
+ use Color::Similarity::RGB qw(distance rgb2rgb distance_rgb);
+ # the greater the distance, more different the colors
+ my $distance = distance( [ $r1, $g1, $b1 ], [ $r2, $g2, $b2 ] );
+
+=head1 DESCRIPTION
+
+Computes color similarity using the RGB color space and Euclidean
+distance metric.
+
+=cut
+
+use strict;
+use base qw(Exporter);
+
+our $VERSION = '0.01';
+our @EXPORT_OK = qw(rgb2rgb distance distance_rgb);
+
+=head1 FUNCTIONS
+
+=head2 distance
+
+ my $distance = distance( [ $r1, $g1, $b1 ], [ $r2, $g2, $b2 ] );
+
+Synonim for C<distance_rgb>, for consistency with other
+C<Color::Similarity::*> modules.
+
+=cut
+
+*distance = \&distance_rgb;
+
+=head2 rgb2rgb
+
+ [ $r, $g, $b ] = rgb2rgb( $r, $g, $b );
+
+Silly "conversion" function, for consistency with other
+C<Color::Similarity::*> modules.
+
+=cut
+
+sub rgb2rgb {
+ my( $r, $g, $b ) = @_;
+
+ return [ $r, $g, $b ];
+}
+
+=head2 distance_rgb
+
+ my $distance = distance_rgb( [ $r1, $g1, $b1 ], [ $r2, $b2, $b2 ] );
+
+Computes the Euclidean distance between two colors in the RGB color space.
+
+=cut
+
+sub distance_rgb {
+ my( $t1, $t2 ) = @_;
+ my( $r1, $g1, $b1 ) = @$t1;
+ my( $r2, $g2, $b2 ) = @$t2;
+
+ return sqrt( ( $r2 - $r1 ) ** 2
+ + ( $g2 - $g1 ) ** 2
+ + ( $b2 - $b1 ) ** 2 );
+}
+
+=head1 SEE ALSO
+
+L<Color::Similarity>, L<Color::Similarity::RGB>, L<Color::Similarity::HCL>
+
+=head1 AUTHOR
+
+Mattia Barbon, C<< <mbarbon@cpan.org> >>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2007, Mattia Barbon
+
+This program is free software; you can redistribute it or modify it
+under the same terms as Perl itself.
+
+=cut
+
+sub _vtable {
+ return { distance_rgb => \&distance_rgb,
+ convert_rgb => \&rgb2rgb,
+ distance => \&distance_rgb,
+ };
+}
+
+1;
View
8 t/001_load.t
@@ -0,0 +1,8 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 3;
+
+use_ok( 'Color::Similarity' );
+use_ok( 'Color::Similarity::RGB' );
+use_ok( 'Color::Similarity::Lab' );
View
16 t/002_sanity_lab.t
@@ -0,0 +1,16 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Color::Similarity::Lab qw(distance);
+
+use constant STEP => 14; # keep test count manageable
+use Test::More no_plan => 1;
+
+# maybe use random samples?
+for( my $r = 0; $r < 256; $r += STEP ) {
+ for( my $g = 0; $g < 256; $g += STEP ) {
+ for( my $b = 0; $b < 256; $b += STEP ) {
+ is( distance( [ $r, $g, $b ], [ $r, $g, $b ] ), 0 );
+ }
+ }
+}
View
16 t/002_sanity_rgb.t
@@ -0,0 +1,16 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Color::Similarity::RGB qw(distance);
+
+use constant STEP => 14; # keep test count manageable
+use Test::More no_plan => 1;
+
+# maybe use random samples?
+for( my $r = 0; $r < 256; $r += STEP ) {
+ for( my $g = 0; $g < 256; $g += STEP ) {
+ for( my $b = 0; $b < 256; $b += STEP ) {
+ is( distance( [ $r, $g, $b ], [ $r, $g, $b ] ), 0 );
+ }
+ }
+}
View
33 t/003_api.t
@@ -0,0 +1,33 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Color::Similarity;
+use Color::Similarity::Lab;
+use Color::Similarity::RGB;
+
+use Test::More tests => 9;
+
+my $rgb = Color::Similarity->new( 'Color::Similarity::RGB' );
+my $lab = Color::Similarity->new( 'Color::Similarity::Lab' );
+
+is_deeply( $rgb->convert_rgb( 100, 120, 130 ), [ 100, 120, 130 ] );
+is_deeply( [ map int( $_ ), @{$lab->convert_rgb( 100, 120, 130 )} ],
+ [ 5000, -418, -677 ] );
+
+is( $rgb->distance_rgb( [ 100, 120, 130 ], [ 100, 120, 130 ] ), 0 );
+is( $lab->distance_rgb( [ 100, 120, 130 ], [ 100, 120, 130 ] ), 0 );
+
+is( int( $rgb->distance_rgb( [ 200, 120, 130 ], [ 100, 120, 130 ] ) ), 100 );
+is( int( $lab->distance_rgb( [ 200, 120, 130 ], [ 100, 120, 130 ] ) ), 3594 );
+
+is( $rgb->distance_rgb( [ 200, 120, 130 ], [ 100, 120, 130 ] ),
+ $rgb->distance( [ 200, 120, 130 ], [ 100, 120, 130 ] )
+ );
+is( $rgb->distance_rgb( [ 200, 120, 130 ], [ 100, 120, 130 ] ),
+ $rgb->distance( map $rgb->convert_rgb( @$_ ),
+ [ 200, 120, 130 ], [ 100, 120, 130 ] )
+ );
+is( $lab->distance_rgb( [ 200, 120, 130 ], [ 100, 120, 130 ] ),
+ $lab->distance( map $lab->convert_rgb( @$_ ),
+ [ 200, 120, 130 ], [ 100, 120, 130 ] )
+ );
View
11 t/zzy_pod_coverage.t
@@ -0,0 +1,11 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+eval "use Test::Pod::Coverage 1.00";
+plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage"
+ if $@;
+plan( tests => 3 );
+pod_coverage_ok( 'Color::Similarity' );
+pod_coverage_ok( 'Color::Similarity::RGB' );
+pod_coverage_ok( 'Color::Similarity::Lab' );
View
8 t/zzz_pod.t
@@ -0,0 +1,8 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+
+all_pod_files_ok( all_pod_files( 'blib' ) );
Please sign in to comment.
Something went wrong with that request. Please try again.