File Coverage

blib/lib/Color/RGB/Util.pm

Criterion	Covered	Total	%
statement	250	289	86.5
branch	107	164	65.2
condition	26	53	49.0
subroutine	29	30	96.6
pod	24	24	100.0
total	436	560	77.8

package Color::RGB::Util;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-01-19'; # DATE
our $DIST = 'Color-RGB-Util'; # DIST
our $VERSION = '0.603'; # VERSION

use 5.010001;
use strict;
use warnings;

#use List::Util qw(min);

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
                       assign_rgb_color
                       assign_rgb_dark_color
                       assign_rgb_light_color
                       hsl2hsv
                       hsl2rgb
                       hsv2hsl
                       hsv2rgb
                       int2rgb
                       mix_2_rgb_colors
                       mix_rgb_colors
                       rand_rgb_color
                       rand_rgb_colors
                       reverse_rgb_color
                       rgb2grayscale
                       rgb2hsv
                       rgb2hsl
                       rgb2int
                       rgb2sepia
                       rgb_diff
                       rgb_distance
                       rgb_is_dark
                       rgb_is_light
                       rgb_luminance
                       tint_rgb_color
               );

my $re_rgb = qr/\A#?([0-9A-Fa-f]{2})([0-9A-Fa-f]{2})([0-9A-Fa-f]{2})\z/;

sub _min {
    $_[0] < $_[1] ? $_[0] : $_[1];
}

sub _wrap_h {
    my $h = shift;
    $h %= 360 if abs($h) > 360;
    $h >= 0 ? $h : 360+$h;
}

sub assign_rgb_color {
    require Digest::SHA;

    my ($str) = @_;

    my $sha1 = Digest::SHA::sha1_hex($str);
    substr($sha1, 0, 2) .
    substr($sha1, 18, 2) .
    substr($sha1, 38, 2);
}

sub assign_rgb_dark_color {
    my $str = shift;

    my $rgb = assign_rgb_color($str);
    rgb_is_dark($rgb) ? $rgb : mix_2_rgb_colors($rgb, '000000');
}

sub assign_rgb_light_color {
    my $str = shift;

    my $rgb = assign_rgb_color($str);
    rgb_is_light($rgb) ? $rgb : mix_2_rgb_colors($rgb, 'ffffff');
}

sub int2rgb {
    my $int = shift;

    return sprintf("%02x%02x%02x",
                   ($int & 0xff0000) >> 16,
                   ($int & 0x00ff00) >>  8,
                   ($int & 0x0000ff),
               );
}

sub mix_2_rgb_colors {
    my ($rgb1, $rgb2, $pct) = @_;

    $pct //= 0.5;

    my ($r1, $g1, $b1) =
        $rgb1 =~ $re_rgb or die "Invalid rgb1 color '$rgb1', must be in 'ffffff' form";
    my ($r2, $g2, $b2) =
        $rgb2 =~ $re_rgb or die "Invalid rgb2 color '$rgb2', must be in 'ffffff' form";
    for ($r1, $g1, $b1, $r2, $g2, $b2) { $_ = hex $_ }

    return sprintf("%02x%02x%02x",
                   $r1 + $pct*($r2-$r1),
                   $g1 + $pct*($g2-$g1),
                   $b1 + $pct*($b2-$b1),
               );
}

