File Coverage

blib/lib/Flame/Palette.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Flame::Palette;

use 5.008;
use strict;
use warnings;

use Carp 'croak';
use Math::Interpolator::Linear;
use Math::Interpolator::Knot;
use XML::Parser;
use XML::Writer;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Flame::Palette ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.02';


# Preloaded methods go here.

sub new {
    my $class = shift;

    return bless {}, $class;
}

sub check_integer {
    my $self = shift;
    my $subject = shift;
    my $name = shift;

    croak "undefined subject" unless defined $subject;

    unless($subject =~ /^\d+$/ && $subject >= 0 && $subject <= 255) {
	croak "invalid $name '$subject'";
    }
}

sub set {
    my($self, %stuff) = @_;

    croak "missing index argument" unless exists $stuff{index};

    my $index = $stuff{index};

    $self->check_integer($index, 'index');

    if(exists $stuff{red} && exists $stuff{green} && exists $stuff{blue}) {
	foreach(qw(red green blue)) {
	    $self->check_integer($stuff{$_}, $_);
	}

	my($r, $g, $b) = map { $stuff{$_} } qw(red green blue);

	$self->{data}->[$index] = [$r, $g, $b];

	return 1;
    }

    croak "expect index, red, green, blue arguments";
}

sub get {
    my($self, %stuff) = @_;

    croak "missing 'index' argument" unless exists $stuff{index};

    my $index = $stuff{index};

    $self->check_integer($index, 'index');

    my @data = (0, 0, 0);

    if(exists $self->{data} && $index < @{$self->{data}}) {
	@data = @{$self->{data}->[$index] || []};
    }

    if(wantarray) {
	return @data;
    }

    return \@data;
}

sub unparse_xml {
    my($self, $stream) = @_;

    my $w = XML::Writer->new(OUTPUT => $stream);

    $w->startTag('palette');

    foreach my $i (0...255) {
	my($r, $g, $b) = $self->get(index => $i);

	$w->emptyTag('color', index => $i, rgb => join ' ', $r, $g, $b);
    }

    $w->endTag;
}

sub clear {
    my $self = shift;

    delete $self->{data};
}

sub parse_flame {
    my($self, $stream) = @_;

    $self->clear;

    my $ok = 0;
    my $done = 0;

    my $s_start = sub {
	my(undef, $tag, %attr) = @_;

	unless($done) {
	    if($tag =~ /^flame$/) {
		$ok = 1;
	    } elsif($ok) {
		if($tag =~ /^color$/) {
		    croak "missing 'index' attribute in 'color' tag" unless exists $attr{index};
		    croak "missing 'rgb' attribute in 'color' tag" unless exists $attr{rgb};

		    my($red, $green, $blue) = split '\D+', $attr{rgb};

		    $self->set(index => $attr{index},
			       red => $red,
			       green => $green,
			       blue => $blue);
		}
	    }
	}
    };

    my $s_end = sub {
	my(undef, $tag) = @_;

	unless($done) {
	    if($tag =~ /^flame$/) {
		$done = 1;
	    }
	}
    };

    XML::Parser->new(Handlers => { Start => $s_start, End => $s_end })->parse($stream);
}

sub parse_xml {
    my($self, $stream) = @_;

    $self->clear;

    my $level = 0;

    my $s_start = sub {
	my(undef, $tag, %attr) = @_;

	if($tag =~ /^palette$/ && $level == 0) {
	    if(keys %attr != 0) {
		croak "the 'palette' tag doesn't accept attributes";
	    }
	} elsif($tag =~ /^color$/ && $level == 1) {
	    croak "missing 'index' attribute" unless exists $attr{index};
	    croak "missing 'rgb' attribute" unless exists $attr{rgb};

	    my $index = $attr{index};
	    my $rgb = $attr{rgb};

	    delete $attr{index};
	    delete $attr{rgb};

	    if(keys %attr != 0) {
		croak "the 'color' tag doesn't accept attributes but index,rgb";
	    }

	    my($red, $green, $blue) = split '\D+', $rgb;

	    $self->set(index => $index, red => $red, green => $green, blue => $blue);
	} else {
	    croak "unknown tag '$tag'";
	}

	$level++;
    };

    my $s_end = sub { $level-- };

    XML::Parser->new(Handlers => { Start => $s_start, End => $s_end })->parse($stream);
}

sub interpolate {
    my $self = shift;

    my $i = 0;

    while($i < 255) {
	if(defined $self->{data}->[$i] && !defined $self->{data}->[$i + 1]) {
	    my $j = $i + 1;

	    while($j < 255 && !defined $self->{data}->[$j]) {
		$j++;
	    }

	    my($fr, $fg, $fb) = $self->get(index => $i);
	    my($tr, $tg, $tb) = $self->get(index => $j);

	    my $ci = sub {
		push my @p, Math::Interpolator::Knot->new($i, $_[0]);
		push @p, Math::Interpolator::Knot->new($j, $_[1]);

		my $ipl = Math::Interpolator::Linear->new(@p);

		sub { int($ipl->y($_[0])) }
	    };

	    my $r_ip = $ci->($fr, $tr);
	    my $g_ip = $ci->($fg, $tg);
	    my $b_ip = $ci->($fb, $tb);

	    foreach($i...$j) {
		$self->set(index => $_,
			   red   => $r_ip->($_),
			   green => $g_ip->($_),
			   blue  => $b_ip->($_));
	    }
	}

	$i++;
    }
}

# TODO: CHECK DOCUMENTATION

1;
__END__