Commit f5f261c6 authored by Mark Oteiza's avatar Mark Oteiza
Browse files

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

* src/lcms.c (lcms-temp->white-point): New function.
* test/src/lcms-tests.el: New file.
parent 30c955b1
......@@ -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;
if (!lcms_initialized)
lcms_initialized = init_lcms_functions ();
if (!lcms_initialized)
message1 ("lcms2 library not found");
return Qnil;
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. */)
;;; lcms-tests.el --- tests for Little CMS interface -*- lexical-binding: t -*-
;; Copyright (C) 2017 Free Software Foundation, Inc.
;; Maintainer:
;; 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
;; 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
;; Other references:
;;; 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
(apply #'color-xyz-to-xyy (lcms-temp->white-point 5503))
'(0.33242 0.34743 1.0)))
;; D65
(apply #'color-xyz-to-xyy (lcms-temp->white-point 6504))
'(0.31271 0.32902 1.0)))
;; D75
(apply #'color-xyz-to-xyy (lcms-temp->white-point 7504))
'(0.29902 0.31485 1.0))))
;;; lcms-tests.el ends here
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment