File Coverage

blib/lib/Convert/Color/HUSL.pm

Criterion	Covered	Total	%
statement	76	76	100.0
branch	14	14	100.0
condition			n/a
subroutine	22	22	100.0
pod	6	10	60.0
total	118	122	96.7

package Convert::Color::HUSL;

use 5.008009;
use strict;
use warnings;
use parent qw/Convert::Color/;

use Convert::Color::XYZ;
use Convert::Color::LUV;
use Convert::Color::LCh;
use List::Util qw/min/;
use Math::Trig qw/:pi/;

BEGIN {
	*MAT_R = *Convert::Color::XYZ::MAT_R;
	*MAT_G = *Convert::Color::XYZ::MAT_G;
	*MAT_B = *Convert::Color::XYZ::MAT_B;

	*KAPPA = *Convert::Color::LUV::KAPPA;
	*EPS   = *Convert::Color::LUV::EPS;
}

our $VERSION = '1.000';

__PACKAGE__->register_color_space('husl');

sub new {
	my ($class, $h, $s, $l) = @_;
	($h, $s, $l) = split /,/s, $h unless defined $s;
	bless [$h, $s, $l], $class
}

sub H { shift->[0] }
sub S { shift->[1] }
sub L { shift->[2] }

sub hsl { @{$_[0]} }

sub _get_bounds {
	my ($l) = @_;
	my $sub1 = ($l + 16) ** 3 / 1_560_896;
	my $sub2 = $sub1 > EPS ? $sub1 : $l / KAPPA;
	my @ret;

	for (MAT_R, MAT_G, MAT_B) {
		my ($m1, $m2, $m3) = @$_;
		for (0, 1) {
			my $top1 = (284_517 * $m1 - 94_839 * $m3) * $sub2;
			my $top2 = (838_422 * $m3 + 769_860 * $m2 + 731_718 * $m1) * $l * $sub2 - 769_860 * $_ * $l;
			my $bottom = (632_260 * $m3 - 126_452 * $m2) * $sub2 + 126_452 * $_;
			push @ret, [$top1 / $bottom, $top2 / $bottom]
		}
	}

	@ret
}

sub _length_of_ray_until_intersect {
	my ($theta, $line) = @_;
	my ($m, $n) = @$line;
	my $len = $n / (sin ($theta) - $m * cos $theta);
	return if $len < 0;
	$len
}

sub max_chroma_for_lh {
	my ($self, $l, $h) = @_;
	my $hrad = $h / 180 * pi;
	min map {
		_length_of_ray_until_intersect $hrad, $_
	} _get_bounds $l;
}

sub convert_to_lch {
	my ($self) = @_;
	my ($h, $s, $l) = @$self;
	return Convert::Color::LCh->new(100, 0, $h) if $l > 99.9999999;
	return Convert::Color::LCh->new(0, 0, $h) if $l < 0.00000001;
	my $max = $self->max_chroma_for_lh($l, $h);
	my $c = $max / 100 * $s;
	Convert::Color::LCh->new($l, $c, $h)
}

sub new_from_lch {
	my ($class, $lch) = @_;
	my ($l, $c, $h) = @$lch;
	return $class->new($h, 0, 100) if $l > 99.9999999;
	return $class->new($h, 0, 0) if $l < 0.00000001;
	my $max = $class->max_chroma_for_lh($l, $h);
	my $s = $c / $max * 100;
	$class->new($h, $s, $l)
}

sub rgb { shift->convert_to_lch->rgb }
sub new_rgb { shift->new_from_lch(Convert::Color::LCh->new_rgb(@_)) }

1;
__END__