bug#28400: 26.0.50; lcms2 bindings

bug#28400: 26.0.50; lcms2 bindings

[Mark Oteiza]

[-- Attachment #1: Type: text/plain, Size: 738 bytes --]


Wishlist.

Hi,

Some time ago I wrote some integration with lcms2 in the interest of
replacing tty-color-approximate, color-distance, etc. with superior
(more perceptually uniform) color metrics.  This would presumably
improve Emacs' color picking on smaller color palettes (e.g. 256 color
term) and potentially provide access to many useful color-related
functions in Lisp---not to discount color.el.

I am not sure how this might be added--perhaps in its own .c file and
exposing a feature?

Attached is a patch splicing lcms2 CIE DE2000 into color-distance.
I don't know what x_alloc_nearest_color_1 does but I apparently patched
that as well.

Also attached is a small module with CIE DE2000 and CAM02-UCS color
distance functions.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: lcms2.patch --]
[-- Type: text/x-diff, Size: 7233 bytes --]

diff --git a/configure.ac b/configure.ac
index 5aaf006c54..e85c1e4d97 100644
--- a/configure.ac
+++ b/configure.ac
@@ -3151,7 +3151,7 @@ AC_DEFUN
 	OLD_LIBS="$LIBS"
 	CPPFLAGS="$CPPFLAGS $XFT_CFLAGS"
 	CFLAGS="$CFLAGS $XFT_CFLAGS"
-	XFT_LIBS="-lXrender $XFT_LIBS"
+	XFT_LIBS="-lXrender $XFT_LIBS -llcms2"
 	LIBS="$XFT_LIBS $LIBS"
 	AC_CHECK_HEADER(X11/Xft/Xft.h,
 	  AC_CHECK_LIB(Xft, XftFontOpen, HAVE_XFT=yes, , $XFT_LIBS) , ,
diff --git a/src/xfaces.c b/src/xfaces.c
index accb98bf4c..604404aafd 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -205,6 +205,8 @@ along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 #include <sys/types.h>
 #include <sys/stat.h>
 
+#include <lcms2.h>
+
 #include "lisp.h"
 #include "character.h"
 #include "frame.h"
@@ -352,7 +354,7 @@ static struct face_cache *make_face_cache (struct frame *);
 static void free_face_cache (struct face_cache *);
 static bool merge_face_ref (struct frame *, Lisp_Object, Lisp_Object *,
 			    bool, struct named_merge_point *);
-static int color_distance (XColor *x, XColor *y);
+static double color_distance (XColor *x, XColor *y);
 
 #ifdef HAVE_WINDOW_SYSTEM
 static void set_font_frame_param (Lisp_Object, Lisp_Object);
@@ -4063,35 +4065,41 @@ prepare_face_for_display (struct frame *f, struct face *face)
 
 /* Returns the `distance' between the colors X and Y.  */
 
-static int
+static double
 color_distance (XColor *x, XColor *y)
 {
-  /* This formula is from a paper titled `Colour metric' by Thiadmer Riemersma.
-     Quoting from that paper:
-
-	 This formula has results that are very close to L*u*v* (with the
-	 modified lightness curve) and, more importantly, it is a more even
-	 algorithm: it does not have a range of colors where it suddenly
-	 gives far from optimal results.
-
-     See <http://www.compuphase.com/cmetric.htm> for more info.  */
-
-  long r = (x->red   - y->red)   >> 8;
-  long g = (x->green - y->green) >> 8;
-  long b = (x->blue  - y->blue)  >> 8;
-  long r_mean = (x->red + y->red) >> 9;
-
-  return
-    (((512 + r_mean) * r * r) >> 8)
-    + 4 * g * g
-    + (((767 - r_mean) * b * b) >> 8);
+  /* http://www.ece.rochester.edu/~gsharma/ciede2000/ciede2000noteCRNA.pdf> */
+  cmsHPROFILE profile_in, profile_out;
+  cmsHTRANSFORM transform;
+  cmsCIELab Labx, Laby;
+  cmsUInt16Number rgbx[3], rgby[3];
+  cmsFloat64Number delta;
+
+  profile_in = cmsCreate_sRGBProfile();
+  profile_out = cmsCreateLab4Profile(NULL);
+  transform = cmsCreateTransform(profile_in, TYPE_RGB_16,
+                                 profile_out, TYPE_Lab_DBL,
+                                 INTENT_PERCEPTUAL, 0);
+  cmsCloseProfile(profile_in);
+  cmsCloseProfile(profile_out);
+  rgbx[0] = x->red;
+  rgbx[1] = x->green;
+  rgbx[2] = x->blue;
+  rgby[0] = y->red;
+  rgby[1] = y->green;
+  rgby[2] = y->blue;
+  cmsDoTransform(transform, rgbx, &Labx, 1);
+  cmsDoTransform(transform, rgby, &Laby, 1);
+  cmsDeleteTransform(transform);
+  delta = cmsCIE2000DeltaE(&Labx, &Laby, 1.0, 1.0, 1.0);
+  return delta;
 }
 
 
 DEFUN ("color-distance", Fcolor_distance, Scolor_distance, 2, 3, 0,
-       doc: /* Return an integer distance between COLOR1 and COLOR2 on FRAME.
+       doc: /* Return a float 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).
+or lists of the form (RED GREEN BLUE), in the range 0 to 65355 inclusive.
 If FRAME is unspecified or nil, the current frame is used.  */)
   (Lisp_Object color1, Lisp_Object color2, Lisp_Object frame)
 {
@@ -4107,7 +4115,7 @@ 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));
+  return make_float (color_distance (&cdef1, &cdef2));
 }
 
 \f
