X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr-color.el;h=7011034d2421c1ab02b23ca19681c602d06d87ac;hb=5beb390633ce1e32cdf319c6ba19926244bbfdf2;hp=d611609e39c2aca1d06302ea149d9ec7a7b32845;hpb=748a26d641dd1996f89f290d7e276bcb955e4056;p=gnus diff --git a/lisp/shr-color.el b/lisp/shr-color.el index d611609e3..7011034d2 100644 --- a/lisp/shr-color.el +++ b/lisp/shr-color.el @@ -1,6 +1,6 @@ ;;; shr-color.el --- Simple HTML Renderer color management -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010-2012 Free Software Foundation, Inc. ;; Author: Julien Danjou ;; Keywords: html @@ -26,7 +26,8 @@ ;;; Code: -(require 'color-lab) +(require 'color) +(eval-when-compile (require 'cl)) (defgroup shr-color nil "Simple HTML Renderer colors" @@ -40,7 +41,7 @@ Must be between 0 and 100." (defcustom shr-color-visible-distance-min 5 "Minimum color distance between two colors to be considered visible. -This value is used to compare result for `ciede2000'. Its an +This value is used to compare result for `ciede2000'. It's an absolute value without any unit." :group 'shr :type 'integer) @@ -197,7 +198,8 @@ absolute value without any unit." Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR).") (defun shr-color-relative-to-absolute (number) - "Convert a relative NUMBER to absolute. If NUMBER is absolute, return NUMBER. + "Convert a relative NUMBER to absolute. +If NUMBER is absolute, return NUMBER. This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." (let ((string-length (- (length number) 1))) ;; Is this a number with %? @@ -231,10 +233,10 @@ Like rgb() or hsl()." (when color (cond ;; Hexadecimal color: #abc or #aabbcc - ((string-match-p - "#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?" + ((string-match + "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)" color) - color) + (match-string 1 color)) ;; rgb() or rgba() colors ((or (string-match "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)" @@ -258,18 +260,18 @@ Like rgb() or hsl()." (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0))) (destructuring-bind (r g b) (shr-color-hsl-to-rgb-fractions h s l) - (format "#%02X%02X%02X" (* r 255) (* g 255) (* b 255))))) + (color-rgb-to-hex r g b)))) ;; Color names - ((assoc color shr-color-html-colors-alist) - (cdr (assoc-string color shr-color-html-colors-alist t))) + ((cdr (assoc-string color shr-color-html-colors-alist t))) ;; Unrecognized color :( (t nil)))) -(defun set-minimum-interval (val1 val2 min max interval &optional fixed) +(defun shr-color-set-minimum-interval (val1 val2 min max interval + &optional fixed) "Set minimum interval between VAL1 and VAL2 to INTERVAL. The values are bound by MIN and MAX. -If FIXED is t, then val1 will not be touched." +If FIXED is t, then VAL1 will not be touched." (let ((diff (abs (- val1 val2)))) (unless (>= diff interval) (if fixed @@ -319,32 +321,42 @@ If FIXED is t, then val1 will not be touched." (defun shr-color-visible (bg fg &optional fixed-background) "Check that BG and FG colors are visible if they are drawn on each other. -Return t if they are. If they are too similar, two new colors are -returned instead. +Return (bg fg) if they are. If they are too similar, two new +colors are returned instead. If FIXED-BACKGROUND is set, and if the color are not visible, a -new background color will not be computed. Only the foreground +new background color will not be computed. Only the foreground color will be adapted to be visible on BG." ;; Convert fg and bg to CIE Lab - (let* ((fg-lab (apply 'rgb->lab (rgb->normalize fg))) - (bg-lab (apply 'rgb->lab (rgb->normalize bg))) - ;; Compute color distance using CIE DE 2000 - (fg-bg-distance (color-lab-ciede2000 fg-lab bg-lab)) - ;; Compute luminance distance (substract L component) - (luminance-distance (abs (- (car fg-lab) (car bg-lab))))) - (if (and (>= fg-bg-distance shr-color-visible-distance-min) - (>= luminance-distance shr-color-visible-luminance-min)) - (list bg fg) - ;; Not visible, try to change luminance to make them visible - (let ((Ls (set-minimum-interval (car bg-lab) (car fg-lab) 0 100 - shr-color-visible-luminance-min - fixed-background))) - (setcar bg-lab (car Ls)) - (setcar fg-lab (cadr Ls)) - (list - (apply 'format "#%02x%02x%02x" - (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb bg-lab))) - (apply 'format "#%02x%02x%02x" - (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb fg-lab)))))))) + (let ((fg-norm (color-name-to-rgb fg)) + (bg-norm (color-name-to-rgb bg))) + (if (or (null fg-norm) + (null bg-norm)) + (list bg fg) + (let* ((fg-lab (apply 'color-srgb-to-lab fg-norm)) + (bg-lab (apply 'color-srgb-to-lab bg-norm)) + ;; Compute color distance using CIE DE 2000 + (fg-bg-distance (color-cie-de2000 fg-lab bg-lab)) + ;; Compute luminance distance (subtract L component) + (luminance-distance (abs (- (car fg-lab) (car bg-lab))))) + (if (and (>= fg-bg-distance shr-color-visible-distance-min) + (>= luminance-distance shr-color-visible-luminance-min)) + (list bg fg) + ;; Not visible, try to change luminance to make them visible + (let ((Ls (shr-color-set-minimum-interval + (car bg-lab) (car fg-lab) 0 100 + shr-color-visible-luminance-min fixed-background))) + (unless fixed-background + (setcar bg-lab (car Ls))) + (setcar fg-lab (cadr Ls)) + (list + (if fixed-background + bg + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) + (apply 'color-lab-to-srgb bg-lab)))) + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) + (apply 'color-lab-to-srgb fg-lab)))))))))) (provide 'shr-color)