;;; gawd-faces.el --- Startup code that sets face colours, for the Gordianet. ;;; Copyright (C) 1999--2011 Nix . ;; Author: Nix ;; Created: 1999-04-18 ;; Keywords: faces ;; This file is not part of XEmacs. ;;; Commentary: ;; Flashy colours and dark fruit salad. ;; We *like* fruit salad. ;;; Requirements: (eval-when-compile (require 'balloon-help) (require 'gnus-salt) (require 'jde) (require 'jde-checkstyle)) (require 'advice) ;;; Code: ;; My most important set of fonts get smashed by italicization in ways ;; that are too boring to determine. Just skip italicization for those ;; fonts. (defadvice make-face-italic (around nix-block-neep-make-face-italic activate compile) "Avoid italicizing the Neep faces." (unless (string-match "^Neep[^\w]" (font-name (face-font face locale tags exact-p))) ad-do-it)) (defadvice make-face-bold-italic (around nix-block-neep-make-face-bold-italic activate compile) "Avoid italicizing the Neep faces." (unless (string-match "^Neep[^\w]" (font-name (face-font face locale tags exact-p))) ad-do-it)) ;; We want to use lazy fontification (whereupon the size of the buffer ;; becomes irrelevant) with C support (to lower the CPU load of having ;; a huge pile of open buffers). (add-hook 'font-lock-mode-hook 'turn-on-lazy-shot) (setq lazy-shot-stealth-lines 50 lazy-shot-stealth-nice 0.5 lazy-shot-step-size 512) ;; Fontify even massive buffers; try oblique fonts first, because our ;; default face has no sanely-sized italic fonts (setq font-lock-maximum-size nil try-oblique-before-italic-fonts t) ;; Some convenience face-setting and -querying functions. (defsubst set-face-properties (face props) "Set lots of face properties at once. PROPS is a list of pairs of (PROPERTY VALUE [LOCALE TAG-SET HOW-TO-ADD])." (mapc #'(lambda (property) (apply 'set-face-property face property)) props) nil) (defsubst remove-face-properties (face props) "Remove lots of face properties at once, ignoring errors. PROPS is a list of pairs of (PROPERTY [LOCALE TAG-SET])." (mapc #'(lambda (property) (apply 'remove-face-property face property)) props) nil) (defun face-at-point (&optional pos buffer) "Return a list of faces being used at POS in BUFFER. The most important is listed first. By default, use `point' in the current buffer." (let ((upper-face-extent (extent-at (or pos (point buffer)) (or buffer (current-buffer)) 'face))) (if (not upper-face-extent) ; No face but `default'? 'default (extent-face upper-face-extent)))) (defun face-at-point-command (&optional pos buffer) "Print the name of the face at POS in BUFFER at the bottom of the frame. By default, use `point' in the current buffer." (interactive) (message "Face: %s" (face-at-point pos buffer))) ;; Set up font-lock-mode. ;; Force heavy fontification for certain languages. (setq font-lock-maximum-decoration t) ; Decorate everything lots ;; Change the colours. (make-face-italic 'font-lock-comment-face) (make-face-unbold 'font-lock-comment-face) (set-face-properties 'font-lock-comment-face '((foreground "grey45" nil x) (dim t) (underline nil))) (make-face-unbold 'font-lock-doc-string-face) (set-face-properties 'font-lock-doc-string-face '((foreground "steelblue1" nil x) (highlight t))) (make-face-unbold 'font-lock-string-face) (set-face-properties 'font-lock-string-face '((foreground "PaleVioletRed" nil x) (highlight t))) (make-face-bold 'font-lock-function-name-face) (set-face-properties 'font-lock-function-name-face '((foreground "white" nil x) (highlight nil) (underline nil))) (make-face-bold 'font-lock-variable-name-face) (set-face-properties 'font-lock-variable-name-face '((foreground "cyan" nil x) (underline nil))) (make-face-bold 'font-lock-keyword-face) (set-face-properties 'font-lock-keyword-face '((foreground "white" nil x) (highlight nil) (underline nil))) (make-face-italic 'font-lock-preprocessor-face) (set-face-properties 'font-lock-preprocessor-face '((foreground "lightblue" nil x) (underline nil) (italic t))) (set-face-properties 'font-lock-reference-face '((foreground "linen" nil x) (highlight t tty))) (set-face-foreground 'font-lock-type-face "lightsteelblue" nil 'x) ;; Non-font-lock customizations ;; The zmacs region is light green in X, and green on a TTY. (set-face-properties 'zmacs-region '((foreground "Black") (background "LightGreen" nil x) (background "green" nil tty))) (copy-face 'zmacs-region 'highlight) ; And the same for keyboard selections/highlights... (copy-face 'zmacs-region 'primary-selection) ; ... and the primary selection. (copy-face 'primary-selection 'secondary-selection) (set-face-properties 'secondary-selection '((background "darkolivegreen" nil x) (dim t))) (set-face-properties 'isearch '((background "dimgrey" nil x) (background "grey" nil tty))) (set-face-properties 'text-cursor '((background "white" nil x))) (set-face-properties 'pointer '((foreground "Black" nil x) (background "White" nil x))) (set-face-properties 'list-mode-item-selected '((background "dodgerblue" nil x))) ;; Ediff customizations (defun gawd-sanitize-ediff-faces () "Set the ediff faces to something legible on a dark background." (set-face-properties 'ediff-even-diff-A '((foreground "White" nil x) (background "Black" nil x) (background-pixmap "dark-grey-marble.xpm"))) (copy-face 'ediff-even-diff-A 'ediff-even-diff-C) (set-face-background-pixmap 'ediff-even-diff-C "dark-yellow-marble.xpm") (set-face-properties 'ediff-even-diff-B '((foreground "LightSteelBlue" nil x) (background "Black" nil x) (background-pixmap "dark-purple-marble.xpm"))) (copy-face 'ediff-even-diff-B 'ediff-even-diff-Ancestor) (copy-face 'ediff-even-diff-A 'ediff-odd-diff-A) (set-face-background-pixmap 'ediff-odd-diff-A "really-dark-grey-marble.xpm") (copy-face 'ediff-odd-diff-A 'ediff-odd-diff-C) (set-face-background-pixmap 'ediff-odd-diff-C "really-dark-yellow-marble.xpm") (copy-face 'ediff-even-diff-B 'ediff-odd-diff-B) (set-face-background-pixmap 'ediff-odd-diff-B "really-dark-purple-marble.xpm") (copy-face 'ediff-odd-diff-B 'ediff-odd-diff-Ancestor) (set-face-properties 'ediff-fine-diff-A '((foreground "darkblue") (background "navy") (background-pixmap "grey-marble.xpm"))) (set-face-properties 'ediff-fine-diff-A '((foreground "darkblue") (background "navy") (background-pixmap "grey-marble.xpm"))) (set-face-properties 'ediff-fine-diff-B '((foreground "black") (background "Yellow") (background-pixmap "yellow-marble.xpm"))) (set-face-properties 'ediff-fine-diff-C '((foreground "yellow") (background "skyblue") (background-pixmap "purple-marble.xpm")))) (add-hook 'ediff-load-hook 'gawd-sanitize-ediff-faces) ;; w3m customizations (defmacro gawd-sanitize-some-w3m-faces (face-pixmap-alist) "Set the w3m faces to something sane. The FACE-PIXMAP-ALIST is an alist mapping faces to pixmaps." (list 'map nil #'(lambda (face pixmap) (remove-face-properties face `((foreground nil x) (background-pixmap nil x))) (set-face-properties face `((foreground "black" nil x) (underline nil x) (background-pixmap ,pixmap nil x)))) (list 'quote (mapcar* 'car (eval face-pixmap-alist))) (list 'quote (mapcar* 'cdr (eval face-pixmap-alist))))) (defun gawd-sanitize-general-w3m-faces () "Set the general (non-forms) w3m faces to something sane. Specifically, turn off (horrible-looking) underlining, and use a background pixmap instead." (gawd-sanitize-some-w3m-faces '((w3m-anchor-face . "yellow-marble.xpm") (w3m-arrived-anchor-face . "dark-yellow-marble.xpm")))) (defun gawd-sanitize-forms-w3m-faces () "Set the general (form-related) w3m faces to something sane. Specifically, turn off (horrible-looking) underlining, and use a background pixmap instead." (gawd-sanitize-some-w3m-faces '((w3m-form-face . "purple-marble.xpm")))) (add-hook 'w3m-load-hook 'gawd-sanitize-general-w3m-faces) (add-hook 'w3m-forms-load-hook 'gawd-sanitize-forms-w3m-faces) ;; ERC customizations (defun gawd-sanitize-erc-faces () "Set the faces for the ERC client to something sane. This is pretty much an inversion of the preexisting colours." (set-face-properties 'erc-direct-msg-face '((foreground "hotpink" nil x) (foreground "brightred" nil tty))) (set-face-properties 'erc-highlight-face '((foreground "green" nil tty))) (set-face-properties 'erc-host-danger-face '((foreground "magenta"))) (remove-face-property 'erc-input-face 'background) (set-face-properties 'erc-input-face '((foreground "white" nil tty))) (set-face-properties 'erc-inverse-face '((foreground "black") (background "white"))) (make-face-unbold 'erc-notice-face) (make-face-italic 'erc-notice-face) (set-face-properties 'erc-notice-face '((foreground "lightsteelblue" nil x) (foreground "blue" nil tty))) (set-face-properties 'erc-pal-face '((foreground "antiquewhite" nil x) (foreground "white" nil tty))) (set-face-properties 'erc-prompt-face '((background "black") (foreground "lightblue2" nil x) (foreground "blue" nil tty))) (set-face-background 'bg:erc-color-face0 "black") (set-face-background 'bg:erc-color-face1 "White") (set-face-background 'fg:erc-color-face0 "black") (set-face-background 'fg:erc-color-face1 "White")) (add-hook 'erc-load-hook 'gawd-sanitize-erc-faces) ;; Message-mode customizations (defun gawd-sanitize-message-faces () "Set the faces used in email responses to something sane." (set-face-foreground 'message-cited-text "tan" nil 'x) (set-face-foreground 'message-cited-text "brightred" nil 'tty)) (add-hook 'message-load-hook 'gawd-sanitize-message-faces) ;; Set mode line colours &c ;; The colours for face `default' must be set in X resources ;; or the background mode does not get set correctly. ; All modeline faces have a dark slate-grey background. (mapc #'(lambda (face) (set-face-background face "#102060" nil 'x)) (mapcan #'(lambda (face) (and (string-match "^modeline-?" (symbol-name face)) (list face))) (face-list))) ; Make the `vc-mode-face' point at something sensible... (setq vc-mode-face 'modeline-mousable) (set-face-foreground 'modeline "chartreuse" nil 'x) (set-face-foreground 'modeline-buffer-id "palegoldenrod" nil 'x) (set-face-foreground 'modeline-mousable "burlywood" nil 'x) (set-face-foreground 'modeline-mousable-minor-mode "lightseagreen" nil 'x) (setq gnus-selected-tree-face 'isearch) ; `modeline', the default, is quite unreadable now ;; Colour the buffer tabs sanely; make the toolbar vanish. (set-specifier default-toolbar-visible-p nil) (set-face-background 'buffers-tab "Black") ;; Make the echo area glow lightseagreen (or green on ttys) (make-face 'echo-area-face "Face used to display the echo area.") (set-face-properties 'echo-area-face '((foreground "lightseagreen" nil x) (foreground "brightgreen" nil tty))) ; Oh, yuck. Changes to the echo area don't take effect unless it is the ; current buffer. Thank you, redisplay. (save-excursion (set-buffer " *Echo Area*") (let ((echo-area-face-extent (make-extent (point-min) (point-max)))) (set-extent-properties echo-area-face-extent '(end-open nil detachable nil)) (set-extent-face echo-area-face-extent 'echo-area-face))) ;; balloon-help customizations (setq balloon-help-foreground (color-instance-name (face-property-instance 'echo-area-face 'foreground))) (setq balloon-help-background (color-instance-name (face-property-instance 'echo-area-face 'background))) (setq balloon-help-background-pixmap "dark-purple-marble.xpm") (setq balloon-help-border-color "mintcream") (setq balloon-help-font "-adobe-new century schoolbook-medium-r-normal-*-*-120-*-*-p-*-iso-10646-1") ;; Fix up paren blinking colours; blink between bold and normal, not between ;; selected (bright green, hence unreadable!) and black (hence unreadable). (copy-face 'default 'paren-match) (make-face-bold 'paren-match) ; It would be nice if we could just copy the `default' face to ; `paren-blink-off'; but paren.el uses `face-differs-from-default-p' ; to tell whether to redefine the face, so this change would be ; instantly stamped on. As an ugly crock workaround, we add ; properties to the face's X domain that get ignored by X, and to the ; face's TTY domain that get ignored by a TTY. (copy-face 'default 'paren-blink-off) (set-face-properties 'paren-blink-off '((dim t nil x) (background-pixmap "foo" nil tty))) (provide 'gawd-faces)