sub mix_rgb_colors {

    my (@weights, @r, @g, @b);

    while (@_ >= 2) {
        my ($rgb, $weight) = splice @_, 0, 2;
        my ($r, $g, $b) = $rgb =~ $re_rgb
            or die "Invalid rgb color '$rgb', must be in 'ffffff' form";
        push @r, hex $r;
        push @g, hex $g;
        push @b, hex $b;
        push @weights, $weight;
    }
    my $tot_r = 0; for (0..$#r) { $tot_r += $r[$_]*$weights[$_] }
    my $tot_g = 0; for (0..$#g) { $tot_g += $g[$_]*$weights[$_] }
    my $tot_b = 0; for (0..$#b) { $tot_b += $b[$_]*$weights[$_] }
    my $tot_weight = 0; $tot_weight += $_ for @weights;
    die "Zero/negative total weight" unless $tot_weight > 0;

    return sprintf("%02x%02x%02x",
                   $tot_r / $tot_weight,
                   $tot_g / $tot_weight,
                   $tot_b / $tot_weight,
               );
}

sub rand_rgb_color {
    my ($rgb1, $rgb2) = @_;

    $rgb1 //= '000000';
    my ($r1, $g1, $b1) =
        $rgb1 =~ $re_rgb or die "Invalid rgb1 color '$rgb1', must be in 'ffffff' form";
    $rgb2 //= 'ffffff';
    my ($r2, $g2, $b2) =
        $rgb2 =~ $re_rgb or die "Invalid rgb2 color '$rgb2', must be in 'ffffff' form";
    for ($r1, $g1, $b1, $r2, $g2, $b2) { $_ = hex $_ }

    return sprintf("%02x%02x%02x",
                   $r1 + rand()*($r2-$r1+1),
                   $g1 + rand()*($g2-$g1+1),
                   $b1 + rand()*($b2-$b1+1),
               );
}

sub rand_rgb_colors {
    my $opts = ref $_[0] eq 'HASH' ? shift : {};
    my $num = shift // 1;
    my $light_color  = exists($opts->{light_color}) ? $opts->{light_color} : 1;
    my $max_attempts = $opts->{max_attempts} // 1000;
    my $avoid_colors = $opts->{avoid_colors};

    my $num_check = 10;
    my $min_distance = rgb_diff("000000", "ffffff", "approx2") / 2 / $num;

    my @res;
    while (@res < $num) {
        my $num_attempts = 0;
        my $rgb;
        while (1) {
            $rgb = rand_rgb_color();
            my $reject = 0;
          REJECT: {
                if ($light_color) {
                    do { $reject++; last } if rgb_is_dark($rgb);
                } elsif (defined $light_color) {
                    do { $reject++; last } if rgb_is_light($rgb);
                }
                if ($avoid_colors && ref $avoid_colors eq 'ARRAY') {
                    do { $reject++; last } if grep { $rgb eq $_ } @$avoid_colors;
                }
                if ($avoid_colors && ref $avoid_colors eq 'HASH') {
                    do { $reject++; last } if $avoid_colors->{$rgb}
                }

                for (1..$num_check) {
                    last if @res-$_ < 0;
                    my $prev_rgb = $res[ @res - $_ ];
                    do { $reject++; last REJECT } if rgb_diff($rgb, $prev_rgb, "approx2") < $min_distance;
                }

            } # REJECT
            last if !$reject;
            last if ++$num_attempts >= $max_attempts;
        }
        push @res, $rgb;
    }
    @res;
}

sub reverse_rgb_color {
    my ($rgb) = @_;

    my ($r, $g, $b) =
        $rgb =~ $re_rgb or die "Invalid rgb color '$rgb', must be in 'ffffff' form";
    for ($r, $g, $b) { $_ = hex $_ }

    return sprintf("%02x%02x%02x", 255-$r, 255-$g, 255-$b);
}

sub rgb2grayscale {
    my ($rgb) = @_;

    my ($r, $g, $b) =
        $rgb =~ $re_rgb or die "Invalid rgb color '$rgb', must be in 'ffffff' form";
    for ($r, $g, $b) { $_ = hex $_ }

    # basically we just average the R, G, B
    my $avg = int(($r + $g + $b)/3);
    return sprintf("%02x%02x%02x", $avg, $avg, $avg);
}

sub rgb2int {
    my $rgb = shift;

    # just to check
    $rgb =~ $re_rgb or die "Invalid rgb color '$rgb', must be in 'ffffff' form";

    hex($rgb);
}

sub rgb2sepia {
    my ($rgb) = @_;

    my ($r, $g, $b) =
        $rgb =~ $re_rgb or die "Invalid rgb color '$rgb', must be in 'ffffff' form";
    for ($r, $g, $b) { $_ = hex $_ }

    # reference: http://www.techrepublic.com/blog/howdoi/how-do-i-convert-images-to-grayscale-and-sepia-tone-using-c/120
    my $or = ($r*0.393) + ($g*0.769) + ($b*0.189);
    my $og = ($r*0.349) + ($g*0.686) + ($b*0.168);
    my $ob = ($r*0.272) + ($g*0.534) + ($b*0.131);
    for ($or, $og, $ob) { $_ = 255 if $_ > 255 }
    return sprintf("%02x%02x%02x", $or, $og, $ob);
}

sub rgb_diff {
    my ($rgb1, $rgb2, $algo) = @_;

    $algo //= 'euclidean';

    my ($r1, $g1, $b1) =
        $rgb1 =~ $re_rgb or die "Invalid rgb1 color '$rgb1', must be in 'ffffff' form";
    my ($r2, $g2, $b2) =
        $rgb2 =~ $re_rgb or die "Invalid rgb2 color '$rgb2', must be in 'ffffff' form";
    for ($r1, $g1, $b1, $r2, $g2, $b2) { $_ = hex $_ }

    my $dr2 = ($r1-$r2)**2;
    my $dg2 = ($g1-$g2)**2;
    my $db2 = ($b1-$b2)**2;

    if ($algo eq 'approx1' || $algo eq 'approx2') {
        my $rm = ($r1 + $r2)/2;
        if ($algo eq 'approx1') {
            return (2*$dr2 + 4*$dg2 + 3*$db2 + $rm*($dr2 - $db2)/256 )**0.5;
        } else { # approx2
            if ($rm < 128) {
                return (3*$dr2 + 4*$dg2 + 2*$db2)**0.5;
            } else {
                return (2*$dr2 + 4*$dg2 + 3*$db2)**0.5;
            }
        }
    } elsif ($algo eq 'hsv_euclidean' || $algo eq 'hsv_hue1') {
        my $hsv1 = rgb2hsv($rgb1);
        my ($h1, $s1, $v1) = split / /, $hsv1;
        my $hsv2 = rgb2hsv($rgb2);
        my ($h2, $s2, $v2) = split / /, $hsv2;

        my $dh2 = ( _min(abs($h2-$h1), 360-abs($h2-$h1))/180 )**2;
        my $ds2 = ( $s2-$s1 )**2;
        my $dv2 = ( ($v2-$v1)/255.0 )**2;

        if ($algo eq 'hsv_hue1') {
            return (5*$dh2 + $ds2 + $dv2)**0.5;
        } else { # hsv_euclidean
            return ($dh2 + $ds2 + $dv2)**0.5;
        }
    } else { # euclidean
        return ($dr2 + $dg2 + $db2)**0.5;
    }
}

sub rgb_distance {
    my ($rgb1, $rgb2) = @_;

    my ($r1, $g1, $b1) =
        $rgb1 =~ $re_rgb or die "Invalid rgb1 color '$rgb1', must be in 'ffffff' form";
    my ($r2, $g2, $b2) =
        $rgb2 =~ $re_rgb or die "Invalid rgb2 color '$rgb2', must be in 'ffffff' form";
    for ($r1, $g1, $b1, $r2, $g2, $b2) { $_ = hex $_ }

    (($r1-$r2)**2 + ($g1-$g2)**2 + ($b1-$b2)**2)**0.5;
}

sub rgb_is_dark {
    my ($rgb) = @_;
    rgb_distance($rgb, "000000") < rgb_distance($rgb, "ffffff") ? 1:0;
}

sub rgb_is_light {
    my ($rgb) = @_;
    rgb_distance($rgb, "000000") > rgb_distance($rgb, "ffffff") ? 1:0;
}

sub _rgb_luminance {
    my ($r, $g, $b) = @_;
    0.2126*$r/255 + 0.7152*$g/255 + 0.0722*$b/255;
}

sub rgb_luminance {
    my ($rgb) = @_;

    my ($r, $g, $b) =
        $rgb =~ $re_rgb or die "Invalid rgb color '$rgb', must be in 'ffffff' form";
    for ($r, $g, $b) { $_ = hex $_ }

    return _rgb_luminance($r, $g, $b);
}

sub tint_rgb_color {
    my ($rgb1, $rgb2, $pct) = @_;

    $pct //= 0.5;

    my ($r1, $g1, $b1) =
        $rgb1 =~ $re_rgb or die "Invalid rgb1 color '$rgb1', must be in 'ffffff' form";
    my ($r2, $g2, $b2) =
        $rgb2 =~ $re_rgb or die "Invalid rgb2 color '$rgb2', must be in 'ffffff' form";
    for ($r1, $g1, $b1, $r2, $g2, $b2) { $_ = hex $_ }

    my $lum = _rgb_luminance($r1, $g1, $b1);

    return sprintf("%02x%02x%02x",
                   $r1 + $pct*($r2-$r1)*$lum,
                   $g1 + $pct*($g2-$g1)*$lum,
                   $b1 + $pct*($b2-$b1)*$lum,
               );
}

sub rgb2hsl {
    my ($rgb) = @_;

    my ($r, $g, $b) =
        $rgb =~ $re_rgb or die "Invalid rgb color '$rgb', must be in 'ffffff' form";
    for ($r, $g, $b) { $_ = hex($_)/255 }

    my $max = $r;
    my $maxc = 'r';
    my $min = $r;

    if ($g > $max) {
        $max = $g;
        $maxc = 'g';
    }
    if ($b > $max) {
        $max = $b;
        $maxc = 'b';
    }

    if ($g < $min) {
        $min = $g;
    }
    if ($b < $min) {
        $min = $b;
    }

    my ($h, $s, $l);
    if ($max == $min) {
        $h = 0;
    } elsif ($maxc eq 'r') {
        $h = 60 * (($g - $b) / ($max - $min)) % 360;
    } elsif ($maxc eq 'g') {
        $h = (60 * (($b - $r) / ($max - $min)) + 120);
    } elsif ($maxc eq 'b') {
        $h = (60 * (($r - $g) / ($max - $min)) + 240);
    }

    $l = ($max + $min) / 2;

    if ($max == $min) {
        $s = 0;
    } elsif($l <= .5) {
        $s = ($max - $min) / ($max + $min);
    } else {
        $s = ($max - $min) / (2 - ($max + $min));
    }

    return sprintf("%.3g %.3g %.3g", $h, $s, $l);
}

sub rgb2hsv {
    my ($rgb) = @_;

    my ($r, $g, $b) =
        $rgb =~ $re_rgb or die "Invalid rgb color '$rgb', must be in 'ffffff' form";
    for ($r, $g, $b) { $_ = hex($_)/255 }

    my $max = $r;
    my $maxc = 'r';
    my $min = $r;

    if ($g > $max) {
        $max = $g;
        $maxc = 'g';
    }
    if($b > $max) {
        $max = $b;
        $maxc = 'b';
    }

    if($g < $min) {
        $min = $g;
    }
    if($b < $min) {
        $min = $b;
    }

    my ($h, $s, $v);

    if ($max == $min) {
        $h = 0;
    } elsif ($maxc eq 'r') {
        $h = 60 * (($g - $b) / ($max - $min)) % 360;
    } elsif ($maxc eq 'g') {
        $h = (60 * (($b - $r) / ($max - $min)) + 120);
    } elsif ($maxc eq 'b') {
        $h = (60 * (($r - $g) / ($max - $min)) + 240);
    }

    $v = $max;
    if($max == 0) {
        $s = 0;
    } else {
        $s = 1 - ($min / $max);
    }

    return sprintf("%.3g %.3g %.3g", $h, $s, $v);
}

sub hsl2hsv {
    my $hsl = shift;

    my ($h, $s, $l) = split / /, $hsl;
    $h>=0 && $h<=360 or $h = _wrap_h($h); $s>=0 && $s<=1 or die "Invalid S in HSL '$hsl', must be in 0-1"; $l>=0 && $l<=1 or die "Invalid L in HSL '$hsl', must be in 0-1";
    my $_h = $h;
    my $_s;
    my $_v;

    $l *= 2;
    $s *= ($l <= 1) ? $l : 2-$l;
    $_v = ($l+$s) / 2;
    $_s = (2*$s) / ($l+$s);

    "$_h $_s $_v";
}

sub hsv2hsl {
    my $hsv = shift;

    my ($h, $s, $v) = split / /, $hsv;
    $h>=0 && $h<=360 or $h = _wrap_h($h); $s>=0 && $s<=1 or die "Invalid S in HSV '$hsv', must be in 0-1"; $v>=0 && $v<=1 or die "Invalid V in HSV '$hsv', must be in 0-1";
    my $_h = $h;
    my $_s = $s * $v;
    my $_l = (2-$s) * $v;

    $_s /= $_l <= 1 ? ($_l==0 ? 1 : $_l) : (2-$_l);
    $_l /= 2;

    "$_h $_s $_l";
}

sub hsl2rgb {
    hsv2rgb(hsl2hsv(shift));
}

sub hsv2rgb {
    my $hsv = shift;

    my ($h, $s, $v) = split / /, $hsv;
    $h>=0 && $h<=360 or $h = _wrap_h($h); $s>=0 && $s<=1 or die "Invalid S in HSV '$hsv', must be in 0-1"; $v>=0 && $v<=1 or die "Invalid V in HSV '$hsv', must be in 0-1";

    my $i = int($h/60);
    my $f = $h/60 - $i;
    my $p = $v * (1-$s);
    my $q = $v * (1-$f*$s);
    my $t = $v * (1-(1-$f)*$s);

    my ($r, $g, $b);
    if ($i==0) {
        $r = $v; $g = $t; $b = $p;
    } elsif ($i==1) {
        $r = $q; $g = $v; $b = $p;
    } elsif ($i==2) {
        $r = $p; $g = $v; $b = $t;
    } elsif ($i==3) {
        $r = $p; $g = $q; $b = $v;
    } elsif ($i==4) {
        $r = $t; $g = $p; $b = $v;
    } else {
        $r = $v; $g = $p; $b = $q;
    }

    return sprintf("%02x%02x%02x", $r*255, $g*255, $b*255);
}

1;
# ABSTRACT: Utilities related to RGB colors

__END__