File Coverage

blib/lib/Sew/Color.pm

Criterion	Covered	Total	%
statement	81	175	46.2
branch	18	74	24.3
condition	2	6	33.3
subroutine	11	16	68.7
pod	0	12	0.0
total	112	283	39.5

package Sew::Color;

use 5.010001;
use strict;
use warnings;
use Carp;

require Exporter;

our @ISA = qw(Exporter);

our $VERSION='1.05';
#
#use base 'Exporter';
our @EXPORT=(
             'rgb',   # rgb('Brother','405') returns the red green and blue colors of this thread.
			 'name',  # returns english name of color, eg 'Bright Red'. Caution, not unique.
			 'code',  # code('Brother',$r,$g,$b) gives the closest thread code to the given rgb
			          # in array context, returns (code, error distance) using a simple 3d color
					  # space model.
					  # 1st parameter may be a manufacturers name, empty (for all)
					  # a comma seperate list, or an array reference containing single manufacturers
			 'manlist',
			 'custom',
             'custom_sub',
             'custom_list',
             'evecrgb',
             'mag',
             'sat'
		    ) ;
my $colorlist='';

sub get_color_list
{
# Brother,Black,100,28,26,28
$colorlist={};
local $_;
while ()
{
   m/^ *#/ and next;
   chomp;
   my @x=split(/,/);
   my @rgb;
   @rgb=@x[3..5];
   exists($colorlist->{$x[0]}) or  $colorlist->{$x[0]}={};
   $colorlist->{$x[0]}->{$x[2]}={};
   $colorlist->{$x[0]}->{$x[2]}->{name}=$x[1];
   $colorlist->{$x[0]}->{$x[2]}->{rgb}=\@rgb;
}
close DATA;
}
sub rgb
{
  my ($man,$code)=@_;

  $colorlist or get_color_list();

  my $r=$colorlist->{$man}->{$code}->{rgb};
  return @$r;
}
sub name
{
  my ($man,$code)=@_;

  $colorlist or get_color_list();
  if (!exists($colorlist->{$man}))
  {
    croak("Invalid manufacturer code '$man' supplied to function name()");
  }

  my $r=$colorlist->{$man}->{$code}->{name};
  return $r;
}

sub manlist
{
  $colorlist or get_color_list();
  return keys %$colorlist;
}

# give a list of threads that you have for custom searches.
# can be Brother 405 406 407 Maderia 1005 102
sub custom
{
  $colorlist or get_color_list();
  my @mankeys=keys %$colorlist;
  my $man='';
  if (@_==0)
  {
	for $man  (@mankeys)
	{
	  for my $code (keys %{$colorlist->{$man}})
	  {
		  delete $colorlist->{$man}->{$code}->{custom};
	  }
	}
    return;
  }
  for my $t (@_)
  {
	 my $nmk;
	 $nmk='';
	 ($nmk)=grep { $t eq $_ } @mankeys;
	 defined $nmk or $nmk='';
	 #if (0
	 if ($nmk ne '')
	 {
	    $man=$nmk;
		next;
	 }
	 # else its a code.
	 if ($t eq 'all') # add all for current manufacturer or all manufacturer.
     {
       if ($man ne '')
       {
         for my $key (keys %{$colorlist->{$man}})
         {
             $colorlist->{$man}->{$key}->{'custom'}=1;
         }
       }
       else
       {
         for my $man (keys %{$colorlist})
         {
           for my $key (keys %{$colorlist->{$man}})
           {
             $colorlist->{$man}->{$key}->{'custom'}=1;
           }
         }
       }
      next;
      }
	 die "Error no manufacturer given in call to custom for code $t or mispelt manufacturer!" if ($man eq '');
	 die "Invalid code '$t' for manufacturer $man in call to custom" if (!exists($colorlist->{$man}->{$t}));
	 $colorlist->{$man}->{$t}->{'custom'}=1;
  }
}
# list entries for custom searches.
sub custom_list
{
  my ($man,$format)=@_;
  # man can be empty, a single manufacturer, or a ref to a list of manufacturers.
  # format can be '%m replace with manufacturer code. %c replace with code, %% replace with %.
  # Default is '%c';
  $colorlist or get_color_list();

  my @r;

  my @mana;

  defined($format) or  $format='%c';

  if ($man eq '')
  {
    @mana=();
  }
  elsif (!ref($man))
  {
    @mana=($man);
  }
  else
  {
    @mana=@$man;
  }

  @mana=keys %$colorlist if (@mana==0);

	 for my $man (@mana)
     {
        for my $key (keys %{$colorlist->{$man}})
        {
           if (exists($colorlist->{$man}->{$key}->{'custom'}))
           {
             my $f;
             $f=$format;
             $f=~s/%m/$man/g;
             $f=~s/%c/$key/g;
             $f=~s/%%/%/g;
             push(@r,$f);
           }
        }
      }
      return @r;
}

