Re: Darkening font-lock colors

[Juri Linkov]

As proposed in 
http://lists.gnu.org/archive/html/emacs-devel/2005-01/msg00251.html
I implemented the color sorting option for `list-colors-display'.

Below is a short patch that adds a customizable variable
`list-colors-sort' with some useful sort orders to sort
by color name, RGB, HSV, and HVS distance to the specified color.
The default is unordered - the same order as now.

The HVS distance is the most useful sorting order.
For instance, for the source color "rosy brown"
(the former `font-lock-string-face' color) it shows
that a new color "VioletRed4" is far away from "rosy brown".
The closest colors for "rosy brown" on the HVS cylinder are:

  rosy brown
  RosyBrown3
  RosyBrown4
  RosyBrown2
  RosyBrown1
  light coral
  indian red
  IndianRed3
  IndianRed4
  IndianRed2
  IndianRed1
  brown
  brown3
  brown4
  brown2
  firebrick

The actual patch for color sorting is below:

Index: lisp/facemenu.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/facemenu.el,v
retrieving revision 1.108
diff -c -r1.108 facemenu.el
*** lisp/facemenu.el    18 Apr 2009 13:50:23 -0000      1.108
--- lisp/facemenu.el    4 Aug 2009 22:12:43 -0000
***************
*** 469,474 ****
--- 469,534 ----
        nil
        col)))
  
+ (defun rgb-to-hsv (r g b)
+   "For R, G, B color components return a list of hue, saturation, value.
+ R, G, B input values should be in [0..65535] range.
+ Output values for hue are in [0..360] range.
+ Output values for saturation and value are in [0..1] range."
+   (let* ((r (/ r 65535.0))
+        (g (/ g 65535.0))
+        (b (/ b 65535.0))
+        (max (max r g b))
+        (min (min r g b))
+        (h (cond ((= max min) 0)
+                 ((= max r) (mod (+ (* 60 (/ (- g b) (- max min))) 360) 360))
+                 ((= max g) (+ (* 60 (/ (- b r) (- max min))) 120))
+                 ((= max b) (+ (* 60 (/ (- r g) (- max min))) 240))))
+        (s (cond ((= max 0) 0)
+                 (t (- 1 (/ min max)))))
+        (v max))
+     (list h s v)))
+ 
+ (defcustom list-colors-sort nil
+   "Sort order for `list-colors-display'.
+ `nil' means unsorted (implementation-dependent order).
+ `name' sorts by color name.
+ `r-g-b' sorts by red, green, blue components.
+ `h-s-v' sorts by hue, saturation, value.
+ `hsv-dist' sorts by the HVS distance to the specified color."
+   :type '(choice (const :tag "Color Name" name)
+                (const :tag "Red-Green-Blue" r-g-b)
+                (const :tag "Hue-Saturation-Value" h-s-v)
+                (cons :tag "Distance on HSV cylinder"
+                      (const :tag "Distance from Color" hsv-dist)
+                      (color :tag "Source Color Name"))
+                (const :tag "Unsorted" nil))
+   :group 'facemenu
+   :version "23.2")
+ 
+ (defun list-colors-key (color)
+   "Return a list of keys for sorting colors depending on `list-colors-sort'.
+ COLOR is the name of the color.  Filters out a color from the output
+ when return value is nil."
+   (cond
+    ((null list-colors-sort) color)
+    ((eq list-colors-sort 'name)
+     (list color))
+    ((eq list-colors-sort 'r-g-b)
+     (color-values color))
+    ((eq list-colors-sort 'h-s-v)
+     (apply 'rgb-to-hsv (color-values color)))
+    ((eq (car list-colors-sort) 'hsv-dist)
+     (let* ((c-rgb (color-values color))
+          (c-hsv (apply 'rgb-to-hsv c-rgb))
+          (o-hsv (apply 'rgb-to-hsv (color-values (cdr list-colors-sort)))))
+       (unless (and (eq (nth 0 c-rgb) (nth 1 c-rgb)) ; exclude grayscale
+                  (eq (nth 1 c-rgb) (nth 2 c-rgb)))
+       ;; 3D Euclidean distance
+       (list (+ (expt (- (abs (- 180 (nth 0 c-hsv))) ; wrap hue as circle
+                         (abs (- 180 (nth 0 o-hsv)))) 2)
+                (expt (- (nth 1 c-hsv) (nth 1 o-hsv)) 2)
+                (expt (- (nth 2 c-hsv) (nth 2 o-hsv)) 2))))))))
+ 
  (defun list-colors-display (&optional list buffer-name)
    "Display names of defined colors, and show what they look like.
  If the optional argument LIST is non-nil, it should be a list of
***************
*** 478,483 ****
--- 538,564 ----
    (interactive)
    (when (and (null list) (> (display-color-cells) 0))
      (setq list (list-colors-duplicates (defined-colors)))
+     (when list-colors-sort
+       (setq list (mapcar
+                 'car
+                 (sort (delq nil (mapcar
+                                  (lambda (c)
+                                    (let ((key (list-colors-key (car c))))
+                                      (and key (cons c key))))
+                                  list))
+                       (lambda (a b)
+                         (let* ((a-keys (cdr a))
+                                (b-keys (cdr b))
+                                (a-key (car a-keys))
+                                (b-key (car b-keys)))
+                           (while (and a-key b-key (eq a-key b-key))
+                             (setq a-keys (cdr a-keys) a-key (car a-keys)
+                                   b-keys (cdr b-keys) b-key (car b-keys)))
+                           (cond
+                            ((and (numberp a-key) (numberp b-key))
+                             (< a-key b-key))
+                            ((and (stringp a-key) (stringp b-key))
+                             (string< a-key b-key)))))))))
      (when (memq (display-visual-class) '(gray-scale pseudo-color 
direct-color))
        ;; Don't show more than what the display can handle.
        (let ((lc (nthcdr (1- (display-color-cells)) list)))

-- 
Juri Linkov
http://www.jurta.org/emacs/