Add lcms-temp->white-point and initial tests

* src/lcms.c (lcms-temp->white-point): New function.
* test/src/lcms-tests.el: New file.

2 files changed, 97 insertions, 0 deletions

diff --git a/src/lcms.c b/src/lcms.c
index 49af402327a..974fcd49300 100644
--- a/src/lcms.c
+++ b/src/lcms.c
@@ -232,6 +232,34 @@ Optional argument is the XYZ white point, which defaults to illuminant D65. */)
                            (bp2 - bp1) * (bp2 - bp1)));
 }
 
+DEFUN ("lcms-temp->white-point", Flcms_temp_to_white_point, Slcms_temp_to_white_point, 1, 1, 0,
+       doc: /* Return XYZ black body chromaticity from TEMPERATURE given in K.
+Valid range is 4000K to 25000K. */)
+  (Lisp_Object temperature)
+{
+  cmsFloat64Number tempK;
+  cmsCIExyY whitepoint;
+  cmsCIEXYZ wp;
+
+#ifdef WINDOWSNT
+  if (!lcms_initialized)
+    lcms_initialized = init_lcms_functions ();
+  if (!lcms_initialized)
+    {
+      message1 ("lcms2 library not found");
+      return Qnil;
+    }
+#endif
+
+  CHECK_NUMBER_OR_FLOAT(temperature);
+
+  tempK = XFLOATINT(temperature);
+  if (!(cmsWhitePointFromTemp(&whitepoint, tempK)))
+    signal_error("Invalid temperature", temperature);
+  cmsxyY2XYZ(&wp, &whitepoint);
+  return list3 (make_float (wp.X), make_float (wp.Y), make_float (wp.Z));
+}
+
 DEFUN ("lcms2-available-p", Flcms2_available_p, Slcms2_available_p, 0, 0, 0,
        doc: /* Return t if lcms2 color calculations are available in this instance of Emacs.  */)
      (void)
diff --git a/test/src/lcms-tests.el b/test/src/lcms-tests.el
new file mode 100644
index 00000000000..0d6b8db3d4b
--- /dev/null
+++ b/test/src/lcms-tests.el
@@ -0,0 +1,69 @@
+;;; lcms-tests.el --- tests for Little CMS interface -*- lexical-binding: t -*-
+
+;; Copyright (C) 2017  Free Software Foundation, Inc.
+
+;; Maintainer: emacs-devel@gnu.org
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Some "exact" values computed using the colorspacious python library
+;; written by Nathaniel J. Smith.  See
+;; https://colorspacious.readthedocs.io/en/v1.1.0/
+
+;; Other references:
+;; http://www.babelcolor.com/index_htm_files/A%20review%20of%20RGB%20color%20spaces.pdf
+
+;;; Code:
+
+(require 'ert)
+(require 'color)
+
+(defun lcms-approx-p (a b &optional delta)
+  "Check if A and B are within relative error DELTA of one another.
+B is considered the exact value."
+  (> (or delta 0.001) (abs (1- (/ a b)))))
+
+(defun lcms-triple-approx-p (a b &optional delta)
+  "Like `lcms-approx-p' except for color triples."
+  (pcase-let ((`(,a1 ,a2 ,a3) a)
+              (`(,b1 ,b2 ,b3) b))
+   (and (lcms-approx-p a1 b1 delta)
+        (lcms-approx-p a2 b2 delta)
+        (lcms-approx-p a3 b3 delta))))
+
+(ert-deftest lcms-whitepoint ()
+  "Test use of `lcms-temp->white-point'."
+  (should-error (lcms-temp->white-point 3999))
+  (should-error (lcms-temp->white-point 25001))
+  ;; D55
+  (should
+   (lcms-triple-approx-p
+    (apply #'color-xyz-to-xyy (lcms-temp->white-point 5503))
+    '(0.33242 0.34743 1.0)))
+  ;; D65
+  (should
+   (lcms-triple-approx-p
+    (apply #'color-xyz-to-xyy (lcms-temp->white-point 6504))
+    '(0.31271 0.32902 1.0)))
+  ;; D75
+  (should
+   (lcms-triple-approx-p
+    (apply #'color-xyz-to-xyy (lcms-temp->white-point 7504))
+    '(0.29902 0.31485 1.0))))
+
+;;; lcms-tests.el ends here