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.
This commit is contained in:
Mark Oteiza 2017-09-13 10:27:37 -04:00
parent 9a8bbb9d5d
commit 5d4c539bd7
7 changed files with 234 additions and 7 deletions

View file

@ -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

View file

@ -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
+++

View file

@ -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

View file

@ -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

182
src/lcms.c Normal file
View file

@ -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 <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)));
}
/* Initialization */
void
syms_of_lcms2 (void)
{
defsubr (&Slcms_cie_de2000);
defsubr (&Slcms_cam02_ucs);
}
#endif /* HAVE_LCMS2 */

View file

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

View file

@ -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);
}