(interactive (internal-face-interactive "foreground"))
(internal-set-face-1 face 'foreground color 4 frame))
+(defvar face-default-stipple "gray3"
+ "Default stipple pattern used on monochrome displays.
+This stipple pattern is used on monochrome displays
+instead of shades of gray for a face background color.
+See `set-face-stipple' for possible values for this variable.")
+
+(defun face-color-gray-p (color &optional frame)
+ "Return t if COLOR is a shade of gray (or white or black).
+FRAME specifies the frame and thus the display for interpreting COLOR."
+ (let* ((values (x-color-values color frame))
+ (r (nth 0 values))
+ (g (nth 1 values))
+ (b (nth 2 values)))
+ (and (< (abs (- r g)) (/ (max 1 (abs r) (abs g)) 20))
+ (< (abs (- g b)) (/ (max 1 (abs g) (abs b)) 20))
+ (< (abs (- b r)) (/ (max 1 (abs b) (abs r)) 20)))))
+
(defun set-face-background (face color &optional frame)
"Change the background color of face FACE to COLOR (a string).
If the optional FRAME argument is provided, change only
(interactive (internal-face-interactive "background"))
;; For a specific frame, use gray stipple instead of gray color
;; if the display does not support a gray color.
- (if (and frame (not (eq frame t))
- (member color '("gray" "gray1" "gray3"))
- (not (x-display-color-p frame))
- (not (x-display-grayscale-p frame)))
- (set-face-stipple face color frame)
+ (if (and frame (not (eq frame t)) color
+ ;; Check for support for foreground, not for background!
+ ;; face-color-supported-p is smart enough to know
+ ;; that grays are "supported" as background
+ ;; because we are supposed to use stipple for them!
+ (not (face-color-supported-p frame color nil)))
+ (set-face-stipple face face-default-stipple frame)
(if (null frame)
(let ((frames (frame-list)))
(while frames
color)
(internal-set-face-1 face 'background color 5 frame))))
-(defun set-face-stipple (face name &optional frame)
+(defun set-face-stipple (face pixmap &optional frame)
"Change the stipple pixmap of face FACE to PIXMAP.
PIXMAP should be a string, the name of a file of pixmap data.
The directories listed in the `x-bitmap-file-path' variable are searched.
If the optional FRAME argument is provided, change only
in that frame; otherwise change each frame."
(interactive (internal-face-interactive "stipple"))
- (internal-set-face-1 face 'background-pixmap name 6 frame))
+ (internal-set-face-1 face 'background-pixmap pixmap 6 frame))
(defalias 'set-face-background-pixmap 'set-face-stipple)
(t value))))
(defun modify-face (face foreground background stipple
- bold-p italic-p underline-p)
+ bold-p italic-p underline-p &optional frame)
"Change the display attributes for face FACE.
-FOREGROUND and BACKGROUND should be color strings or nil.
-STIPPLE should be a stipple pattern name or nil.
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame.
+
+FOREGROUND and BACKGROUND should be a colour name string (or list of strings to
+try) or nil. STIPPLE should be a stipple pattern name string or nil.
+If nil, means do not change the display attribute corresponding to that arg.
+
BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold,
-in italic, and underlined, respectively. (Yes if non-nil.)
-If called interactively, prompts for a face and face attributes."
+in italic, and underlined, respectively. If neither nil or t, means do not
+change the display attribute corresponding to that arg.
+
+If called interactively, prompts for a face name and face attributes."
(interactive
(let* ((completion-ignore-case t)
- (face (symbol-name (read-face-name "Modify face: ")))
- (colors (mapcar 'list x-colors))
- (stipples (mapcar 'list
- (apply 'nconc
- (mapcar 'directory-files
- x-bitmap-file-path))))
- (foreground (modify-face-read-string
- face (face-foreground (intern face))
- "foreground" colors))
- (background (modify-face-read-string
- face (face-background (intern face))
- "background" colors))
- (stipple (modify-face-read-string
- face (face-stipple (intern face))
- "stipple" stipples))
- (bold-p (y-or-n-p (concat "Set face " face " bold ")))
- (italic-p (y-or-n-p (concat "Set face " face " italic ")))
- (underline-p (y-or-n-p (concat "Set face " face " underline "))))
+ (face (symbol-name (read-face-name "Modify face: ")))
+ (colors (mapcar 'list x-colors))
+ (stipples (mapcar 'list (apply 'nconc
+ (mapcar 'directory-files
+ x-bitmap-file-path))))
+ (foreground (modify-face-read-string
+ face (face-foreground (intern face))
+ "foreground" colors))
+ (background (modify-face-read-string
+ face (face-background (intern face))
+ "background" colors))
+ (stipple (modify-face-read-string
+ face (face-stipple (intern face))
+ "stipple" stipples))
+ (bold-p (y-or-n-p (concat "Set face " face " bold ")))
+ (italic-p (y-or-n-p (concat "Set face " face " italic ")))
+ (underline-p (y-or-n-p (concat "Set face " face " underline ")))
+ (all-frames-p (y-or-n-p (concat "Modify face " face " in all frames "))))
(message "Face %s: %s" face
(mapconcat 'identity
(delq nil
(and bold-p "bold") (and italic-p "italic")
(and underline-p "underline"))) ", "))
(list (intern face) foreground background stipple
- bold-p italic-p underline-p)))
- (condition-case nil (set-face-foreground face foreground) (error nil))
- (condition-case nil (set-face-background face background) (error nil))
- (condition-case nil (set-face-stipple face stipple) (error nil))
- (funcall (if bold-p 'make-face-bold 'make-face-unbold) face nil t)
- (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face nil t)
- (set-face-underline-p face underline-p)
+ bold-p italic-p underline-p
+ (if all-frames-p nil (selected-frame)))))
+ (condition-case nil
+ (face-try-color-list 'set-face-foreground face foreground frame)
+ (error nil))
+ (condition-case nil
+ (face-try-color-list 'set-face-background face background frame)
+ (error nil))
+ (condition-case nil
+ (set-face-stipple face stipple frame)
+ (error nil))
+ (cond ((eq bold-p nil) (make-face-unbold face frame t))
+ ((eq bold-p t) (make-face-bold face frame t)))
+ (cond ((eq italic-p nil) (make-face-unitalic face frame t))
+ ((eq italic-p t) (make-face-italic face frame t)))
+ (if (memq underline-p '(nil t))
+ (set-face-underline-p face underline-p frame))
(and (interactive-p) (redraw-display)))
\f
;;;; Associating face names (symbols) with their face vectors.
(setq frames (cdr frames)))
(setq global-face-data (cons (cons name face) global-face-data)))
;; when making a face after frames already exist
- (if (eq window-system 'x)
+ (if (or (eq window-system 'x) (eq window-system 'win32))
(make-face-x-resource-internal face))
;; add to menu
(if (fboundp 'facemenu-add-new-face)
(cond ((null frame)
(let ((frames (frame-list)))
(while frames
- (if (eq (framep (car frames)) 'x)
+ (if (or (eq (framep (car frames)) 'x) (eq (framep (car frames)) 'win32))
(make-face-x-resource-internal (face-name face)
(car frames) set-anyway))
(setq frames (cdr frames)))))
)
(if fn
(condition-case ()
- (set-face-font face fn frame)
- (error (message "font `%s' not found for face `%s'" fn name))))
+ (cond ((string= fn "italic")
+ (make-face-italic face))
+ ((string= fn "bold")
+ (make-face-bold face))
+ ((string= fn "bold-italic")
+ (make-face-bold-italic face))
+ (t
+ (set-face-font face fn frame)))
+ (error
+ (if (member fn '("italic" "bold" "bold-italic"))
+ (message "no %s version found for face `%s'" fn name)
+ (message "font `%s' not found for face `%s'" fn name)))))
(if fg
(condition-case ()
(set-face-foreground face fg frame)
(defconst x-font-regexp-weight nil)
(defconst x-font-regexp-slant nil)
+(defconst x-font-regexp-weight-subnum 1)
+(defconst x-font-regexp-slant-subnum 2)
+(defconst x-font-regexp-swidth-subnum 3)
+(defconst x-font-regexp-adstyle-subnum 4)
+
;;; Regexps matching font names in "Host Portable Character Representation."
;;;
(let ((- "[-?]")
; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3
(swidth "\\([^-]*\\)") ; 3
; (adstyle "\\(\\*\\|sans\\|\\)") ; 4
- (adstyle "[^-]*") ; 4
+ (adstyle "\\([^-]*\\)") ; 4
(pixelsize "[0-9]+")
(pointsize "[0-9][0-9]+")
(resx "[0-9][0-9]+")
(setq x-font-regexp
(concat "\\`\\*?[-?*]"
foundry - family - weight\? - slant\? - swidth - adstyle -
- pixelsize - pointsize - resx - resy - spacing - registry -
- encoding "[-?*]\\*?\\'"
+ pixelsize - pointsize - resx - resy - spacing - avgwidth -
+ registry - encoding "\\*?\\'"
))
(setq x-font-regexp-head
(concat "\\`[-?*]" foundry - family - weight\? - slant\?
(cdr (assq 'font (frame-parameters (selected-frame))))))
(defun x-frob-font-weight (font which)
- (if (or (string-match x-font-regexp font)
- (string-match x-font-regexp-head font)
- (string-match x-font-regexp-weight font))
- (concat (substring font 0 (match-beginning 1)) which
- (substring font (match-end 1)))
- nil))
+ (let ((case-fold-search t))
+ (cond ((string-match x-font-regexp font)
+ (concat (substring font 0
+ (match-beginning x-font-regexp-weight-subnum))
+ which
+ (substring font (match-end x-font-regexp-weight-subnum)
+ (match-beginning x-font-regexp-adstyle-subnum))
+ ;; Replace the ADD_STYLE_NAME field with *
+ ;; because the info in it may not be the same
+ ;; for related fonts.
+ "*"
+ (substring font (match-end x-font-regexp-adstyle-subnum))))
+ ((or (string-match x-font-regexp-head font)
+ (string-match x-font-regexp-weight font))
+ (concat (substring font 0 (match-beginning 1)) which
+ (substring font (match-end 1)))))))
(defun x-frob-font-slant (font which)
- (cond ((or (string-match x-font-regexp font)
- (string-match x-font-regexp-head font))
- (concat (substring font 0 (match-beginning 2)) which
- (substring font (match-end 2))))
- ((string-match x-font-regexp-slant font)
- (concat (substring font 0 (match-beginning 1)) which
- (substring font (match-end 1))))
- (t nil)))
-
+ (let ((case-fold-search t))
+ (cond ((string-match x-font-regexp font)
+ (concat (substring font 0
+ (match-beginning x-font-regexp-slant-subnum))
+ which
+ (substring font (match-end x-font-regexp-slant-subnum)
+ (match-beginning x-font-regexp-adstyle-subnum))
+ ;; Replace the ADD_STYLE_NAME field with *
+ ;; because the info in it may not be the same
+ ;; for related fonts.
+ "*"
+ (substring font (match-end x-font-regexp-adstyle-subnum))))
+ ((or (string-match x-font-regexp-head font)
+ (string-match x-font-regexp-slant font))
+ (concat (substring font 0 (match-beginning 1)) which
+ (substring font (match-end 1)))))))
(defun x-make-font-bold (font)
"Given an X font specification, make a bold version of it.
(set-face-font face (if (memq 'italic (face-font face t))
'(bold italic) '(bold))
t)
- (let ((ofont (face-font face frame))
- font)
+ (let (font)
(if (null frame)
(let ((frames (frame-list)))
;; Make this face bold in global-face-data.
(setq font (or font
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
- (and font (make-face-bold-internal face frame font)))
- (or (not (equal ofont (face-font face)))
- (and (not noerror)
- (error "No bold version of %S" font))))))
+ (or (and font (make-face-bold-internal face frame font))
+ ;; We failed to find a bold version of the font.
+ noerror
+ (error "No bold version of %S" font))))))
(defun make-face-bold-internal (face frame font)
(let (f2)
(set-face-font face (if (memq 'bold (face-font face t))
'(bold italic) '(italic))
t)
- (let ((ofont (face-font face frame))
- font)
+ (let (font)
(if (null frame)
(let ((frames (frame-list)))
;; Make this face italic in global-face-data.
(setq font (or font
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
- (and font (make-face-italic-internal face frame font)))
- (or (not (equal ofont (face-font face)))
- (and (not noerror)
- (error "No italic version of %S" font))))))
+ (or (and font (make-face-italic-internal face frame font))
+ ;; We failed to find an italic version of the font.
+ noerror
+ (error "No italic version of %S" font))))))
(defun make-face-italic-internal (face frame font)
(let (f2)
(interactive (list (read-face-name "Make which face bold-italic: ")))
(if (and (eq frame t) (listp (face-font face t)))
(set-face-font face '(bold italic) t)
- (let ((ofont (face-font face frame))
- font)
+ (let (font)
(if (null frame)
(let ((frames (frame-list)))
;; Make this face bold-italic in global-face-data.
(setq font (or font
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
- (and font (make-face-bold-italic-internal face frame font)))
- (or (not (equal ofont (face-font face)))
- (and (not noerror)
- (error "No bold italic version of %S" font))))))
+ (or (and font (make-face-bold-italic-internal face frame font))
+ ;; We failed to find a bold italic version.
+ noerror
+ (error "No bold italic version of %S" font))))))
(defun make-face-bold-italic-internal (face frame font)
(let (f2 f3)
(set-face-font face (if (memq 'italic (face-font face t))
'(italic) nil)
t)
- (let ((ofont (face-font face frame))
- font font1)
+ (let (font font1)
(if (null frame)
(let ((frames (frame-list)))
;; Make this face unbold in global-face-data.
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
(setq font (and font1 (x-make-font-unbold font1)))
- (if font (internal-try-face-font face font frame)))
- (or (not (equal ofont (face-font face)))
- (and (not noerror)
- (error "No unbold version of %S" font1))))))
+ (or (if font (internal-try-face-font face font frame))
+ noerror
+ (error "No unbold version of %S" font1))))))
(defun make-face-unitalic (face &optional frame noerror)
"Make the font of the given face be non-italic, if possible.
(set-face-font face (if (memq 'bold (face-font face t))
'(bold) nil)
t)
- (let ((ofont (face-font face frame))
- font font1)
+ (let (font font1)
(if (null frame)
(let ((frames (frame-list)))
;; Make this face unitalic in global-face-data.
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
(setq font (and font1 (x-make-font-unitalic font1)))
- (if font (internal-try-face-font face font frame)))
- (or (not (equal ofont (face-font face)))
- (and (not noerror)
- (error "No unitalic version of %S" font1))))))
+ (or (if font (internal-try-face-font face font frame))
+ noerror
+ (error "No unitalic version of %S" font1))))))
\f
(defvar list-faces-sample-text
"abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
(while faces
(copy-face (car faces) (car faces) frame disp-frame)
(setq faces (cdr faces)))))))
+
+(defun describe-face (face)
+ "Display the properties of face FACE."
+ (interactive (list (read-face-name "Describe face: ")))
+ (with-output-to-temp-buffer "*Help*"
+ (princ "Properties of face `")
+ (princ (face-name face))
+ (princ "':") (terpri)
+ (princ "Foreground: ") (princ (face-foreground face)) (terpri)
+ (princ "Background: ") (princ (face-background face)) (terpri)
+ (princ " Font: ") (princ (face-font face)) (terpri)
+ (princ "Underlined: ") (princ (if (face-underline-p face) "yes" "no")) (terpri)
+ (princ " Stipple: ") (princ (or (face-stipple face) "none"))))
\f
;;; Make the standard faces.
;;; The C code knows the default and modeline faces as faces 0 and 1,
;; Read this frame's geometry resource, if it has an explicit name,
;; and put the specs into PARAMETERS.
(let* ((name (or (cdr (assq 'name parameters))
- (cdr (assq 'name default-frame-alist))
- (cdr (assq 'name initial-frame-alist))))
+ (cdr (assq 'name default-frame-alist))))
(x-resource-name name)
(res-geometry (if name (x-get-resource "geometry" "Geometry")))
parsed)
(if (or (assq 'top parsed) (assq 'left parsed))
(setq parsed (cons '(user-position . t)
(cons '(user-size . t) parsed))))
- ;; All geometry parms apply to the initial frame.
- (setq parameters (append parameters parsed)))))
- (if (null global-face-data)
- (x-create-frame parameters)
- (let* ((visibility-spec (assq 'visibility parameters))
- (frame (x-create-frame (cons '(visibility . nil) parameters)))
- (faces (copy-alist global-face-data))
- success
- (rest faces))
- (unwind-protect
- (progn
- (set-frame-face-alist frame faces)
-
- (if (cdr (or (assq 'reverse parameters)
- (assq 'reverse default-frame-alist)
- (let ((resource (x-get-resource "reverseVideo"
- "ReverseVideo")))
- (if resource
- (cons nil (member (downcase resource)
- '("on" "true")))))))
- (let* ((params (frame-parameters frame))
- (bg (cdr (assq 'foreground-color params)))
- (fg (cdr (assq 'background-color params))))
- (modify-frame-parameters frame
- (list (cons 'foreground-color fg)
- (cons 'background-color bg)))
- (if (equal bg (cdr (assq 'border-color params)))
- (modify-frame-parameters frame
- (list (cons 'border-color fg))))
- (if (equal bg (cdr (assq 'mouse-color params)))
- (modify-frame-parameters frame
- (list (cons 'mouse-color fg))))
- (if (equal bg (cdr (assq 'cursor-color params)))
- (modify-frame-parameters frame
- (list (cons 'cursor-color fg))))))
- ;; Copy the vectors that represent the faces.
- ;; Also fill them in from X resources.
- (while rest
- (let ((global (cdr (car rest))))
- (setcdr (car rest) (vector 'face
- (face-name (cdr (car rest)))
- (face-id (cdr (car rest)))
- nil nil nil nil nil))
- (face-fill-in (car (car rest)) global frame))
- (make-face-x-resource-internal (cdr (car rest)) frame t)
- (setq rest (cdr rest)))
- (if (null visibility-spec)
- (make-frame-visible frame)
- (modify-frame-parameters frame (list visibility-spec)))
- (setq success t)
- frame)
- (or success
- (delete-frame frame))))))
+ ;; Put the geometry parameters at the end.
+ ;; Copy default-frame-alist so that they go after it.
+ (setq parameters (append parameters
+ default-frame-alist
+ parsed)))))
+ (let (frame)
+ (if (null global-face-data)
+ (setq frame (x-create-frame parameters))
+ (let* ((visibility-spec (assq 'visibility parameters))
+ (faces (copy-alist global-face-data))
+ success
+ (rest faces))
+ (setq frame (x-create-frame (cons '(visibility . nil) parameters)))
+ (unwind-protect
+ (progn
+ (set-frame-face-alist frame faces)
+
+ (if (cdr (or (assq 'reverse parameters)
+ (assq 'reverse default-frame-alist)
+ (let ((resource (x-get-resource "reverseVideo"
+ "ReverseVideo")))
+ (if resource
+ (cons nil (member (downcase resource)
+ '("on" "true")))))))
+ (let* ((params (frame-parameters frame))
+ (bg (cdr (assq 'foreground-color params)))
+ (fg (cdr (assq 'background-color params))))
+ (modify-frame-parameters frame
+ (list (cons 'foreground-color fg)
+ (cons 'background-color bg)))
+ (if (equal bg (cdr (assq 'border-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'border-color fg))))
+ (if (equal bg (cdr (assq 'mouse-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'mouse-color fg))))
+ (if (equal bg (cdr (assq 'cursor-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'cursor-color fg))))))
+ ;; Copy the vectors that represent the faces.
+ ;; Also fill them in from X resources.
+ (while rest
+ (let ((global (cdr (car rest))))
+ (setcdr (car rest) (vector 'face
+ (face-name (cdr (car rest)))
+ (face-id (cdr (car rest)))
+ nil nil nil nil nil))
+ (face-fill-in (car (car rest)) global frame))
+ (make-face-x-resource-internal (cdr (car rest)) frame t)
+ (setq rest (cdr rest)))
+ (if (null visibility-spec)
+ (make-frame-visible frame)
+ (modify-frame-parameters frame (list visibility-spec)))
+ (setq success t))
+ (or success
+ (delete-frame frame)))))
+ ;; Set up the background-mode frame parameter
+ ;; so that programs can decide good ways of highlighting
+ ;; on this frame.
+ (let ((bg-resource (x-get-resource ".backgroundMode"
+ "BackgroundMode"))
+ (params (frame-parameters frame))
+ (bg-mode))
+ (setq bg-mode
+ (cond (bg-resource (intern (downcase bg-resource)))
+ ((< (apply '+ (x-color-values
+ (cdr (assq 'background-color params))
+ frame))
+ (/ (apply '+ (x-color-values "white" frame)) 3))
+ 'dark)
+ (t 'light)))
+ (modify-frame-parameters frame
+ (list (cons 'background-mode bg-mode)
+ (cons 'display-type
+ (cond ((x-display-color-p frame)
+ 'color)
+ ((x-display-grayscale-p frame)
+ 'grayscale)
+ (t 'mono))))))
+ frame))
;; Update a frame's faces when we change its default font.
(defun frame-update-faces (frame)
;; Assuming COLOR is a valid color name,
;; return t if it can be displayed on FRAME.
(defun face-color-supported-p (frame color background-p)
- (or (x-display-color-p frame)
- ;; A black-and-white display can implement these.
- (member color '("black" "white"))
- ;; A black-and-white display can fake these for background.
- (and background-p
- (member color '("gray" "gray1" "gray3")))
- ;; A grayscale display can implement colors that are gray (more or less).
- (and (x-display-grayscale-p frame)
- (let* ((values (x-color-values color frame))
- (r (nth 0 values))
- (g (nth 1 values))
- (b (nth 2 values)))
- (and (< (abs (- r g)) (/ (abs (+ r g)) 20))
- (< (abs (- g b)) (/ (abs (+ g b)) 20))
- (< (abs (- b r)) (/ (abs (+ b r)) 20)))))))
+ (and window-system
+ (or (x-display-color-p frame)
+ ;; A black-and-white display can implement these.
+ (member color '("black" "white"))
+ ;; A black-and-white display can fake gray for background.
+ (and background-p
+ (face-color-gray-p color frame))
+ ;; A grayscale display can implement colors that are gray (more or less).
+ (and (x-display-grayscale-p frame)
+ (face-color-gray-p color frame)))))
;; Use FUNCTION to store a color in FACE on FRAME.
;; COLORS is either a single color or a list of colors.
(setq colors (cdr colors)))))))
;; If we are already using x-window frames, initialize faces for them.
-(if (eq (framep (selected-frame)) 'x)
+(if (or (eq (framep (selected-frame)) 'x) (eq (framep (selected-frame)) 'win32))
(face-initialize))
(provide 'faces)