SEXP do_hsv(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP c, h, s, v, gm, a;
double hh, ss, vv, gg, aa, r, g, b;
int i, max, nh, ns, nv, ng, na;
checkArity(op, args);
PROTECT(h = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(s = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(v = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(gm = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args),REALSXP)); args = CDR(args);
nh = LENGTH(h);
ns = LENGTH(s);
nv = LENGTH(v);
ng = LENGTH(gm);
na = LENGTH(a);
if (nh <= 0 || ns <= 0 || nv <= 0 || ng <= 0 || na <= 0) {
UNPROTECT(5);
return(allocVector(STRSXP, 0));
}
max = nh;
if (max < ns) max = ns;
if (max < nv) max = nv;
if (max < ng) max = ng;
if (max < na) max = na;
PROTECT(c = allocVector(STRSXP, max));
if(max == 0) return(c);
for (i = 0; i < max; i++) {
hh = REAL(h)[i % nh];
ss = REAL(s)[i % ns];
vv = REAL(v)[i % nv];
gg = REAL(gm)[i % ng];
aa = REAL(a)[i % na];
if (hh < 0 || hh > 1 || ss < 0 || ss > 1 || vv < 0 || vv > 1 ||
aa < 0 || aa > 1)
errorcall(call, _("invalid HSV color"));
hsv2rgb(hh, ss, vv, &r, &g, &b);
r = pow(r, gg);
g = pow(g, gg);
b = pow(b, gg);
SET_STRING_ELT(c, i, mkChar(RGBA2rgb(ScaleColor(r),
ScaleColor(g),
ScaleColor(b),
ScaleAlpha(aa))));
}
UNPROTECT(6);
return c;
}
SEXP do_hcl(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP h, c, l, a, ans;
double H, C, L, A, r, g, b;
int nh, nc, nl, na, max, i;
int ir, ig, ib;
int fixup;
checkArity(op, args);
PROTECT(h = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(c = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(l = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args),REALSXP)); args = CDR(args);
fixup = asLogical(CAR(args));
nh = LENGTH(h);
nc = LENGTH(c);
nl = LENGTH(l);
na = LENGTH(a);
if (nh <= 0 || nc <= 0 || nl <= 0 || na <= 0) {
UNPROTECT(4);
return(allocVector(STRSXP, 0));
}
max = nh;
if (max < nc) max = nc;
if (max < nl) max = nl;
if (max < na) max = na;
PROTECT(ans = allocVector(STRSXP, max));
for (i = 0; i < max; i++) {
H = REAL(h)[i % nh];
C = REAL(c)[i % nc];
L = REAL(l)[i % nl];
A = REAL(a)[i % na];
if (!finite(A)) A = 1;
if (L < 0 || L > WHITE_Y || C < 0 || A < 0 || A > 1)
errorcall(call, _("invalid hcl color"));
hcl2rgb(H, C, L, &r, &g, &b);
ir = 255 * r + .5;
ig = 255 * g + .5;
ib = 255 * b + .5;
if (FixupColor(&ir, &ig, &ib) && !fixup)
SET_STRING_ELT(ans, i, NA_STRING);
else
SET_STRING_ELT(ans, i, mkChar(RGBA2rgb(ir, ig, ib,
ScaleAlpha(A))));
}
UNPROTECT(5);
return ans;
}
SEXP attribute_hidden do_hsv(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP c, h, s, v, a;
double hh, ss, vv, aa, r=0., g=0., b=0.; /* -Wall */
int i, max, nh, ns, nv, na;
checkArity(op, args);
PROTECT(h = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(s = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(v = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args),REALSXP)); args = CDR(args);
nh = LENGTH(h);
ns = LENGTH(s);
nv = LENGTH(v);
na = LENGTH(a);
if (nh <= 0 || ns <= 0 || nv <= 0 || na <= 0) {
UNPROTECT(4);
return(allocVector(STRSXP, 0));
}
max = nh;
if (max < ns) max = ns;
if (max < nv) max = nv;
if (max < na) max = na;
PROTECT(c = allocVector(STRSXP, max));
if(max == 0) return(c);
for (i = 0; i < max; i++) {
hh = REAL(h)[i % nh];
ss = REAL(s)[i % ns];
vv = REAL(v)[i % nv];
aa = REAL(a)[i % na];
if (hh < 0 || hh > 1 || ss < 0 || ss > 1 || vv < 0 || vv > 1 ||
aa < 0 || aa > 1)
error(_("invalid hsv color"));
hsv2rgb(hh, ss, vv, &r, &g, &b);
SET_STRING_ELT(c, i, mkChar(RGBA2rgb(ScaleColor(r),
ScaleColor(g),
ScaleColor(b),
ScaleAlpha(aa))));
}
UNPROTECT(5);
return c;
}