diff options
Diffstat (limited to 'lisp/facemenu.el')
| -rw-r--r-- | lisp/facemenu.el | 352 |
1 files changed, 243 insertions, 109 deletions
diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 5c0dbba7b7c..76c555da574 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -5,6 +5,7 @@ ;; Author: Boris Goldowsky <boris@gnu.org> ;; Keywords: faces +;; Package: emacs ;; This file is part of GNU Emacs. @@ -357,7 +358,7 @@ inserted. Moving point or switching buffers before typing a character to insert cancels the specification." (interactive (list (progn (barf-if-buffer-read-only) - (facemenu-read-color "Foreground color: ")) + (read-color "Foreground color: ")) (if (and mark-active (not current-prefix-arg)) (region-beginning)) (if (and mark-active (not current-prefix-arg)) @@ -379,7 +380,7 @@ inserted. Moving point or switching buffers before typing a character to insert cancels the specification." (interactive (list (progn (barf-if-buffer-read-only) - (facemenu-read-color "Background color: ")) + (read-color "Background color: ")) (if (and mark-active (not current-prefix-arg)) (region-beginning)) (if (and mark-active (not current-prefix-arg)) @@ -461,81 +462,197 @@ These special properties include `invisible', `intangible' and `read-only'." (remove-text-properties start end '(invisible nil intangible nil read-only nil)))) -(defun facemenu-read-color (&optional prompt) - "Read a color using the minibuffer." - (let* ((completion-ignore-case t) - (color-list (or facemenu-color-alist (defined-colors))) - (completer - (lambda (string pred all-completions) - (if all-completions - (or (all-completions string color-list pred) - (if (color-defined-p string) - (list string))) - (or (try-completion string color-list pred) - (if (color-defined-p string) - string))))) - (col (completing-read (or prompt "Color: ") completer nil t))) - (if (equal "" col) - nil - col))) - -(defun list-colors-display (&optional list buffer-name) +(defalias 'facemenu-read-color 'read-color) + +(defun color-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 integers in [0..360] range. +Output values for saturation and value are integers in [0..100] 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 (round h) (round s 0.01) (round v 0.01)))) + +(defcustom list-colors-sort nil + "Color sort order for `list-colors-display'. +`nil' means default implementation-dependent order (defined in `x-colors'). +`name' sorts by color name. +`rgb' sorts by red, green, blue components. +`(rgb-dist . COLOR)' sorts by the RGB distance to the specified color. +`hsv' sorts by hue, saturation, value. +`(hsv-dist . COLOR)' sorts by the HSV distance to the specified color +and excludes grayscale colors." + :type '(choice (const :tag "Unsorted" nil) + (const :tag "Color Name" name) + (const :tag "Red-Green-Blue" rgb) + (cons :tag "Distance on RGB cube" + (const :tag "Distance from Color" rgb-dist) + (color :tag "Source Color Name")) + (const :tag "Hue-Saturation-Value" hsv) + (cons :tag "Distance on HSV cylinder" + (const :tag "Distance from Color" hsv-dist) + (color :tag "Source Color Name"))) + :group 'facemenu + :version "24.1") + +(defun list-colors-sort-key (color) + "Return a list of keys for sorting colors depending on `list-colors-sort'. +COLOR is the name of the color. When return value is nil, +filter out the color from the output." + (cond + ((null list-colors-sort) color) + ((eq list-colors-sort 'name) + (downcase color)) + ((eq list-colors-sort 'rgb) + (color-values color)) + ((eq (car-safe list-colors-sort) 'rgb-dist) + (color-distance color (cdr list-colors-sort))) + ((eq list-colors-sort 'hsv) + (apply 'color-rgb-to-hsv (color-values color))) + ((eq (car-safe list-colors-sort) 'hsv-dist) + (let* ((c-rgb (color-values color)) + (c-hsv (apply 'color-rgb-to-hsv c-rgb)) + (o-hsv (apply 'color-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 (sqrt is not needed for sorting) + (+ (expt (- 180 (abs (- 180 (abs (- (nth 0 c-hsv) ; wrap hue + (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 callback) "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 colors to display. Otherwise, this command computes a list of -colors that the current display can handle. If the optional -argument BUFFER-NAME is nil, it defaults to *Colors*." +colors that the current display can handle. + +If the optional argument BUFFER-NAME is nil, it defaults to +*Colors*. + +If the optional argument CALLBACK is non-nil, it should be a +function to call each time the user types RET or clicks on a +color. The function should accept a single argument, the color +name. + +You can change the color sort order by customizing `list-colors-sort'." (interactive) (when (and (null list) (> (display-color-cells) 0)) (setq list (list-colors-duplicates (defined-colors))) + (when list-colors-sort + ;; Schwartzian transform with `(color key1 key2 key3 ...)'. + (setq list (mapcar + 'car + (sort (delq nil (mapcar + (lambda (c) + (let ((key (list-colors-sort-key + (car c)))) + (when key + (cons c (if (consp key) key + (list key)))))) + list)) + (lambda (a b) + (let* ((a-keys (cdr a)) + (b-keys (cdr b)) + (a-key (car a-keys)) + (b-key (car b-keys))) + ;; Skip common keys at the beginning of key lists. + (while (and a-key b-key (equal 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))) (if lc (setcdr lc nil))))) - (with-help-window (or buffer-name "*Colors*") - (with-current-buffer standard-output + (let ((buf (get-buffer-create "*Colors*"))) + (with-current-buffer buf + (erase-buffer) (setq truncate-lines t) - (if temp-buffer-show-function - (list-colors-print list) - ;; Call list-colors-print from temp-buffer-show-hook - ;; to get the right value of window-width in list-colors-print - ;; after the buffer is displayed. - (add-hook 'temp-buffer-show-hook - (lambda () - (set-buffer-modified-p - (prog1 (buffer-modified-p) - (list-colors-print list)))) - nil t))))) - -(defun list-colors-print (list) - (dolist (color list) - (if (consp color) - (if (cdr color) - (setq color (sort color (lambda (a b) - (string< (downcase a) - (downcase b)))))) - (setq color (list color))) - (put-text-property - (prog1 (point) - (insert (car color)) - (indent-to 22)) - (point) - 'face (list ':background (car color))) - (put-text-property - (prog1 (point) - (insert " " (if (cdr color) - (mapconcat 'identity (cdr color) ", ") - (car color)))) - (point) - 'face (list ':foreground (car color))) - (indent-to (max (- (window-width) 8) 44)) - (insert (apply 'format "#%02x%02x%02x" - (mapcar (lambda (c) (lsh c -8)) - (color-values (car color))))) - - (insert "\n")) - (goto-char (point-min))) + ;; Display buffer before generating content to allow + ;; `list-colors-print' to get the right window-width. + (pop-to-buffer buf) + (list-colors-print list callback) + (set-buffer-modified-p nil))) + (if callback + (message "Click on a color to select it."))) + +(defun list-colors-print (list &optional callback) + (let ((callback-fn + (if callback + `(lambda (button) + (funcall ,callback (button-get button 'color-name)))))) + (dolist (color list) + (if (consp color) + (if (cdr color) + (setq color (sort color (lambda (a b) + (string< (downcase a) + (downcase b)))))) + (setq color (list color))) + (let* ((opoint (point)) + (color-values (color-values (car color))) + (light-p (>= (apply 'max color-values) + (* (car (color-values "white")) .5))) + (max-len (max (- (window-width) 33) 20))) + (insert (car color)) + (indent-to 22) + (put-text-property opoint (point) 'face `(:background ,(car color))) + (put-text-property + (prog1 (point) + (insert " ") + (if (cdr color) + ;; Insert as many color names as possible, fitting max-len. + (let ((names (list (car color))) + (others (cdr color)) + (len (length (car color))) + newlen) + (while (and others + (< (setq newlen (+ len 2 (length (car others)))) + max-len)) + (setq len newlen) + (push (pop others) names)) + (insert (mapconcat 'identity (nreverse names) ", "))) + (insert (car color)))) + (point) + 'face (list :foreground (car color))) + (indent-to (max (- (window-width) 8) 44)) + (insert (propertize + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (c) (lsh c -8)) + color-values)) + 'mouse-face 'highlight + 'help-echo + (let ((hsv (apply 'color-rgb-to-hsv + (color-values (car color))))) + (format "H:%d S:%d V:%d" + (nth 0 hsv) (nth 1 hsv) (nth 2 hsv))))) + (when callback + (make-text-button + opoint (point) + 'follow-link t + 'mouse-face (list :background (car color) + :foreground (if light-p "black" "white")) + 'color-name (car color) + 'action callback-fn))) + (insert "\n")) + (goto-char (point-min)))) + (defun list-colors-duplicates (&optional list) "Return a list of colors with grouped duplicate colors. @@ -567,6 +684,22 @@ determine the correct answer." (cond ((equal a b) t) ((equal (color-values a) (color-values b))))) + +(defvar facemenu-self-insert-data nil) + +(defun facemenu-post-self-insert-function () + (when (and (car facemenu-self-insert-data) + (eq last-command (cdr facemenu-self-insert-data))) + (put-text-property (1- (point)) (point) + 'face (car facemenu-self-insert-data)) + (setq facemenu-self-insert-data nil)) + (remove-hook 'post-self-insert-hook 'facemenu-post-self-insert-function)) + +(defun facemenu-set-self-insert-face (face) + "Arrange for the next self-inserted char to have face `face'." + (setq facemenu-self-insert-data (cons face this-command)) + (add-hook 'post-self-insert-hook 'facemenu-post-self-insert-function)) + (defun facemenu-add-face (face &optional start end) "Add FACE to text between START and END. If START is nil or START to END is empty, add FACE to next typed character @@ -580,51 +713,52 @@ As a special case, if FACE is `default', then the region is left with NO face text property. Otherwise, selecting the default face would not have any effect. See `facemenu-remove-face-function'." (interactive "*xFace: \nr") - (if (and (eq face 'default) - (not (eq facemenu-remove-face-function t))) - (if facemenu-remove-face-function - (funcall facemenu-remove-face-function start end) - (if (and start (< start end)) - (remove-text-properties start end '(face default)) - (setq self-insert-face 'default - self-insert-face-command this-command))) - (if facemenu-add-face-function - (save-excursion - (if end (goto-char end)) - (save-excursion - (if start (goto-char start)) - (insert-before-markers - (funcall facemenu-add-face-function face end))) - (if facemenu-end-add-face - (insert (if (stringp facemenu-end-add-face) - facemenu-end-add-face - (funcall facemenu-end-add-face face))))) + (cond + ((and (eq face 'default) + (not (eq facemenu-remove-face-function t))) + (if facemenu-remove-face-function + (funcall facemenu-remove-face-function start end) (if (and start (< start end)) - (let ((part-start start) part-end) - (while (not (= part-start end)) - (setq part-end (next-single-property-change part-start 'face - nil end)) - (let ((prev (get-text-property part-start 'face))) - (put-text-property part-start part-end 'face - (if (null prev) - face - (facemenu-active-faces - (cons face - (if (listp prev) - prev - (list prev))) - ;; Specify the selected frame - ;; because nil would mean to use - ;; the new-frame default settings, - ;; and those are usually nil. - (selected-frame))))) - (setq part-start part-end))) - (setq self-insert-face (if (eq last-command self-insert-face-command) - (cons face (if (listp self-insert-face) - self-insert-face - (list self-insert-face))) - face) - self-insert-face-command this-command)))) + (remove-text-properties start end '(face default)) + (facemenu-set-self-insert-face 'default)))) + (facemenu-add-face-function + (save-excursion + (if end (goto-char end)) + (save-excursion + (if start (goto-char start)) + (insert-before-markers + (funcall facemenu-add-face-function face end))) + (if facemenu-end-add-face + (insert (if (stringp facemenu-end-add-face) + facemenu-end-add-face + (funcall facemenu-end-add-face face)))))) + ((and start (< start end)) + (let ((part-start start) part-end) + (while (not (= part-start end)) + (setq part-end (next-single-property-change part-start 'face + nil end)) + (let ((prev (get-text-property part-start 'face))) + (put-text-property part-start part-end 'face + (if (null prev) + face + (facemenu-active-faces + (cons face + (if (listp prev) + prev + (list prev))) + ;; Specify the selected frame + ;; because nil would mean to use + ;; the new-frame default settings, + ;; and those are usually nil. + (selected-frame))))) + (setq part-start part-end)))) + (t + (facemenu-set-self-insert-face + (if (eq last-command (cdr facemenu-self-insert-data)) + (cons face (if (listp (car facemenu-self-insert-data)) + (car facemenu-self-insert-data) + (list (car facemenu-self-insert-data)))) + face)))) (unless (facemenu-enable-faces-p) (message "Font-lock mode will override any faces you set in this buffer"))) |