From 5d4c539bd7e15e7fd0fb092276791b6287260a9a Mon Sep 17 00:00:00 2001 From: Mark Oteiza Date: Wed, 13 Sep 2017 10:27:37 -0400 Subject: [PATCH] Add lcms2 interface configure.ac: Add boilerplate for configuring and detecting liblcms2. etc/NEWS: Mention new configure option and color-distance change. src/Makefile.in: Add references to lcms.c and liblcms. src/emacs.c: Define lcms2 symbols. src/lcms.c: New file. src/lisp.h: Add declaration for lcms2. src/xfaces.c: Add optional METRIC argument. --- configure.ac | 19 +++++ etc/NEWS | 10 +++ src/Makefile.in | 6 +- src/emacs.c | 4 ++ src/lcms.c | 182 ++++++++++++++++++++++++++++++++++++++++++++++++ src/lisp.h | 5 ++ src/xfaces.c | 15 ++-- 7 files changed, 234 insertions(+), 7 deletions(-) create mode 100644 src/lcms.c diff --git a/configure.ac b/configure.ac index d294412dc4a..df3931f938f 100644 --- a/configure.ac +++ b/configure.ac @@ -3451,6 +3451,25 @@ if test "${with_jpeg}" != "no"; then fi AC_SUBST(LIBJPEG) +HAVE_LCMS2=no +LIBLCMS2= +if test "${with_lcms2}" != "no"; then + OLIBS=$LIBS + AC_SEARCH_LIBS([cmsCreateTransform], [lcms2], [HAVE_LCMS2=yes]) + LIBS=$OLIBS + case $ac_cv_search_cmsCreateTransform in + -*) LIBLCMS2=$ac_cv_search_cmsCreateTransform ;; + esac +fi +if test "${HAVE_LCMS2}" = "yes"; then + AC_DEFINE([HAVE_LCMS2], 1, [Define to 1 if you have the lcms2 library (-llcms2).]) + ### ??? + if test "${opsys}" = "mingw32"; then + LIBLCMS2= + fi +fi +AC_SUBST(LIBLCMS2) + HAVE_ZLIB=no LIBZ= if test "${with_zlib}" != "no"; then diff --git a/etc/NEWS b/etc/NEWS index 94673697090..b49cf70e2a7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -69,6 +69,11 @@ Deterministic builds omit the build date from the output of the following variables nil: 'emacs-build-system', 'emacs-build-time', 'erc-emacs-build-time'. +** New configure option '--with-lcms2' attempts to build an Emacs +linked to Little CMS, exposing color management functions in Lisp. +Implemented functions include the color metrics 'lcms-cie-de2000' and +'lcms-cam02-ucs'. + ** The configure option '--with-gameuser' now defaults to 'no', as this appears to be the most common configuration in practice. When it is 'no', the shared game directory and the auxiliary program @@ -1588,6 +1593,11 @@ function keeps on returning the line number taking potential narrowing into account. If this parameter is non-nil, the function ignores narrowing and returns the absolute line number. +--- +** The function 'color-distance' now takes a second optional argument +'metric'. When non-nil, it should be a function of two arguments that +accepts two colors and returns a number. + ** Changes in Frame and Window Handling +++ diff --git a/src/Makefile.in b/src/Makefile.in index dde3f1d3fb4..a98ad9c5ebd 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -234,6 +234,8 @@ LIBXML2_CFLAGS = @LIBXML2_CFLAGS@ GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@ +LIBLCMS2 = @LIBLCMS2@ + LIBZ = @LIBZ@ ## system-specific libs for dynamic modules, else empty @@ -389,7 +391,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ syntax.o $(UNEXEC_OBJ) bytecode.o \ process.o gnutls.o callproc.o \ region-cache.o sound.o atimer.o \ - doprnt.o intervals.o textprop.o composite.o xml.o $(NOTIFY_OBJ) \ + doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \ $(XWIDGETS_OBJ) \ profiler.o decompress.o \ thread.o systhread.o \ @@ -490,7 +492,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(LIBXML2_LIBS) $(LIBGPM) $(LIBS_SYSTEM) $(CAIRO_LIBS) \ $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ - $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) \ + $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) ## FORCE it so that admin/unidata can decide whether these files diff --git a/src/emacs.c b/src/emacs.c index 44f6285795a..668711a5ab9 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1546,6 +1546,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_xml (); #endif +#ifdef HAVE_LCMS2 + syms_of_lcms2 (); +#endif + #ifdef HAVE_ZLIB syms_of_decompress (); #endif diff --git a/src/lcms.c b/src/lcms.c new file mode 100644 index 00000000000..120ef769810 --- /dev/null +++ b/src/lcms.c @@ -0,0 +1,182 @@ +/* Interface to Little CMS + Copyright (C) 2017 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#ifdef HAVE_LCMS2 + +#include +#include + +#include "lisp.h" + +static bool +parse_lab_list (Lisp_Object lab_list, cmsCIELab *color) +{ +#define PARSE_LAB_LIST_FIELD(field) \ + if (CONSP (lab_list) && NUMBERP (XCAR (lab_list))) \ + { \ + color->field = XFLOATINT (XCAR (lab_list)); \ + lab_list = XCDR (lab_list); \ + } \ + else \ + return false; + + PARSE_LAB_LIST_FIELD (L); + PARSE_LAB_LIST_FIELD (a); + PARSE_LAB_LIST_FIELD (b); + + return true; +} + +/* http://www.ece.rochester.edu/~gsharma/ciede2000/ciede2000noteCRNA.pdf> */ + +DEFUN ("lcms-cie-de2000", Flcms_cie_de2000, Slcms_cie_de2000, 2, 5, 0, + doc: /* Compute CIEDE2000 metric distance between COLOR1 and COLOR2. +Each color is a list of L*a*b* coordinates, where the L* channel ranges from +0 to 100, and the a* and b* channels range from -128 to 128. +Optional arguments KL, KC, KH are weighting parameters for lightness, +chroma, and hue, respectively. The parameters each default to 1. */) + (Lisp_Object color1, Lisp_Object color2, + Lisp_Object kL, Lisp_Object kC, Lisp_Object kH) +{ + cmsCIELab Lab1, Lab2; + cmsFloat64Number Kl, Kc, Kh; + + if (!(CONSP (color1) && parse_lab_list (color1, &Lab1))) + signal_error ("Invalid color", color1); + if (!(CONSP (color2) && parse_lab_list (color2, &Lab2))) + signal_error ("Invalid color", color1); + if (NILP (kL)) + Kl = 1.0f; + else if (!(NUMBERP (kL) && (Kl = XFLOATINT(kL)))) + wrong_type_argument(Qnumberp, kL); + if (NILP (kC)) + Kc = 1.0f; + else if (!(NUMBERP (kC) && (Kc = XFLOATINT(kC)))) + wrong_type_argument(Qnumberp, kC); + if (NILP (kL)) + Kh = 1.0f; + else if (!(NUMBERP (kH) && (Kh = XFLOATINT(kH)))) + wrong_type_argument(Qnumberp, kH); + + return make_float (cmsCIE2000DeltaE (&Lab1, &Lab2, Kl, Kc, Kh)); +} + +/* FIXME: code duplication */ + +static bool +parse_xyz_list (Lisp_Object xyz_list, cmsCIEXYZ *color) +{ +#define PARSE_XYZ_LIST_FIELD(field) \ + if (CONSP (xyz_list) && NUMBERP (XCAR (xyz_list))) \ + { \ + color->field = 100.0 * XFLOATINT (XCAR (xyz_list)); \ + xyz_list = XCDR (xyz_list); \ + } \ + else \ + return false; + + PARSE_XYZ_LIST_FIELD (X); + PARSE_XYZ_LIST_FIELD (Y); + PARSE_XYZ_LIST_FIELD (Z); + + return true; +} + +DEFUN ("lcms-cam02-ucs", Flcms_cam02_ucs, Slcms_cam02_ucs, 2, 3, 0, + doc: /* Compute CAM02-UCS metric distance between COLOR1 and COLOR2. +Each color is a list of XYZ coordinates, with Y scaled to unity. +Optional argument is the XYZ white point, which defaults to illuminant D65. */) + (Lisp_Object color1, Lisp_Object color2, Lisp_Object whitepoint) +{ + cmsViewingConditions vc; + cmsJCh jch1, jch2; + cmsHANDLE h1, h2; + cmsCIEXYZ xyz1, xyz2, xyzw; + double Jp1, ap1, bp1, Jp2, ap2, bp2; + double Mp1, Mp2, FL, k, k4; + + if (!(CONSP (color1) && parse_xyz_list (color1, &xyz1))) + signal_error ("Invalid color", color1); + if (!(CONSP (color2) && parse_xyz_list (color2, &xyz2))) + signal_error ("Invalid color", color1); + if (NILP (whitepoint)) + { + xyzw.X = 95.047; + xyzw.Y = 100.0; + xyzw.Z = 108.883; + } + else if (!(CONSP (whitepoint) && parse_xyz_list(whitepoint, &xyzw))) + signal_error("Invalid white point", whitepoint); + + vc.whitePoint.X = xyzw.X; + vc.whitePoint.Y = xyzw.Y; + vc.whitePoint.Z = xyzw.Z; + vc.Yb = 20; + vc.La = 100; + vc.surround = AVG_SURROUND; + vc.D_value = 1.0; + + h1 = cmsCIECAM02Init (0, &vc); + h2 = cmsCIECAM02Init (0, &vc); + cmsCIECAM02Forward (h1, &xyz1, &jch1); + cmsCIECAM02Forward (h2, &xyz2, &jch2); + cmsCIECAM02Done (h1); + cmsCIECAM02Done (h2); + + /* Now have colors in JCh, need to calculate J'a'b' + + M = C * F_L^0.25 + J' = 1.7 J / (1 + 0.007 J) + M' = 43.86 ln(1 + 0.0228 M) + a' = M' cos(h) + b' = M' sin(h) + + where + + F_L = 0.2 k^4 (5 L_A) + 0.1 (1 - k^4)^2 (5 L_A)^(1/3), + k = 1/(5 L_A + 1) + */ + k = 1.0 / (1.0 + (5.0 * vc.La)); + k4 = k * k * k * k; + FL = vc.La * k4 + 0.1 * (1 - k4) * (1 - k4) * cbrt (5.0 * vc.La); + Mp1 = 43.86 * log (1.0 + 0.0228 * (jch1.C * sqrt (sqrt (FL)))); + Mp2 = 43.86 * log (1.0 + 0.0228 * (jch2.C * sqrt (sqrt (FL)))); + Jp1 = 1.7 * jch1.J / (1.0 + (0.007 * jch1.J)); + Jp2 = 1.7 * jch2.J / (1.0 + (0.007 * jch2.J)); + ap1 = Mp1 * cos (jch1.h); + ap2 = Mp2 * cos (jch2.h); + bp1 = Mp1 * sin (jch1.h); + bp2 = Mp2 * sin (jch2.h); + + return make_float (sqrt ((Jp2 - Jp1) * (Jp2 - Jp1) + + (ap2 - ap1) * (ap2 - ap1) + + (bp2 - bp1) * (bp2 - bp1))); +} + + +/* Initialization */ +void +syms_of_lcms2 (void) +{ + defsubr (&Slcms_cie_de2000); + defsubr (&Slcms_cam02_ucs); +} + +#endif /* HAVE_LCMS2 */ diff --git a/src/lisp.h b/src/lisp.h index 81f8d6a24b5..19594e7830d 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4396,6 +4396,11 @@ extern void syms_of_xml (void); extern void xml_cleanup_parser (void); #endif +#ifdef HAVE_LCMS2 +/* Defined in lcms.c. */ +extern void syms_of_lcms2 (void); +#endif + #ifdef HAVE_ZLIB /* Defined in decompress.c. */ extern void syms_of_decompress (void); diff --git a/src/xfaces.c b/src/xfaces.c index 86bb9b0b496..32a5bd5f60b 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -4088,12 +4088,14 @@ color_distance (XColor *x, XColor *y) } -DEFUN ("color-distance", Fcolor_distance, Scolor_distance, 2, 3, 0, +DEFUN ("color-distance", Fcolor_distance, Scolor_distance, 2, 4, 0, doc: /* Return an integer distance between COLOR1 and COLOR2 on FRAME. COLOR1 and COLOR2 may be either strings containing the color name, -or lists of the form (RED GREEN BLUE). -If FRAME is unspecified or nil, the current frame is used. */) - (Lisp_Object color1, Lisp_Object color2, Lisp_Object frame) +or lists of the form (RED GREEN BLUE), each in the range 0 to 65535 inclusive. +If FRAME is unspecified or nil, the current frame is used. +If METRIC is unspecified or nil, a modified L*u*v* metric is used. */) + (Lisp_Object color1, Lisp_Object color2, Lisp_Object frame, + Lisp_Object metric) { struct frame *f = decode_live_frame (frame); XColor cdef1, cdef2; @@ -4107,7 +4109,10 @@ If FRAME is unspecified or nil, the current frame is used. */) && defined_color (f, SSDATA (color2), &cdef2, false))) signal_error ("Invalid color", color2); - return make_number (color_distance (&cdef1, &cdef2)); + if (NILP (metric)) + return make_number (color_distance (&cdef1, &cdef2)); + else + return call2 (metric, color1, color2); } -- 2.39.5