Automate your color correction with a Perl script

Nicely Out of Focus

Before a script can reliably identify the three areas at the center of the image, you need to make some preparations. Figure 2 clearly shows how much the graph fluctuates, and this is obviously going to make it difficult to identify the somewhat flatter areas. Thus, the cardfind detection script (Listing 2) needs to run a blur filter that uses the "Gaussian Blur" method with a radius of 10 to defocus the image (lines 15ff.).

In an out-of-focus image (see Figure 3), the color transitions between individual pixels are less abrupt. Instead of jumping directly from a white to black pixel, an out-of-focus image will show a transition with several gray scale values. The graph shown in Figure 4, which represents the pixel values on the same horizontal line, is far smoother as a result of this, and also simplifies the task of identifying the three areas to be identified.

Listing 2

cardfind

001 #!/usr/local/bin/perl -w
002 use strict;
003 use Imager;
004 use YAML qw(Dump);
005
006 my ($file) = @ARGV;
007 die "No file given"
008   unless defined $file;
009
010 my $img = Imager->new();
011 $img->read( file => $file )
012   or die "Can't read $file";
013
014 # Blur
015 $img->filter(
016   type   => "gaussian",
017   stddev => 10
018 ) or die $img->errstr;
019
020 my $y = int(
021   $img->getheight() / 2 );
022 my $width = $img->getwidth();
023
024 my @intens_ring = ();
025 my @diff_ring   = ();
026 my $found       = 0;
027 my @ctl_points  = ();
028
029 for my $x ( 0 .. $width - 1 )
030 {
031   my $color = $img->getpixel(
032     x => $x,
033     y => $y
034   );
035   my @components =
036     $color->rgba();
037
038 # Save current intensity
039 # in ring buffer
040   my $intens =
041     @components[ 0, 1, 2 ];
042   push @intens_ring, $intens;
043   shift @intens_ring
044     if @intens_ring > 50;
045
046 # Store slope between
047 # x and x-50
048   push @diff_ring,
049     abs( $intens -
050       $intens_ring[0] );
051   shift @diff_ring
052     if @diff_ring > 50;
053
054   if ($found) {
055
056     # Inside flat region
057     if ( avg( \@diff_ring ) >
058       10 )
059     {
060       $found = 0;
061     }
062   }
063   else {
064
065     # Outside flat region
066     if (  $x > $width / 3
067       and $x < 2 / 3 * $width
068       and avg( \@diff_ring )
069       < 3 )
070     {
071       $found = 1;
072       push @ctl_points,
073         [ @components[ 0, 1,
074         2 ] ];
075     }
076   }
077 }
078
079 my $out = {};
080 my @labels =
081   qw(low medium high);
082
083 # Sort by intensity
084 for my $ctl_point (
085   sort {
086     $a->[0] +
087       $a->[1] +
088       $a->[2] <=> $b->[0] +
089       $b->[1] +
090       $b->[2]
091   } @ctl_points
092   )
093 {
094   my $label = shift @labels;
095   $out->{$label}->{red} =
096     $ctl_point->[0];
097   $out->{$label}->{green} =
098     $ctl_point->[1];
099   $out->{$label}->{blue} =
100     $ctl_point->[2];
101   last unless @labels;
102 }
103
104 print Dump($out);
105
106 #############################
107 sub avg {
108 #############################
109   my ($arr) = @_;
110
111   my $sum = 0;
112   $sum += $_ for @$arr;
113   return $sum / @$arr;
114 }

Back to School?

In these card areas, the curve is fairly flat over a length of hundreds of pixels. If you remember your math from school, you might recall that the first derivative of a graph like this at flat spots is constant and about zero, whereas the values will be far higher and fluctuate significantly everywhere else.

Figure 5 shows the first derivative of intensity values, which are calculated by adding the pixel values for the red, green, and blue channels. The recorded values are indicative of the fluctuation of the original graph and drop to zero over quite considerable distances.

The cards, with their homogeneous gray scales, occupy these positions in the original image. Thus, the script just needs to follow this graph, create a ring buffer of about 50 investigated values, and alert when the buffer average drops to a value close to zero. When it does so, it has located a card.

Return to Search

When the buffer values start to fluctuate again, the script has left the card area and returns to the state "search for the next homogeneous location." The script should be able to find all three regions you are looking for and return the RGB values it finds there in YAML format. This lets the picfix script I discussed in last month's Perl column adjust the white balance of other images with the same light conditions.

Buy this article as PDF

Express-Checkout as PDF
Price $2.95
(incl. VAT)

Buy Linux Magazine

SINGLE ISSUES
 
SUBSCRIPTIONS
 
TABLET & SMARTPHONE APPS
Get it on Google Play

US / Canada

Get it on Google Play

UK / Australia

Related content

  • Perl: Retouching Photos

    In many cases, whole series of digital images need the same kind of modifications, which forces the photo-grapher to repeat the same steps time and time again in GIMP. Have you ever considered retouching in Perl?

  • Perl: Photos Effects

    With the GIMP image editing program, and a little help from Perl, you can enhance your digital photos and transform a modern image into a nostalgic turn-of-the-century shot.

  • Perl: Google Chart Instructions

    A CPAN module passes drawing instructions in object-oriented Perl to Google Chart, which draws visually attractive diagrams.

  • Perl: Portfolio Watch

    We'll show you a Perl script that helps you draw area graphs to keep track of your portfolio's performance.

  • Perl: Sharpen Images

    How do you sharpen a digital image? A short introduction to the principles and a Perl plugin for GIMP help amateur digital photographers polish their snapshots in a professional way.

comments powered by Disqus

Direct Download

Read full article as PDF:

072-076_perl.pdf  (801.31 kB)

News