home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / prim / faces.el < prev    next >
Encoding:
Text File  |  1993-02-17  |  14.3 KB  |  370 lines
  1. ;; Lisp interface to the c "face" structure.
  2. ;; Copyright (C) 1992-1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (defsubst facep (x)
  21.   (and (vectorp x) (= (length x) 8) (eq (aref x 0) 'face)))
  22.  
  23. (defmacro check-face (face)
  24.   (` (while (not (facep (, face)))
  25.        (setq (, face) (signal 'wrong-type-argument (list 'facep (, face)))))))
  26.  
  27.  
  28. (defvar global-face-data nil "do not use this")
  29. (defvar face-id-tick 0 "don't even think of using this")
  30.  
  31. (defun list-faces ()
  32.   "Returns a list of the names of all of the defined faces."
  33.   (mapcar 'car global-face-data))
  34.  
  35. (defun find-face (name &optional screen)
  36.   "Retrieve the face of the given name.
  37. If NAME is a symbol and SCREEN is provided, the face is looked up on
  38. that screen; otherwise, the selected screen is used.
  39. If there is no such face, returns nil.
  40. If SCREEN is the symbol t, then the global, non-screen face is returned.
  41. If NAME is already a face, it is simply returned."
  42.   (if (and (eq screen t) (not (symbolp name)))
  43.       (setq name (face-name name)))
  44.   (if (symbolp name)
  45.       (cdr (assq name
  46.          (if (eq screen t)
  47.              global-face-data
  48.            (screen-face-alist (or screen (selected-screen))))))
  49.     (check-face name)
  50.     name))
  51.  
  52. (defun get-face (name &optional screen)
  53.   "Retrieve the face of the given name.
  54. If NAME is a symbol and SCREEN is provided, the face is looked up on
  55. that screen; otherwise, the selected screen is used.
  56. If there is no such face, an error is signalled.  See also `find-face'.
  57. If SCREEN is the symbol t, then the global, non-screen face is returned.
  58. If NAME is already a face, it is simply returned."
  59.   (or (find-face name screen)
  60.       (check-face name)))
  61.  
  62. (defsubst face-name (face)
  63.   "Returns the name of the given face."
  64.   (aref (get-face face) 1))
  65.  
  66. (defsubst face-id (face)
  67.   "Returns the internal ID number of the given face."
  68.   (aref (get-face face) 2))
  69.  
  70. (defsubst face-font (face &optional screen)
  71.   "Returns the font name of the given face, or nil if it is unspecified."
  72.   (aref (get-face face screen) 3))
  73.  
  74. (defsubst face-foreground (face &optional screen)
  75.   "Returns the foreground color name of the given face, or nil if unspecified."
  76.   (aref (get-face face screen) 4))
  77.  
  78. (defsubst face-background (face &optional screen)
  79.   "Returns the background color name of the given face, or nil if unspecified."
  80.   (aref (get-face face screen) 5))
  81.  
  82. (defsubst face-background-pixmap (face &optional screen)
  83.  "Returns the background pixmap name of the given face, or nil if unspecified."
  84.  (aref (get-face face screen) 6))
  85.  
  86. (defsubst face-underline-p (face &optional screen)
  87.  "Returns whether the given face is underlined."
  88.  (aref (get-face face screen) 7))
  89.  
  90.  
  91. (defun set-face-1 (face name value index screen)
  92.   (let ((inhibit-quit t))
  93.     (if (null screen)
  94.     (let ((screens (screen-list)))
  95.       (while screens
  96.         (set-face-1 (face-name face) name value index (car screens))
  97.         (setq screens (cdr screens)))
  98.       (aset (get-face (if (symbolp face) face (face-name face)) t)
  99.         index value)
  100.       value)
  101.       (or (eq screen t)
  102.       (set-face-attribute-internal (face-id face) name value screen))
  103.       (aset (get-face face screen) index value))))
  104.  
  105.  
  106. (defun read-face-name (prompt)
  107.   (let (face)
  108.     (while (= (length face) 0)
  109.       (setq face (completing-read prompt
  110.                   (mapcar '(lambda (x) (list (symbol-name x)))
  111.                       (list-faces))
  112.                   nil t)))
  113.     (intern face)))
  114.  
  115. (defun face-interactive (what &optional bool)
  116.   (let* ((fn (intern (concat "face-" what)))
  117.      (prompt (concat "Set " what " of face"))
  118.      (face (read-face-name (concat prompt ": ")))
  119.      (default (if (fboundp fn)
  120.               (or (funcall fn face (selected-screen))
  121.               (funcall fn 'default (selected-screen)))))
  122.      (value (if bool
  123.             (y-or-n-p (concat "Should face " (symbol-name face)
  124.                       " be " bool "? "))
  125.           (read-string (concat prompt " " (symbol-name face) " to: ")
  126.                    default))))
  127.     (list face (if (equal value "") nil value))))
  128.  
  129.  
  130. (defsubst set-face-font (face font &optional screen)
  131.   "Change the font of the given face.  The font should be a string, the name
  132. string, the name of the font.  If the optional SCREEN argument is provided, 
  133. this face will be changed only in that screen\; otherwise it will be changed
  134. in all screens."
  135.   (interactive (face-interactive "font"))
  136.   (set-face-1 face 'font font 3 screen))
  137.  
  138. (defsubst set-face-foreground (face color &optional screen)
  139.   "Change the foreground color of the given face.  The color should be a 
  140. string, the name of a color.  If the optional SCREEN argument is provided, 
  141. this face will be changed only in that screen; otherwise it will be changed 
  142. in all screens."
  143.   (interactive (face-interactive "foreground"))
  144.   (set-face-1 face 'foreground color 4 screen))
  145.  
  146. (defsubst set-face-background (face color &optional screen)
  147.   "Change the background color of the given face.  The color should be a 
  148. string, the name of a color.  If the optional SCREEN argument is provided, 
  149. this face will be changed only in that screen; otherwise it will be changed 
  150. in all screens."
  151.   (interactive (face-interactive "background"))
  152.   (set-face-1 face 'background color 5 screen))
  153.  
  154. (defsubst set-face-background-pixmap (face name &optional screen)
  155.   "Change the background pixmap of the given face.  The pixmap name should be
  156. a string, the name of a file of pixmap data.  The directories listed in the
  157. x-bitmap-file-path variable will be searched.  The bitmap may also be a list
  158. of the form (width height data) where width and height are the size in pixels,
  159. and data is a string, containing the raw bits of the bitmap.  
  160. If the optional SCREEN argument is provided, this face will be changed only
  161. in that screen\; otherwise it will be changed in all screens."
  162.   (interactive (face-interactive "background-pixmap"))
  163.   (set-face-1 face 'background-pixmap name 6 screen))
  164.  
  165. (defsubst set-face-underline-p (face underline-p &optional screen)
  166.   "Change whether the given face is underlined.  
  167. If the optional SCREEN argument is provided, this face will be changed only
  168. in that screen\; otherwise it will be changed in all screens."
  169.   (interactive (face-interactive "underline-p" "underlined"))
  170.   (set-face-1 face 'underline underline-p 7 screen))
  171.  
  172.  
  173. (defun make-face (name)
  174.   "Defines and returns a new FACE on all screens.  
  175. You can modify the font, color, etc of this face with the set-face- functions.
  176. If the face already exists, it is unmodified."
  177.   (or (find-face name)
  178.       (let ((face (make-vector 8 nil)))
  179.     (aset face 0 'face)
  180.     (aset face 1 name)
  181.     (let* ((screens (screen-list))
  182.            (inhibit-quit t)
  183.            (id face-id-tick))
  184.       (make-face-internal name face id) ; may error
  185.       (setq face-id-tick (1+ face-id-tick)) ; now it's safe
  186.       (while screens
  187.         (aset (get-face name (car screens)) 2 id)
  188.         (setq screens (cdr screens)))
  189.       (setq face (copy-sequence face))
  190.       (aset face 2 id)
  191.       (setq global-face-data (cons (cons name face) global-face-data)))
  192.     ;; when making a face after screens already exist
  193.     (if (eq window-system 'x)
  194.         (x-resource-face face))
  195.     face)))
  196.  
  197. (defun copy-face (old-face new-name &optional screen)
  198.   "Defines and returns a new face which is a copy of an existing one,
  199. or makes an already-existing face be exactly like another."
  200.   (setq old-face (get-face old-face screen))
  201.   (let* ((inhibit-quit t)
  202.      (new-face (or (find-face new-name screen)
  203.                (make-face new-name))))
  204.     (if (null screen)
  205.     (let ((screens (screen-list)))
  206.       (while screens
  207.         (copy-face old-face new-name (car screens))
  208.         (setq screens (cdr screens)))
  209.       (copy-face old-face new-name t))
  210.       (set-face-font new-face (face-font old-face screen) screen)
  211.       (set-face-foreground new-face (face-foreground old-face screen) screen)
  212.       (set-face-background new-face (face-background old-face screen) screen)
  213.       (set-face-background-pixmap
  214.        new-face (face-background-pixmap old-face screen) screen)
  215.       (set-face-underline-p new-face (face-underline-p old-face screen)
  216.                 screen))
  217.     new-face))
  218.  
  219. (defun set-extent-face (extent face)
  220.   "Make the given EXTENT have the graphic attributes specified by FACE."
  221.   (set-extent-attribute extent (face-id face)))
  222.  
  223. (defun extent-face (extent)
  224.   "Returns the name of the face in which EXTENT is displayed."
  225.   (let ((id (extent-attributes extent t))
  226.     (rest global-face-data)
  227.     face)
  228.     (if (= id -1) (setq id 0))
  229.     (while rest
  230.       (if (= id (face-id (cdr (car rest))))
  231.       (setq face (car (car rest)) rest nil))
  232.       (setq rest (cdr rest)))
  233.     (or face (error "unknown face??"))))
  234.  
  235.  
  236. (defun face-equal (face1 face2 &optional screen)
  237.   "True if the given faces will display in the the same way."
  238.   (setq face1 (get-face face1 screen)
  239.     face2 (get-face face2 screen))
  240.   (and (equal (face-foreground face1 screen) (face-foreground face2 screen))
  241.        (equal (face-background face1 screen) (face-background face2 screen))
  242.        (equal (face-font face1 screen) (face-font face2 screen))
  243.        (equal (face-background-pixmap face1 screen)
  244.           (face-background-pixmap face2 screen))))
  245.  
  246. (defun face-differs-from-default-p (face &optional screen)
  247.   "True if the given face will display differently from the default face.
  248. A face is considered to be ``the same'' as the default face if it is 
  249. actually specified in the same way (equivalent fonts, etc) or if it is 
  250. fully unspecified, and thus will inherit the attributes of any face it 
  251. is displayed on top of."
  252.   (let ((default (get-face 'default screen)))
  253.     (setq face (get-face face screen))
  254.     (not (and (or (equal (face-foreground default screen)
  255.              (face-foreground face screen))
  256.           (null (face-foreground face screen)))
  257.           (or (equal (face-background default screen)
  258.              (face-background face screen))
  259.           (null (face-background face screen)))
  260.           (or (equal (face-font default screen) (face-font face screen))
  261.           (null (face-font face screen)))
  262.           (or (equal (face-background-pixmap default screen)
  263.              (face-background-pixmap face screen))
  264.           (null (face-background-pixmap face screen)))
  265.           (equal (face-underline-p default screen)
  266.              (face-underline-p face screen))
  267.           ))))
  268.  
  269.  
  270. (defun invert-face (face &optional screen)
  271.   "Swap the foreground and background colors of the given face.
  272. If the face doesn't specify both foreground and background, then
  273. its foreground and background are set to the background and
  274. foreground of the default face."
  275.   (interactive (list (read-face-name "Invert face: ")))
  276.   (setq face (get-face face screen))
  277.   (let ((fg (face-foreground face screen))
  278.     (bg (face-background face screen)))
  279.     (if (or fg bg)
  280.     (progn
  281.       (set-face-foreground face bg screen)
  282.       (set-face-background face fg screen))
  283.       (set-face-foreground face (face-background 'default screen) screen)
  284.       (set-face-background face (face-foreground 'default screen) screen)))
  285.   face)
  286.  
  287.  
  288. (defun try-face-font (face font &optional screen)
  289.   "Like set-face-font, but returns nil on failure instead of an error."
  290.   (condition-case ()
  291.       (set-face-font face font screen)
  292.     (error nil)))
  293.  
  294.  
  295. (defun set-default-font (font)
  296.   "Sets the font used for normal text and the modeline to FONT in all screens.
  297. For finer-grained control, use set-face-font."
  298.   (interactive (list (read-string "Set default font: "
  299.                   (face-font 'default (selected-screen)))))
  300.   (set-face-font 'default font)
  301.   (set-face-font 'modeline font))
  302.  
  303.  
  304. ;;; This is called from make-screen (well, x-create-screen) just before
  305. ;;; the create-screen-hook is run.  This is responsible for making sure
  306. ;;; that the "default" and "modeline" faces for this screen have enough
  307. ;;; attributes specified for emacs to be able to display anything on it.
  308. ;;; This had better not signal an error.
  309.  
  310. (defun make-screen-initial-faces ()
  311.   (let* ((faces (copy-alist global-face-data))
  312.      (screen (selected-screen))
  313.      (rest faces)
  314.      default modeline)
  315.     (set-screen-face-alist screen faces)
  316.     (while rest
  317.       (setcdr (car rest) (copy-sequence (cdr (car rest))))
  318.       (if (eq window-system 'x)
  319.       (x-resource-face (cdr (car rest)) screen t))
  320.       (setq rest (cdr rest)))
  321.  
  322.     (setq default (get-face 'default screen)
  323.       modeline (get-face 'modeline screen))
  324.     
  325.     (if (eq window-system 'x)
  326.     (x-initialize-screen-faces screen))
  327.     ;;
  328.     ;; If the "default" face and the "modeline" face would display the same
  329.     ;; (meaning they have the same values, or the modeline values are
  330.     ;; unspecified and would thus inherit the "default" values) then change
  331.     ;; the modeline to be inverse-video w.r.t. the default face.  If the
  332.     ;; user really wants the modeline to look just like buffer text, which
  333.     ;; I can't imagine anyone actually wanting, they can do it by calling
  334.     ;; set-face-{fore,back}ground on 'modeline from their .emacs file.
  335.     ;;
  336.     (or (face-differs-from-default-p modeline screen)
  337.     (progn
  338.       (set-face-foreground modeline (face-background default screen)
  339.                    screen)
  340.       (set-face-background modeline (face-foreground default screen)
  341.                    screen)))
  342.  
  343.     ;; now make sure the modeline face is fully qualified.
  344.     (if (and (not (face-font modeline screen)) (face-font default screen))
  345.     (set-face-font modeline (face-font default screen) screen))
  346.     (if (and (not (face-background modeline screen))
  347.          (face-background default screen))
  348.     (set-face-background modeline (face-background default screen) screen))
  349.     (if (and (not (face-foreground modeline screen))
  350.          (face-foreground default screen))
  351.     (set-face-foreground modeline (face-foreground default screen) screen))
  352.     ))
  353.  
  354.  
  355. ;;; Make the builtin faces; the C code knows these as faces 0, 1, and 2,
  356. ;;; respectively, so they must be the first three faces made.
  357.  
  358. (if (find-face 'default)
  359.     nil
  360.   (make-face 'default)
  361.   (make-face 'modeline)
  362.   (make-face 'highlight)
  363.   ;;
  364.   ;; These aren't really special in any way, but they're nice to have around.
  365.   ;; The X-specific code is clever at them.
  366.   ;;
  367.   (make-face 'bold)
  368.   (make-face 'italic)
  369.   (make-face 'bold-italic))
  370.