root/src/lcms.c

DEFINITIONS

1. init_lcms_functions
2. parse_lab_list
3. deg2rad
4. rad2deg
5. default_viewing_conditions
6. parse_xyz_list
7. parse_jch_list
8. parse_jab_list
9. parse_viewing_conditions
10. xyz_to_jch
11. jch_to_xyz
12. jch_to_jab
13. jab_to_jch
14. DEFUN
15. DEFUN
16. syms_of_lcms2

     1 /* Interface to Little CMS
     2    Copyright (C) 2017-2023 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 typedef struct
    29 {
    30   double J;
    31   double a;
    32   double b;
    33 } lcmsJab_t;
    34 
    35 #ifdef WINDOWSNT
    36 # include <windows.h>
    37 # include "w32common.h"
    38 # include "w32.h"
    39 
    40 DEF_DLL_FN (cmsFloat64Number, cmsCIE2000DeltaE,
    41             (const cmsCIELab* Lab1, const cmsCIELab* Lab2, cmsFloat64Number Kl,
    42              cmsFloat64Number Kc, cmsFloat64Number Kh));
    43 DEF_DLL_FN (cmsHANDLE, cmsCIECAM02Init,
    44             (cmsContext ContextID, const cmsViewingConditions* pVC));
    45 DEF_DLL_FN (void, cmsCIECAM02Forward,
    46             (cmsHANDLE hModel, const cmsCIEXYZ* pIn, cmsJCh* pOut));
    47 DEF_DLL_FN (void, cmsCIECAM02Reverse,
    48             (cmsHANDLE hModel, const cmsJCh* pIn, cmsCIEXYZ* pOut));
    49 DEF_DLL_FN (void, cmsCIECAM02Done, (cmsHANDLE hModel));
    50 DEF_DLL_FN (cmsBool, cmsWhitePointFromTemp,
    51             (cmsCIExyY* WhitePoint, cmsFloat64Number TempK));
    52 DEF_DLL_FN (void, cmsxyY2XYZ, (cmsCIEXYZ* Dest, const cmsCIExyY* Source));
    53 
    54 static bool lcms_initialized;
    55 
    56 static bool
    57 init_lcms_functions (void)
    58 {
    59   HMODULE library = w32_delayed_load (Qlcms2);
    60 
    61   if (!library)
    62     return false;
    63 
    64   LOAD_DLL_FN (library, cmsCIE2000DeltaE);
    65   LOAD_DLL_FN (library, cmsCIECAM02Init);
    66   LOAD_DLL_FN (library, cmsCIECAM02Forward);
    67   LOAD_DLL_FN (library, cmsCIECAM02Reverse);
    68   LOAD_DLL_FN (library, cmsCIECAM02Done);
    69   LOAD_DLL_FN (library, cmsWhitePointFromTemp);
    70   LOAD_DLL_FN (library, cmsxyY2XYZ);
    71   return true;
    72 }
    73 
    74 # undef cmsCIE2000DeltaE
    75 # undef cmsCIECAM02Init
    76 # undef cmsCIECAM02Forward
    77 # undef cmsCIECAM02Reverse
    78 # undef cmsCIECAM02Done
    79 # undef cmsWhitePointFromTemp
    80 # undef cmsxyY2XYZ
    81 
    82 # define cmsCIE2000DeltaE      fn_cmsCIE2000DeltaE
    83 # define cmsCIECAM02Init       fn_cmsCIECAM02Init
    84 # define cmsCIECAM02Forward    fn_cmsCIECAM02Forward
    85 # define cmsCIECAM02Reverse    fn_cmsCIECAM02Reverse
    86 # define cmsCIECAM02Done       fn_cmsCIECAM02Done
    87 # define cmsWhitePointFromTemp fn_cmsWhitePointFromTemp
    88 # define cmsxyY2XYZ            fn_cmsxyY2XYZ
    89 
    90 #endif  /* WINDOWSNT */
    91 
    92 static bool
    93 parse_lab_list (Lisp_Object lab_list, cmsCIELab *color)
    94 {
    95 #define PARSE_LAB_LIST_FIELD(field)                                     \
    96   if (CONSP (lab_list) && NUMBERP (XCAR (lab_list)))                    \
    97     {                                                                   \
    98       color->field = XFLOATINT (XCAR (lab_list));                       \
    99       lab_list = XCDR (lab_list);                                       \
   100     }                                                                   \
   101   else                                                                  \
   102     return false;
   103 
   104   PARSE_LAB_LIST_FIELD (L);
   105   PARSE_LAB_LIST_FIELD (a);
   106   PARSE_LAB_LIST_FIELD (b);
   107 
   108   return true;
   109 }
   110 
   111 /* http://www.ece.rochester.edu/~gsharma/ciede2000/ciede2000noteCRNA.pdf */
   112 
   113 DEFUN ("lcms-cie-de2000", Flcms_cie_de2000, Slcms_cie_de2000, 2, 5, 0,
   114        doc: /* Compute CIEDE2000 metric distance between COLOR1 and COLOR2.
   115 Each color is a list of L*a*b* coordinates, where the L* channel ranges from
   116 0 to 100, and the a* and b* channels range from -128 to 128.
   117 Optional arguments KL, KC, KH are weighting parameters for lightness,
   118 chroma, and hue, respectively. The parameters each default to 1.  */)
   119   (Lisp_Object color1, Lisp_Object color2,
   120    Lisp_Object kL, Lisp_Object kC, Lisp_Object kH)
   121 {
   122   cmsCIELab Lab1, Lab2;
   123   cmsFloat64Number Kl, Kc, Kh;
   124 
   125 #ifdef WINDOWSNT
   126   if (!lcms_initialized)
   127     lcms_initialized = init_lcms_functions ();
   128   if (!lcms_initialized)
   129     {
   130       message1 ("lcms2 library not found");
   131       return Qnil;
   132     }
   133 #endif
   134 
   135   if (!(CONSP (color1) && parse_lab_list (color1, &Lab1)))
   136     signal_error ("Invalid color", color1);
   137   if (!(CONSP (color2) && parse_lab_list (color2, &Lab2)))
   138     signal_error ("Invalid color", color1);
   139   if (NILP (kL))
   140     Kl = 1.0f;
   141   else if (!(NUMBERP (kL) && (Kl = XFLOATINT(kL))))
   142     wrong_type_argument(Qnumberp, kL);
   143   if (NILP (kC))
   144     Kc = 1.0f;
   145   else if (!(NUMBERP (kC) && (Kc = XFLOATINT(kC))))
   146     wrong_type_argument(Qnumberp, kC);
   147   if (NILP (kL))
   148     Kh = 1.0f;
   149   else if (!(NUMBERP (kH) && (Kh = XFLOATINT(kH))))
   150     wrong_type_argument(Qnumberp, kH);
   151 
   152   return make_float (cmsCIE2000DeltaE (&Lab1, &Lab2, Kl, Kc, Kh));
   153 }
   154 
   155 static double
   156 deg2rad (double degrees)
   157 {
   158   return M_PI * degrees / 180.0;
   159 }
   160 
   161 static double
   162 rad2deg (double radians)
   163 {
   164   return 180.0 * radians / M_PI;
   165 }
   166 
   167 static cmsCIEXYZ illuminant_d65 = { .X = 95.0455, .Y = 100.0, .Z = 108.8753 };
   168 
   169 static void
   170 default_viewing_conditions (const cmsCIEXYZ *wp, cmsViewingConditions *vc)
   171 {
   172   vc->whitePoint.X = wp->X;
   173   vc->whitePoint.Y = wp->Y;
   174   vc->whitePoint.Z = wp->Z;
   175   vc->Yb = 20;
   176   vc->La = 100;
   177   vc->surround = AVG_SURROUND;
   178   vc->D_value = 1.0;
   179 }
   180 
   181 /* FIXME: code duplication */
   182 
   183 static bool
   184 parse_xyz_list (Lisp_Object xyz_list, cmsCIEXYZ *color)
   185 {
   186 #define PARSE_XYZ_LIST_FIELD(field)                                     \
   187   if (CONSP (xyz_list) && NUMBERP (XCAR (xyz_list)))                    \
   188     {                                                                   \
   189       color->field = 100.0 * XFLOATINT (XCAR (xyz_list));               \
   190       xyz_list = XCDR (xyz_list);                                       \
   191     }                                                                   \
   192   else                                                                  \
   193     return false;
   194 
   195   PARSE_XYZ_LIST_FIELD (X);
   196   PARSE_XYZ_LIST_FIELD (Y);
   197   PARSE_XYZ_LIST_FIELD (Z);
   198 
   199   return true;
   200 }
   201 
   202 static bool
   203 parse_jch_list (Lisp_Object jch_list, cmsJCh *color)
   204 {
   205 #define PARSE_JCH_LIST_FIELD(field)                                     \
   206   if (CONSP (jch_list) && NUMBERP (XCAR (jch_list)))                    \
   207     {                                                                   \
   208       color->field = XFLOATINT (XCAR (jch_list));                       \
   209       jch_list = XCDR (jch_list);                                       \
   210     }                                                                   \
   211   else                                                                  \
   212     return false;
   213 
   214   PARSE_JCH_LIST_FIELD (J);
   215   PARSE_JCH_LIST_FIELD (C);
   216   PARSE_JCH_LIST_FIELD (h);
   217 
   218   if (! NILP (jch_list))
   219     return false;
   220   return true;
   221 }
   222 
   223 static bool
   224 parse_jab_list (Lisp_Object jab_list, lcmsJab_t *color)
   225 {
   226 #define PARSE_JAB_LIST_FIELD(field)                                     \
   227   if (CONSP (jab_list) && NUMBERP (XCAR (jab_list)))                    \
   228     {                                                                   \
   229       color->field = XFLOATINT (XCAR (jab_list));                       \
   230       jab_list = XCDR (jab_list);                                       \
   231     }                                                                   \
   232   else                                                                  \
   233     return false;
   234 
   235   PARSE_JAB_LIST_FIELD (J);
   236   PARSE_JAB_LIST_FIELD (a);
   237   PARSE_JAB_LIST_FIELD (b);
   238 
   239   return true;
   240 }
   241 
   242 static bool
   243 parse_viewing_conditions (Lisp_Object view, const cmsCIEXYZ *wp,
   244                           cmsViewingConditions *vc)
   245 {
   246 #define PARSE_VIEW_CONDITION_FLOAT(field)                               \
   247   if (CONSP (view) && NUMBERP (XCAR (view)))                            \
   248     {                                                                   \
   249       vc->field = XFLOATINT (XCAR (view));                              \
   250       view = XCDR (view);                                               \
   251     }                                                                   \
   252   else                                                                  \
   253     return false;
   254 #define PARSE_VIEW_CONDITION_INT(field)                                 \
   255   if (CONSP (view) && FIXNATP (XCAR (view)))                            \
   256     {                                                                   \
   257       vc->field = check_integer_range (XCAR (view), 1, 4);              \
   258       view = XCDR (view);                                               \
   259     }                                                                   \
   260   else                                                                  \
   261     return false;
   262 
   263   PARSE_VIEW_CONDITION_FLOAT (Yb);
   264   PARSE_VIEW_CONDITION_FLOAT (La);
   265   PARSE_VIEW_CONDITION_INT (surround);
   266   PARSE_VIEW_CONDITION_FLOAT (D_value);
   267 
   268   if (! NILP (view))
   269     return false;
   270 
   271   vc->whitePoint.X = wp->X;
   272   vc->whitePoint.Y = wp->Y;
   273   vc->whitePoint.Z = wp->Z;
   274   return true;
   275 }
   276 
   277 static void
   278 xyz_to_jch (const cmsCIEXYZ *xyz, cmsJCh *jch, const cmsViewingConditions *vc)
   279 {
   280   cmsHANDLE h;
   281 
   282   h = cmsCIECAM02Init (0, vc);
   283   cmsCIECAM02Forward (h, xyz, jch);
   284   cmsCIECAM02Done (h);
   285 }
   286 
   287 static void
   288 jch_to_xyz (const cmsJCh *jch, cmsCIEXYZ *xyz, const cmsViewingConditions *vc)
   289 {
   290   cmsHANDLE h;
   291 
   292   h = cmsCIECAM02Init (0, vc);
   293   cmsCIECAM02Reverse (h, jch, xyz);
   294   cmsCIECAM02Done (h);
   295 }
   296 
   297 static void
   298 jch_to_jab (const cmsJCh *jch, lcmsJab_t *jab, double FL, double c1, double c2)
   299 {
   300   double Mp = 43.86 * log (1.0 + c2 * (jch->C * sqrt (sqrt (FL))));
   301   jab->J = 1.7 * jch->J / (1.0 + (c1 * jch->J));
   302   jab->a = Mp * cos (deg2rad (jch->h));
   303   jab->b = Mp * sin (deg2rad (jch->h));
   304 }
   305 
   306 static void
   307 jab_to_jch (const lcmsJab_t *jab, cmsJCh *jch, double FL, double c1, double c2)
   308 {
   309   jch->J = jab->J / (1.0 + c1 * (100.0 - jab->J));
   310   jch->h = atan2 (jab->b, jab->a);
   311   double Mp = hypot (jab->a, jab->b);
   312   jch->h = rad2deg (jch->h);
   313   if (jch->h < 0.0)
   314     jch->h += 360.0;
   315   jch->C = (exp (c2 * Mp) - 1.0) / (c2 * sqrt (sqrt (FL)));
   316 }
   317 
   318 DEFUN ("lcms-xyz->jch", Flcms_xyz_to_jch, Slcms_xyz_to_jch, 1, 3, 0,
   319        doc: /* Convert CIE XYZ to CIE CAM02 JCh.
   320 COLOR is a list (X Y Z), with Y scaled about unity.
   321 Optional arguments WHITEPOINT and VIEW are the same as in `lcms-cam02-ucs',
   322 which see.  */)
   323   (Lisp_Object color, Lisp_Object whitepoint, Lisp_Object view)
   324 {
   325   cmsViewingConditions vc;
   326   cmsJCh jch;
   327   cmsCIEXYZ xyz, xyzw;
   328 
   329 #ifdef WINDOWSNT
   330   if (!lcms_initialized)
   331     lcms_initialized = init_lcms_functions ();
   332   if (!lcms_initialized)
   333     {
   334       message1 ("lcms2 library not found");
   335       return Qnil;
   336     }
   337 #endif
   338 
   339   if (!(CONSP (color) && parse_xyz_list (color, &xyz)))
   340     signal_error ("Invalid color", color);
   341   if (NILP (whitepoint))
   342     xyzw = illuminant_d65;
   343   else if (!(CONSP (whitepoint) && parse_xyz_list (whitepoint, &xyzw)))
   344     signal_error ("Invalid white point", whitepoint);
   345   if (NILP (view))
   346     default_viewing_conditions (&xyzw, &vc);
   347   else if (!(CONSP (view) && parse_viewing_conditions (view, &xyzw, &vc)))
   348     signal_error ("Invalid viewing conditions", view);
   349 
   350   xyz_to_jch(&xyz, &jch, &vc);
   351   return list3 (make_float (jch.J), make_float (jch.C), make_float (jch.h));
   352 }
   353 
   354 DEFUN ("lcms-jch->xyz", Flcms_jch_to_xyz, Slcms_jch_to_xyz, 1, 3, 0,
   355        doc: /* Convert CIE CAM02 JCh to CIE XYZ.
   356 COLOR is a list (J C h), where lightness of white is equal to 100, and hue
   357 is given in degrees.
   358 Optional arguments WHITEPOINT and VIEW are the same as in `lcms-cam02-ucs',
   359 which see.  */)
   360   (Lisp_Object color, Lisp_Object whitepoint, Lisp_Object view)
   361 {
   362   cmsViewingConditions vc;
   363   cmsJCh jch;
   364   cmsCIEXYZ xyz, xyzw;
   365 
   366 #ifdef WINDOWSNT
   367   if (!lcms_initialized)
   368     lcms_initialized = init_lcms_functions ();
   369   if (!lcms_initialized)
   370     {
   371       message1 ("lcms2 library not found");
   372       return Qnil;
   373     }
   374 #endif
   375 
   376   if (!(CONSP (color) && parse_jch_list (color, &jch)))
   377     signal_error ("Invalid color", color);
   378   if (NILP (whitepoint))
   379     xyzw = illuminant_d65;
   380   else if (!(CONSP (whitepoint) && parse_xyz_list (whitepoint, &xyzw)))
   381     signal_error ("Invalid white point", whitepoint);
   382   if (NILP (view))
   383     default_viewing_conditions (&xyzw, &vc);
   384   else if (!(CONSP (view) && parse_viewing_conditions (view, &xyzw, &vc)))
   385     signal_error ("Invalid viewing conditions", view);
   386 
   387   jch_to_xyz(&jch, &xyz, &vc);
   388   return list3 (make_float (xyz.X / 100.0),
   389                 make_float (xyz.Y / 100.0),
   390                 make_float (xyz.Z / 100.0));
   391 }
   392 
   393 DEFUN ("lcms-jch->jab", Flcms_jch_to_jab, Slcms_jch_to_jab, 1, 3, 0,
   394        doc: /* Convert CIE CAM02 JCh to CAM02-UCS J'a'b'.
   395 COLOR is a list (J C h) as described in `lcms-jch->xyz', which see.
   396 Optional arguments WHITEPOINT and VIEW are the same as in `lcms-cam02-ucs',
   397 which see.  */)
   398   (Lisp_Object color, Lisp_Object whitepoint, Lisp_Object view)
   399 {
   400   cmsViewingConditions vc;
   401   lcmsJab_t jab;
   402   cmsJCh jch;
   403   cmsCIEXYZ xyzw;
   404   double FL, k, k4;
   405 
   406 #ifdef WINDOWSNT
   407   if (!lcms_initialized)
   408     lcms_initialized = init_lcms_functions ();
   409   if (!lcms_initialized)
   410     {
   411       message1 ("lcms2 library not found");
   412       return Qnil;
   413     }
   414 #endif
   415 
   416   if (!(CONSP (color) && parse_jch_list (color, &jch)))
   417     signal_error ("Invalid color", color);
   418   if (NILP (whitepoint))
   419     xyzw = illuminant_d65;
   420   else if (!(CONSP (whitepoint) && parse_xyz_list (whitepoint, &xyzw)))
   421     signal_error ("Invalid white point", whitepoint);
   422   if (NILP (view))
   423     default_viewing_conditions (&xyzw, &vc);
   424   else if (!(CONSP (view) && parse_viewing_conditions (view, &xyzw, &vc)))
   425     signal_error ("Invalid viewing conditions", view);
   426 
   427   k = 1.0 / (1.0 + (5.0 * vc.La));
   428   k4 = k * k * k * k;
   429   FL = vc.La * k4 + 0.1 * (1 - k4) * (1 - k4) * cbrt (5.0 * vc.La);
   430   jch_to_jab (&jch, &jab, FL, 0.007, 0.0228);
   431   return list3 (make_float (jab.J), make_float (jab.a), make_float (jab.b));
   432 }
   433 
   434 DEFUN ("lcms-jab->jch", Flcms_jab_to_jch, Slcms_jab_to_jch, 1, 3, 0,
   435        doc: /* Convert CAM02-UCS J'a'b' to CIE CAM02 JCh.
   436 COLOR is a list (J' a' b'), where white corresponds to lightness J equal to 100.
   437 Optional arguments WHITEPOINT and VIEW are the same as in `lcms-cam02-ucs',
   438 which see.  */)
   439   (Lisp_Object color, Lisp_Object whitepoint, Lisp_Object view)
   440 {
   441   cmsViewingConditions vc;
   442   cmsJCh jch;
   443   lcmsJab_t jab;
   444   cmsCIEXYZ xyzw;
   445   double FL, k, k4;
   446 
   447 #ifdef WINDOWSNT
   448   if (!lcms_initialized)
   449     lcms_initialized = init_lcms_functions ();
   450   if (!lcms_initialized)
   451     {
   452       message1 ("lcms2 library not found");
   453       return Qnil;
   454     }
   455 #endif
   456 
   457   if (!(CONSP (color) && parse_jab_list (color, &jab)))
   458     signal_error ("Invalid color", color);
   459   if (NILP (whitepoint))
   460     xyzw = illuminant_d65;
   461   else if (!(CONSP (whitepoint) && parse_xyz_list (whitepoint, &xyzw)))
   462     signal_error ("Invalid white point", whitepoint);
   463   if (NILP (view))
   464     default_viewing_conditions (&xyzw, &vc);
   465   else if (!(CONSP (view) && parse_viewing_conditions (view, &xyzw, &vc)))
   466     signal_error ("Invalid viewing conditions", view);
   467 
   468   k = 1.0 / (1.0 + (5.0 * vc.La));
   469   k4 = k * k * k * k;
   470   FL = vc.La * k4 + 0.1 * (1 - k4) * (1 - k4) * cbrt (5.0 * vc.La);
   471   jab_to_jch (&jab, &jch, FL, 0.007, 0.0228);
   472   return list3 (make_float (jch.J), make_float (jch.C), make_float (jch.h));
   473 }
   474 
   475 /* References:
   476    Li, Luo et al. "The CRI-CAM02UCS colour rendering index." COLOR research
   477    and application, 37 No.3, 2012.
   478    Luo et al. "Uniform colour spaces based on CIECAM02 colour appearance
   479    model." COLOR research and application, 31 No.4, 2006. */
   480 
   481 DEFUN ("lcms-cam02-ucs", Flcms_cam02_ucs, Slcms_cam02_ucs, 2, 4, 0,
   482        doc: /* Compute CAM02-UCS metric distance between COLOR1 and COLOR2.
   483 Each color is a list of XYZ tristimulus values, with Y scaled about unity.
   484 Optional argument WHITEPOINT is the XYZ white point, which defaults to
   485 illuminant D65.
   486 Optional argument VIEW is a list containing the viewing conditions, and
   487 is of the form (YB LA SURROUND DVALUE) where SURROUND corresponds to
   488   1   AVG_SURROUND
   489   2   DIM_SURROUND
   490   3   DARK_SURROUND
   491   4   CUTSHEET_SURROUND
   492 The default viewing conditions are (20 100 1 1).  */)
   493   (Lisp_Object color1, Lisp_Object color2, Lisp_Object whitepoint,
   494    Lisp_Object view)
   495 {
   496   cmsViewingConditions vc;
   497   cmsJCh jch1, jch2;
   498   cmsCIEXYZ xyz1, xyz2, xyzw;
   499   lcmsJab_t jab1, jab2;
   500   double FL, k, k4;
   501 
   502 #ifdef WINDOWSNT
   503   if (!lcms_initialized)
   504     lcms_initialized = init_lcms_functions ();
   505   if (!lcms_initialized)
   506     {
   507       message1 ("lcms2 library not found");
   508       return Qnil;
   509     }
   510 #endif
   511 
   512   if (!(CONSP (color1) && parse_xyz_list (color1, &xyz1)))
   513     signal_error ("Invalid color", color1);
   514   if (!(CONSP (color2) && parse_xyz_list (color2, &xyz2)))
   515     signal_error ("Invalid color", color2);
   516   if (NILP (whitepoint))
   517     xyzw = illuminant_d65;
   518   else if (!(CONSP (whitepoint) && parse_xyz_list (whitepoint, &xyzw)))
   519     signal_error ("Invalid white point", whitepoint);
   520   if (NILP (view))
   521     default_viewing_conditions (&xyzw, &vc);
   522   else if (!(CONSP (view) && parse_viewing_conditions (view, &xyzw, &vc)))
   523     signal_error ("Invalid view conditions", view);
   524 
   525   xyz_to_jch (&xyz1, &jch1, &vc);
   526   xyz_to_jch (&xyz2, &jch2, &vc);
   527 
   528   k = 1.0 / (1.0 + (5.0 * vc.La));
   529   k4 = k * k * k * k;
   530   FL = vc.La * k4 + 0.1 * (1 - k4) * (1 - k4) * cbrt (5.0 * vc.La);
   531   jch_to_jab (&jch1, &jab1, FL, 0.007, 0.0228);
   532   jch_to_jab (&jch2, &jab2, FL, 0.007, 0.0228);
   533 
   534   return make_float (hypot (jab2.J - jab1.J,
   535                             hypot (jab2.a - jab1.a, jab2.b - jab1.b)));
   536 }
   537 
   538 DEFUN ("lcms-temp->white-point", Flcms_temp_to_white_point, Slcms_temp_to_white_point, 1, 1, 0,
   539        doc: /* Return XYZ black body chromaticity from TEMPERATURE given in K.
   540 Valid range of TEMPERATURE is from 4000K to 25000K.  */)
   541   (Lisp_Object temperature)
   542 {
   543   cmsFloat64Number tempK;
   544   cmsCIExyY whitepoint;
   545   cmsCIEXYZ wp;
   546 
   547 #ifdef WINDOWSNT
   548   if (!lcms_initialized)
   549     lcms_initialized = init_lcms_functions ();
   550   if (!lcms_initialized)
   551     {
   552       message1 ("lcms2 library not found");
   553       return Qnil;
   554     }
   555 #endif
   556 
   557   CHECK_NUMBER (temperature);
   558 
   559   tempK = XFLOATINT (temperature);
   560   if (!(cmsWhitePointFromTemp (&whitepoint, tempK)))
   561     signal_error("Invalid temperature", temperature);
   562   cmsxyY2XYZ (&wp, &whitepoint);
   563   return list3 (make_float (wp.X), make_float (wp.Y), make_float (wp.Z));
   564 }
   565 
   566 DEFUN ("lcms2-available-p", Flcms2_available_p, Slcms2_available_p, 0, 0, 0,
   567        doc: /* Return t if lcms2 color calculations are available in this instance of Emacs.  */)
   568      (void)
   569 {
   570 #ifdef WINDOWSNT
   571   Lisp_Object found = Fassq (Qlcms2, Vlibrary_cache);
   572   if (CONSP (found))
   573     return XCDR (found);
   574   else
   575     {
   576       Lisp_Object status;
   577       lcms_initialized = init_lcms_functions ();
   578       status = lcms_initialized ? Qt : Qnil;
   579       Vlibrary_cache = Fcons (Fcons (Qlcms2, status), Vlibrary_cache);
   580       return status;
   581     }
   582 #else  /* !WINDOWSNT */
   583   return Qt;
   584 #endif
   585 }
   586 
   587 
   588 /* Initialization */
   589 void
   590 syms_of_lcms2 (void)
   591 {
   592   defsubr (&Slcms_cie_de2000);
   593   defsubr (&Slcms_xyz_to_jch);
   594   defsubr (&Slcms_jch_to_xyz);
   595   defsubr (&Slcms_jch_to_jab);
   596   defsubr (&Slcms_jab_to_jch);
   597   defsubr (&Slcms_cam02_ucs);
   598   defsubr (&Slcms2_available_p);
   599   defsubr (&Slcms_temp_to_white_point);
   600 
   601   Fprovide (intern_c_string ("lcms2"), Qnil);
   602 }
   603 
   604 #endif /* HAVE_LCMS2 */