bug#28400: 26.0.50; lcms2 bindings

[Mark Oteiza <mvoteiza@udel.edu>]

On 12/09/17 at 06:53pm, Eli Zaretskii wrote:
> > Date: Mon, 11 Sep 2017 19:10:06 -0400
> > From: Mark Oteiza <mvoteiza@udel.edu>
> > Cc: 28400@debbugs.gnu.org
> >
> > +  k = 1.0f / (1.0f + (5.0f * vc.La));
> 
> Any reason why you use float constants, as opposed to double?

Mistake, thanks.

> > +  FL = pow(k, 4) * vc.La +
> > +    0.1f * pow(1 - pow(k, 4), 2) * pow(5.0f * vc.La, 1.0f / 3.0f);
> > +  Mp1 = 43.86f * log(1.0f + 0.0228f * (jch1.C * pow(FL, 0.25)));
> > +  Mp2 = 43.86f * log(1.0f + 0.0228f * (jch2.C * pow(FL, 0.25)));
> > +  Jp1 = 1.7f * jch1.J / (1.0f + (0.007f * jch1.J));
> > +  Jp2 = 1.7f * jch2.J / (1.0f + (0.007f * 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(pow(Jp2 - Jp1, 2) +
> > +                         pow(ap2 - ap1, 2) +
> > +                         pow(bp2 - bp1, 2)));
> 
> <snip>
> 
> So I'd replace:
> 
>    pow (SOMETHING, 2)             with SOMETHING*SOMETHING
>    pow (SOMETHING, 1./3.)         with cubrt (SOMETHING)
>    pow (k, 4)                     with k * k * k * k
>    pow (FL, 0.25)                 with sqrt (sqrt (FL))
> 
> etc.
> 
> Also, a nit: we leave a blank between the function name and the
> following left paren.
> 
> I think this will also need a NEWS entry, under "Installation
> Changes".

Thanks for all the comments, I've implemented them all, I think.

 configure.ac    |  19 ++++++
 etc/NEWS        |   5 ++
 src/Makefile.in |   6 +-
 src/emacs.c     |   4 ++
 src/lcms.c      | 180 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/lisp.h      |   5 ++
 src/xfaces.c    |  15 +++--
 7 files changed, 227 insertions(+), 7 deletions(-)

diff --git a/configure.ac b/configure.ac
index d294412dc4..df3931f938 100644
--- a/configure.ac
+++ b/configure.ac
@@ -3451,6 +3451,25 @@ AC_DEFUN
 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 03ef05b2a3..e97fb612a0 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
diff --git a/src/Makefile.in b/src/Makefile.in
index dde3f1d3fb..a98ad9c5eb 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -234,6 +234,8 @@ 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 =
 	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 =
    $(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 44f6285795..668711a5ab 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 0000000000..076073d5c7
--- /dev/null
+++ b/src/lcms.c
@@ -0,0 +1,180 @@
+/* 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 <http://www.gnu.org/licenses/>.  */
+
+#include <config.h>
+
+#ifdef HAVE_LCMS2
+
+#include <lcms2.h>
+#include <math.h>
+
+#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)));
+}
+
+\f
+/* 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 81f8d6a24b..19594e7830 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 86bb9b0b49..32a5bd5f60 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);
 }
 
 \f