@@ -4627,9 +4635,9 @@ DEFUN ("face-attributes-as-vector", Fface_attributes_as_vector,
 
 /* If the distance (as returned by color_distance) between two colors is
    less than this, then they are considered the same, for determining
-   whether a color is supported or not.  The range of values is 0-65535.  */
+   whether a color is supported or not.  The range of values is 0-100.  */
 
-#define TTY_SAME_COLOR_THRESHOLD  10000
+#define TTY_SAME_COLOR_THRESHOLD  2.3
 
 #ifdef HAVE_WINDOW_SYSTEM
 
@@ -4897,7 +4905,7 @@ tty_supports_face_attributes_p (struct frame *f,
      distance between the standard foreground and background.  */
   if (STRINGP (fg) && STRINGP (bg))
     {
-      int delta_delta
+      double delta_delta
 	= (color_distance (&fg_std_color, &bg_std_color)
 	   - color_distance (&fg_tty_color, &bg_tty_color));
       if (delta_delta > TTY_SAME_COLOR_THRESHOLD
diff --git a/src/xterm.c b/src/xterm.c
index bdc21e6de0..8cb203d418 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -27,6 +27,8 @@ along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
 #include <math.h>
 #endif
 
+#include <lcms2.h>
+
 #include "lisp.h"
 #include "blockinput.h"
 
@@ -2372,18 +2374,37 @@ x_alloc_nearest_color_1 (Display *dpy, Colormap cmap, XColor *color)
 	 a least-squares matching, which is what X uses for closest
 	 color matching with StaticColor visuals.  */
       int nearest, i;
-      int max_color_delta = 255;
-      int max_delta = 3 * max_color_delta;
-      int nearest_delta = max_delta + 1;
+      cmsFloat64Number max_color_delta = 100.0f;
+      cmsFloat64Number max_delta = 3 * max_color_delta;
+      cmsFloat64Number nearest_delta = max_delta + 1;
       int ncells;
       const XColor *cells = x_color_cells (dpy, &ncells);
-
+      cmsHPROFILE profile_in, profile_out;
+      cmsHTRANSFORM transform;
+      cmsCIELab Lab;
+      cmsUInt16Number rgb[3];
+
+      profile_in = cmsCreate_sRGBProfile();
+      profile_out = cmsCreateLab4Profile(NULL);
+      transform = cmsCreateTransform(profile_in, TYPE_RGB_16,
+                                     profile_out, TYPE_Lab_DBL,
+                                     INTENT_PERCEPTUAL, 0);
+      cmsCloseProfile(profile_in);
+      cmsCloseProfile(profile_out);
+      rgb[0] = color->red;
+      rgb[1] = color->green;
+      rgb[2] = color->blue;
+      cmsDoTransform(transform, rgb, &Lab, 1);
       for (nearest = i = 0; i < ncells; ++i)
 	{
-	  int dred   = (color->red   >> 8) - (cells[i].red   >> 8);
-	  int dgreen = (color->green >> 8) - (cells[i].green >> 8);
-	  int dblue  = (color->blue  >> 8) - (cells[i].blue  >> 8);
-	  int delta = dred * dred + dgreen * dgreen + dblue * dblue;
+          cmsCIELab Labi;
+          cmsUInt16Number rgbi[3];
+
+          rgbi[0] = cells[i].red;
+          rgbi[1] = cells[i].green;
+          rgbi[2] = cells[i].blue;
+          cmsDoTransform(transform, rgbi, &Labi, 1);
+          cmsFloat64Number delta = cmsCIE2000DeltaE(&Lab, &Labi, 1.0f, 1.0f, 1.0f);
 
 	  if (delta < nearest_delta)
 	    {
@@ -2391,7 +2412,7 @@ x_alloc_nearest_color_1 (Display *dpy, Colormap cmap, XColor *color)
 	      nearest_delta = delta;
 	    }
 	}
-
+      cmsDeleteTransform(transform);
       color->red   = cells[nearest].red;
       color->green = cells[nearest].green;
       color->blue  = cells[nearest].blue;

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: module --]
[-- Type: text/x-csrc, Size: 5291 bytes --]

/*
  Copyright (C) 2016 Mark Oteiza <mvoteiza@udel.edu>

  Author: Mark Oteiza <mvoteiza@udel.edu>
  Created: 01 March 2016

  This library is free software; you can redistribute it and/or
  modify it under the terms of the GNU Lesser General Public
  License version 2 as published by the Free Software Foundation.

  This library 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
  Lesser General Public License for more details.

  You should have received a copy of the GNU Lesser General Public
  License along with this library. If not, see
  <http://www.gnu.org/licenses/>.
*/

#include <stdio.h>
#include <stdlib.h>
#include <math.h>

#include <X11/Xlib.h>
#include <lcms2.h>

#include "emacs-module.h"

#define UNUSED __attribute__((unused))

int plugin_is_GPL_compatible;

static emacs_value Flcms2_ciede2000 (emacs_env *env, ptrdiff_t UNUSED argc,
                                     emacs_value argv[], void UNUSED *data) {
    emacs_value ret;
    double L1 = env->extract_float(env, argv[0]);
    double a1 = env->extract_float(env, argv[1]);
    double b1 = env->extract_float(env, argv[2]);
    double L2 = env->extract_float(env, argv[3]);
    double a2 = env->extract_float(env, argv[4]);
    double b2 = env->extract_float(env, argv[5]);
    double kL = env->extract_float(env, argv[6]);
    double kC = env->extract_float(env, argv[7]);
    double kH = env->extract_float(env, argv[8]);

    const cmsCIELab lab1 = { .L = L1, .a = a1, .b = b1 };
    const cmsCIELab lab2 = { .L = L2, .a = a2, .b = b2 };
    ret = env->make_float(env, cmsCIE2000DeltaE (&lab1, &lab2, kL, kC, kH));
    return ret;
}

static emacs_value Flcms2_ciecamde02 (emacs_env *env, ptrdiff_t UNUSED argc,
                                      emacs_value argv[], void UNUSED *data) {
    emacs_value ret;
    cmsViewingConditions vc;
    cmsJCh jch1, jch2;
    cmsHANDLE h1, h2;
    /* scale XYZ because emacs funs expect these correlates to be in
       the unit line segment [0,1] */
    double X1 = 100 * env->extract_float(env, argv[0]);
    double Y1 = 100 * env->extract_float(env, argv[1]);
    double Z1 = 100 * env->extract_float(env, argv[2]);
    double X2 = 100 * env->extract_float(env, argv[3]);
    double Y2 = 100 * env->extract_float(env, argv[4]);
    double Z2 = 100 * env->extract_float(env, argv[5]);
    /* printf("(%f, %f, %f) <-> (%f, %f, %f)\n", X1, Y1, Z1, X2, Y2, Z2); */
    double Mp1, Mp2, FL, k;
    double Jp1, ap1, bp1, Jp2, ap2, bp2;
    /* UCS coefficients */
    /* double KL = 0.77; */
    /* double c1 = 0.007; */
    /* double c2 = 0.0228; */

    vc.whitePoint.X = 95.047;
    vc.whitePoint.Y = 100.00;
    vc.whitePoint.Z = 108.883;
    vc.Yb = 20;
    vc.La = 100;
    vc.surround = AVG_SURROUND;
    vc.D_value = 1.0;

    h1 = cmsCIECAM02Init(0, &vc);
    h2 = cmsCIECAM02Init(0, &vc);
    const cmsCIEXYZ xyz1 = { .X = X1, .Y = Y1, .Z = Z1 };
    const cmsCIEXYZ xyz2 = { .X = X2, .Y = Y2, .Z = Z2 };

    cmsCIECAM02Forward(h1, &xyz1, &jch1);
    cmsCIECAM02Forward(h2, &xyz2, &jch2);

    cmsCIECAM02Done(h1);
    cmsCIECAM02Done(h2);
    /* Now have JCh, need to calculate Jab

       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));
    FL = pow(k, 4) * vc.La + 0.1 * pow(1 - pow(k, 4), 2) * pow(5 * vc.La, 1.0 / 3.0);
    Mp1 = 43.86 * log(1.0 + 0.0228 * (jch1.C * pow(FL, 0.25)));
    Mp2 = 43.86 * log(1.0 + 0.0228 * (jch2.C * pow(FL, 0.25)));
    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);
    ret = env->make_float(env, sqrt(pow(Jp2 - Jp1, 2.0) +
                                    pow(ap2 - ap1, 2.0) +
                                    pow(bp2 - bp1, 2.0)));
    return ret;
}

static void bind_function(emacs_env *env, const char *name, emacs_value Sfun) {
    emacs_value Qfset = env->intern(env, "fset");
    emacs_value Qsym = env->intern(env, name);
    emacs_value args[] = { Qsym, Sfun };

    env->funcall(env, Qfset, 2, args);
}

static void provide(emacs_env *env, const char *feature) {
    emacs_value Qfeat = env->intern(env, feature);
    emacs_value Qprovide = env->intern (env, "provide");
    emacs_value args[] = { Qfeat };

    env->funcall(env, Qprovide, 1, args);
}

int emacs_module_init(struct emacs_runtime *ert) {
    emacs_env *env = ert->get_environment(ert);

    bind_function(env, "lcms2-ciede2000-internal",
                  env->make_function(env, 9, 9, Flcms2_ciede2000,
                                     "Compute CIEDE2000 between two colors.\
\n(fn L1 A1 B1 L2 A2 B2 kL kC kH)", NULL));
    bind_function(env, "lcms2-ciecamde02-internal",
                  env->make_function(env, 6, 6, Flcms2_ciecamde02,
                                     "Compute CIECAM02 between two colors.\
\n(fn X1 Y1 Z1 X2 Y2 Z2)", NULL));
    provide(env, "lcms2");
    return EXIT_SUCCESS;
}

bug#28400: 26.0.50; lcms2 bindings

[Eli Zaretskii]

> From: Mark Oteiza <mvoteiza@udel.edu>
> Date: Sat, 09 Sep 2017 11:50:34 -0400
> 
> Some time ago I wrote some integration with lcms2 in the interest of
> replacing tty-color-approximate, color-distance, etc. with superior
> (more perceptually uniform) color metrics.  This would presumably
> improve Emacs' color picking on smaller color palettes (e.g. 256 color
> term) and potentially provide access to many useful color-related
> functions in Lisp---not to discount color.el.

Is it really so much better than what we have now to justify requiring
yet another library to build Emacs?  If it is, could you tell what are
the main advantages, or point to where those advantages are described?

Btw, 256 colors is not "small" by Emacs standards, because our color
approximation should (and does) work in 8-color terminals as well.

Thanks.

bug#28400: 26.0.50; lcms2 bindings

[Mark Oteiza]

On 09/09/17 at 08:37pm, Eli Zaretskii wrote:
>> From: Mark Oteiza <mvoteiza@udel.edu>
>> Date: Sat, 09 Sep 2017 11:50:34 -0400
>>
>> Some time ago I wrote some integration with lcms2 in the interest of
>> replacing tty-color-approximate, color-distance, etc. with superior
>> (more perceptually uniform) color metrics.  This would presumably
>> improve Emacs' color picking on smaller color palettes (e.g. 256 color
>> term) and potentially provide access to many useful color-related
>> functions in Lisp---not to discount color.el.
>
>Is it really so much better than what we have now to justify requiring
>yet another library to build Emacs?  If it is, could you tell what are
>the main advantages, or point to where those advantages are described?

It was just much easier for me to hack existing code than figure out adding
a new file and the configure.ac business.  It would be much more
sensible to offer it as an optional feature and expose color metrics as
optional arguments, e.g.

  (color-distance COLOR1 COLOR2 &optional FRAME METRIC)

where METRIC accepts two colors and returns a number.

>Btw, 256 colors is not "small" by Emacs standards, because our color
>approximation should (and does) work in 8-color terminals as well.

Yes, I should have used a different word than "small".  Approximations
for smaller palettes is easier because the differences between
individual members of the palette are much bigger.  The 256 color
palette (and larger) has many colors much closer to one another, and
calculating perceptual differences between colors that are close
requires a more sophisticated model.

For instance, take CIEDE2000
https://en.wikipedia.org/wiki/Color_difference#CIEDE2000
and compare it to the newer CAM02-UCS
http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.844.5693&rep=rep1&type=pdf
IIRC CAM02 is the de facto model for CMS.  I'm certain Windows uses it
for its CMS.

I like this talk about Matplotlib's new color map.  It explains the
differences between color spaces among other things
https://www.youtube.com/watch?v=xAoljeRJ3lU

bug#28400: 26.0.50; lcms2 bindings

[Eli Zaretskii]

> Date: Sun, 10 Sep 2017 18:04:22 -0400
> From: Mark Oteiza <mvoteiza@udel.edu>
> Cc: 28400@debbugs.gnu.org
> 
> >Is it really so much better than what we have now to justify requiring
> >yet another library to build Emacs?  If it is, could you tell what are
> >the main advantages, or point to where those advantages are described?
> 
> It was just much easier for me to hack existing code than figure out adding
> a new file and the configure.ac business.  It would be much more
> sensible to offer it as an optional feature and expose color metrics as
> optional arguments, e.g.
> 
>   (color-distance COLOR1 COLOR2 &optional FRAME METRIC)
> 
> where METRIC accepts two colors and returns a number.

Oh, I see.  But in that case, I think adding a new file and the
configure.ac business is actually quite easy.  Search configure.ac for
"libz", and you will see a typical example: it involves adding a new
"--with-FOO" option to configure, and then some pretty boilerplate
code to test whether some tell-tale header file is present, and tweak
the compilation/linking flags accordingly.  The new file then should
have all of its body wrapped in "#ifdef HAVE_FOO..#endif", with only
config.h outside of that condition and maybe some simple predicate to
test for the feature existence; see xml.c for a good example.  Then
add that new file to src/Makefile.in, and you are pretty much done.

As for color-distance, did you intend to replace or provide a better
alternative to similar functions in color.el?

> >Btw, 256 colors is not "small" by Emacs standards, because our color
> >approximation should (and does) work in 8-color terminals as well.
> 
> Yes, I should have used a different word than "small".  Approximations
> for smaller palettes is easier because the differences between
> individual members of the palette are much bigger.  The 256 color
> palette (and larger) has many colors much closer to one another, and
> calculating perceptual differences between colors that are close
> requires a more sophisticated model.

So you are saying that tty-colors.el is too simplistic for ncolors
around 256?  If so, perhaps this optional feature could provide
compatible alternatives to that?

Thanks.

bug#28400: 26.0.50; lcms2 bindings

[Mark Oteiza]

On 11/09/17 at 06:01pm, Eli Zaretskii wrote:
> > Date: Sun, 10 Sep 2017 18:04:22 -0400
> > From: Mark Oteiza <mvoteiza@udel.edu>
> > Cc: 28400@debbugs.gnu.org
> > 
> > >Is it really so much better than what we have now to justify requiring
> > >yet another library to build Emacs?  If it is, could you tell what are
> > >the main advantages, or point to where those advantages are described?
> > 
> > It was just much easier for me to hack existing code than figure out adding
> > a new file and the configure.ac business.  It would be much more
> > sensible to offer it as an optional feature and expose color metrics as
> > optional arguments, e.g.
> > 
> >   (color-distance COLOR1 COLOR2 &optional FRAME METRIC)
> > 
> > where METRIC accepts two colors and returns a number.
> 
> Oh, I see.  But in that case, I think adding a new file and the
> configure.ac business is actually quite easy.  Search configure.ac for
> "libz", and you will see a typical example: it involves adding a new
> "--with-FOO" option to configure, and then some pretty boilerplate
> code to test whether some tell-tale header file is present, and tweak
> the compilation/linking flags accordingly.  The new file then should
> have all of its body wrapped in "#ifdef HAVE_FOO..#endif", with only
> config.h outside of that condition and maybe some simple predicate to
> test for the feature existence; see xml.c for a good example.  Then
> add that new file to src/Makefile.in, and you are pretty much done.

Thanks, I'll attempt that.

> As for color-distance, did you intend to replace or provide a better
> alternative to similar functions in color.el?

That is a good question.  I've thought about it, but don't have a good
answer.  lcms2 could certainly replace some of the things in color.el,
but if it's an optional feature I guess there are a number of ways to
handle it.  If we include lcms2.c providing its own 'cms or 'lcms2
feature, I guess featurep'ing things wouldn't be so bad.

> > >Btw, 256 colors is not "small" by Emacs standards, because our color
> > >approximation should (and does) work in 8-color terminals as well.
> > 
> > Yes, I should have used a different word than "small".  Approximations
> > for smaller palettes is easier because the differences between
> > individual members of the palette are much bigger.  The 256 color
> > palette (and larger) has many colors much closer to one another, and
> > calculating perceptual differences between colors that are close
> > requires a more sophisticated model.
> 
> So you are saying that tty-colors.el is too simplistic for ncolors
> around 256?

It will get some interesting results. For instance, asking Emacs for
#3d3535 (dark, slightly reddish grey) in a 256 color term will yield
#5f005f (color-53, a strong purple) instead of color-235 or color-236
(dark greys).  It does a good job overall, so I don't suggest changing
it.

> If so, perhaps this optional feature could provide
> compatible alternatives to that?

Sure, like the example above for color-distance, tty-colors-approximate
could expose an extra optional argument and/or respond to a variable.

bug#28400: 26.0.50; lcms2 bindings

[Eli Zaretskii]

> Date: Mon, 11 Sep 2017 11:25:20 -0400
> From: Mark Oteiza <mvoteiza@udel.edu>
> Cc: 28400@debbugs.gnu.org
> 
> > As for color-distance, did you intend to replace or provide a better
> > alternative to similar functions in color.el?
> 
> That is a good question.  I've thought about it, but don't have a good
> answer.  lcms2 could certainly replace some of the things in color.el,
> but if it's an optional feature I guess there are a number of ways to
> handle it.  If we include lcms2.c providing its own 'cms or 'lcms2
> feature, I guess featurep'ing things wouldn't be so bad.

color.el could call lcms2 functions if they are available, and if not,
fall back on its own implementation.

> > If so, perhaps this optional feature could provide
> > compatible alternatives to that?
> 
> Sure, like the example above for color-distance, tty-colors-approximate
> could expose an extra optional argument and/or respond to a variable.

Sounds good, thanks.

bug#28400: 26.0.50; lcms2 bindings

[Mark Oteiza]

On 11/09/17 at 06:01pm, Eli Zaretskii wrote:
> > Date: Sun, 10 Sep 2017 18:04:22 -0400
> > From: Mark Oteiza <mvoteiza@udel.edu>
> > Cc: 28400@debbugs.gnu.org
> > 
> > >Is it really so much better than what we have now to justify requiring
> > >yet another library to build Emacs?  If it is, could you tell what are
> > >the main advantages, or point to where those advantages are described?
> > 
> > It was just much easier for me to hack existing code than figure out adding
> > a new file and the configure.ac business.  It would be much more
> > sensible to offer it as an optional feature and expose color metrics as
> > optional arguments, e.g.
> > 
> >   (color-distance COLOR1 COLOR2 &optional FRAME METRIC)
> > 
> > where METRIC accepts two colors and returns a number.
> 
> Oh, I see.  But in that case, I think adding a new file and the
> configure.ac business is actually quite easy.

Humble beginnings attached.

 configure.ac    |  19 +++++++
 src/Makefile.in |   6 ++-
 src/emacs.c     |   4 ++
 src/lcms.c      | 157 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/lisp.h      |   5 ++
 5 files changed, 189 insertions(+), 2 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/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..560b262818
--- /dev/null
+++ b/src/lcms.c
@@ -0,0 +1,157 @@
+/* Interface to Little CMS
+   Copyright (C) 2017 Mark Oteiza <mvoteiza@udel.edu>
+
+This file is NOT 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, 2, 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. */)
+  (Lisp_Object color1, Lisp_Object color2)
+{
+  cmsCIELab Lab1, Lab2;
+
+  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);
+  return make_float (cmsCIE2000DeltaE (&Lab1, &Lab2, 1.0f, 1.0f, 1.0f));
+}
+
+/* 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 = 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, 2, 0,
+       doc: /* Compute CAM02-UCS metric distance between COLOR1 and COLOR2.
+Each color is a list of XYZ coordinates.
+Optional argument is the XYZ white point, which defaults to D65. */)
+  (Lisp_Object color1, Lisp_Object color2)
+{
+  cmsViewingConditions vc;
+  cmsJCh jch1, jch2;
+  cmsHANDLE h1, h2;
+  cmsCIEXYZ xyz1, xyz2;
+  double Jp1, ap1, bp1, Jp2, ap2, bp2;
+  double Mp1, Mp2, FL, k;
+
+  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);
+
+  vc.whitePoint.X = 95.047;
+  vc.whitePoint.Y = 100.00;
+  vc.whitePoint.Z = 108.883;
+  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 JCh, need to calculate Jab
+
+     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.0f / (1.0f + (5.0f * vc.La));
+  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)));
+}
+
+\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);

