-;; Creating and Remapping Faces
-
-
-(require 'font-lock)
-
-
-;; The definition below is necessary because some emacs variant does not
-;; define it on font-lock package.
-
-(defvar font-lock-face-attributes nil)
-
-
-;;;###autoload
-(defun ps-new-faces (face-screen &optional face-extension override-p merge-p)
- "Create new faces from FACE-SCREEN.
-
-The FACE-SCREEN elements are added to `font-lock-face-attributes'.
-If optional OVERRIDE-P is non-nil, faces that already exist in
-`font-lock-face-attributes' are overrided.
-
-If optional MERGE-p is non-nil, extensions in FACE-EXTENSION are merged with
-face extension in `ps-print-face-extension-alist'; otherwise, overrides.
-
-The arguments FACE-SCREEN and FACE-EXTENSION are lists whose elements are:
-
- (FACE-NAME FOREGROUND BACKGROUND EXTENSION...)
-
-FACE-NAME is a face name.
-
-FOREGROUND and BACKGROUND may be nil or a string that denotes the
-foreground and background colors respectively.
-
-EXTENSION is some valid extension symbol (see `ps-extend-face')."
- (let ((mapfun (if override-p
- '(lambda (face)
- (let ((face-attributes (ps-extension-to-screen-face face)))
- (font-lock-make-face face-attributes)
- (ps-override-list 'font-lock-face-attributes
- face-attributes)
- (ps-override-list 'ps-print-face-extension-alist
- (ps-extension-to-bit-face face))))
- '(lambda (face)
- (let ((face-attributes (ps-extension-to-screen-face face)))
- (font-lock-make-face face-attributes)
- (add-to-list 'font-lock-face-attributes
- face-attributes)
- (add-to-list 'ps-print-face-extension-alist
- (ps-extension-to-bit-face face))))
- ))
- maplist)
- (mapcar mapfun face-screen)
- (ps-extend-face-list face-extension merge-p)))
-
-
-(defun ps-override-list (sym-list element)
- (let ((maplist (assq (car element) (symbol-value sym-list))))
- (if maplist
- (setcdr maplist (cdr element))
- (set sym-list (cons element (symbol-value sym-list)))
- )))
-
-
-(defun ps-extension-to-bit-face (face-extension)
- (cons (nth 0 face-extension)
- (vector (ps-extension-bit face-extension)
- (nth 1 face-extension)
- (nth 2 face-extension))))
-
-
-(defun ps-extension-to-screen-face (face)
- (let ((face-name (nth 0 face))
- (face-foreground (nth 1 face))
- (face-background (nth 2 face))
- (face-attributes (nthcdr 3 face)))
- (list face-name face-foreground face-background
- (and (memq 'bold face-attributes) t)
- (and (memq 'italic face-attributes) t)
- (and (memq 'underline face-attributes) t))))