lib/Convert/Color/HUSL.pm

   1 package Convert::Color::HUSL;
   2
   3 use 5.008009;
   4 use strict;
   5 use warnings;
   6 use parent qw/Convert::Color/;
   7
   8 use Convert::Color::XYZ;
   9 use Convert::Color::LUV;
  10 use Convert::Color::LCh;
  11 use List::Util qw/min/;
  12 use Math::Trig qw/:pi/;
  13
  14 BEGIN {
  15         *MAT_R = *Convert::Color::XYZ::MAT_R;
  16         *MAT_G = *Convert::Color::XYZ::MAT_G;
  17         *MAT_B = *Convert::Color::XYZ::MAT_B;
  18
  19         *KAPPA = *Convert::Color::LUV::KAPPA;
  20         *EPS   = *Convert::Color::LUV::EPS;
  21 }
  22
  23 our $VERSION = '1.000';
  24
  25 __PACKAGE__->register_color_space('husl');
  26
  27 sub new {
  28         my ($class, $h, $s, $l) = @_;
  29         ($h, $s, $l) = split /,/s, $h unless defined $s;
  30         bless [$h, $s, $l], $class
  31 }
  32
  33 sub H { shift->[0] }
  34 sub S { shift->[1] }
  35 sub L { shift->[2] }
  36
  37 sub hsl { @{$_[0]} }
  38
  39 sub _get_bounds {
  40         my ($l) = @_;
  41         my $sub1 = ($l + 16) ** 3 / 1_560_896;
  42         my $sub2 = $sub1 > EPS ? $sub1 : $l / KAPPA;
  43         my @ret;
  44
  45         for (MAT_R, MAT_G, MAT_B) {
  46                 my ($m1, $m2, $m3) = @$_;
  47                 for (0, 1) {
  48                         my $top1 = (284_517 * $m1 - 94_839 * $m3) * $sub2;
  49                         my $top2 = (838_422 * $m3 + 769_860 * $m2 + 731_718 * $m1) * $l * $sub2 - 769_860 * $_ * $l;
  50                         my $bottom = (632_260 * $m3 - 126_452 * $m2) * $sub2 + 126_452 * $_;
  51                         push @ret, [$top1 / $bottom, $top2 / $bottom]
  52                 }
  53         }
  54
  55         @ret
  56 }
  57
  58 sub _length_of_ray_until_intersect {
  59         my ($theta, $line) = @_;
  60         my ($m, $n) = @$line;
  61         my $len = $n / (sin ($theta) - $m * cos $theta);
  62         return if $len < 0;
  63         $len
  64 }
  65
  66 sub max_chroma_for_lh {
  67         my ($self, $l, $h) = @_;
  68         my $hrad = $h / 180 * pi;
  69         min map {
  70                 _length_of_ray_until_intersect $hrad, $_
  71         } _get_bounds $l;
  72 }
  73
  74 sub convert_to_lch {
  75         my ($self) = @_;
  76         my ($h, $s, $l) = @$self;
  77         return Convert::Color::LCh->new(100, 0, $h) if $l > 99.9999999;
  78         return Convert::Color::LCh->new(0, 0, $h) if $l < 0.00000001;
  79         my $max = $self->max_chroma_for_lh($l, $h);
  80         my $c = $max / 100 * $s;
  81         Convert::Color::LCh->new($l, $c, $h)
  82 }
  83
  84 sub new_from_lch {
  85         my ($class, $lch) = @_;
  86         my ($l, $c, $h) = @$lch;
  87         return $class->new($h, 0, 100) if $l > 99.9999999;
  88         return $class->new($h, 0, 0) if $l < 0.00000001;
  89         my $max = $class->max_chroma_for_lh($l, $h);
  90         my $s = $c / $max * 100;
  91         $class->new($h, $s, $l)
  92 }
  93
  94 sub rgb { shift->convert_to_lch->rgb }
  95 sub new_rgb { shift->new_from_lch(Convert::Color::LCh->new_rgb(@_)) }
  96
  97 1;
  98 __END__
  99
 100 =encoding utf-8
 101
 102 =head1 NAME
 103
 104 Convert::Color::HUSL - a color value in the HUSL color space
 105
 106 =head1 SYNOPSIS
 107
 108   use Convert::Color::HUSL;
 109   my $red = Convert::Color::HUSL->new(12.17705, 100, 53.23712);
 110   my $green = Convert::Color::HUSL->new('127.71501,100,87.73552');
 111
 112   use Convert::Color;
 113   my $blue = Convert::Color->new('husl:265.87432,100,32.30087');
 114
 115   say $red->H; # 12.17705
 116   say $red->S; # 100
 117   say $red->L; # 53.23712
 118   say join ',', $blue->hsl; # 265.87432,100,32.30087
 119
 120 =head1 DESCRIPTION
 121
 122 Objects of this class represent colors in the HUSL color space, revision 4.
 123
 124 Methods:
 125
 126 =over
 127
 128 =item Convert::Color::HUSL->B<new>(I<$h>, I<$s>, I<$l>)
 129
 130 Construct a color from its components.
 131
 132 =item Convert::Color::HUSL->B<new>(I<"$h,$s,$l">)
 133
 134 Construct a color from a string. The string should contain the three
 135 components, separated by commas.
 136
 137 =item $husl->B<H>
 138
 139 =item $husl->B<S>
 140
 141 =item $husl->B<L>
 142
 143 Accessors for the three components of the color.
 144
 145 =item $husl->B<hsl>
 146
 147 Returns the three components as a list.
 148
 149 =back
 150
 151 =head1 SEE ALSO
 152
 153 L<Convert::Color>, L<http://www.husl-colors.org/>
 154
 155 =head1 AUTHOR
 156
 157 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 158
 159 =head1 COPYRIGHT AND LICENSE
 160
 161 Copyright (C) 2015 by Marius Gavrilescu
 162
 163 This library is free software; you can redistribute it and/or modify
 164 it under the same terms as Perl itself, either Perl version 5.20.2 or,
 165 at your option, any later version of Perl 5 you may have available.
 166
 167
 168 =cut