cgit.sxemacs.org Git - sxemacs/blob - lisp/x-color.el

   1 ;;; x-color.el --- X11 color definition support for SXEmacs
   2
   3 ;; Copyright (C) 2007 Nelson Ferreira
   4
   5 ;; Author: Nelson Ferreira
   6 ;; Created: 12-May-07
   7 ;; Maintainer: SXEmacs Development Team
   8 ;; Keywords: internal, dumped
   9
  10 ;; This file is part of SXEmacs.
  11
  12 ;; SXEmacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; SXEmacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Synched up with: all the minibuffer history stuff is synched with
  26 ;;; 19.30.  Not sure about the rest.
  27
  28 ;;; Commentary:
  29
  30 ;; This file is dumped with SXEmacs.
  31
  32 ;; Code:
  33
  34 (defvar x-library-search-path '("/usr/X11R7/lib/X11/"
  35                                 "/usr/X11R6/lib/X11/"
  36                                 "/usr/X11R5/lib/X11/"
  37                                 "/usr/lib/X11R7/X11/"
  38                                 "/usr/lib/X11R6/X11/"
  39                                 "/usr/lib/X11R5/X11/"
  40                                 "/usr/local/X11R7/lib/X11/"
  41                                 "/usr/local/X11R6/lib/X11/"
  42                                 "/usr/local/X11R5/lib/X11/"
  43                                 "/usr/local/lib/X11R7/X11/"
  44                                 "/usr/local/lib/X11R6/X11/"
  45                                 "/usr/local/lib/X11R5/X11/")
  46   "Search path used by `read-color' to find rgb.txt.")
  47
  48 (defvar x-color-slist nil "Map of color names and their RGB values")
  49
  50 (defun x-read-color-completion-table ()
  51   "Color table for interactive completion"
  52   (unless (and (skiplistp x-color-slist)
  53                (> (skiplist-size x-color-slist) 0))
  54     (x-color-read-system-colors))
  55   (let ((res))
  56     (map-skiplist #'(lambda (key val)
  57                       (setq res (nconc res (list (list (format "%s" key))))))
  58                   x-color-slist)
  59     res))
  60
  61 (defun x-color-list ()
  62   "Color list"
  63   (unless (and (skiplistp x-color-slist)
  64                (> (skiplist-size x-color-slist) 0))
  65     (x-color-read-system-colors))
  66   (let ((res))
  67     (map-skiplist #'(lambda (key val)
  68                       (setq res (nconc res (list (format "%s" key)))))
  69                   x-color-slist)
  70     res))
  71
  72
  73 (defun find-color-rgb (name &optional nearest)
  74   "Retrieve the color by NAME"
  75   (interactive)
  76   (x-color-rgb-components name))
  77
  78 (defun x-find-color-rgb (name &optional nearest)
  79   "Retrieve the color by NAME"
  80   (unless (or (symbolp name)
  81               (stringp name)
  82               (x-rgb-color-p name))
  83     (error 'wrong-type-argument name))
  84   (unless (and (skiplistp x-color-slist)
  85                (> (skiplist-size x-color-slist) 0))
  86     (x-color-read-system-colors))
  87   (if (x-rgb-color-p name)
  88       (list (x-rgb-color-red name)
  89             (x-rgb-color-green name)
  90             (x-rgb-color-blue name))
  91     (let* ((color-name (if (symbolp name)
  92                            (symbol-name name)
  93                          name))
  94            (color-sym (intern color-name))
  95            (color-lc-sym (intern (downcase color-name)))
  96            (color-ns-sym (intern (replace-in-string color-name " " "")))
  97            (color-lcns-sym (intern (replace-in-string
  98                                     (downcase color-name)
  99                                     " " ""))))
 100       (or (get-skiplist x-color-slist color-sym)
 101           (get-skiplist x-color-slist color-lc-sym)
 102           (get-skiplist x-color-slist color-ns-sym)
 103           (get-skiplist x-color-slist color-lcns-sym)))))
 104
 105
 106
 107 (defun x-color-parse-rgb-components (color)
 108   "Parse RGB color specification and return a list of integers (R G B).
 109 #FEFEFE and rgb:fe/fe/fe style specifications are parsed.
 110 Returns NIL if RGB color specification is invalid."
 111   (let ((case-fold-search t)
 112         matches)
 113     (if (string-match #r"\([0-9.]+\)\s-+\([0-9.]+\)\s-+\([0-9.]+\)"
 114                       color)
 115         ;; recurse and parse hexadecimal color
 116         (x-color-parse-rgb-components
 117          (apply 'format "#%02X%02X%02X"
 118                 (mapcar #'(lambda (c) (if (floatp c) c (* 255 c)))
 119                         (mapcar #'(lambda (i)
 120                                     (let ((m
 121                                            (string-to-number
 122                                             (match-string i color))))
 123                                       (if (<= 0 m 1)
 124                                           (* 255 m)
 125                                         m)))
 126                                 (list 1 2 3)))))
 127       (when (cond ((string-match "^#[0-9a-f]+$" color)
 128                    (let* ((size (/ (1- (length color)) 3))
 129                           (dig-regex (format #r"\([0-9a-f]\{%s,%s\}\)"
 130                                              size size)))
 131                      ;; Check the intege division had no remainder
 132                      ;; which means no "odd" component sizes
 133                      (when (= (1+ (* 3 size)) (length color))
 134                        (string-match
 135                         (concat "^#" dig-regex dig-regex dig-regex "$")
 136                         color))))
 137                   ((string-match #r"rgb:\([0-9a-f]+\)/\([0-9a-f]+\)/\([0-9a-f]+\)"
 138                                  color))))
 139       (setq matches (mapcar #'(lambda (i) (match-string i color))
 140                             '(1 2 3)))
 141       ;; Make sure all components have at most 4 hex digits
 142       (when (eval
 143              (append '(and)
 144                      (mapcar #'(lambda (component)
 145                                  (> 5 (length component) 0))
 146                              matches)))
 147         (mapcar #'(lambda (component)
 148                     (* (expt 16 (- 4 (length component)))
 149                        (string-to-number component 16)))
 150                 matches)))))
 151
 152 (defsubst x-rgb-color-p (obj)
 153   (or (and (vectorp obj)
 154            (= (length obj) 4)
 155            (eq (aref obj 0) 'rgb))
 156       (and (vectorp obj)
 157            (= (length obj) 3))
 158       (and (listp obj)
 159            (= (length obj) 3))
 160       (and (listp obj)
 161            (= (length obj) 4)
 162            (eq (nth 0 obj) 'rgb))))
 163
 164 (defsubst x-rgb-color-nth (n obj)
 165   (or (and (vectorp obj)
 166            (= (length obj) 4)
 167            (eq (aref obj 0) 'rgb)
 168            (aref obj n))
 169       (and (vectorp obj)
 170            (= (length obj) 3)
 171            (aref obj (1- n)))
 172       (and (listp obj)
 173            (= (length obj) 3)
 174            (nth (1- n) obj))
 175       (and (listp obj)
 176            (= (length obj) 4)
 177            (eq (nth 0 obj) 'rgb)
 178            (nth n obj))))
 179
 180
 181 (defsubst x-rgb-color-red (obj)   (x-rgb-color-nth 1 obj))
 182 (defsubst x-rgb-color-green (obj) (x-rgb-color-nth 2 obj))
 183 (defsubst x-rgb-color-blue (obj)  (x-rgb-color-nth 3 obj))
 184
 185 (defun x-color-rgb-components (color)
 186   "Return the RGB components of COLOR as a list of integers (R G B).
 187 16-bit values are always returned.
 188 #FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly
 189 into their components.
 190 RGB values for color names are looked up using 'x-find-color-rgb'."
 191   (let ((case-fold-search t)
 192         (color-rgb
 193          (cond ((x-rgb-color-p color)
 194                 (mapcar #'(lambda (f)
 195                             (funcall f color))
 196                         (list 'x-rgb-color-red
 197                               'x-rgb-color-green
 198                               'x-rgb-color-blue)))
 199                ((and (vectorp color)
 200                      (= 3 (length color)))
 201                 (mapcar #'(lambda (p)
 202                             (aref color p))
 203                         (list 0 1 2)))
 204                ((and (listp color)
 205                      (= 3 (length color)))
 206                 color))))
 207     (cond ((and color-rgb
 208                 (eval (append '(and)
 209                               (mapcar #'(lambda (c)
 210                                           (and (numberp c) (<= 0 c 1)))
 211                                       color))))
 212            (mapcar #'(lambda (c) (* 65535 c)) color))
 213           ((and color-rgb
 214                 (eval (append '(and)
 215                               (mapcar #'(lambda (c)
 216                                           (and (numberp c) (<= 0 c 255)))
 217                                       color))))
 218            (mapcar #'(lambda (c) (lsh c 8)) color))
 219           ((and color-rgb
 220                 (eval (append '(or)
 221                               (mapcar #'(lambda (c)
 222                                           (and (numberp c) (<= 0 c 65535)))
 223                                       color))))
 224            color)
 225           ((and (stringp color)
 226                 (or (string-match #r"^\(#\|rgb:\)" color)
 227                     (string-match #r"[0-9.]+\s-+[0-9.]+\s-+[0-9.]+"
 228                                   color)))
 229            (x-color-parse-rgb-components color))
 230           (t
 231            (x-find-color-rgb color)))))
 232
 233 (defun x-read-rgb-file (filename)
 234   "Read the colors from FILENAME. The file is expected to have the same
 235 format as X11 rgb.txt"
 236   (let ((rgb-regex
 237          #r"^\s-*\([0-9]+\)\s-+\([0-9]+\)\s-+\([0-9]+\)\s-+\([a-zA-Z0-9 ]+\)\s-*$"))
 238     (unless (skiplistp x-color-slist)
 239       (setq x-color-slist (make-skiplist)))
 240     (when (file-readable-p filename)
 241       (save-excursion
 242         (set-buffer (or (get-file-buffer filename)
 243                         (create-file-buffer filename)))
 244         (erase-buffer)
 245         (insert-file-contents-literally filename)
 246         (if (not (= (aref (buffer-name) 0) ? ))
 247             (rename-buffer (generate-new-buffer-name " *rgb-tmp-buffer*")))
 248         (save-excursion
 249           (save-restriction
 250             (widen)
 251             (goto-char (point-min))
 252             (while (re-search-forward rgb-regex nil t)
 253               (let ((rgb-matches
 254                      (mapcar #'(lambda (i)
 255                                  (lsh (read (match-string i)) 8))
 256                              '(1 2 3)))
 257                     (color-name (match-string 4)))
 258                 (mapc #'(lambda (name)
 259                           (put-skiplist x-color-slist
 260                                         (intern name)
 261                                         rgb-matches))
 262                       (list color-name
 263                             (downcase color-name)
 264                             (replace-in-string color-name " " "")
 265                             (replace-in-string (downcase color-name)
 266                                                " " "")))))))))))
 267
 268 (defun x-color-read-system-colors ()
 269   "Read the system colors"
 270   (when (locate-data-file "rgb.txt")
 271     (x-read-rgb-file (locate-data-file "rgb.txt")))
 272   (mapc 'x-read-rgb-file
 273         (mapcar #'(lambda (dir)
 274                     (expand-file-name "rgb.txt" dir))
 275                 x-library-search-path))
 276   x-color-slist)
 277
 278
 279 (defun x-color-off-gray-diag (r g b)
 280   "Compute the angle between the color given by R,G,B and the gray diagonal.
 281 The gray diagonal is the diagonal of the 3D cube in RGB space which
 282 connects the points corresponding to the black and white colors.  All the
 283 colors whose RGB coordinates belong to this diagonal are various shades
 284 of gray, thus the name."
 285   (let ((mag (sqrt (* 3 (+ (* r r) (* g g) (* b b))))))
 286     (if (< mag 1) 0 (acos (/ (+ r g b) mag)))))
 287
 288
 289 (defsubst x-rgb-to-8bits (rgb)
 290   "Convert a 16-bit components rgb to an 8-bit components one."
 291   (mapcar #'(lambda (c) (lsh c -8)) rgb))
 292
 293 (defsubst x-color-distance-2 (color1 color2)
 294   "Return the color cube distance between the two colors as 8 bit rgb tupples."
 295   (when (and color1 color2)
 296     (unless (and (listp color1)
 297                  (= (length color1) 3))
 298       (error 'wrong-type-argument color1))
 299     (unless (and (listp color2)
 300                  (= (length color2) 3))
 301       (error 'wrong-type-argument color2))
 302     (let ((dR (- (car color1) (car color2)))
 303           (dG (- (cadr color1) (cadr color2)))
 304           (dB (- (caddr color1) (caddr color2))))
 305       (+ (* dR dR) (* dG dG) (* dB dB)))))
 306
 307
 308 (defsubst x-color-distance-1 (color1 color2)
 309   "Return the color cube distance between the two colors.
 310 Assumes COLOR1 is an 8 bit rgb tupple. "
 311 ;; Verification is done in x-color-distance-2
 312   (x-color-distance-2 color1
 313                       (x-rgb-to-8bits (x-color-rgb-components color2))))
 314
 315
 316 (defun x-color-distance (color1 color2)
 317   "Return the color cube distance between the two colors."
 318     (x-color-distance-1 (x-rgb-to-8bits (x-color-rgb-components color1))
 319                         color2))
 320
 321
 322 (defvar x-nearest-color-favor-non-gray-threshold 0.065
 323   "If the approximated color is not close enough to the
 324 gray diagonal of the RGB cube, favor non-gray colors.
 325 The default number 0.065 is an empirical ad-hoc'ery")
 326
 327 (defun x-nearest-color (color &optional colorlist) "
 328 Return the nearest COLOR in COLORLIST.
 329 COLOR can be a color name, an '(r g b) tuple or a color specification.
 330 #FEFEFE and rgb:fe/fe/fe style specifications are parsed.
 331 COLORLIST is a list of colors in the same acceptable formats as COLOR.
 332 Returns NIL if color specification is invalid, or no colors
 333 close enough are found."
 334   (let (color-rgb)
 335     (when (or (stringp color) (symbolp color))
 336       (setq color-rgb (x-rgb-to-8bits (find-color-rgb color))))
 337     (when (not color-rgb)
 338       (error 'invalid-argument color))
 339     (let ((favor-non-gray (>= (apply 'x-color-off-gray-diag color-rgb)
 340                               x-nearest-color-favor-non-gray-threshold))
 341           (best-distance 195076)        ;; Max possible distance: 3 * 255^2 + 15
 342           best-color)
 343       (mapc
 344        #'(lambda (candidate)
 345            (when candidate
 346              (let* ((cand-rgb (find-color-rgb candidate))
 347                     (distance (x-color-distance color-rgb cand-rgb)))
 348                (if (and distance cand-rgb
 349                         (< distance best-distance)
 350                         ;; The candidate color is on the gray diagonal
 351                         ;; if its RGB components are all equal.
 352                         (or (/= (x-rgb-color-red cand-rgb)
 353                                 (x-rgb-color-green cand-rgb))
 354                             (/= (x-rgb-color-green cand-rgb)
 355                                 (x-rgb-color-blue cand-rgb))
 356                             (not favor-non-gray)))
 357                    (setq best-distance distance
 358                          best-color candidate)))))
 359        (or colorlist (x-color-list)))
 360       best-color)))
 361
 362 (provide 'x-color)
 363
 364 ;;; x-color.el ends here