#! /usr/local/bin/perl

# davidhand.com
# noise background
# images/noise3.cgi
#
#        Created: 2000-1107-1502  David Hand  <mailto:davidhand@davidhand.com>
#      Commented: 2000-1207-1519  David Hand  <mailto:davidhand@davidhand.com>
#      De-Sucked: 2001-0701-2058  David Hand  <mailto:davidhand@davidhand.com>
#
# Copyright (c) 2000, 2001 David Hand

use strict;
use warnings;

use CGI;
use GD;
use List::Util qw(sum);

#=============================================================================
# Get Parameters
#-----------------------------------------------------------------------------
my $request = CGI->new();

my $DELIM_OUT   = '_';
my $DELIM_IN    = ',';

my $NUMBER_REGEX        = "((?:\\d+$DELIM_IN?)+)";
my $HEX_TRIPLE_REGEX    = "((?:(?:(?:0x|#)?[A-Fa-f0-9]{6}(?:\\(\\d+\%?\\))?$DELIM_IN?)*$DELIM_OUT?)*)";

my $DEFAULT_WIDTHS      = "0${DELIM_IN}0${DELIM_IN}100${DELIM_IN}0${DELIM_IN}0";
my $DEFAULT_COLORS      = "#FFFFFF${DELIM_OUT}#000000${DELIM_OUT}#FFFFFF${DELIM_IN}#000000${DELIM_OUT}#000000${DELIM_OUT}#FFFFFF";
my $DEFAULT_HEIGHT      = "100";

my @widths = split (/$DELIM_IN/, &detaint('widths', $request,
                                          $DEFAULT_WIDTHS, $NUMBER_REGEX));
my @colors = map ({ [ split /$DELIM_IN/ ]; }
                  split (/$DELIM_OUT/,
                         &detaint('colors', $request,
                                  $DEFAULT_COLORS, $HEX_TRIPLE_REGEX
                                 )
                        )
                 );
# height parameter
my $height = &detaint('height', $request,
                      $DEFAULT_HEIGHT, $NUMBER_REGEX);

#=============================================================================
# Process Image
#-----------------------------------------------------------------------------
my $image = GD::Image->new( sum(@widths), $height);

foreach my $colorlist (@colors) {
        &allocate_colors($image, $colorlist);
}

my $currleft = 0;
my $currright = $widths[1] - 1;
for (my $i = 0; $i < @colors; ++$i) {
        $currright += $widths[$i];
        &paint_rect($image,
                    $currleft, 0,
                    $currright, $height-1,
                    $colors[$i],
                   );
        $currleft += $widths[$i];
}

# Aww, hell.  We've gone to all this work.  Might as well spit out the PNG.
binmode STDOUT;
print $request->header(-type=>'image/png');
print $image->png;

#=============================================================================
# Helper Functions
#-----------------------------------------------------------------------------

# Get & detaint a CGI param, complete with a default if it's not defined.
sub detaint
{
        my $param = shift;
        my $request = shift;
        my $default = scalar (@_) ? shift : "";
        my $regex = scalar (@_) ? shift : "";

        my $return = "";

        if (defined ($return = $request->param($param))) {
                ($return) = $return =~ /$regex/;
                return $return;
        } else {
                return $default;
        }
}

# It's important to register your colors, in an indexed color format.
# The trick here is that we don't want to register a color that's
#   already been registered.
sub allocate_colors
{
        my ($image, $colors_ref) = @_;
        my $candidate;

        foreach my $hex (@{$colors_ref}) {
                if (($candidate = $image->colorExact(&hex2rgb($hex))) == -1) {
                        $hex = $image->colorAllocate(&hex2rgb($hex));
                } else {
                        $hex = $candidate;
                }
        }

        return;
}

# Paint a rectangle.  If we're painting with a single color, don't go
#   to the extra effort of calculating a random number, or of painting
#   pixel-by-pixel.
sub paint_rect
{
        my $image = shift;
        my $x1 = shift; my $y1 = shift;
        my $x2 = shift; my $y2 = shift;
        my $colors_ref = shift;
        my $colorcount = scalar @{$colors_ref};

        return if $x2 <= $x1;  # refuse to create a zero- or negative-size box
        return if $y2 <= $y1;

        if ($colorcount == 1) {
                $image->filledRectangle($x1, $y1, $x2, $y2, $colors_ref->[0]);
        } else {
                for (my $x = $x1; $x <= $x2; $x++) {
                        for (my $y = $y1; $y <= $y2; $y++) {
                                $image->setPixel(
                                         $x, $y,
                                         $colors_ref->[int(rand($colorcount))]
                                );
                        }
                }
        }

        return;
}

# convert an HTML-style hexidecimal to a decimal triplet
sub hex2rgb
{
        my $hex = shift;

        $hex =~ s/^(0x|#)//;

        my $temp = pack('H6', $hex);    # pack the hex into raw binary
        my @rgb = unpack('C3', $temp);  # unpack the binary into a triple

        if (wantarray) {
                # if we want an array, do what this program was
                # originally intended to do
                return @rgb;
        } else {
                # if the user asks for a scalar, give her something
                # useful, rather than a constant 3 (the length of the
                # above array, in all situations).

                # luminance calculation from _Grokking the GIMP_, p. 152
                my $luminance = $rgb[0]*0.3 + $rgb[1]*0.59 + $rgb[2]*0.11;
                return $luminance;
        }
}

# convert a decimal triplet to an HTML-style hexidecimal
# YEAH, I KNOW:  this isn't called anywhere.  I just figured I'd put it
#   in, since I'd put in the inverse function.  Don't know where to put
#   them, permanently, so this'll do for now.
sub rgb2hex
{
        my @rgb = @_[0..2];

        my $temp = pack('CCC', @rgb);   # pack the triple into raw binary
        my $hex = unpack('H6', $temp);  # unpack the binary into hex format

        return $hex;
}