Batched Picture Leveling

A batch script to improve a set of images by auto leveling their tonal range.

Why i needed this

Usually when we come home from vacation we have several hundred pictures that are in need of enhancement. Running this script over them does the trick without a lot of fuzz.

What it does

It iterates over all files in the given input glob, auto levels the images, and stores them by the same name in the output directory. 90% of the time this yields superior images, with the exception often being pictures of see and sky, because they're mostly blue.

Requirements

• The Gimp.
• A Perl interpreter.
• A *nix distribution such as Kubuntu Linux or FreeBSD or maybe even a Mac. The script-fu part would probably work on Windows but the Perl script would need adjustment.

The implementation

The first thing we need is a script-fu batch script for leveling. It takes a source file and a target file. It needs to be stored in a directory where the Gimp can find it. That can be any directory as long as it's set in the gimps script-fu folders. These are usually set under File - Preferences - Folders - Scripts. Take the script below and store it in such a folder by the name of batch-level.scm. You can also download it from here.

;; -*-scheme-*-
(define (script-fu-batch-level srcFile destFile)
   (let* ((image (car (gimp-file-load RUN-NONINTERACTIVE srcFile srcFile)))
          (drawable (car (gimp-image-get-active-layer image))))
     (gimp-levels-stretch drawable)
     (gimp-file-save RUN-NONINTERACTIVE image drawable destFile destFile)
     (gimp-image-delete image))
)

(script-fu-register "script-fu-batch-level"
		    _"_Auto Level Colors"
		    "Auto Levels Colors of specified image."
		    "Mario Theodoridis"
		    "Mario Theodoridis, 2006. Public Domain."
		    "July 2006"
		    ""
		    SF-STRING   "srcFile" ""
		    SF-STRING   "destFile" "")

Below is the perl script to drive it. That can be stored somewhere on the $PATH by the name of levelPics.pl and made executable like this

chmod a+x levelPics.pl

Alternatively you can also download this one from here.

#!/usr/bin/perl -w
##
##   Copyright (C) 2006 Mario Theodoridis, mario@schmut.com
##
##   This "Original Work" is free; you can modify it under the terms of the
##   AFL Academic Free License. This "Original Work" is distributed in the
##   hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
##   implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
##   See the AFL Academic Free License for more details. You should find a
##   copy of the AFL Academic Free License in the highest level directory of
##   this distribution; if not, you may obtain one at the Open Source
##   Initiative, http://www.opensource.org.
##

use strict;
use Getopt::Std;

my $hOpts = {};
my $isOk = getopts('i:o:', $hOpts);

my $inPath = $hOpts->{'i'};
my $outPath = $hOpts->{'o'};

if (!$isOk || !$inPath || !$outPath) {
    print <<EOF;

    Auto levels the colors of all images specified in the input file mask
    and saves them in the output directory creating the directory if needed.

    Usage $0 -i "Input Path" -o "Output Directory"

EOF

    exit;
}

if (-f $outPath) {
	print <<TXT;

    $outPath exists and is not a directory. Please specify a directrory or
    something that doesn't exist already, so i can create it.

TXT
	exit 1;
}

my $aList = getFileList($inPath);

mkdir ($outPath) unless (-d $outPath);

foreach my $inFile (@$aList) {
	my $pUrl = parseUrl($inFile);
	my $file = $pUrl->{'NAME'}.$pUrl->{'DOTEXT'};
	my $outFile = getNormalizedFsPath("$outPath/$file");
	if ( -f $outFile) {
		print ("Skipping existing file $outFile. Please remove it to have it redone.\n");
		next;
	}
	print "Moving $inFile to $outFile\n";
	`gimp -i -b '(script-fu-batch-level "$inFile" "$outFile")' -b '(gimp-quit 0)'`;
}


#
# Some utilities
#

# a list of files without directories
# getFileList( path )
sub getFileList
{
    my $path = shift;
    my $fileList = `ls -1p $path`;
    # get rid directory entries
    $fileList =~ s#^.*/$##m;
    my @files = split(/[\r\n]+/, $fileList);
    return \@files;
}

#
# Parses a url and returns an array of relevant pieces.
# @param $src      source path for the image
#
sub parseUrl # (  $src )
{
    my $src = shift;
    $src =~ /^(?:(\w+:\/\/)([^\/\?]+))?([^?#]*\/)*(.*?)(\.(.*?))?(\?.*?)?(#.*)?$/;
    return {
            'SRC'       => $src,
            'PROTO'     => $1,
            'HOST'      => $2,
            'PATH'      => $3,
            'NAME'      => $4,
            'DOTEXT'    => $5,
            'EXT'       => $6,
            'PARAMS'    => $7,
            'ANCHOR'    => $8,
            };
}

sub getNormalizedFsPath # ($path)
{
    my $path = shift;
    my $expr = '(/[^\/]*?/\.\./|/\./|(?<!:)//)';
    while ($path =~ m&$expr&g) {
        $path =~ s&$expr&/&g;
    }
    return $path;
}

Deficiencies

The script starts and stops the gimp for every image. Improving this would probably increase the speed. But as i'm too lazy to do this, i just start several processes at the same time and segment them by file glob. Such as:

levelPics.pl -i "_MG_12*.JPG" -o "out/"
levelPics.pl -i "_MG_13*.JPG" -o "out/"
levelPics.pl -i "_MG_14*.JPG" -o "out/"

Where the first instance handles the 1200 series, the second the 1300s and so on.