;;; gawd-faces.el --- Startup code that sets face colours, for the Gordianet.

;;; Copyright (C) 1999--2011 Nix <nix@esperi.org.uk>.

;; Author: Nix <nix@esperi.demon.co.uk>
;; 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)