# remove keys from
sub custom_sub
{
  $colorlist or get_color_list();
  my @mankeys=keys %$colorlist;
  my $man='';
  my $nmk;
  for my $t (@_)
  {
	 my $nmk;
	 $nmk='';
	 ($nmk)=grep { $t eq $_ } @mankeys;
	 defined $nmk or $nmk='';
	 #if (0
	 if ($nmk ne '')
	 {
	    $man=$nmk;
		next;
	 }
	 # else its a code.
	 if ($t eq 'all') # add all for current manufacturer or all manufacturer.
     {
       if ($man ne '')
       {
         for my $key (keys %{$colorlist->{$man}})
         {
             delete($colorlist->{$man}->{$key}->{'custom'});
         }
       }
       else
       {
         for my $man (keys %{$colorlist})
         {
           for my $key (keys %{$colorlist->{$man}})
           {
             delete($colorlist->{$man}->{$key}->{'custom'})
           }
         }
       }
      next;
      }
	 die "Error no manufacturer given in call to custom for code $t or mispelt manufacturer!" if ($man eq '');
	 die "Invalid code '$t' for manufacturer $man in call to custom" if (!exists($colorlist->{$man}->{$t}));
	 delete($colorlist->{$man}->{$t}->{'custom'});
  }
}
sub code
{
  my ($man,$r,$g,$b)=@_;
  my $custom=0;
  my @mans;

  $colorlist or get_color_list();

  my @mankeys=keys %$colorlist;
  my $err=10000;
  my $c='' ; # return value;
  my $mk='';

  if (ref($man))
  {
	@mans=@$man;
  }
  else
  {
    @mans=($man);
  }
  @mans=map { split(/,/,$_) }  @mans;
  @mans=grep {$_ ne '' } @mans;
  if (grep { $_ eq 'custom' } @mans )
  {
     $custom=1;
	 @mans=grep { $_ ne 'custom'  } @mans;
  }

  for my $mankey (@mankeys)
  {
    next if (@mans>0 and 0==grep {$mankey eq $_ } @mans); # only use the wanted keys;
    for my $code (keys %{$colorlist->{$mankey}})
	{
			#print "#3 $mankey $code\n";
	   next if ($custom and !exists $colorlist->{$mankey}->{$code}->{'custom'} ) ;
	   my $rgb=$colorlist->{$mankey}->{$code}->{rgb};
	   my @rgb=@$rgb;
	   my $d3=($r-$rgb[0])**2+($g-$rgb[1])**2+($b-$rgb[2])**2;
	   $d3=sqrt($d3);
	   #print "$code ($r,$g,$b) - (@rgb) $d3\n";
	   if ($d3<$err)
	   {
		  $c=$code;
		  $err=$d3;
		  $mk=$mankey;
	   }
	}
  }
  $err='' if ($c eq '');
  if (wantarray) { return ($c,$mk,$err); }
  return $c;
}
# return an error veector between 2 colours as rgb.
sub evecrgb
{
  my ($r1,$g1,$b1,$r2,$g2,$b2)=@_;

  my ($r,$g,$b);

  ($r,$g,$b)=($r1-$r2,$g1-$g2,$b1-$b2);

  return ($r,$g,$b);
}
# return magnetude of rgb value.
sub mag
{
  my ($r,$g,$b)=@_;

  return sqrt($r*$r+$g*$g+$b*$b);
}
# return saturation of rgb value.
# value returned is between 0 an 255 inclusive.
sub sat
{
  my ($r,$g,$b)=@_;
  my $s=0;  # saturation is zero for black.

  my $w=min($r,$g,$b); # white component;
  my $m=mag($r,$g,$b); # magnetude of given colour

  map { $_-=$w } ($r,$g,$b);

  my $nw=mag($r,$g,$b); # non white component;

  if ($m>=1)
  {
     $s=255*$nw/$m;
  }
  return $s;
}
sub min
{
   my (@x)=@_;

   my $m=$x[0];

   for my $x (@x)
   {
      $m=$x if ($x<$m);
   }
   return $m;
}
return 1;
=head1 NAME

 Sew:Color - rgb colours for various manufactures of coloured embroidery thread.

=head1 ABSTRACT

  Extensible Module for determining rgb colours of various manufacturers of embroidering thread
  and the codes that go with them.

=head1 SYNOPSIS

 use Sew::Color
 my @rgb=rgb('Brother', '502');
 my $name=name('Brother','502');

 print "$name (@rgb)\n";
 my @m=manlist();

