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 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 "w32.h"
  38
  39 DEF_DLL_FN (cmsFloat64Number, cmsCIE2000DeltaE,
  40             (const cmsCIELab* Lab1, const cmsCIELab* Lab2, cmsFloat64Number Kl,
  41              cmsFloat64Number Kc, cmsFloat64Number Kh));
  42 DEF_DLL_FN (cmsHANDLE, cmsCIECAM02Init,
  43             (cmsContext ContextID, const cmsViewingConditions* pVC));
  44 DEF_DLL_FN (void, cmsCIECAM02Forward,
  45             (cmsHANDLE hModel, const cmsCIEXYZ* pIn, cmsJCh* pOut));
  46 DEF_DLL_FN (void, cmsCIECAM02Reverse,
  47             (cmsHANDLE hModel, const cmsJCh* pIn, cmsCIEXYZ* pOut));
  48 DEF_DLL_FN (void, cmsCIECAM02Done, (cmsHANDLE hModel));
  49 DEF_DLL_FN (cmsBool, cmsWhitePointFromTemp,
  50             (cmsCIExyY* WhitePoint, cmsFloat64Number TempK));
  51 DEF_DLL_FN (void, cmsxyY2XYZ, (cmsCIEXYZ* Dest, const cmsCIExyY* Source));
  52
  53 static bool lcms_initialized;
  54
  55 static bool
  56 init_lcms_functions (void)
  57 {
  58   HMODULE library = w32_delayed_load (Qlcms2);
  59
  60   if (!library)
  61     return false;
  62
  63   LOAD_DLL_FN (library, cmsCIE2000DeltaE);
  64   LOAD_DLL_FN (library, cmsCIECAM02Init);
  65   LOAD_DLL_FN (library, cmsCIECAM02Forward);
  66   LOAD_DLL_FN (library, cmsCIECAM02Reverse);
  67   LOAD_DLL_FN (library, cmsCIECAM02Done);
  68   LOAD_DLL_FN (library, cmsWhitePointFromTemp);
  69   LOAD_DLL_FN (library, cmsxyY2XYZ);
  70   return true;
  71 }
  72
  73 # undef cmsCIE2000DeltaE
  74 # undef cmsCIECAM02Init
  75 # undef cmsCIECAM02Forward
  76 # undef cmsCIECAM02Reverse
  77 # undef cmsCIECAM02Done
  78 # undef cmsWhitePointFromTemp
  79 # undef cmsxyY2XYZ
  80
  81 # define cmsCIE2000DeltaE      fn_cmsCIE2000DeltaE
  82 # define cmsCIECAM02Init       fn_cmsCIECAM02Init
  83 # define cmsCIECAM02Forward    fn_cmsCIECAM02Forward
  84 # define cmsCIECAM02Reverse    fn_cmsCIECAM02Reverse
  85 # define cmsCIECAM02Done       fn_cmsCIECAM02Done
  86 # define cmsWhitePointFromTemp fn_cmsWhitePointFromTemp
  87 # define cmsxyY2XYZ            fn_cmsxyY2XYZ
  88
  89 #endif  /* WINDOWSNT */
  90
  91 static bool
  92 parse_lab_list (Lisp_Object lab_list, cmsCIELab *color)
  93 {
  94 #define PARSE_LAB_LIST_FIELD(field)                                     \
  95   if (CONSP (lab_list) && NUMBERP (XCAR (lab_list)))                    \
  96     {                                                                   \
  97       color->field = XFLOATINT (XCAR (lab_list));                       \
  98       lab_list = XCDR (lab_list);                                       \
  99     }                                                                   \
 100   else                                                                  \
 101     return false;
 102
 103   PARSE_LAB_LIST_FIELD (L);
 104   PARSE_LAB_LIST_FIELD (a);
 105   PARSE_LAB_LIST_FIELD (b);
 106
 107   return true;
 108 }
 109
 110 /* http://www.ece.rochester.edu/~gsharma/ciede2000/ciede2000noteCRNA.pdf> */
 111
 112 DEFUN ("lcms-cie-de2000", Flcms_cie_de2000, Slcms_cie_de2000, 2, 5, 0,
 113        doc: /* Compute CIEDE2000 metric distance between COLOR1 and COLOR2.
 114 Each color is a list of L*a*b* coordinates, where the L* channel ranges from
 115 0 to 100, and the a* and b* channels range from -128 to 128.
 116 Optional arguments KL, KC, KH are weighting parameters for lightness,
 117 chroma, and hue, respectively. The parameters each default to 1.  */)
 118   (Lisp_Object color1, Lisp_Object color2,
 119    Lisp_Object kL, Lisp_Object kC, Lisp_Object kH)
 120 {
 121   cmsCIELab Lab1, Lab2;
 122   cmsFloat64Number Kl, Kc, Kh;
 123
 124 #ifdef WINDOWSNT
 125   if (!lcms_initialized)
 126     lcms_initialized = init_lcms_functions ();
 127   if (!lcms_initialized)
 128     {
 129       message1 ("lcms2 library not found");
 130       return Qnil;
 131     }
 132 #endif
 133
 134   if (!(CONSP (color1) && parse_lab_list (color1, &Lab1)))
 135     signal_error ("Invalid color", color1);
 136   if (!(CONSP (color2) && parse_lab_list (color2, &Lab2)))
 137     signal_error ("Invalid color", color1);
 138   if (NILP (kL))
 139     Kl = 1.0f;
 140   else if (!(NUMBERP (kL) && (Kl = XFLOATINT(kL))))
 141     wrong_type_argument(Qnumberp, kL);
 142   if (NILP (kC))
 143     Kc = 1.0f;
 144   else if (!(NUMBERP (kC) && (Kc = XFLOATINT(kC))))
 145     wrong_type_argument(Qnumberp, kC);
 146   if (NILP (kL))
 147     Kh = 1.0f;
 148   else if (!(NUMBERP (kH) && (Kh = XFLOATINT(kH))))
 149     wrong_type_argument(Qnumberp, kH);
 150
 151   return make_float (cmsCIE2000DeltaE (&Lab1, &Lab2, Kl, Kc, Kh));
 152 }
 153
 154 static double
 155 deg2rad (double degrees)
 156 {
 157   return M_PI * degrees / 180.0;
 158 }
 159
 160 static double
 161 rad2deg (double radians)
 162 {
 163   return 180.0 * radians / M_PI;
 164 }
 165
 166 static cmsCIEXYZ illuminant_d65 = { .X = 95.0455, .Y = 100.0, .Z = 108.8753 };
 167
 168 static void
 169 default_viewing_conditions (const cmsCIEXYZ *wp, cmsViewingConditions *vc)
 170 {
 171   vc->whitePoint.X = wp->X;
 172   vc->whitePoint.Y = wp->Y;
 173   vc->whitePoint.Z = wp->Z;
 174   vc->Yb = 20;
 175   vc->La = 100;
 176   vc->surround = AVG_SURROUND;
 177   vc->D_value = 1.0;
 178 }
 179
 180 /* FIXME: code duplication */
 181
 182 static bool
 183 parse_xyz_list (Lisp_Object xyz_list, cmsCIEXYZ *color)
 184 {
 185 #define PARSE_XYZ_LIST_FIELD(field)                                     \
 186   if (CONSP (xyz_list) && NUMBERP (XCAR (xyz_list)))                    \
 187     {                                                                   \
 188       color->field = 100.0 * XFLOATINT (XCAR (xyz_list));               \
 189       xyz_list = XCDR (xyz_list);                                       \
 190     }                                                                   \
 191   else                                                                  \
 192     return false;
 193
 194   PARSE_XYZ_LIST_FIELD (X);
 195   PARSE_XYZ_LIST_FIELD (Y);
 196   PARSE_XYZ_LIST_FIELD (Z);
 197
 198   return true;
 199 }
 200
 201 static bool
 202 parse_jch_list (Lisp_Object jch_list, cmsJCh *color)
 203 {
 204 #define PARSE_JCH_LIST_FIELD(field)                                     \
 205   if (CONSP (jch_list) && NUMBERP (XCAR (jch_list)))                    \
 206     {                                                                   \
 207       color->field = XFLOATINT (XCAR (jch_list));                       \
 208       jch_list = XCDR (jch_list);                                       \
 209     }                                                                   \
 210   else                                                                  \
 211     return false;
 212
 213   PARSE_JCH_LIST_FIELD (J);
 214   PARSE_JCH_LIST_FIELD (C);
 215   PARSE_JCH_LIST_FIELD (h);
 216
 217   if (! NILP (jch_list))
 218     return false;
 219   return true;
 220 }
 221
 222 static bool
 223 parse_jab_list (Lisp_Object jab_list, lcmsJab_t *color)
 224 {
 225 #define PARSE_JAB_LIST_FIELD(field)                                     \
 226   if (CONSP (jab_list) && NUMBERP (XCAR (jab_list)))                    \
 227     {                                                                   \
 228       color->field = XFLOATINT (XCAR (jab_list));                       \
 229       jab_list = XCDR (jab_list);                                       \
 230     }                                                                   \
 231   else                                                                  \
 232     return false;
 233
 234   PARSE_JAB_LIST_FIELD (J);
 235   PARSE_JAB_LIST_FIELD (a);
 236   PARSE_JAB_LIST_FIELD (b);
 237
 238   return true;
 239 }
 240
 241 static bool
 242 parse_viewing_conditions (Lisp_Object view, const cmsCIEXYZ *wp,
 243                           cmsViewingConditions *vc)
 244 {
 245 #define PARSE_VIEW_CONDITION_FLOAT(field)                               \
 246   if (CONSP (view) && NUMBERP (XCAR (view)))                            \
 247     {                                                                   \
 248       vc->field = XFLOATINT (XCAR (view));                              \
 249       view = XCDR (view);                                               \
 250     }                                                                   \
 251   else                                                                  \
 252     return false;
 253 #define PARSE_VIEW_CONDITION_INT(field)                                 \
 254   if (CONSP (view) && NATNUMP (XCAR (view)))                            \
 255     {                                                                   \
 256       CHECK_RANGED_INTEGER (XCAR (view), 1, 4);                         \
 257       vc->field = XINT (XCAR (view));                                   \
 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 CAM02 JCh to CIE XYZ.
 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 XYZ to CIE CAM02 JCh.
 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_OR_FLOAT (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 \f
 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 */