forked from mia/Aegisub
Adding Perl conversions of utils.lua. Requires discussion of what symbols should be exported by default; for now it exports the ones I think are interesting.
Originally committed to SVN as r1749.
This commit is contained in:
Karl Blomster
parent
cf38dbe139
commit
f2b6d17eb3
1 changed files with 250 additions and 0 deletions
250
automation/include/Auto4Utils.pm
Normal file
250
automation/include/Auto4Utils.pm
Normal file
|
|
@ -0,0 +1,250 @@
|
||||||
|
#/usr/bin/perl
|
||||||
|
|
||||||
|
#########
|
||||||
|
#
|
||||||
|
# Written by Karl Blomster (TheFluff) 2008.
|
||||||
|
# (OK, mostly just a translation of utils-auto4.lua.)
|
||||||
|
#
|
||||||
|
# This script is hereby given into the public domain.
|
||||||
|
# If that is not possible according to local laws, I, the author, hereby grant
|
||||||
|
# anyone the right to use this script for any purpose.
|
||||||
|
#
|
||||||
|
#########
|
||||||
|
|
||||||
|
package Auto4Utils;
|
||||||
|
require Exporter;
|
||||||
|
|
||||||
|
use warnings;
|
||||||
|
use strict;
|
||||||
|
use feature ":5.10";
|
||||||
|
use utf8; # just to be safe
|
||||||
|
use POSIX (); # gah, we only need floor(), no need to import all of IEEE 1003.1
|
||||||
|
|
||||||
|
|
||||||
|
# TODO: discuss what should be exported by default
|
||||||
|
our @ISA = qw(Exporter);
|
||||||
|
our @EXPORT = qw(extract_color alpha_from_style color_from_style HSV_to_RGB HSL_to_RGB interpolate_color interpolate_alpha);
|
||||||
|
our @EXPORT_OK = qw(ass_color ass_alpha ass_style_color string_trim clamp interpolate);
|
||||||
|
|
||||||
|
|
||||||
|
# Given 3 integers R,G,B, returns ASS formatted &HBBGGRR& string
|
||||||
|
sub ass_color {
|
||||||
|
my ($r, $g, $b) = @_;
|
||||||
|
return(sprintf("&H%02X%02X%02X&", $b, $g, $r));
|
||||||
|
}
|
||||||
|
# Perlier version of that:
|
||||||
|
# sub ass_color { return sprintf "&H%02X%02X%02X&", reverse }
|
||||||
|
# I don't think reverse reverses @_ by default, rats :(
|
||||||
|
|
||||||
|
# Convert decimal alpha value to &H00& form
|
||||||
|
sub ass_alpha {
|
||||||
|
return(sprintf("&H%02X&", shift(@_)));
|
||||||
|
}
|
||||||
|
|
||||||
|
# Given 4 integers R,G,B,A, returns a v4+ formatted style color string
|
||||||
|
# (note no terminating &)
|
||||||
|
sub ass_style_color {
|
||||||
|
my ($r, $g, $b, $a) = @_;
|
||||||
|
return(sprintf("&H%02X%02X%02X%02X", $a, $b, $g, $r));
|
||||||
|
}
|
||||||
|
|
||||||
|
# Tries its best to convert a string to 4 integers R,G,B,A.
|
||||||
|
# Returns them in that order if it succeeds, or undef if it can't do it.
|
||||||
|
# Useless in scalar context.
|
||||||
|
sub extract_color {
|
||||||
|
my $string = shift(@_);
|
||||||
|
|
||||||
|
# This here thingie is a switch statement. Magic!
|
||||||
|
given ( $string ) {
|
||||||
|
# try v4+ style (ABGR)
|
||||||
|
when ( /\&H([a-f0-9]{2})([a-f0-9]{2})([a-f0-9]{2})([a-f0-9]{2})/i ) {
|
||||||
|
return(hex($4), hex($3), hex($2), hex($1));
|
||||||
|
}
|
||||||
|
# color override? (BGR)
|
||||||
|
when ( /\&H([a-f0-9]{2})([a-f0-9]{2})([a-f0-9]{2})\&H/i ) {
|
||||||
|
return(0, hex($3), hex($2), hex($1));
|
||||||
|
}
|
||||||
|
# alpha override? (A)
|
||||||
|
# (bug: bogus results with \c&H<hex>& with the first four zeros omitted)
|
||||||
|
when ( /\&H([a-f0-9]{2})\&/i ) {
|
||||||
|
return(hex($1), 0, 0, 0);
|
||||||
|
}
|
||||||
|
# try HTML format for laffs (RGB)
|
||||||
|
when ( /\#([a-f0-9]{2})([a-f0-9]{2})?([a-f0-9]{2})?/i ) {
|
||||||
|
return(0, (hex($2) or 0), (hex($2) or 0), (hex($3) or 0));
|
||||||
|
}
|
||||||
|
default {
|
||||||
|
return(undef, undef, undef, undef);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# Given a a style color string, returns the alpha part formatted as override
|
||||||
|
sub alpha_from_style {
|
||||||
|
my $color_string = shift(@_);
|
||||||
|
my ($r, $g, $b, $a) = extract_color($color_string);
|
||||||
|
return(ass_alpha($a or 0));
|
||||||
|
}
|
||||||
|
|
||||||
|
# Given a style color string, returns the color part formatted as override
|
||||||
|
sub color_from_style {
|
||||||
|
my $color_string = shift(@_);
|
||||||
|
my ($r, $g, $b, $a) = extract_color($color_string);
|
||||||
|
return(ass_color(($r or 0), ($g or 0), ($b or 0)));
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
# Converts 3 integers H, S, V (hue, saturation, value) to R, G, B
|
||||||
|
sub HSV_to_RGB {
|
||||||
|
my ($H, $S, $V) = @_;
|
||||||
|
my ($r, $g, $b);
|
||||||
|
|
||||||
|
# saturation is zero, make grey
|
||||||
|
if ($S == 0) {
|
||||||
|
$r = $V * 255;
|
||||||
|
$r = clamp($r, 0, 255);
|
||||||
|
($g, $b) = ($r, $r);
|
||||||
|
}
|
||||||
|
# else calculate color
|
||||||
|
else {
|
||||||
|
# calculate subvalues
|
||||||
|
$H = $H % 360; # put $h in range [0,360]
|
||||||
|
my $Hi = POSIX::floor($H/60);
|
||||||
|
my $f = $H/60 - $Hi;
|
||||||
|
my $p = $V * (1 - $S);
|
||||||
|
my $q = $V * (1 - $f * $S);
|
||||||
|
my $t = $V * (1 - (1 - $f) * $S);
|
||||||
|
|
||||||
|
# do math based on hue index
|
||||||
|
if ($Hi == 0) { $r = $V*255; $g = $t*255; $b = $p*255; }
|
||||||
|
elsif ($Hi == 1) { $r = $q*255; $g = $V*255; $b = $p*255; }
|
||||||
|
elsif ($Hi == 2) { $r = $p*255; $g = $V*255; $b = $t*255; }
|
||||||
|
elsif ($Hi == 3) { $r = $p*255; $g = $q*255; $b = $V*255; }
|
||||||
|
elsif ($Hi == 4) { $r = $t*255; $g = $p*255; $b = $V*255; }
|
||||||
|
elsif ($Hi == 5) { $r = $V*255; $g = $p*255; $b = $q*255; }
|
||||||
|
# TODO: replace this with Aegisub::Script::debug_out() or whatever it is
|
||||||
|
else { warn("HSV_to_RGB: Hi got an unexpected value: $Hi"); }
|
||||||
|
}
|
||||||
|
|
||||||
|
$r = POSIX::floor($r);
|
||||||
|
$g = POSIX::floor($g);
|
||||||
|
$b = POSIX::floor($b);
|
||||||
|
return($r, $g, $b);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
# Converts 3 integers H, S, L (hue, saturation, luminance) to R, G, B
|
||||||
|
# Routine is best performed to "The HSL Song" by Diablo-D3 and the #darkhold idlers.
|
||||||
|
# The lyrics are as follows:
|
||||||
|
# I see a little silluetto of a man
|
||||||
|
# It's in color, its in color, can you convert to HSL?
|
||||||
|
# Cyan, yellow and magenta, very very outdated now
|
||||||
|
# Alvy Smith, Alvy Smith, Alvy Smith, Alvy Smith, Fiigaarrooo
|
||||||
|
# I'm just a poor boy, stuck with RGB
|
||||||
|
# (He's just a poor boy, from a poor colorspace, spare him his eyes from this monstrosity)
|
||||||
|
#
|
||||||
|
# Easy come, easy go, will you let me HSL?
|
||||||
|
# (No! We will not let you HSL!)
|
||||||
|
# Let him HSL!
|
||||||
|
# (No! We will not let you HSL!)
|
||||||
|
# Let him HSL!
|
||||||
|
# (No! We will not let you HSL!)
|
||||||
|
# Let me HSL!
|
||||||
|
# (Will not HSL!)
|
||||||
|
# Let me HSL!
|
||||||
|
# (Will not HSL!)
|
||||||
|
# Let me HSL! Let me HSL!
|
||||||
|
# (Never never never never never!)
|
||||||
|
# Let me HHHHHSSSSSLLLLL!
|
||||||
|
# (No no no no no no no!)
|
||||||
|
#
|
||||||
|
# [70's rock/bad humour segment ends here. We now return to your regularily scheduled Perl hacking...]
|
||||||
|
sub HSL_to_RGB {
|
||||||
|
my ($H, $S, $L) = @_;
|
||||||
|
my ($r, $g, $b, $Q);
|
||||||
|
|
||||||
|
# make sure input is in range
|
||||||
|
$H = $H % 360;
|
||||||
|
$S = clamp($S, 0, 1);
|
||||||
|
$L = clamp($L, 0, 1);
|
||||||
|
|
||||||
|
# simple case if saturation is 0, all grey
|
||||||
|
if ($S == 0) {
|
||||||
|
($r, $g, $b) = ($L, $L, $L);
|
||||||
|
}
|
||||||
|
# more common case, saturated color
|
||||||
|
else {
|
||||||
|
if ($L < 0.5) { $Q = $L * (1 + $S); }
|
||||||
|
else { $Q = $L + $S - ($L * $S); }
|
||||||
|
|
||||||
|
my $P = 2 * $L - $Q;
|
||||||
|
my $Hk = $H / 360;
|
||||||
|
|
||||||
|
my ($Tr, $Tg, $Tb);
|
||||||
|
$Tg = $Hk;
|
||||||
|
if ($Hk < 1/3) { $Tr = $Hk + 1/3; $Tb = $Hk + 2/3; }
|
||||||
|
elsif ($Hk > 2/3) { $Tr = $Hk - 2/3; $Tb = $Hk - 1/3; }
|
||||||
|
else { $Tr = $Hk + 1/3; $Tb = $Hk - 1/3; }
|
||||||
|
|
||||||
|
# anonymous subroutine required for closure reasons
|
||||||
|
my $get_component = sub {
|
||||||
|
my $T = shift(@_);
|
||||||
|
if ($T < 1/6) { return($P + (($Q - $P) * 6 * $T)) }
|
||||||
|
elsif (1/6 <= $T and $T < 1/2) { return($Q) }
|
||||||
|
elsif (1/2 <= $T and $T < 2/3) { return($P + (($Q - $P) * (2/3 - $T) * 6)) }
|
||||||
|
else { return($P) }
|
||||||
|
};
|
||||||
|
|
||||||
|
$r = $get_component->($Tr);
|
||||||
|
$g = $get_component->($Tg);
|
||||||
|
$b = $get_component->($Tb);
|
||||||
|
}
|
||||||
|
|
||||||
|
return($r, $g, $b);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
# Removes whitespace at the start and end of a string
|
||||||
|
# (will anyone ever use this in a perl program?)
|
||||||
|
sub string_trim {
|
||||||
|
my $string = shift(@_);
|
||||||
|
$string =~ s!^\s*(.+?)\s*$!$1!;
|
||||||
|
return($string);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
# Clamp a numeric value to a range
|
||||||
|
sub clamp {
|
||||||
|
my ($val, $min, $max) = @_;
|
||||||
|
if ($val < $min) { return($min) }
|
||||||
|
elsif ($val > $max) { return($max) }
|
||||||
|
else { return($val) }
|
||||||
|
}
|
||||||
|
|
||||||
|
# interpolate between two numbers
|
||||||
|
sub interpolate {
|
||||||
|
my ($pct, $min, $max) = @_;
|
||||||
|
if ($pct <= 0) { return($min) }
|
||||||
|
elsif ($pct >= 1) { return($max) }
|
||||||
|
else { return($pct * ($max - $min) + $min) }
|
||||||
|
}
|
||||||
|
|
||||||
|
# interpolate between two color values (given as &HBBGGRR strings)
|
||||||
|
# returns string formatted with \c&H override format
|
||||||
|
sub interpolate_color {
|
||||||
|
my ($pct, $start, $end) = @_;
|
||||||
|
my ($r1, $g1, $b1) = extract_color($start);
|
||||||
|
my ($r2, $g2, $b2) = extract_color($end);
|
||||||
|
my ($r, $g, $b) =
|
||||||
|
(interpolate($pct, $r1, $r2), interpolate($pct, $g1, $g2), interpolate($pct, $b1, $b2));
|
||||||
|
return(ass_color($r, $g, $b));
|
||||||
|
}
|
||||||
|
|
||||||
|
# interpolate between two alpha values (given as either override or part of style color strings)
|
||||||
|
# returns string formatted with \c&H override format
|
||||||
|
sub interpolate_alpha {
|
||||||
|
my ($pct, $start, $end) = @_;
|
||||||
|
my ($r1, $g1, $b1, $a1) = extract_color($start);
|
||||||
|
my ($r2, $g2, $b2, $a2) = extract_color($end);
|
||||||
|
return(ass_alpha(interpolate($pct, $a1, $a2)));
|
||||||
|
}
|
||||||
Loading…
Reference in a new issue