=head1 DESCRIPTION

 These calls return respectively the red green and blue components of the colour of the thread
 and the 'English' name of the thread colour. The colour components will be in the range 0 to 255.
 In this case, Brother thread number 502.
 Be aware that the name of the thread colour is not unique, there are some codes that have
 the same name, although they are mostly different.

 The above code prints out

    Mint Green (148 190 140)

 code(Manufacturer,red,green.blue)

 This function does a simple search in the colour space to find the colour that is closest to the rgb values you provide.

 The parameters are

   Manufacturer: Can be a single manufacturer, a comma seperated list or an array reference of manufacturers.
   				 It can be empty to search all known about.
   red, green, blue are the colour co-ordinates to search for. Distnce is done through a very simple sequential search
                 using a simple 3-d colour model without any weightings. (so rgb all treated the same.)

 The return values are:

	In a scalar context, just the code, for example '502'.
	In an array context it returns a 3 element array, with the following entries

		Thread code, eg '502'
		Manufacturer, eg 'Brother'
		Error distance, eg 42. This is the distance in linear units scaled to 255
		between the thread found and the desired colour. Note that it can be more than 255
		(Consider that the diagonal of a cube with side 255 is more than 255. ) but will normally
		not be.

     Note that only one result is returned, and this ought tobe changed, all nearest results should be found.

The function manlist() returns an array of the names of the manufacturers supported.

=head2 Custom Searches

 If you only have certain threads that you want to search (you dont happen to have the full Madeira
 in your store cupboard!) you can say which ones you do have by using the custom function. This is called as follows

   custom('Manufacturer',list of codes, 'Manufacturer', list of codes )

 A call to the code function with the special string 'custom' as manufacturer will search only these threads.

   custom()

 will reset all the custom threads.

 Multiple calls to custom where the argument list is not empty will add each new set to the custom search list.

 The special keyword all may be used with the custom function to either add all the threads for a manufacturer, or to add all threads of all manufacturers. so custom('Brother','all') would add all Brother threads, while custom('all') would add all known threads. Once added individual threads or sets can be removed with the custom_sub function.

 custom_sub() takes parameters similar to custom and will remove specific threads from the custom search list.



=head2 Methods

		rgb(Manufacturer, code) returns a 255-max scaled rgb tripplet.
		name(Manufacturer,code) returns the "English" name of the colour.
		code(Manufacturer-list,r,g,b)  returns either the code or an array
								with the following: (Manufacturer,code,error distance)

=head1 CAVEAT

 All should be aware that giving an rgb value for a thread colour will never be anything more than an approximation at best, even assuming
 the values are right. Be aware that many thread manufacturers give or sell colour cards that have actual samples of the thread on, because even
 using paint on paper has proved so unsatisfactory. Really I cannot say it loud enough, trying to represent real-world colours that are not
 a photograph, using rgb values is massively approximate at best. For example, it depends on the angle of the light, the amount of
 light, the type of light and other factors. Or it may not. I have seen materials that change colour quite noticibly depending on weather they
 are viewed by sunlight, incandescent light or flourscent light. Its a manufacturers nightmare, but it happens.

=head1 PROCESS

 In the main these values were derived by me by taking a web page which has a photograph of the thread, cropping it to remove anything like a shadow,
 changing the size to 1 by 1 pixcel (so that all other pixcels are averaged) and then listing the colour of that pixcel.

 This results in rather real-world values - the extreme ends of the scale near 0 and 255 do not appear and the colours are a bit less saturated than...
 well then you might think.

 Sulky helpfully provide a spreadsheet with rgb values. It would be a bit silly not to use it, wouldnt it? But the truth is that the values
 you get are very different since they have clearly been normalised in some way so that blacks are fully black and whites are fully white.

 For example, Sulky "Black" 942-1005 has rgb values (0,0,0) in the spreadsheet. But using the other method, has rgb values (44,42,44).

 Which is right? The answer is of course that both are, and you need to use the values obtained carefully and sensibly, processing them if needed.

 Sulky do this (perhaps) because in part you are throwing away some of the precision in your 8 bit representation if you say the lowest value
 I am going to have is 42. They are (probably) not happy using 8 bits any way, because from there perspective this is not much precision to
 represent a world of colour, why throw some of it away?

 Which Sulky values did I include? In the end I included the real-world values since thats more compatible with the other manufacturers in the
 package. Let me know if you think I should do other wise. It also allows me to easily include varigated threads (that have a delibneratly
 variable colour along its length) since this will be correctly averaged.

=head2 EXTENSION

The module may be extended to a new manufacturer by adding lines of the following format to the module:

manufacturer,english name,code,red,green,blue

for example the line
      Brother,Moss Green,515,48,125,38

is responsible for the Moss Green number 515 entry.

=head1 BUGS and the like

 There are many manufacturers not covered.

 If you use this please drop me an email to say it has been useful (or not) to you.

 The sat() function generally returned 255 in version 1.04. This is fixed in 1.05

=head1 AUTHOR

 Mark Winder June 2012.
 markwin (at) cpan.org

=cut

__DATA__