File Coverage

blib/lib/Color/Fade.pm

Criterion	Covered	Total	%
statement	6	124	4.8
branch	0	68	0.0
condition			n/a
subroutine	2	6	33.3
pod	3	4	75.0
total	11	202	5.4

package Color::Fade;

use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT_OK = qw (
	color_fade
	format_color
);

our @EXPORT = qw(
);

our $VERSION = '0.02';
our $debug = 0;

sub debug {
	my $val = shift;
	if ($val) {
		$debug = 1;
	}
	return $debug;
}

sub format_color {
	my ($format,@codes) = @_;

	# Some pre-defined formats.
	my %formats = (
		html => '$char',
		ubb  => '[color=$color]$char[/color]',
		css  => '$char',
	);
	if (exists $formats{$format}) {
		$format = $formats{$format};
	}

	# Loop through the given codes.
	my @out = ();
	foreach my $part (@codes) {
		my ($color,$char) = $part =~ /^]+?)>(.+?)$/i;
		my $result = $format;
		$result =~ s/\$color/$color/ig;
		$result =~ s/\$char/$char/ig;
		push (@out,$result);
	}
	return wantarray ? (@out) : join("",@out);
}

sub color_fade {
	my ($text,@in_colors) = @_;

	# Validate the arguments.
	if (not length $text) {
		warn "You must pass a string with a length > 0 to color_fade.";
		return;
	}
	if (not scalar(@in_colors)) {
		warn "You must pass a series of hexadecimal color codes to color_fade.";
		return;
	}

	# There must be at least two colors.
	if (scalar(@in_colors) < 2) {
		warn "color_fade requires at least two colors.";
		return;
	}

	# Validate and clean up color codes.
	my @nodes = ();
	foreach my $ccode (@in_colors) {
		$ccode =~ s/#//g; # Remove hex indicators.
		if (length $ccode != 6) {
			warn "You must pass 6 digit hexadecimal color codes to color_fade.";
			return;
		}
		if ($ccode =~ /^[^A-Fa-f0-9]$/i) {
			warn "You must pass 6 digit hexadecimal color codes to color_fade.";
			return;
		}
		push (@nodes,$ccode);
	}

	# Get the length of the string.
	my $len = length $text;

	# Divide the length into segments (number of colors - 1)
	my $sections = $len / (scalar(@nodes) - 1);
	if ($sections =~ /\./) {
		# If it was a decimal, add one and int it.
		$sections += 1;
	}
	$sections = int($sections);

	# If the length of a given segment of text is too great, no fading will
	# occur (for ex: 255-0-0 to 0-0-0 has a delta of -255 in the red. If the
	# length of this segment is >255 characters, 255/(>255) will result in
	# a fraction less than 1, so no per-character offset will be computed.
	# So, if the length of the segments is gonna be too long, double the
	# number of nodes...
	my $giveup = 0;
	while ($sections > 128) {
		my @newNodes = ();
		for (my $i = 0; $i < scalar(@nodes); $i++) {
			my $color = $nodes[$i];
			push (@newNodes,$color);

			# If we have another color after the one we're looping
			# on right now--good.
			if ($i < scalar(@nodes)) {
				my $neighbor = $nodes[$i + 1];
				$neighbor = $color unless defined $neighbor;

				# Find the average between these two colors.
				my $average = Color::Fade::average_colors($color,$neighbor);
				push (@newNodes,$average);
			}
		}
		(@nodes) = @newNodes;

		$sections = $len / (scalar(@nodes) - 1);
		if ($sections =~ /\./) {
			$sections += 1;
		}
		$sections = int($sections);
		$giveup++;
		if ($giveup > 100) {
			# After 100 tries to factor this down, let's just give up.
			last;
		}
	}

	# Split the string into individual characters.
	my @chars = split(//, $text);
	my @faded = ();

	print "Color::Fade: preparing to fade a string.\n"
		. "length of string:           $len\n"
		. "number of nodes (colors):   " . scalar(@nodes) . "\n"
		. "number of char per segment: $sections\n" if $debug;

	if ($giveup > 0) {
		print "Note: the input string was very long: a given\n"
			. "segment would be >128 characters in length, which\n"
			. "doesn't make for a good fade effect. It was factors\n"
			. "down $giveup times.\n" if $debug;
	}

	print "Color::Fade: beginning the segment loop\n" if $debug;

	my $nodeStart = 0;
	for (my $i = 0; $i < $len; $i += $sections) {
		# Find the length of this segment.
		my $seglen = ($i + $sections) - $i;

		# Separate the RGB components of the start and end colors.
		my (@RGB_Hex_Start) = $nodes[$nodeStart]     =~ /^(..)(..)(..)$/i; # /^([0-9A-Fa-f]{2}){3}$/i;
		my (@RGB_Hex_End)   = $nodes[$nodeStart + 1] =~ /^(..)(..)(..)$/i; # /^([0-9A-Fa-f]{2}){3}$/i;
		(@RGB_Hex_End) = (@RGB_Hex_Start) unless scalar(@RGB_Hex_End);

		# Convert hexadecimal to decimal.
		my @RGB_Dec_Start = (
			hex ("0x" . $RGB_Hex_Start[0]),
			hex ("0x" . $RGB_Hex_Start[1]),
			hex ("0x" . $RGB_Hex_Start[2]),
		);
		my @RGB_Dec_End = (
			hex ("0x" . $RGB_Hex_End[0]),
			hex ("0x" . $RGB_Hex_End[1]),
			hex ("0x" . $RGB_Hex_End[2]),
		);

		# Find the distances in Red/Green/Blue values.
		my $distR = $RGB_Dec_Start[0] - $RGB_Dec_End[0];
		my $distG = $RGB_Dec_Start[1] - $RGB_Dec_End[1];
		my $distB = $RGB_Dec_Start[2] - $RGB_Dec_End[2];

		$distR < 0 ? $distR = abs($distR) : $distR = -$distR;
		$distG < 0 ? $distG = abs($distG) : $distG = -$distG;
		$distB < 0 ? $distB = abs($distB) : $distB = -$distB;

		# Divide each distance by the length of this segment,
		# so we can find out how many characters to operate on.
		my $charsR = int($distR / $seglen);
		my $charsG = int($distG / $seglen);
		my $charsB = int($distB / $seglen);

		print "  Segment length: $seglen\n"
			. "  RGB Start: " . join("-",@RGB_Dec_Start) . "\n"
			. "  RGB End:   " . join("-",@RGB_Dec_End) . "\n"
			. "  RGB Delta: " . join(" : ",$distR,$distG,$distB) . "\n"
			. "  RGB Chars: " . join(" : ",$charsR,$charsG,$charsB) . "\n" if $debug;

		# For each character in this segment...
		my ($r,$g,$b) = @RGB_Dec_Start;
		for (my $c = $i; $c < ($i + $seglen); $c++) {
			next unless defined $chars[$c];
			print "    Working with character $chars[$c]\n" if $debug;

			# Convert each color value back into hex.
			my $hexR = sprintf ("%02x", $r);
			my $hexG = sprintf ("%02x", $g);
			my $hexB = sprintf ("%02x", $b);

			# Turn the hex values into a color code.
			my $code = join ("", $hexR, $hexG, $hexB);

			print "      Hex code: $code => $chars[$c]\n" if $debug;

			# Prepare an easy to parse color marker for this character.
			$chars[$c] = " " if $chars[$c] =~ /^[\x0d\x0a]$/;
			my $marker = "" . $chars[$c];

			# Append this color information to the output array.
			push (@faded,$marker);

			# Increment each color by charsR, charsG, and charsB at a time.
			$r += $charsR;
			$g += $charsG;
			$b += $charsB;

			# Keep the numbers within a valid range.
			$r = 0 if $r < 0;
			$g = 0 if $g < 0;
			$b = 0 if $b < 0;
			$r = 255 if $r > 255;
			$g = 255 if $g > 255;
			$b = 255 if $b > 255;

			print "    RGB for next char: $r-$g-$b\n" if $debug;
		}

		$nodeStart++;
	}

	return wantarray ? @faded : join ("",@faded);
}

sub average_colors {
	my ($alpha,$beta) = @_;

	# This function, given two hex colors, returns the value of the color
	# directly between the two colors (an average of two).

	# Separate the hex values.
	my (@hexStart) = $alpha =~ /^(..)(..)(..)$/i;
	my (@hexEnd)   = $beta  =~ /^(..)(..)(..)$/i;

	# Get their numeric counterparts.
	my @decStart = (
		hex("0x" . $hexStart[0]),
		hex("0x" . $hexStart[1]),
		hex("0x" . $hexStart[2]),
	);
	my @decEnd = (
		hex("0x" . $hexEnd[0]),
		hex("0x" . $hexEnd[1]),
		hex("0x" . $hexEnd[2]),
	);

	# Get the averages of each color.
	my $avRed = int( ($decStart[0] + $decEnd[0]) / 2 );
	my $avGrn = int( ($decStart[1] + $decEnd[1]) / 2 );
	my $avBlu = int( ($decStart[2] + $decEnd[2]) / 2 );

	# And convert the averages back into hex.
	my @hexAvg = (
		sprintf ("%02x", $avRed),
		sprintf ("%02x", $avGrn),
		sprintf ("%02x", $avBlu),
	);
	return join("",@hexAvg);
}

1;
__END__