Created
October 18, 2025 16:52
-
-
Save noureddin/c57a262d890c8ed7e8bee86791952581 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| package HSLuv; | |
| use v5.14; use warnings; use utf8; | |
| use Exporter 'import'; | |
| our @EXPORT = qw[ rgb2hex hex2rgb hex2hsluv hsluv2hex hsluv2rgb rgb2hsluv ]; | |
| our @EXPORT_OK = @EXPORT; | |
| use List::Util qw[ min sum ]; | |
| use Math::Trig; | |
| # translated from HSLuv-PHP: https://github.com/hsluv/hsluv-php | |
| our %M = ( | |
| R => [3.2409699419045214, -1.5373831775700935, -0.49861076029300328], | |
| G => [-0.96924363628087983, 1.8759675015077207, 0.041555057407175613], | |
| B => [0.055630079696993609, -0.20397695888897657, 1.0569715142428786], | |
| ); | |
| our %M_INV = ( | |
| X => [0.41239079926595948, 0.35758433938387796, 0.18048078840183429], | |
| Y => [0.21263900587151036, 0.71516867876775593, 0.072192315360733715], | |
| Z => [0.019330818715591851, 0.11919477979462599, 0.95053215224966058], | |
| ); | |
| use constant REF_U => 0.19783000664283681; | |
| use constant REF_V => 0.468319994938791; | |
| # CIE LUV constants | |
| use constant KAPPA => 903.2962962962963; | |
| use constant EPSILLON => 0.0088564516790356308; | |
| ## For a given lightness, return a list of 6 lines in slope-intercept | |
| ## form that represent the bounds in CIELUV, stepping over which will | |
| ## push a value out of the RGB gamut | |
| ## | |
| ## @param mixed $L | |
| ## @return array | |
| sub getBounds { my ($L) = @_; | |
| my $sub1 = (($L + 16) ** 3) / 1560896; | |
| my $sub2 = ($sub1 > EPSILLON ? $sub1 : $L / KAPPA); | |
| my @ret; | |
| my @components = ('R', 'G', 'B'); | |
| for my $channel (@components) { | |
| my ($m1, $m2, $m3) = @{$M{$channel}}; | |
| my @binary = (0, 1); | |
| for my $digit (@binary) { | |
| my $top1 = (284517 * $m1 - 94839 * $m3) * $sub2; | |
| my $top2 = (838422 * $m3 + 769860 * $m2 + 731718 * $m1) * $L * $sub2 - 769860 * $digit * $L; | |
| my $bottom = (632260 * $m3 - 126452 * $m2) * $sub2 + 126452 * $digit; | |
| push @ret, [$top1/$bottom, $top2/$bottom]; | |
| } | |
| } | |
| return @ret; | |
| } | |
| sub intersectLineLine { my ($line1, $line2) = @_; | |
| return (($line1->[1] - $line2->[1]) / ($line2->[0] - $line1->[0])); | |
| } | |
| sub distanceFromPole { my ($point) = @_; | |
| return (($point->[0] ** 2) + ($point->[1] ** 2)) ** 0.5; | |
| } | |
| ## theta -- angle of ray starting at (0, 0) | |
| ## m, b -- slope and intercept of line | |
| ## x1, y1 -- coordinates of intersection | |
| ## len -- length of ray until it intersects with line | |
| ## | |
| ## b + m * x1 = y1 | |
| ## len >= 0 | |
| ## len * cos(theta) = x1 | |
| ## len * sin(theta) = y1 | |
| ## | |
| ## | |
| ## b + m * (len * cos(theta)) = len * sin(theta) | |
| ## b = len * sin(hrad) - m * len * cos(theta) | |
| ## b = len * (sin(hrad) - m * cos(hrad)) | |
| ## len = b / (sin(hrad) - m * cos(hrad)) | |
| ## | |
| ## @param mixed $theta | |
| ## @param mixed $line | |
| ## @return float|int|null | |
| sub lengthOfRayUntilIntersect { my ($theta, $line) = @_; | |
| my ($m1, $b1) = @$line; | |
| my $len = $b1 / (sin($theta) - $m1 * cos($theta)); | |
| return $len < 0 ? undef : $len; | |
| } | |
| ## For given lightness, returns the maximum chroma. Keeping the chroma value | |
| ## below this number will ensure that for any hue, the color is within the RGB | |
| ## gamut. | |
| ## | |
| ## @param mixed $L | |
| ## @return mixed | |
| sub maxSafeChromaForL { my ($L) = @_; | |
| my @lengths; | |
| my @bounds = getBounds($L); | |
| for my $it (@bounds) { | |
| # x where line intersects with perpendicular running though (0, 0) | |
| my ($m1, $b1) = @$it; | |
| my $x = intersectLineLine([$m1, $b1], [-1 / $m1, 0]); | |
| push @lengths, distanceFromPole([$x, $b1 + $x * $m1]); | |
| } | |
| return min(@lengths); | |
| } | |
| ## For a given lightness and hue, return the maximum chroma that fits in | |
| ## the RGB gamut. | |
| ## | |
| ## @param mixed $L | |
| ## @param mixed $H | |
| ## @return mixed | |
| sub maxChromaForLH { my ($L, $H) = @_; | |
| my $hrad = $H / 360 * pi * 2; | |
| my @lengths; | |
| my @bounds = getBounds($L); | |
| for my $it (@bounds) { | |
| my $l = lengthOfRayUntilIntersect($hrad, $it); | |
| push @lengths, $l if defined $l; | |
| } | |
| return min(@lengths); | |
| } | |
| sub dotProduct { my ($a, $b) = @_; | |
| return sum map { $a->[$_] * $b->[$_] } 0..$#$a; | |
| } | |
| # Used for rgb conversions | |
| sub fromLinear(_) { my ($c) = @_; | |
| if ($c <= 0.0031308) { | |
| return 12.92 * $c; | |
| } | |
| else { | |
| return 1.055 * ($c ** (1 / 2.4)) - 0.055; | |
| } | |
| } | |
| sub toLinear(_) { my ($c) = @_; | |
| $a = 0.055; | |
| if ($c > 0.04045) { | |
| return ((($c + $a) / (1 + $a)) ** 2.4); | |
| } | |
| else { | |
| return $c / 12.92; | |
| } | |
| } | |
| sub xyzToRgb { return map { fromLinear dotProduct($M{$_}, \@_) } qw[ R G B ] } | |
| sub rgbToXyz { | |
| my @rgbl = map { toLinear } @_; | |
| return map { dotProduct($M_INV{$_}, \@rgbl) } qw[ X Y Z ]; | |
| } | |
| ## http://en.wikipedia.org/wiki/CIELUV | |
| ## In these formulas, Yn refers to the reference white point. We are using | |
| ## illuminant D65, so Yn (see refY in Maxima file) equals 1. The formula is | |
| ## simplified accordingly. | |
| ## | |
| ## @param mixed $Y | |
| ## @return mixed | |
| sub Y_to_L { my ($Y) = @_; | |
| if ($Y <= EPSILLON) { | |
| return $Y * KAPPA; | |
| } | |
| else { | |
| return 116 * $Y ** (1 / 3) - 16; | |
| } | |
| } | |
| sub L_to_Y { my ($L) = @_; | |
| if ($L <= 8) { | |
| return $L / KAPPA; | |
| } | |
| else { | |
| return (($L + 16) / 116) ** 3; | |
| } | |
| } | |
| sub xyzToLuv { my ($X, $Y, $Z) = @_; | |
| # Black will create a divide-by-zero error | |
| return 0, 0, 0 if $Y == 0; | |
| my $L = Y_to_L($Y); | |
| my $varU = 4 * $X / ($X + 15 * $Y + 3 * $Z); | |
| my $varV = 9 * $Y / ($X + 15 * $Y + 3 * $Z); | |
| my $U = 13 * $L * ($varU - REF_U); | |
| my $V = 13 * $L * ($varV - REF_V); | |
| return $L, $U, $V; | |
| } | |
| sub luvToXyz { my ($L, $U, $V) = @_; | |
| # Black will create a divide-by-zero error | |
| return 0, 0, 0 if $L == 0; | |
| my $varU = $U / (13 * $L) + REF_U; | |
| my $varV = $V / (13 * $L) + REF_V; | |
| my $Y = L_to_Y($L); | |
| my $X = 0 - 9 * $Y * $varU / (($varU - 4) * $varV - $varU * $varV); | |
| my $Z = (9 * $Y - 15 * $varV * $Y - $varV * $X) / (3 * $varV); | |
| return $X, $Y, $Z; | |
| } | |
| sub luvToLch { my ($L, $U, $V) = @_; | |
| my $C = ($U ** 2 + $V ** 2) ** 0.5; | |
| my $H; | |
| # Greys: disambiguate hue | |
| if ($C < 0.00000001) { | |
| $H = 0; | |
| } | |
| else { | |
| my $Hrad = atan2($V, $U); | |
| $H = $Hrad * 360 / 2 / pi; | |
| $H += 360 if $H < 0; | |
| } | |
| return $L, $C, $H; | |
| } | |
| sub lchToLuv { my ($L, $C, $H) = @_; | |
| my $Hrad = $H / 360 * 2 * pi; | |
| my $U = cos($Hrad) * $C; | |
| my $V = sin($Hrad) * $C; | |
| return $L, $U, $V; | |
| } | |
| sub hsluvToLch { my ($H, $S, $L) = @_; | |
| # White and black: disambiguate chroma | |
| my $C = $L > 99.9999999 || $L < 0.00000001 | |
| ? 0 | |
| : maxChromaForLH($L, $H) / 100 * $S | |
| ; | |
| return $L, $C, $H; | |
| } | |
| sub lchToHsluv { my ($L, $C, $H) = @_; | |
| # White and black: disambiguate saturation | |
| my $S = $L > 99.9999999 || $L < 0.00000001 | |
| ? 0 | |
| : $C / maxChromaForLH($L, $H) * 100 | |
| ; | |
| return $H, $S, $L; | |
| } | |
| sub hpluvToLch { my ($H, $S, $L) = @_; | |
| # White and black: disambiguate chroma | |
| my $C = $L > 99.9999999 || $L < 0.00000001 | |
| ? 0 | |
| : maxSafeChromaForL($L) / 100 * $S | |
| ; | |
| return $L, $C, $H; | |
| } | |
| sub lchToHpluv { my ($L, $C, $H) = @_; | |
| # White and black: disambiguate saturation | |
| my $S = $L > 99.9999999 || $L < 0.00000001 | |
| ? 0 | |
| : $C / maxSafeChromaForL($L) * 100 | |
| ; | |
| return $H, $S, $L; | |
| } | |
| sub rgbToHex { | |
| return sprintf '#' . ('%02X') x 3, | |
| map { int(0.5 + $_ * 255) } | |
| @_; | |
| } | |
| sub hexToRgb { my ($hex) = @_; | |
| $hex =~ s/^#//; | |
| return length $hex == 3 | |
| ? map { hex($_) / 16 } $hex =~ /.{1}/g | |
| : map { hex($_) / 255 } $hex =~ /.{2}/g | |
| ; | |
| } | |
| # Helper functions | |
| sub lchToRgb { return xyzToRgb luvToXyz lchToLuv @_ } | |
| sub rgbToLch { return luvToLch xyzToLuv rgbToXyz @_ } | |
| sub hsluvToRgb { return lchToRgb hsluvToLch @_ } | |
| sub rgbToHsluv { return lchToHsluv rgbToLch @_ } | |
| sub hpluvToRgb { return lchToRgb hpluvToLch @_ } | |
| sub rgbToHpluv { return lchToHpluv rgbToLch @_ } | |
| sub fromRgb { return rgbToHsluv @_ } | |
| sub fromRgbInt { return rgbToHsluv map { $_ / 255 } @_ } | |
| sub fromHex { return rgbToHsluv hexToRgb @_ } | |
| sub toRgb { return hsluvToRgb @_ } | |
| sub toRgbInt { return map { int(0.5 + $_ * 255) } hsluvToRgb @_ } | |
| sub toHex { return rgbToHex hsluvToRgb @_ } | |
| sub p_toRgb { return xyzToRgb luvToXyz lchToLuv hpluvToLch @_ } | |
| sub p_toHex { return rgbToHex xyzToRgb luvToXyz lchToLuv hpluvToLch @_ } | |
| sub p_fromRgb { return lchToHpluv luvToLch xyzToLuv rgbToXyz @_ } | |
| sub p_fromHex { return lchToHpluv luvToLch xyzToLuv rgbToXyz hexToRgb @_ } | |
| # Exported functions | |
| sub rgb2hex { goto &rgbToHex } | |
| sub hex2rgb { goto &hexToRgb } | |
| sub hsluv2rgb { goto &hsluvToRgb } | |
| sub rgb2hsluv { goto &rgbToHsluv } | |
| sub hex2hsluv { rgb2hsluv hex2rgb @_ } | |
| sub hsluv2hex { rgb2hex hsluv2rgb @_ } | |
| 1; |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment