From: Mark Oteiza Date: Sat, 16 Sep 2017 03:49:42 +0000 (-0400) Subject: Add lcms-temp->white-point and initial tests X-Git-Tag: emacs-26.0.90~171 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=f5f261c6901e51b28deaa05dab157a38adf08912;p=emacs.git Add lcms-temp->white-point and initial tests * src/lcms.c (lcms-temp->white-point): New function. * test/src/lcms-tests.el: New file. --- 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 . + +;;; 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