src/lcms.c

   1 /* Interface to Little CMS
   2    Copyright (C) 2017 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software: you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation, either version 3 of the License, or (at
   9 your option) any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
  18
  19 #include <config.h>
  20
  21 #ifdef HAVE_LCMS2
  22
  23 #include <lcms2.h>
  24 #include <math.h>
  25
  26 #include "lisp.h"
  27
  28 #ifdef WINDOWSNT
  29 # include <windows.h>
  30 # include "w32.h"
  31
  32 DEF_DLL_FN (cmsFloat64Number, cmsCIE2000DeltaE,
  33             (const cmsCIELab* Lab1, const cmsCIELab* Lab2, cmsFloat64Number Kl,
  34              cmsFloat64Number Kc, cmsFloat64Number Kh));
  35 DEF_DLL_FN (cmsHANDLE, cmsCIECAM02Init,
  36             (cmsContext ContextID, const cmsViewingConditions* pVC));
  37 DEF_DLL_FN (void, cmsCIECAM02Forward,
  38             (cmsHANDLE hModel, const cmsCIEXYZ* pIn, cmsJCh* pOut));
  39 DEF_DLL_FN (void, cmsCIECAM02Done, (cmsHANDLE hModel));
  40
  41 static bool lcms_initialized;
  42
  43 static bool
  44 init_lcms_functions (void)
  45 {
  46   HMODULE library = w32_delayed_load (Qlcms2);
  47
  48   if (!library)
  49     return false;
  50
  51   LOAD_DLL_FN (library, cmsCIE2000DeltaE);
  52   LOAD_DLL_FN (library, cmsCIECAM02Init);
  53   LOAD_DLL_FN (library, cmsCIECAM02Forward);
  54   LOAD_DLL_FN (library, cmsCIECAM02Done);
  55   return true;
  56 }
  57
  58 # undef cmsCIE2000DeltaE
  59 # undef cmsCIECAM02Init
  60 # undef cmsCIECAM02Forward
  61 # undef cmsCIECAM02Done
  62
  63 # define cmsCIE2000DeltaE   fn_cmsCIE2000DeltaE
  64 # define cmsCIECAM02Init    fn_cmsCIECAM02Init
  65 # define cmsCIECAM02Forward fn_cmsCIECAM02Forward
  66 # define cmsCIECAM02Done    fn_cmsCIECAM02Done
  67
  68 #endif  /* WINDOWSNT */
  69
  70 static bool
  71 parse_lab_list (Lisp_Object lab_list, cmsCIELab *color)
  72 {
  73 #define PARSE_LAB_LIST_FIELD(field)                                     \
  74   if (CONSP (lab_list) && NUMBERP (XCAR (lab_list)))                    \
  75     {                                                                   \
  76       color->field = XFLOATINT (XCAR (lab_list));                       \
  77       lab_list = XCDR (lab_list);                                       \
  78     }                                                                   \
  79   else                                                                  \
  80     return false;
  81
  82   PARSE_LAB_LIST_FIELD (L);
  83   PARSE_LAB_LIST_FIELD (a);
  84   PARSE_LAB_LIST_FIELD (b);
  85
  86   return true;
  87 }
  88
  89 /* http://www.ece.rochester.edu/~gsharma/ciede2000/ciede2000noteCRNA.pdf> */
  90
  91 DEFUN ("lcms-cie-de2000", Flcms_cie_de2000, Slcms_cie_de2000, 2, 5, 0,
  92        doc: /* Compute CIEDE2000 metric distance between COLOR1 and COLOR2.
  93 Each color is a list of L*a*b* coordinates, where the L* channel ranges from
  94 0 to 100, and the a* and b* channels range from -128 to 128.
  95 Optional arguments KL, KC, KH are weighting parameters for lightness,
  96 chroma, and hue, respectively. The parameters each default to 1. */)
  97   (Lisp_Object color1, Lisp_Object color2,
  98    Lisp_Object kL, Lisp_Object kC, Lisp_Object kH)
  99 {
 100   cmsCIELab Lab1, Lab2;
 101   cmsFloat64Number Kl, Kc, Kh;
 102
 103 #ifdef WINDOWSNT
 104   if (!lcms_initialized)
 105     lcms_initialized = init_lcms_functions ();
 106   if (!lcms_initialized)
 107     {
 108       message1 ("lcms2 library not found");
 109       return Qnil;
 110     }
 111 #endif
 112
 113   if (!(CONSP (color1) && parse_lab_list (color1, &Lab1)))
 114     signal_error ("Invalid color", color1);
 115   if (!(CONSP (color2) && parse_lab_list (color2, &Lab2)))
 116     signal_error ("Invalid color", color1);
 117   if (NILP (kL))
 118     Kl = 1.0f;
 119   else if (!(NUMBERP (kL) && (Kl = XFLOATINT(kL))))
 120     wrong_type_argument(Qnumberp, kL);
 121   if (NILP (kC))
 122     Kc = 1.0f;
 123   else if (!(NUMBERP (kC) && (Kc = XFLOATINT(kC))))
 124     wrong_type_argument(Qnumberp, kC);
 125   if (NILP (kL))
 126     Kh = 1.0f;
 127   else if (!(NUMBERP (kH) && (Kh = XFLOATINT(kH))))
 128     wrong_type_argument(Qnumberp, kH);
 129
 130   return make_float (cmsCIE2000DeltaE (&Lab1, &Lab2, Kl, Kc, Kh));
 131 }
 132
 133 /* FIXME: code duplication */
 134
 135 static bool
 136 parse_xyz_list (Lisp_Object xyz_list, cmsCIEXYZ *color)
 137 {
 138 #define PARSE_XYZ_LIST_FIELD(field)                                     \
 139   if (CONSP (xyz_list) && NUMBERP (XCAR (xyz_list)))                    \
 140     {                                                                   \
 141       color->field = 100.0 * XFLOATINT (XCAR (xyz_list));               \
 142       xyz_list = XCDR (xyz_list);                                       \
 143     }                                                                   \
 144   else                                                                  \
 145     return false;
 146
 147   PARSE_XYZ_LIST_FIELD (X);
 148   PARSE_XYZ_LIST_FIELD (Y);
 149   PARSE_XYZ_LIST_FIELD (Z);
 150
 151   return true;
 152 }
 153
 154 DEFUN ("lcms-cam02-ucs", Flcms_cam02_ucs, Slcms_cam02_ucs, 2, 3, 0,
 155        doc: /* Compute CAM02-UCS metric distance between COLOR1 and COLOR2.
 156 Each color is a list of XYZ coordinates, with Y scaled to unity.
 157 Optional argument is the XYZ white point, which defaults to illuminant D65. */)
 158   (Lisp_Object color1, Lisp_Object color2, Lisp_Object whitepoint)
 159 {
 160   cmsViewingConditions vc;
 161   cmsJCh jch1, jch2;
 162   cmsHANDLE h1, h2;
 163   cmsCIEXYZ xyz1, xyz2, xyzw;
 164   double Jp1, ap1, bp1, Jp2, ap2, bp2;
 165   double Mp1, Mp2, FL, k, k4;
 166
 167 #ifdef WINDOWSNT
 168   if (!lcms_initialized)
 169     lcms_initialized = init_lcms_functions ();
 170   if (!lcms_initialized)
 171     {
 172       message1 ("lcms2 library not found");
 173       return Qnil;
 174     }
 175 #endif
 176
 177   if (!(CONSP (color1) && parse_xyz_list (color1, &xyz1)))
 178     signal_error ("Invalid color", color1);
 179   if (!(CONSP (color2) && parse_xyz_list (color2, &xyz2)))
 180     signal_error ("Invalid color", color1);
 181   if (NILP (whitepoint))
 182     {
 183       xyzw.X = 95.047;
 184       xyzw.Y = 100.0;
 185       xyzw.Z = 108.883;
 186     }
 187   else if (!(CONSP (whitepoint) && parse_xyz_list(whitepoint, &xyzw)))
 188     signal_error("Invalid white point", whitepoint);
 189
 190   vc.whitePoint.X = xyzw.X;
 191   vc.whitePoint.Y = xyzw.Y;
 192   vc.whitePoint.Z = xyzw.Z;
 193   vc.Yb = 20;
 194   vc.La = 100;
 195   vc.surround = AVG_SURROUND;
 196   vc.D_value = 1.0;
 197
 198   h1 = cmsCIECAM02Init (0, &vc);
 199   h2 = cmsCIECAM02Init (0, &vc);
 200   cmsCIECAM02Forward (h1, &xyz1, &jch1);
 201   cmsCIECAM02Forward (h2, &xyz2, &jch2);
 202   cmsCIECAM02Done (h1);
 203   cmsCIECAM02Done (h2);
 204
 205   /* Now have colors in JCh, need to calculate J'a'b'
 206
 207      M = C * F_L^0.25
 208      J' = 1.7 J / (1 + 0.007 J)
 209      M' = 43.86 ln(1 + 0.0228 M)
 210      a' = M' cos(h)
 211      b' = M' sin(h)
 212
 213      where
 214
 215      F_L = 0.2 k^4 (5 L_A) + 0.1 (1 - k^4)^2 (5 L_A)^(1/3),
 216      k = 1/(5 L_A + 1)
 217   */
 218   k = 1.0 / (1.0 + (5.0 * vc.La));
 219   k4 = k * k * k * k;
 220   FL = vc.La * k4 + 0.1 * (1 - k4) * (1 - k4) * cbrt (5.0 * vc.La);
 221   Mp1 = 43.86 * log (1.0 + 0.0228 * (jch1.C * sqrt (sqrt (FL))));
 222   Mp2 = 43.86 * log (1.0 + 0.0228 * (jch2.C * sqrt (sqrt (FL))));
 223   Jp1 = 1.7 * jch1.J / (1.0 + (0.007 * jch1.J));
 224   Jp2 = 1.7 * jch2.J / (1.0 + (0.007 * jch2.J));
 225   ap1 = Mp1 * cos (jch1.h);
 226   ap2 = Mp2 * cos (jch2.h);
 227   bp1 = Mp1 * sin (jch1.h);
 228   bp2 = Mp2 * sin (jch2.h);
 229
 230   return make_float (sqrt ((Jp2 - Jp1) * (Jp2 - Jp1) +
 231                            (ap2 - ap1) * (ap2 - ap1) +
 232                            (bp2 - bp1) * (bp2 - bp1)));
 233 }
 234
 235 DEFUN ("lcms2-available-p", Flcms2_available_p, Slcms2_available_p, 0, 0, 0,
 236        doc: /* Return t if lcms2 color calculations are available in this instance of Emacs.  */)
 237      (void)
 238 {
 239 #ifdef WINDOWSNT
 240   Lisp_Object found = Fassq (Qlcms2, Vlibrary_cache);
 241   if (CONSP (found))
 242     return XCDR (found);
 243   else
 244     {
 245       Lisp_Object status;
 246       lcms_initialized = init_lcms_functions ();
 247       status = lcms_initialized ? Qt : Qnil;
 248       Vlibrary_cache = Fcons (Fcons (Qlcms2, status), Vlibrary_cache);
 249       return status;
 250     }
 251 #else  /* !WINDOWSNT */
 252   return Qt;
 253 #endif
 254 }
 255
 256 \f
 257 /* Initialization */
 258 void
 259 syms_of_lcms2 (void)
 260 {
 261   defsubr (&Slcms_cie_de2000);
 262   defsubr (&Slcms_cam02_ucs);
 263   defsubr (&Slcms2_available_p);
 264
 265   Fprovide (intern_c_string ("lcms2"), Qnil);
 266 }
 267
 268 #endif /* HAVE_LCMS2 */