bug#28400: 26.0.50; lcms2 bindings

[Eli Zaretskii]

> Date: Mon, 11 Sep 2017 19:10:06 -0400
> From: Mark Oteiza <mvoteiza@udel.edu>
> Cc: 28400@debbugs.gnu.org
> 
> > Oh, I see.  But in that case, I think adding a new file and the
> > configure.ac business is actually quite easy.
> 
> Humble beginnings attached.

Thanks, it looks good.  A few comments:

> diff --git a/src/lcms.c b/src/lcms.c
> new file mode 100644
> index 0000000000..560b262818
> --- /dev/null
> +++ b/src/lcms.c
> @@ -0,0 +1,157 @@
> +/* Interface to Little CMS
> +   Copyright (C) 2017 Mark Oteiza <mvoteiza@udel.edu>
> +
> +This file is NOT part of GNU Emacs.

This will have to change to our standard preamble, of course.

> +DEFUN ("lcms-cie-de2000", Flcms_cie_de2000, Slcms_cie_de2000, 2, 2, 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. */)
> +  (Lisp_Object color1, Lisp_Object color2)

I don't see any optional arguments.

> +DEFUN ("lcms-cam02-ucs", Flcms-cam02-ucs, Slcms_cam02_ucs, 2, 2, 0,
> +       doc: /* Compute CAM02-UCS metric distance between COLOR1 and COLOR2.
> +Each color is a list of XYZ coordinates.
> +Optional argument is the XYZ white point, which defaults to D65. */)
> +  (Lisp_Object color1, Lisp_Object color2)

Likewise.

> +  k = 1.0f / (1.0f + (5.0f * vc.La));

Any reason why you use float constants, as opposed to double?

> +  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)));

I generally dislike 'pow', where simpler functions will do.  'pow' is
expensive and less accurate numerically than the alternatives (where
they exist); it also makes the code slightly harder to read and
understand.  Granted, this code is unlikely to run in the inner-most
loops of some Lisp program, or to require last-ulp accuracy, so some
of these arguments are admittedly weak.  But still...

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 again for working on this.

bug#28400: 26.0.50; lcms2 bindings

[Mark Oteiza]

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