The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
package Image::DominantColors;

use 5.006;
use strict;
use warnings FATAL => 'all';
use Data::Dumper;
use Imager;
use Imager::Fill;
use Image::ColorCollection;
use POSIX;
 
our $VERSION = '0.02';


sub new {
	my ($class, $params) = @_;
	my $self = undef;
	if($params) {
		$self =  $params;
	} else {
	#carp die. We need a filename...
	}
	bless $self, $class;
	return $self;
}

sub getDominantColors {
	my $class = shift;
	my $img = Imager->new(file => $class->{file});
	my $clusters = 3;
	my $clus = $class->{clusters};
	if($clus)
	{
		$clusters = $clus;
	}
	my $h = $img->getheight() - 1;
	my $w = $img->getwidth() - 1;

	my @colors = ();
	for (my $j = 0; $j < $w; $j++) {
		for (my $k = 0; $k < $h; $k++) {
			my $oth = $img->getpixel(x => $j, y => $k);
			my ($red, $green, $blue, $alpha) = $oth->rgba();
			push (@colors, {
				r => $red,
				g => $green,
				b => $blue,
			});
		}		
	}

	my @centroids = ();
	for (my $i = 1; $i <= $clusters; $i++) {
		my $cc = Image::ColorCollection->new();
		push @centroids, $cc;
	}
	
	my $shft = 100;
	my $it = 0;#track iterations
#	print "TotalCentroid : ".scalar(@centroids);
	while($shft != 0)
	{
		foreach my $col (@colors) {
			my $min = LONG_MAX;
			my $cent = undef;
#				print "TotalCentroidAgainb : ".scalar(@centroids);
			foreach my $c (@centroids) {
				#print Dumper($c);
				my $d = int(euclideanDist($col, $c->getCentroid()));
				if($d < $min)
				{
					$min = $d;
					$cent = $c;					
				}
			}
			$cent->addColor($col);			
		}
		my $localShft = 0;
		foreach my $cnt (@centroids) {
			$localShft += $cnt->updateCentroid();
			$cnt->clear();
		}
		$shft = $localShft;
		$it++;				
#		print "Iteration : $it , shift : $shft\n";
	}
	my @ret = map { $_->getCentroid() } @centroids;
	return \@ret;
}
sub euclideanDist {
	my ($c1, $c2) = @_;
	return sqrt((($c1->{r}-$c2->{r})**2) + (($c1->{g}-$c2->{g})**2) + (($c1->{b}-$c2->{b})**2));
}

1; # End of Image::DominantColors
__END__


=head1 NAME

Image::DominantColors - Find dominant colors in an image with k-means clustering.

=head1 VERSION

Version 0.01

=cut




=head1 SYNOPSIS

This module does just one simple thing. It scans an image and clusters colors with the L<k-means clustering|http://en.wikipedia.org/wiki/K-means_clustering> 
algorithm to give you the most dominant colors in that image.

Here is a live demo : L<http://www.tryperl.com/dominantcolors/>

This is how it works, I would advise leaving the clusters to a default 3 which works best with images.:

    use Image::DominantColors;
    use Data::Dumper;
    
    
    my $dmt = Image::DominantColors->new({file => 'some_path/img.jpg', clusters => 4});
    #OR three clusters is default
    my $dmt = Image::DominantColors->new({file => 'some_path/img.jpg'});
    my $r = $dmt->getDominantColors();
    
    print Dumper($r);
	#This outputs the following:
    # [
    #           {
    #             'r' => 31,
    #             'b' => 23,
    #             'g' => 15
    #           },
    #           {
    #             'r' => 193,
    #             'b' => 41,
    #             'g' => 84
    #           },
    #           {
    #             'r' => 114,
    #             'b' => 136,
    #             'g' => 128
    #           },
    #           {
    #             'r' => 61,
    #             'b' => 82,
    #             'g' => 66
    #           }
    # ];
    ...

=head1 EXPORT

A list of functions that can be exported.  You can delete this section
if you don't export anything, such as for a purely object-oriented module.

=head1 SUBROUTINES/METHODS

=head2 getDominantColors
    
    This is the only user function the module contains. it returns an array of hashes as in the synopsis.

=cut



=head1 AUTHOR

Gideon Israel Dsouza, C<< <gideon at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-image-dominantcolors at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Image-DominantColors>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Image::DominantColors


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Image-DominantColors>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Image-DominantColors>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Image-DominantColors>

=item * Search CPAN

L<http://search.cpan.org/dist/Image-DominantColors/>

=back


=head1 LICENSE AND COPYRIGHT

Copyright 2013 Gideon Israel Dsouza.

This program is free software; you can redistribute it and/or modify it
under the terms of the the Artistic License (2.0). You may obtain a
copy of the full license at:

L<http://www.perlfoundation.org/artistic_license_2_0>

=cut