procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
* src/lcms.c (lcms-temp->white-point): New function.
* test/src/lcms-tests.el: New file.
This commit is contained in:
Mark Oteiza 2017-09-15 23:49:42 -04:00
parent 30c955b172
commit f5f261c690
2 changed files with 97 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
src/lcms.c
View file

@ -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)

69
test/src/lcms-tests.el Normal file
View file

@ -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