comparison lisp/ps-print.el @ 23550:d8a958630c9d

User option for multibyte buffer handling and doc fix. (ps-multibyte-buffer): New user option. (ps-setup): Print new user option. (ps-print-quote): New fun. (ps-color-p, ps-mule-font-info-database-latin): New var. (ps-default-color, ps-mule-font-info-database) (ps-mule-font-info-database-ps-bdf): Adjust initialization. (ps-mule-get-font-spec, ps-mule-begin, ps-begin-file) (ps-plot-with-face, ps-generate-postscript-with-faces, ps-generate): Little code improvement. (ps-mule-initialize): Initialize ps-mule-font-info-database. (ps-print-prologue-header, ps-font-family, ps-font-size) (ps-header-font-family, ps-header-font-size, ps-header-title-font-size) (ps-build-face-reference, ps-mule-font-info-database-bdf) (ps-mule-external-libraries, ps-mule-init-external-library) (ps-mule-prepare-font, ps-mule-find-wrappoint, ps-mule-plot-string): doc fix. To make it work also on Emacs 20.2 and the earlier version, check the value of mule-version. (ps-print-version): New version number (4.1.1) and doc fix. (ps-print-prologue-header): New user option. (ps-color-values, ps-xemacs-face-kind-p, ps-mapper, ps-extent-sorter): Conditional compilation for GNU Emacs and emacsens. (ps-generate-postscript-with-faces): Skip invisible text better. (ps-setup): Print new user option. (ps-print-preprint): Check if input file name exists and is unwritable. (ps-begin-file): Adjust PostScript prologue header for duplex printers and insert user PostScript prologue header comments. (ps-mule-encode-bit, ps-mule-string-ascii, ps-mule-string-encoding): New funs. (dos-ps-printer, lazy-lock-fontify-buffer): Eliminated. (ps-mule-prologue, ps-mule-cmpchar-prologue, ps-mule-bitmap-prologue): PostScript programming normalization. (ps-mule-encode-7bit, ps-mule-encode-8bit, ps-mule-generate-font) (ps-mule-generate-glyphs, ps-mule-prepare-font, ps-mule-plot-string) (ps-mule-skip-same-charset, ps-mule-plot-rule-cmpchar) (ps-mule-plot-cmpchar, ps-mule-prepare-cmpchar-font) (ps-mule-initialize, ps-mule-begin, ps-face-bold-p, ps-do-despool): Programming style normalization.

23549:aab4ef022ffd

;; Author:	Vinicius Jose Latorre <[e-mail]>
;; Author:	Kenichi Handa <[e-mail]> (multibyte characters)
;; Maintainer:	Kenichi Handa <[e-mail]> (multibyte characters)
;; Maintainer:	Vinicius Jose Latorre <[e-mail]>
;; Keywords:	print, PostScript
;; Time-stamp:	<98/09/18   9:51:23 vinicius>
;; Version:	4.1

(defconst ps-print-version "4.1"
  "ps-print.el, v 4.1 <98/09/18 vinicius>

Vinicius's last change version -- this file may have been edited as part of
Emacs without changes to the version number.  When reporting bugs,
please also report the version of Emacs, if any, that ps-print was
distributed with.

;; About ps-print
;; --------------
;;
;; This package provides printing of Emacs buffers on PostScript
;; printers; the buffer's bold and italic text attributes are
;; preserved in the printer output.  Ps-print is intended for use with
;; Emacs 19 or Lucid Emacs, together with a fontifying package such as
;; font-lock or hilit.
;;
;; ps-print uses the same face attributes defined through font-lock or hilit
;; to print a PostScript file, but some faces are better seeing on the screen

;; Using ps-print
;; --------------
;;
;; The Commands
;;
;; Ps-print provides eight commands for generating PostScript images
;; of Emacs buffers:
;;
;;        ps-print-buffer
;;        ps-print-buffer-with-faces
;;        ps-print-region

;; files (mail messages or netnews articles) to save paper that would
;; otherwise be wasted on banner pages, and to make it easier to find
;; your output at the printer (it's easier to pick up one 50-page
;; printout than to find 50 single-page printouts).
;;
;; Ps-print has a hook in the `kill-emacs-hook' so that you won't
;; accidentally quit from Emacs while you have unprinted PostScript
;; waiting in the spool buffer.  If you do attempt to exit with
;; spooled PostScript, you'll be asked if you want to print it, and if
;; you decline, you'll be asked to confirm the exit; this is modeled
;; on the confirmation that Emacs uses for modified buffers.

;; `lpr-command' and `lpr-switches'.
;;
;; Make sure that they contain appropriate values for your system;
;; see the usage notes below and the documentation of these variables.
;;
;; NOTE: `ps-lpr-command' and `ps-lpr-switches' take their initial values
;;       from the variables `lpr-command' and `lpr-switches'.  If you have
;;       `lpr-command' set to invoke a pretty-printer such as `enscript',
;;       then ps-print won't work properly.  `ps-lpr-command' must name
;;       a program that does not format the files it prints.
;;
;;
;; The Page Layout
;; ---------------
;;

;;
;;
;; Headers
;; -------
;;
;; Ps-print can print headers at the top of each column or at the top
;; of each page; the default headers contain the following four items:
;; on the left, the name of the buffer and, if the buffer is visiting
;; a file, the file's directory; on the right, the page number and
;; date of printing.  The default headers look something like this:
;;

;; aborting the print job, this kind of error can be hard to track down.
;;
;; Consider yourself warned!
;;
;;
;; Duplex Printers
;; ---------------
;;
;; If you have a duplex-capable printer (one that prints both sides of
;; the paper), set `ps-spool-duplex' to t.
;; Ps-print will insert blank pages to make sure each buffer starts
;; on the correct side of the paper.
;; Don't forget to set `ps-lpr-switches' to select duplex printing
;; for your printer.
;;
;;

;; The default is `control-8-bit'.
;;
;; Characters TAB, NEWLINE and FORMFEED are always treated by ps-print engine.
;;
;;
;; Printing Multi-Byte Buffer
;; --------------------------
;;
;; ps-print can print multi-byte buffer.
;;
;; If you are using only Latin-1 characters, you don't need to do anything else.
;;
;; If you have a japanese or korean PostScript printer, you can print ASCII,
;; Latin-1, Japanese (JISX0208, and JISX0201-Kana) and Korean characters by
;; setting:
;;
;;	(setq ps-mule-font-info-database ps-mule-font-info-database-ps)
;;
;; At present, it was not tested the korean characters printing.  If you have
;; a korean PostScript printer, please verify it.
;;
;; If you use any other kind of character, you need to install intlfonts-1.1.
;; So you can print using BDF fonts contained in intlfonts-1.1.  To print using
;; BDF fonts, do the following settings:
;;
;;   (1) Set the variable `bdf-directory-list' appropriately (see bdf.el for
;;       documentation of this variable).
;;
;;   (2) (setq ps-mule-font-info-database-ps ps-mule-font-info-database-bdf)
;;
;;
;; Line Number
;; -----------
;;

;;
;;
;; Hooks
;; -----
;;
;; Ps-print has the following hook variables:
;;
;; `ps-print-hook'
;;    It is evaluated once before any printing process.  This is the right
;;    place to initialize ps-print global data.
;;    For an example, see section Adding a New Font Family.

;;
;;
;; Font Managing
;; -------------
;;
;; Ps-print now knows rather precisely some fonts:
;; the variable `ps-font-info-database' contains information
;; for a list of font families (currently mainly `Courier' `Helvetica'
;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk').
;; Each font family contains the font names for standard, bold, italic
;; and bold-italic characters, a reference size (usually 10) and the

;;              (w3-table-hack-x-face . "LineDrawNormal"))
;;       (size . 10.0)
;;       (line-height . 10.55)
;;       (space-width . 6.0)
;;       (avg-char-width . 6.0))
;; Now you can use your new font family with any size:
;;	(setq ps-font-family 'my-mixed-family)
;;
;; Note that on above example the `w3-table-hack-x-face' entry refers to
;; a face symbol, so when printing this face it'll be used the font

;;      (setq ps-underlined-faces '(my-green-face))
;;
;; Faces like bold-italic that are both bold and italic should go in
;; *both* lists.
;;
;; Ps-print keeps internal lists of which fonts are bold and which are
;; italic; these lists are built the first time you invoke ps-print.
;; For the sake of efficiency, the lists are built only once; the same
;; lists are referred in later invocations of ps-print.
;;
;; Because these lists are built only once, it's possible for them to

;;
;;
;; How Ps-Print Deals With Color
;; -----------------------------
;;
;; Ps-print detects faces with foreground and background colors
;; defined and embeds color information in the PostScript image.
;; The default foreground and background colors are defined by the
;; variables `ps-default-fg' and `ps-default-bg'.
;; On black-and-white printers, colors are displayed in grayscale.
;; To turn off color output, set `ps-print-color-p' to nil.

;;
;;
;; How Ps-Print Has A Text And/Or Image On Background
;; --------------------------------------------------
;;
;; Ps-print can print texts and/or EPS PostScript images on background; it is
;; possible to define the following text attributes: font name, font size,
;; initial position, angle, gray scale and pages to print.
;;
;; It has the following EPS PostScript images attributes: file name containing
;; the image, initial position, X and Y scales, angle and pages to print.

;;
;;
;; New since version 2.8
;; ---------------------
;;
;; [keinichi] 980819 Kein'ichi Handa <[e-mail]>
;;
;; Multi-byte buffer handling.
;;
;; [vinicius] 980306 Vinicius Jose Latorre <[e-mail]>
;;
;; Skip invisible text.
;;

;; Landscape mode.
;; Multiple columns.
;; Tools for page setup.
;;
;;
;; Known bugs and limitations of ps-print:
;; --------------------------------------
;;
;; Although color printing will work in XEmacs 19.12, it doesn't work
;; well; in particular, bold or italic fonts don't print in the right
;; background color.

;;
;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care
;; of folding lines.
;;
;;
;; Things to change:
;; ----------------
;;
;; Avoid page break inside a paragraph.
;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy).
;; Improve the memory management for big files (hard?).
;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care
;; of folding lines.
;;
;;
;; Acknowledgements
;; ----------------
;;
;; Thanks to Kein'ichi Handa <[e-mail]> for multi-byte buffer handling.
;;
;; Thanks to Matthew O Persico <[e-mail]> for line number on
;; empty columns.
;;
;; Thanks to Theodore Jump <[e-mail]> for adjust PostScript code order on

  :prefix "ps-"
  :tag "PS Faces"
  :group 'ps-print
  :group 'faces)


(defcustom ps-printer-name printer-name
  "*The name of a local printer for printing PostScript files.

On Unix-like systems, a string value should be a name understood by

it is sent the string \"^D\".

Valid values are:

  `8-bit'         This is the value to use when you want an ASCII encoding of
                  any control or non-ASCII character.  Control characters are
                  encoded as \"^D\", and non-ASCII characters have an
                  octal encoding.

  `control-8-bit' This is the value to use when you want an ASCII encoding of
                  any control character, whether it is 7 or 8-bit.
                  European 8-bits accented characters are printed according
                  the current font.

  `control'       Only ASCII control characters have an ASCII encoding.
                  European 8-bits accented characters are printed according
                  the current font.

  nil             No ASCII encoding.  Any character is printed according the
                  current font.

Any other value is treated as nil."
  :type '(choice (const 8-bit) (const control-8-bit)
		 (const control) (other :tag "nil" nil))
  :group 'ps-print)

			     (const :format "" avg-char-width)
			     (number :tag "Average Character Width"))))
  :group 'ps-print-font)

(defcustom ps-font-family 'Courier
  "Font family name for ordinary text, when generating PostScript."
  :type 'symbol
  :group 'ps-print-font)

(defcustom ps-font-size   (if ps-landscape-mode 7 8.5)
  "Font size, in points, for ordinary text, when generating PostScript."
  :type 'number
  :group 'ps-print-font)

(defcustom ps-header-font-family      'Helvetica
  "Font family name for text in the header, when generating PostScript."
  :type 'symbol
  :group 'ps-print-font)

(defcustom ps-header-font-size       (if ps-landscape-mode 10 12)
  "Font size, in points, for text in the header, when generating PostScript."
  :type 'number
  :group 'ps-print-font)

(defcustom ps-header-title-font-size (if ps-landscape-mode 12 14)
  "Font size, in points, for the top line of text in header, in PostScript."
  :type 'number
  :group 'ps-print-font)

;;; Colors

  :group 'ps-print)

(defcustom ps-build-face-reference t
  "*Non-nil means build the reference face lists.

Ps-print sets this value to nil after it builds its internal reference
lists of bold and italic faces.  By settings its value back to t, you
can force ps-print to rebuild the lists the next time you invoke one
of the ...-with-faces commands.

You should set this value back to t after you change the attributes of

(defun ps-setup ()
  "Return the current PostScript-generation setup."
  (format
   "
\(setq ps-print-color-p  %s
      ps-lpr-command    \"%s\"
      ps-lpr-switches   %s

      ps-paper-type          '%s
      ps-landscape-mode      %s
      ps-number-of-columns   %s

      ps-zebra-stripes       %s
      ps-zebra-stripe-height %s
      ps-line-number         %s

      ps-print-control-characters %s

      ps-print-background-image %s

      ps-print-background-text %s

      ps-left-margin        %s
      ps-right-margin       %s
      ps-inter-column       %s
      ps-bottom-margin      %s
      ps-top-margin         %s
      ps-header-offset      %s
      ps-header-line-pad    %s
      ps-print-header       %s
      ps-print-header-frame %s
      ps-header-lines       %s
      ps-show-n-of-n        %s
      ps-spool-duplex       %s

      ps-font-family            '%s
      ps-font-size              %s
      ps-header-font-family     '%s
      ps-header-font-size       %s
      ps-header-title-font-size %s)
"
   ps-print-color-p
   ps-lpr-command
   ps-lpr-switches
   ps-paper-type
   ps-landscape-mode
   ps-number-of-columns
   ps-zebra-stripes
   ps-zebra-stripe-height
   ps-line-number
   ps-print-control-characters
   ps-print-background-image
   ps-print-background-text
   ps-left-margin
   ps-right-margin
   ps-inter-column
   ps-bottom-margin
   ps-top-margin
   ps-header-offset
   ps-header-line-pad
   ps-print-header
   ps-print-header-frame
   ps-header-lines
   ps-show-n-of-n
   ps-spool-duplex
   ps-font-family
   ps-font-size
   ps-header-font-family
   ps-header-font-size
   ps-header-title-font-size))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utility functions and variables:

(defvar ps-print-emacs-type
  (cond ((string-match "XEmacs" emacs-version) 'xemacs)
	((string-match "Lucid" emacs-version) 'lucid)
	((string-match "Epoch" emacs-version) 'epoch)

(defvar ps-background-all-pages nil)
(defvar ps-background-text-count 0)
(defvar ps-background-image-count 0)

(defvar ps-current-font 0)
(defvar ps-default-color (if ps-print-color-p ps-default-fg)) ; black
(defvar ps-current-color ps-default-color)
(defvar ps-current-bg nil)

(defvar ps-razchunk 0)

(defvar ps-color-format
  (if (eq ps-print-emacs-type 'emacs)

      ;; Emacs understands the %f format; we'll use it to limit color RGB
      ;; values to three decimals to cut down some on the size of the

which long lines wrap around."
  (get font-sym 'avg-char-width))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; For handling multibyte characters.
;;
;; The following comments apply only to this part (through the next ^L).
;; Author:	Kenichi Handa <[e-mail]>
;; Maintainer:	Kenichi Handa <[e-mail]>

(eval-and-compile
  (if (fboundp 'set-buffer-multibyte)
      (progn
	(defalias 'ps-mule-next-point '1+)
	(defalias 'ps-mule-chars-in-string 'length)
	(defalias 'ps-mule-string-char 'aref)
	(defsubst ps-mule-next-index (str i) (1+ i)))

    (defun ps-mule-next-index (str i)
      (1+ i)))
  )

(defvar ps-mule-font-info-database
  '((latin-iso8859-1
     (normal nil nil iso-latin-1)))
  "Alist of charsets vs the corresponding font information.
Each element has the form:
	(CHARSET (FONT-TYPE FONT-SRC FONT-NAME ENCODING BYTES) ...)
where

CHARSET is a charset (symbol) for this font family,

FONT-TYPE is a type of font: normal, bold, italic, or bold-italic.

FONT-SRC is a source of font: builtin, bdf, vflib, or nil.

  If FONT-SRC is builtin, FONT-NAME is a buitin PostScript font name.

  If FONT-SRC is bdf, FONT-NAME is a BDF font file name.  To use this
  font, the external library `bdf' is required.

  If FONT-SRC is vflib, FONT-NAME is name of font VFlib knows.  To use
  this font, the external library `vflib' is required.

  If FONT-SRC is nil, a proper ASCII font in the variable
  `ps-font-info-database' is used.  This is useful for Latin-1
  characters.

ENCODING is a coding system to encode a string of characters of
CHARSET into a proper string matching an encoding of the specified
font.  ENCODING may be a function to call to do this encoding.  In
this case, the function is called with one arguemnt, the string to
encode, and it should return an encoded string.

BYTES specifies how many bytes in encoded byte sequence construct esch
character, it should be 1 or 2.

All multibyte characters are printed by fonts specified in this
database regardless of a font family of ASCII characters.  The
exception is Latin-1 characters which are printed by the same font as
ASCII characters, thus obey font family.

See also the variable `ps-font-info-database'.")

(defconst ps-mule-font-info-database-ps
  '((katakana-jisx0201
     (normal builtin "Ryumin-Light.Katakana" ps-mule-encode-7bit 1)
     (bold builtin "GothicBBB-Medium.Katakana" ps-mule-encode-7bit 1)

    (indian-2-column
     (normal bdf "mule-indian-24.bdf" ps-mule-encode-7bit 2))
    (tibetan
     (normal bdf "mule-tibmdx-24.bdf" ps-mule-encode-7bit 2)))
  "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.
BDF (Bitmap Distribution Format) is a format used for distributing
X's font source file.

Current default value lists BDF fonts included in `intlfonts-1.1'
which is a collection of X11 fonts for all characters supported by
Emacs.

With the default value, all characters including ASCII and Latin-1 are
printed by BDF fonts.   See also `ps-mule-font-info-database-ps-bdf'.")

(defconst ps-mule-font-info-database-ps-bdf
  (cons '(latin-iso8859-1
	  (normal nil nil iso-latin-1))
	(cdr (cdr ps-mule-font-info-database-bdf)))
  "Sample setting of the `ps-mule-font-info-database to use BDF fonts.

Current default value lists BDF fonts included in `intlfonts-1.1'
which is a collection of X11 fonts for all characters supported by
Emacs.

With the default value, all characters except for ASCII and Latin-1 are
printed by BDF fonts.   ASCII and Latin-1 charcaters are printed by
PostScript font specified by `ps-font-family'.

See also `ps-mule-font-info-database-bdf'.")

;; Two typical encoding functions for PostScript fonts.

(defun ps-mule-encode-7bit (string)
  (let* ((dim (charset-dimension
	       (char-charset (ps-mule-string-char string 0))))
	 (len (* (ps-mule-chars-in-string string) dim))
	 (str (make-string len 0))
	 (i 0) (j 0))
    (if (= dim 1)
	(while (< j len)
	  (aset str j (nth 1 (split-char (ps-mule-string-char string i))))
	  (setq i (ps-mule-next-index string i)
		j (1+ j)))
      (while (< j len)
	(let ((split (split-char (ps-mule-string-char string i))))
	  (aset str j (nth 1 split))
	  (aset str (1+ j) (nth 2 split))
	  (setq i (ps-mule-next-index string i)
		j (+ j 2)))))
    str))

(defun ps-mule-encode-8bit (string)
  (let* ((dim (charset-dimension
	       (char-charset (ps-mule-string-char string 0))))
	 (len (* (ps-mule-chars-in-string string) dim))
	 (str (make-string len 0))
	 (i 0) (j 0))
    (if (= dim 1)
	(while (< j len)
	  (aset str j
		(+ (nth 1 (split-char (ps-mule-string-char string i))) 128))
	  (setq i (ps-mule-next-index string i)
		j (1+ j)))
      (while (< j len)
	(let ((split (split-char (ps-mule-string-char string i))))
	  (aset str j (+ (nth 1 split) 128))
	  (aset str (1+ j) (+ (nth 2 split) 128))
	  (setq i (ps-mule-next-index string i)
		j (+ j 2)))))
    str))

;; Special encoding function for Ethiopic.

;; A charset which we are now processing.
(defvar ps-mule-current-charset nil)

(defun ps-mule-get-font-spec (charset font-type)
  "Return FONT-SPEC for printing characters CHARSET with FONT-TYPE.  
FONT-SPEC is a list of FONT-SRC, FONT-NAME, ENCODING, and BYTES,
this information is extracted from `ps-mule-font-info-database'
See the documentation of `ps-mule-font-info-database' for the meaning
of each element of the list."
  (let ((slot (cdr (assq charset ps-mule-font-info-database))))
    (if slot
	(cdr (or (assq font-type slot)
		 (and (eq font-type 'bold-italic)
		      (or (assq 'bold slot) (assq 'italic slot)))
		 (assq 'normal slot))))))

;; Functions to access each element of FONT-SPEC.
(defsubst ps-mule-font-spec-src (font-spec) (car font-spec))
(defsubst ps-mule-font-spec-name (font-spec) (nth 1 font-spec))
(defsubst ps-mule-font-spec-encoding (font-spec) (nth 2 font-spec))

	 pcf-generate-prologue pcf-generate-font pcf-generate-glyphs)
    (vflib nil
	   vflib-generate-prologue vflib-generate-font vflib-generate-glyphs))
  "Alist of information of external libraries to support PostScript printing.
Each element has the form:
    (FONT-SRC INITIALIZED-P PROLOGUE-FUNC FONT-FUNC GLYPHS-FUNC)

FONT-SRC is a source of font: builtin, bdf, pcf, or vflib.  Except for
builtin, libraries of the same names are necessary, but currently, we
only have the library `bdf'.

INITIALIZED-P is a flag to tell this library is initialized or not.

PROLOGUE-FUNC is a function to call to get a PostScript codes which
define procedures to use this library.  It is called with no argument,
and should return a list of strings.

FONT-FUNC is a function to call to get a PostScript codes which define
a new font.  It is called with one argument FONT-SPEC, and should
return a list of strings.

GLYPHS-FUNC is a function to call to get a PostScript codes which
define glyphs of characters.  It is called with three arguments
FONT-SPEC, CODE-LIST, and BYTES, and should return a list of strings.")

(defun ps-mule-init-external-library (font-spec)
  "Initialize external librarie specified in FONT-SPEC for PostScript printing.
See the documentation of `ps-mule-get-font-spec' for the meaning of
each element of the list."
  (let* ((font-src (ps-mule-font-spec-src font-spec))
	 (slot (assq font-src ps-mule-external-libraries)))
    (or (not font-src)
	(nth 1 slot)
	(let ((func (nth 2 slot)))

	 (scaled-font-name
	  (if (eq charset 'ascii)
	      (format "f%d" ps-current-font)
	    (format "f%02x-%d"
		    (charset-id charset) ps-current-font))))
    (if (and func (not font-cache))
	(ps-output-prologue (funcall func charset font-spec)))
    (ps-output-prologue
     (list (format "/%s %f /%s Def%sFontMule\n"
		   scaled-font-name ps-font-size font-name
		   (if (eq ps-mule-current-charset 'ascii) "Ascii" ""))))
    (if font-cache
	(setcar (cdr font-cache)
		(cons (cons ps-current-font scaled-font-name)
		      (nth 1 font-cache)))
      (setq font-cache (list font-name
			     (list (cons ps-current-font scaled-font-name))
			     'cache))
      (setq ps-mule-font-cache (cons font-cache ps-mule-font-cache)))
    font-cache))

(defun ps-mule-generate-glyphs (font-spec code-list)
  "Generate PostScript codes which generate glyphs for CODE-LIST of FONT-SPEC."
  (let* ((font-src (ps-mule-font-spec-src font-spec))
	 (func (nth 4 (assq font-src ps-mule-external-libraries))))
    (if func
	(ps-output-prologue
	 (funcall func font-spec code-list
		  (ps-mule-font-spec-bytes font-spec))))))

(defvar ps-last-font nil)

(defun ps-mule-prepare-font (font-spec string charset &optional no-setfont) 
  "Generate PostScript codes to print STRING of CHARSET by font in FONT-SPEC.
The generated codes goes to prologue part except for a code for
setting the current font (using PostScript procedure `FM').
If optional arg NO-SETFONT is non-nil, don't generate the code for
setting the current font."
  (let ((font-cache (assoc (ps-mule-font-spec-name font-spec)
			   ps-mule-font-cache)))
    (or (and font-cache (assq ps-current-font (nth 1 font-cache)))
	(setq font-cache (ps-mule-generate-font font-spec charset)))
    (or no-setfont

	       (bytes (ps-mule-font-spec-bytes font-spec))
	       (len (length string))
	       (i 0)
	       code)
	  (while (< i len)
	    (setq code
		  (if (= bytes 1) (aref string i)
		    (+ (* (aref string i) 256) (aref string (1+ i)))))
	    (or (memq code cached-codes)
		(progn
		  (setq newcodes (cons code newcodes))
		  (setcdr cached-codes (cons code (cdr cached-codes)))))
	    (setq i (+ i bytes)))
	  (if newcodes
	      (ps-mule-generate-glyphs font-spec newcodes))))))

;; List of charsets of multibyte characters in a text being printed.
;; If the text doesn't contain any multibyte characters (i.e. only
;; ASCII), the value is nil.
(defvar ps-mule-charset-list nil)

;; This constant string is a PostScript code embeded as is in the
;; header of generated PostScript.

(defvar ps-mule-prologue-generated nil)

(defconst ps-mule-prologue
  "%%%% Start of Mule Section

%% Working dictionaly for general use.
/MuleDict 10 dict def

%% Define already scaled font for non-ASCII character sets.
/DefFontMule {			% fontname size basefont  |-  --
  findfont exch scalefont definefont pop

"
  "PostScript code for printing multibyte characters.")

(defun ps-mule-skip-same-charset (charset)
  "Skip characters of CHARSET following the current point."
  (while (eq (charset-after) charset) (forward-char 1)))

(defun ps-mule-find-wrappoint (from to char-width)
  "Find a longest sequence at FROM which is printable in the current line.

TO limits the sequence.  It is assumed that all characters between
FROM and TO belong to a charset set in `ps-mule-current-charset'.

CHAR-WIDTH is an average width of ASCII characters in the current font.

The return value is a cons of ENDPOS and RUN-WIDTH, where
ENDPOS is an end position of the sequence,
RUN-WIDTH is the width of the sequence."
  (let (run-width)
    (if (eq ps-mule-current-charset 'composition)
	;; We must draw one char by one.
	(let ((ch (char-after from)))
	  (setq run-width (* (char-width ch) char-width))

	  (setq from to))))
    (cons from run-width)))

(defun ps-mule-plot-string (from to &optional bg-color)
  "Generate PostScript code for ploting characters in the region FROM and TO.
It is assumed that all characters in this region belong to the
charset `ps-mule-current-charset'.
Optional arg BG-COLOR specifies background color.
The return value is a cons of ENDPOS and WIDTH of the sequence
actually plotted by this function."
  (let* ((wrappoint (ps-mule-find-wrappoint
		     from to (ps-avg-char-width 'ps-font-for-text)))
	 (to (car wrappoint))
	 (font-type (car (nth ps-current-font
			      (ps-font-alist 'ps-font-for-text))))
	 (font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type))
	 (encoding (ps-mule-font-spec-encoding font-spec))
	 (string (buffer-substring-no-properties from to)))
    (cond
     ((= from to)
      ;; We can't print any more characters in the current line.
      nil)

     (font-spec
      ;; We surely have a font for printing this character set.
      (if (coding-system-p encoding)
	  (setq string (encode-coding-string string encoding))
	(if (functionp encoding)
	    (setq string (funcall encoding string))
	  (if encoding
	      (error "Invalid coding system or function: %s" encoding))))
      (setq string (string-as-unibyte string))
      (if (ps-mule-font-spec-src font-spec)
	  (ps-mule-prepare-font font-spec string ps-mule-current-charset)
	(ps-set-font ps-current-font))
      (ps-output-string string)
      (ps-output " S\n"))

     ((eq ps-mule-current-charset 'latin-iso8859-1)
      ;; Latin-1 can be printed by a normal ASCII font.
      (ps-set-font ps-current-font)
      (ps-output-string
       (string-as-unibyte (encode-coding-string string 'iso-latin-1)))
      (ps-output " S\n"))

     ((eq ps-mule-current-charset 'composition)
      (let* ((ch (char-after from))
	     (width (char-width ch))

    top HIGH gt { /HIGH top def } if
    btm LOW lt { /LOW btm def } if
    currentpoint pop btm LLY sub moveto
    S
    grestore
} bind def    

%% Relative composition
/RLC {				% str  |-  --
    gsave
    dup GetPathBox

  "PostScript code for printing composite characters.")

(defun ps-mule-plot-rule-cmpchar (ch-rule-list total-width font-type)
  (let* ((leftmost 0.0)
	 (rightmost (float (char-width (car ch-rule-list))))
	 (l (cons '(3 . 3) ch-rule-list))
	 (cmpchar-elements nil))
    (while l
      (let* ((this (car l))
	     (gref (car this))
	     (nref (cdr this))
	     ;; X-axis info (0:left, 1:center, 2:right)
	     (gref-x (% gref 3))
	     (nref-x (% nref 3))
	     ;; Y-axis info (0:top, 1:base, 2:bottom, 3:center)
	     (gref-y (if (= gref 4) 3 (/ gref 3)))
	     (nref-y (if (= nref 4) 3 (/ nref 3)))
	     (width (float (char-width (car (cdr l)))))
	     left)
	(setq left (+ leftmost
		      (/ (* (- rightmost leftmost) gref-x) 2.0)
		      (- (/ (* nref-x width) 2.0))))
	(setq cmpchar-elements
	      (cons (list (car (cdr l)) left gref-y nref-y) cmpchar-elements))
	(if (< left leftmost)
	    (setq leftmost left))
	(if (> (+ left width) rightmost)
	    (setq rightmost (+ left width)))
	(setq l (nthcdr 2 l))))
    (if (< leftmost 0)
	(let ((l cmpchar-elements))
	  (while l
	    (setcar (cdr (car l))
		    (- (nth 1 (car l)) leftmost))
	    (setq l (cdr l)))))
    (ps-mule-plot-cmpchar (nreverse cmpchar-elements)
			  total-width nil font-type)))

(defun ps-mule-plot-cmpchar (elements total-width relativep font-type)
  (let* ((ch (if relativep (car elements) (car (car elements))))
	 (str (ps-mule-prepare-cmpchar-font ch font-type)))
    (ps-output-string str)
    (ps-output (format " %d %d BC "
		       (if relativep 0 (nth 1 (car elements)))
		       total-width)))
  (setq elements (cdr elements))
  (while elements
    (let* ((elt (car elements))
	   (ch (if relativep elt (car elt)))
	   (str (ps-mule-prepare-cmpchar-font ch font-type)))
      (if relativep
	  (progn
	    (ps-output-string str)
	    (ps-output " RLC "))
	(ps-output-string str)
	(ps-output (format " %d %d %d RBC "
			   (nth 1 elt) (nth 2 elt) (nth 3 elt)))))
    (setq elements (cdr elements)))
  (ps-output "EC\n"))
    
(defun ps-mule-prepare-cmpchar-font (char font-type)
  (let* ((ps-mule-current-charset (char-charset char))
	 (font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type))
	 (encoding (ps-mule-font-spec-encoding font-spec))
	 (str (char-to-string char)))
    (cond (font-spec
	   (if (coding-system-p encoding)
	       (setq str (encode-coding-string str encoding))
	     (if (functionp encoding)
		 (setq str (funcall encoding str))
	       (if encoding
		   (error "Invalid coding system or function: %s" encoding))))
	   (setq str (string-as-unibyte str))
	   (if (ps-mule-font-spec-src font-spec)
	       (ps-mule-prepare-font font-spec str ps-mule-current-charset)
	     (ps-set-font ps-current-font)))

	  ((eq ps-mule-current-charset 'latin-iso8859-1)
	   (ps-set-font ps-current-font)
	   (setq str
		 (string-as-unibyte (encode-coding-string str 'iso-latin-1))))

	  (t
	   ;; No font for CHAR.
	   (ps-set-font ps-current-font)
	   (setq str " ")))
    str))

;; Bitmap font support

(defvar ps-mule-bitmap-prologue-generated nil)

%% bitmap dictionary.
/GlobalCharName {		% fontidx code1 code2  |-  gloval-charname
    exch 256 mul add exch 65536 mul add 16777216 add 16 str7 cvrs 0 66 put
    str7 cvn
} bind def
    
%% Character code holder for a 2-byte character.
/FirstCode -1 def

%% Glyph rendering procedure
/BuildGlyphCommon {		% fontdict charname  |-  --

	    [ size 0 0 size neg bmp 3 get neg bmp 2 get bmp 4 get add ] % matrix
	    bmp 5 1 getinterval cvx	% datasrc
	    imagemask
	} if
    } ifelse
} bind def    

/BuildCharCommon {
    1 index /Encoding get exch get
    1 index /BuildGlyph get exec
} bind def

;; Mule specific initializers.

(defun ps-mule-initialize ()
  "Produce Poscript code in the prologue part for multibyte characters."
  (setq ps-mule-current-charset 'ascii
	ps-mule-font-cache nil
	ps-mule-prologue-generated nil
	ps-mule-cmpchar-prologue-generated nil
	ps-mule-bitmap-prologue-generated nil)
  (mapcar (function (lambda (x) (setcar (cdr x) nil)))
	  ps-mule-external-libraries))

(defun ps-mule-begin (from to)
  (if (and (boundp 'enable-multibyte-characters)
	   enable-multibyte-characters)
      ;; Initialize `ps-mule-charset-list'.  If some characters aren't
      ;; printable, warn it.
      (let ((charsets (delete 'ascii (find-charset-region from to))))
	(setq ps-mule-charset-list charsets)
	(save-excursion
	  (goto-char from)
	  (if (search-forward "\200" to t)
	      (setq ps-mule-charset-list
		    (cons 'composition ps-mule-charset-list))))
	(if (and (catch 'tag
		   (while charsets
		     (if (or (eq (car charsets) 'composition)
			     (ps-mule-printable-p (car charsets)))
			 (setq charsets (cdr charsets))
		       (throw 'tag t))))
		 (not (y-or-n-p "Font for some characters not found, continue anyway? ")))
	    (error "Printing cancelled"))))

  (if ps-mule-charset-list
      (let ((l ps-mule-charset-list)
	    font-spec)
	(unless ps-mule-prologue-generated
	  (ps-output-prologue ps-mule-prologue)
	  (setq ps-mule-prologue-generated t))
	;; If external functions are necessary, generate prologues for them.
	(while l
	  (if (and (eq (car l) 'composition)
		   (not ps-mule-cmpchar-prologue-generated))
	      (progn
		(ps-output-prologue ps-mule-cmpchar-prologue)
		(setq ps-mule-cmpchar-prologue-generated t))
	    (if (setq font-spec (ps-mule-get-font-spec (car l) 'normal))
		(ps-mule-init-external-library font-spec)))
	  (setq l (cdr l)))))

  ;; If ASCII font is also specified in ps-mule-font-info-database,
  ;; use it istead of what specified in ps-font-info-database.
  (let ((font-spec (ps-mule-get-font-spec 'ascii 'normal)))
    (if font-spec

	      (let ((ps-current-font i))
		;; Be sure to download a glyph for SPACE in advance.
		(ps-mule-prepare-font
		 (ps-mule-get-font-spec 'ascii (car font))
		 " " 'ascii 'no-setfont))
	      (setq font (cdr font) i (1+ i))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun ps-line-lengths-internal ()
  "Display the correspondence between a line length and a font size,
using the current ps-print setup.
Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"

(defun ps-print-preprint (&optional filename)
  (and filename
       (or (numberp filename)
	   (listp filename))
       (let* ((name   (concat (buffer-name) ".ps"))
	      (prompt (format "Save PostScript to file: (default %s) " name))
	      (res    (read-file-name prompt default-directory name nil)))
	 (if (file-directory-p res)
	     (expand-file-name name (file-name-as-directory res))
	   res))))

;; The following functions implement a simple list-buffering scheme so

	     " (using ps-print v" ps-print-version
	     ")\n%%CreationDate: "
	     (time-stamp-hh:mm:ss) " " (time-stamp-mon-dd-yyyy)
	     "\n%%Orientation: "
	     (if ps-landscape-mode "Landscape" "Portrait")
	     "\n%% DocumentFonts: Times-Roman Times-Italic "
	     (mapconcat 'identity
			(ps-remove-duplicates
			 (append (ps-fonts 'ps-font-for-text)
				 (list (ps-font 'ps-font-for-header 'normal)
				       (ps-font 'ps-font-for-header 'bold))))
			" ")
	     "\n%%Pages: (atend)\n"
	     "%%EndComments\n\n")

  (ps-output-boolean "LandscapeMode"             ps-landscape-mode)
  (ps-output (format "/NumberOfColumns %d def\n" ps-number-of-columns)

	     (format "/LandscapePageHeight %s def\n" ps-landscape-page-height)

(defun ps-color-value (x-color-value)
  ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
  (/ x-color-value ps-print-color-scale))

(defun ps-color-values (x-color)
  (cond ((fboundp 'x-color-values)
	 (x-color-values x-color))
	((and (fboundp 'color-instance-rgb-components)
	      (ps-color-device))
	 (color-instance-rgb-components
	  (if (color-instance-p x-color)
	      x-color
	    (make-color-instance
	     (if (color-specifier-p x-color)
		 (color-name x-color)
	       x-color)))))
	(t (error "No available function to determine X color values."))))


(defun ps-face-attributes (face)
  "Return face attribute vector.

   (t					; otherwise, text has a valid face
    (let* ((face-bit   (ps-face-attribute-list face))
	   (effect     (aref face-bit 0))
	   (foreground (aref face-bit 1))
	   (background (aref face-bit 2))
	   (fg-color (if (and ps-print-color-p foreground (ps-color-device))
			 (mapcar 'ps-color-value
				 (ps-color-values foreground))
		       ps-default-color))
	   (bg-color (and ps-print-color-p background (ps-color-device)
			  (mapcar 'ps-color-value
				  (ps-color-values background)))))
      (ps-plot-region
       from to
       (ps-font-number 'ps-font-for-text

			   face))
       fg-color bg-color (lsh effect -2)))))
  (goto-char to))


(defun ps-xemacs-face-kind-p (face kind kind-regex kind-list)
  (let* ((frame-font (or (face-font-instance face)
			 (face-font-instance 'default)))
	 (kind-cons (and frame-font
			 (assq kind (font-instance-properties frame-font))))
	 (kind-spec (cdr-safe kind-cons))
	 (case-fold-search t))
    (or (and kind-spec (string-match kind-regex kind-spec))
	;; Kludge-compatible:
	(memq face kind-list))))


(cond ((eq ps-print-emacs-type 'emacs)  ; emacs

       (defun ps-face-bold-p (face)
	 (or (face-bold-p face)
	     (memq face ps-bold-faces)))

	     (memq face ps-italic-faces)))
       )
					; xemacs
					; lucid
      (t				; epoch
       (defun ps-face-bold-p (face)
	 (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold" ps-bold-faces))

       (defun ps-face-italic-p (face)
	 (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o" ps-italic-faces)
	     (ps-xemacs-face-kind-p face 'SLANT "i\\|o" ps-italic-faces)))
       ))

			(if (ps-face-underlined-p face) 4 0)) ; underline
		(face-foreground face)
		(face-background face))))


(defun ps-mapper (extent list)
  (nconc list (list (list (extent-start-position extent) 'push extent)
		    (list (extent-end-position extent) 'pull extent)))
  nil)

(defun ps-extent-sorter (a b)
  (< (extent-priority a) (extent-priority b)))

(defun ps-print-ensure-fontified (start end)
  (and (boundp 'lazy-lock-mode) (symbol-value 'lazy-lock-mode)
       (if (fboundp 'lazy-lock-fontify-region)
	   (lazy-lock-fontify-region start end) ; the new
	 (lazy-lock-fontify-buffer))))	; the old

(defun ps-generate-postscript-with-faces (from to)
  ;; Some initialization...
  (setq ps-current-effect 0)

	(message "Collecting face information...")
	(ps-build-reference-face-lists)))
  ;; Set the color scale.  We do it here instead of in the defvar so
  ;; that ps-print can be dumped into emacs.  This expression can't be
  ;; evaluated at dump-time because X isn't initialized.
  (setq ps-print-color-scale
	(if (and ps-print-color-p (ps-color-device))
	    (float (car (ps-color-values "white")))
	  1.0))
  ;; Generate some PostScript.
  (save-restriction
    (narrow-to-region from to)
    (let ((face 'default)
	  (position to))
      (ps-print-ensure-fontified from to)
      (cond
       ((or (eq ps-print-emacs-type 'lucid)
	    (eq ps-print-emacs-type 'xemacs))
	;; Build the list of extents...
	(let ((a (cons 'dummy nil))

	    (and (>= from (point-min)) (<= position (point-max))
		 (ps-plot-with-face from position face))

	    (cond
	     ((eq type 'push)
	      (if (extent-face extent)
		  (setq extent-list (sort (cons extent extent-list)
					  'ps-extent-sorter))))

	     ((eq type 'pull)
	      (setq extent-list (sort (delq extent extent-list)
				      'ps-extent-sorter))))

	    (setq face
		  (if extent-list
		      (extent-face (car extent-list))
		    'default)

		  from position
		  a (cdr a)))))

       ((eq ps-print-emacs-type 'emacs)
	(let ((property-change from)
	      (overlay-change from)
	      (save-buffer-invisibility-spec buffer-invisibility-spec)
	      (buffer-invisibility-spec nil))
	  (while (< from to)
	    (if (< property-change to)	; Don't search for property change
					; unless previous search succeeded.
		(setq property-change
		      (next-property-change from nil to)))
	    (if (< overlay-change to)	; Don't search for overlay change
					; unless previous search succeeded.
		(setq overlay-change
		      (min (next-overlay-change from) to)))
	    (setq position
		  (min property-change overlay-change))
	    ;; The code below is not quite correct,
	    ;; because a non-nil overlay invisible property
	    ;; which is inactive according to the current value
	    ;; of buffer-invisibility-spec nonetheless overrides
	    ;; a face text property.

			 'emacs--invisible--face)
			((get-text-property from 'face))
			(t 'default)))
	    (let ((overlays (overlays-at from))
		  (face-priority -1))	; text-property
	      (while overlays
		(let* ((overlay (car overlays))
		       (overlay-face (overlay-get overlay 'face))
		       (overlay-invisible (overlay-get overlay 'invisible))
		       (overlay-priority (or (overlay-get overlay
							  'priority)
					     0)))
		  (and (or overlay-invisible overlay-face)
		       (> overlay-priority face-priority)
		       (setq face
			     (cond ((if (eq save-buffer-invisibility-spec t)
					(not (null overlay-invisible))
				      (or (memq overlay-invisible
						save-buffer-invisibility-spec)
					  (assq overlay-invisible
						save-buffer-invisibility-spec)))
				    'emacs--invisible--face)
				   (face overlay-face))
			     face-priority overlay-priority)))
		(setq overlays (cdr overlays))))
	    ;; Plot up to this record.
	    (ps-plot-with-face from position face)
	    (setq from position)))))

		(goto-char (point-min))
		(or (looking-at (regexp-quote ps-adobe-tag))
		    (setq needs-begin-file t))
		(save-excursion
		  (set-buffer ps-source-buffer)
		  (if needs-begin-file (ps-begin-file))
		  (ps-mule-begin from to)
		  (ps-begin-job)
		  (ps-begin-page))
		(set-buffer ps-source-buffer)
		(funcall genfunc from to)

		   (set-buffer ps-spool-buffer)
		   (delete-region (marker-position safe-marker) (point-max))))))

	(and ps-razzle-dazzle (message "Formatting...done"))))))

;; To avoid compilation gripes
(defvar dos-ps-printer nil)

;; Permit dynamic evaluation at print time of `ps-lpr-switches'.
(defun ps-do-despool (filename)
  (if (or (not (boundp 'ps-spool-buffer))
	  (not (symbol-value 'ps-spool-buffer)))

	       (ps-lpr-switches
		(append (and (stringp ps-printer-name)
			     (list (concat "-P" ps-printer-name)))
			ps-lpr-switches)))
	  (if (and (memq system-type '(ms-dos windows-nt))
		   (or (stringp dos-ps-printer)
		       (stringp ps-printer-name)))
	      (write-region (point-min) (point-max)
			    (if (stringp  dos-ps-printer)
				dos-ps-printer
			      ps-printer-name)
			    t 0)
	    (apply 'call-process-region
		   (point-min) (point-max) ps-lpr-command nil
		   (and (fboundp 'start-process) 0)
		   nil
		   (ps-flatten-list	; dynamic evaluation

    (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
	 (buffer-modified-p ps-buffer)
	 (not (yes-or-no-p "Unprinted PostScript waiting; exit anyway? "))
	 (error "Unprinted PostScript"))))

(if (fboundp 'add-hook)
    (funcall 'add-hook 'kill-emacs-hook 'ps-kill-emacs-check)
  (if kill-emacs-hook
      (message "Won't override existing kill-emacs-hook")
    (setq kill-emacs-hook 'ps-kill-emacs-check)))

;;; Sample Setup Code:

;; This stuff is for anybody that's brave enough to look this far,
;; and able to figure out how to use it.  It isn't really part of

23550:d8a958630c9d

;; Author:	Vinicius Jose Latorre <[e-mail]>
;; Author:	Kenichi Handa <[e-mail]> (multibyte characters)
;; Maintainer:	Kenichi Handa <[e-mail]> (multibyte characters)
;; Maintainer:	Vinicius Jose Latorre <[e-mail]>
;; Keywords:	print, PostScript
;; Time-stamp:	<98/10/13  15:42:23 vinicius>
;; Version:	4.1.1

(defconst ps-print-version "4.1.1"
  "ps-print.el, v 4.1.1 <98/10/13 vinicius>

Vinicius's last change version -- this file may have been edited as part of
Emacs without changes to the version number.  When reporting bugs,
please also report the version of Emacs, if any, that ps-print was
distributed with.

;; About ps-print
;; --------------
;;
;; This package provides printing of Emacs buffers on PostScript
;; printers; the buffer's bold and italic text attributes are
;; preserved in the printer output.  ps-print is intended for use with
;; Emacs 19 or Lucid Emacs, together with a fontifying package such as
;; font-lock or hilit.
;;
;; ps-print uses the same face attributes defined through font-lock or hilit
;; to print a PostScript file, but some faces are better seeing on the screen

;; Using ps-print
;; --------------
;;
;; The Commands
;;
;; ps-print provides eight commands for generating PostScript images
;; of Emacs buffers:
;;
;;        ps-print-buffer
;;        ps-print-buffer-with-faces
;;        ps-print-region

;; files (mail messages or netnews articles) to save paper that would
;; otherwise be wasted on banner pages, and to make it easier to find
;; your output at the printer (it's easier to pick up one 50-page
;; printout than to find 50 single-page printouts).
;;
;; ps-print has a hook in the `kill-emacs-hook' so that you won't
;; accidentally quit from Emacs while you have unprinted PostScript
;; waiting in the spool buffer.  If you do attempt to exit with
;; spooled PostScript, you'll be asked if you want to print it, and if
;; you decline, you'll be asked to confirm the exit; this is modeled
;; on the confirmation that Emacs uses for modified buffers.

;; `lpr-command' and `lpr-switches'.
;;
;; Make sure that they contain appropriate values for your system;
;; see the usage notes below and the documentation of these variables.
;;
;; The variable `ps-printer-name' determine the name of a local printer for
;; printing PostScript files.
;;
;; NOTE: `ps-lpr-command' and `ps-lpr-switches' take their initial values
;;       from the variables `lpr-command' and `lpr-switches'.  If you have
;;       `lpr-command' set to invoke a pretty-printer such as `enscript',
;;       then ps-print won't work properly.  `ps-lpr-command' must name
;;       a program that does not format the files it prints.
;;       `ps-printer-name' takes its initial value from the variable
;;       `printer-name'.
;;
;;
;; The Page Layout
;; ---------------
;;

;;
;;
;; Headers
;; -------
;;
;; ps-print can print headers at the top of each column or at the top
;; of each page; the default headers contain the following four items:
;; on the left, the name of the buffer and, if the buffer is visiting
;; a file, the file's directory; on the right, the page number and
;; date of printing.  The default headers look something like this:
;;

;; aborting the print job, this kind of error can be hard to track down.
;;
;; Consider yourself warned!
;;
;;
;; PostScript Prologue Header
;; --------------------------
;;
;; It is possible to add PostScript prologue header comments besides that
;; ps-print generates by setting the variable `ps-print-prologue-header'.
;;
;; `ps-print-prologue-header' may be a string or a symbol function which
;; returns a string.  Note that this string is inserted on PostScript prologue
;; header section which is used to define some document characteristic through
;; PostScript special comments, like "%%Requirements: jog\n".
;;
;; By default `ps-print-prologue-header' is nil.
;;
;; ps-print always inserts the %%Requirements: comment, so if you need to insert
;; more requirements put them first in `ps-print-prologue-header' using the
;; "%%+" comment.  For example, if you need to set numcopies to 3 and jog on
;; requirements and set %%LanguageLevel: to 2, do:
;;
;; (setq ps-print-prologue-header
;;       "%%+ numcopies(3) jog\n%%LanguageLevel: 2\n")
;;
;; The duplex requirement is inserted by ps-print (see section Duplex Printers).
;;
;; Do not forget to terminate the string with "\n".
;;
;; For more information about PostScript document comments, see:
;;    PostScript Language Reference Manual (2nd edition)
;;    Adobe Systems Incorporated
;;    Appendix G: Document Structuring Conventions -- Version 3.0
;;
;;
;; Duplex Printers
;; ---------------
;;
;; If you have a duplex-capable printer (one that prints both sides of
;; the paper), set `ps-spool-duplex' to t.
;; ps-print will insert blank pages to make sure each buffer starts
;; on the correct side of the paper.
;; Don't forget to set `ps-lpr-switches' to select duplex printing
;; for your printer.
;;
;;

;; The default is `control-8-bit'.
;;
;; Characters TAB, NEWLINE and FORMFEED are always treated by ps-print engine.
;;
;;
;; Printing Multibyte Buffer
;; -------------------------
;;
;; The variable `ps-multibyte-buffer' specifies the ps-print multibyte buffer
;; handling.
;;
;; Valid values for `ps-multibyte-buffer' are:
;;
;;  nil                     This is the value to use when you are printing
;;			    buffer with only ASCII and Latin characters.
;;
;;  `non-latin-printer'     This is the value to use when you have a japanese
;;			    or korean PostScript printer and want to print
;;			    buffer with ASCII, Latin-1, Japanese (JISX0208 and
;;			    JISX0201-Kana) and Korean characters.  At present,
;;			    it was not tested the Korean characters printing.
;;			    If you have a korean PostScript printer, please,
;;			    test it.
;;
;;  `bdf-font'              This is the value to use when you want to print
;;			    buffer with BDF fonts.  BDF fonts include both latin
;;			    and non-latin fonts.  BDF (Bitmap Distribution
;;			    Format) is a format used for distributing X's font
;;			    source file.  BDF fonts are included in
;;			    `intlfonts-1.1' which is a collection of X11 fonts
;;			    for all characters supported by Emacs.  In order to
;;			    use this value, be sure to have installed
;;			    `intlfonts-1.1' and set the variable
;;			    `bdf-directory-list' appropriately (see bdf.el for
;;			    documentation of this variable).
;;
;;  `bdf-font-except-latin' This is like `bdf-font' except that it is used
;;			    PostScript default fonts to print ASCII and Latin-1
;;			    characters.  This is convenient when you want or
;;			    need to use both latin and non-latin characters on
;;			    the same buffer.  See `ps-font-family',
;;			    `ps-header-font-family' and `ps-font-info-database'.
;;
;; Any other value is treated as nil.
;;
;; The default is nil.
;;
;;
;; Line Number
;; -----------
;;

;;
;;
;; Hooks
;; -----
;;
;; ps-print has the following hook variables:
;;
;; `ps-print-hook'
;;    It is evaluated once before any printing process.  This is the right
;;    place to initialize ps-print global data.
;;    For an example, see section Adding a New Font Family.

;;
;;
;; Font Managing
;; -------------
;;
;; ps-print now knows rather precisely some fonts:
;; the variable `ps-font-info-database' contains information
;; for a list of font families (currently mainly `Courier' `Helvetica'
;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk').
;; Each font family contains the font names for standard, bold, italic
;; and bold-italic characters, a reference size (usually 10) and the

;;              (w3-table-hack-x-face . "LineDrawNormal"))
;;       (size . 10.0)
;;       (line-height . 10.55)
;;       (space-width . 6.0)
;;       (avg-char-width . 6.0))
;;
;; Now you can use your new font family with any size:
;;	(setq ps-font-family 'my-mixed-family)
;;
;; Note that on above example the `w3-table-hack-x-face' entry refers to
;; a face symbol, so when printing this face it'll be used the font

;;      (setq ps-underlined-faces '(my-green-face))
;;
;; Faces like bold-italic that are both bold and italic should go in
;; *both* lists.
;;
;; ps-print keeps internal lists of which fonts are bold and which are
;; italic; these lists are built the first time you invoke ps-print.
;; For the sake of efficiency, the lists are built only once; the same
;; lists are referred in later invocations of ps-print.
;;
;; Because these lists are built only once, it's possible for them to

;;
;;
;; How Ps-Print Deals With Color
;; -----------------------------
;;
;; ps-print detects faces with foreground and background colors
;; defined and embeds color information in the PostScript image.
;; The default foreground and background colors are defined by the
;; variables `ps-default-fg' and `ps-default-bg'.
;; On black-and-white printers, colors are displayed in grayscale.
;; To turn off color output, set `ps-print-color-p' to nil.

;;
;;
;; How Ps-Print Has A Text And/Or Image On Background
;; --------------------------------------------------
;;
;; ps-print can print texts and/or EPS PostScript images on background; it is
;; possible to define the following text attributes: font name, font size,
;; initial position, angle, gray scale and pages to print.
;;
;; It has the following EPS PostScript images attributes: file name containing
;; the image, initial position, X and Y scales, angle and pages to print.

;;
;;
;; New since version 2.8
;; ---------------------
;;
;; [vinicius] 980922 Vinicius Jose Latorre <[e-mail]>
;;
;; PostScript prologue header comment insertion.
;; Skip invisible text better.
;;
;; [keinichi] 980819 Kein'ichi Handa <[e-mail]>
;;
;; Multibyte buffer handling.
;;
;; [vinicius] 980306 Vinicius Jose Latorre <[e-mail]>
;;
;; Skip invisible text.
;;

;; Landscape mode.
;; Multiple columns.
;; Tools for page setup.
;;
;;
;; Known bugs and limitations of ps-print
;; --------------------------------------
;;
;; Although color printing will work in XEmacs 19.12, it doesn't work
;; well; in particular, bold or italic fonts don't print in the right
;; background color.

;;
;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care
;; of folding lines.
;;
;;
;; Things to change
;; ----------------
;;
;; 2-up and 4-up capabilities.
;; Avoid page break inside a paragraph.
;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy).
;; Improve the memory management for big files (hard?).
;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care
;; of folding lines.
;;
;;
;; Acknowledgements
;; ----------------
;;
;; Thanks to Kein'ichi Handa <[e-mail]> for multibyte buffer handling.
;;
;; Thanks to Matthew O Persico <[e-mail]> for line number on
;; empty columns.
;;
;; Thanks to Theodore Jump <[e-mail]> for adjust PostScript code order on

  :prefix "ps-"
  :tag "PS Faces"
  :group 'ps-print
  :group 'faces)


(defcustom ps-multibyte-buffer nil
  "*Specifies the multibyte buffer handling.

Valid values are:

  nil                     This is the value to use when you are printing
			  buffer with only ASCII and Latin characters.

  `non-latin-printer'     This is the value to use when you have a japanese
			  or korean PostScript printer and want to print
			  buffer with ASCII, Latin-1, Japanese (JISX0208 and
			  JISX0201-Kana) and Korean characters.  At present,
			  it was not tested the Korean characters printing.
			  If you have a korean PostScript printer, please,
			  test it.

  `bdf-font'              This is the value to use when you want to print
			  buffer with BDF fonts.  BDF fonts include both latin
			  and non-latin fonts.  BDF (Bitmap Distribution
			  Format) is a format used for distributing X's font
			  source file.  BDF fonts are included in
			  `intlfonts-1.1' which is a collection of X11 fonts
			  for all characters supported by Emacs.  In order to
			  use this value, be sure to have installed
			  `intlfonts-1.1' and set the variable
			  `bdf-directory-list' appropriately (see bdf.el for
			  documentation of this variable).

  `bdf-font-except-latin' This is like `bdf-font' except that it is used
			  PostScript default fonts to print ASCII and Latin-1
			  characters.  This is convenient when you want or
			  need to use both latin and non-latin characters on
			  the same buffer.  See `ps-font-family',
			  `ps-header-font-family' and `ps-font-info-database'.

Any other value is treated as nil."
  :type '(choice (const non-latin-printer) (const bdf-font)
		 (const bdf-font-except-latin) (other :tag "nil" nil))
  :group 'ps-print-font)

(defcustom ps-print-prologue-header nil
  "*PostScript prologue header comments besides that ps-print generates.

`ps-print-prologue-header' may be a string or a symbol function which
returns a string.  Note that this string is inserted on PostScript prologue
header section which is used to define some document characteristic through
PostScript special comments, like \"%%Requirements: jog\\n\".

ps-print always inserts the %%Requirements: comment, so if you need to insert
more requirements put them first in `ps-print-prologue-header' using the
\"%%+\" comment.  For example, if you need to set numcopies to 3 and jog on
requirements and set %%LanguageLevel: to 2, do:

(setq ps-print-prologue-header
      \"%%+ numcopies(3) jog\\n%%LanguageLevel: 2\\n\")

The duplex requirement is inserted by ps-print (see `ps-spool-duplex').

Do not forget to terminate the string with \"\\n\".

For more information about PostScript document comments, see:
   PostScript Language Reference Manual (2nd edition)
   Adobe Systems Incorporated
   Appendix G: Document Structuring Conventions -- Version 3.0"
  :type '(choice string symbol (other :tag "nil" nil))
  :group 'ps-print)

(defcustom ps-printer-name printer-name
  "*The name of a local printer for printing PostScript files.

On Unix-like systems, a string value should be a name understood by

it is sent the string \"^D\".

Valid values are:

  `8-bit'         This is the value to use when you want an ASCII encoding of
		  any control or non-ASCII character.  Control characters are
		  encoded as \"^D\", and non-ASCII characters have an
		  octal encoding.

  `control-8-bit' This is the value to use when you want an ASCII encoding of
		  any control character, whether it is 7 or 8-bit.
		  European 8-bits accented characters are printed according
		  the current font.

  `control'       Only ASCII control characters have an ASCII encoding.
		  European 8-bits accented characters are printed according
		  the current font.

  nil             No ASCII encoding.  Any character is printed according the
		  current font.

Any other value is treated as nil."
  :type '(choice (const 8-bit) (const control-8-bit)
		 (const control) (other :tag "nil" nil))
  :group 'ps-print)

			     (const :format "" avg-char-width)
			     (number :tag "Average Character Width"))))
  :group 'ps-print-font)

(defcustom ps-font-family 'Courier
  "*Font family name for ordinary text, when generating PostScript."
  :type 'symbol
  :group 'ps-print-font)

(defcustom ps-font-size   (if ps-landscape-mode 7 8.5)
  "*Font size, in points, for ordinary text, when generating PostScript."
  :type 'number
  :group 'ps-print-font)

(defcustom ps-header-font-family      'Helvetica
  "*Font family name for text in the header, when generating PostScript."
  :type 'symbol
  :group 'ps-print-font)

(defcustom ps-header-font-size       (if ps-landscape-mode 10 12)
  "*Font size, in points, for text in the header, when generating PostScript."
  :type 'number
  :group 'ps-print-font)

(defcustom ps-header-title-font-size (if ps-landscape-mode 12 14)
  "*Font size, in points, for the top line of text in header, in PostScript."
  :type 'number
  :group 'ps-print-font)

;;; Colors

  :group 'ps-print)

(defcustom ps-build-face-reference t
  "*Non-nil means build the reference face lists.

ps-print sets this value to nil after it builds its internal reference
lists of bold and italic faces.  By settings its value back to t, you
can force ps-print to rebuild the lists the next time you invoke one
of the ...-with-faces commands.

You should set this value back to t after you change the attributes of

(defun ps-setup ()
  "Return the current PostScript-generation setup."
  (format
   "
\(setq ps-print-color-p  %s
      ps-lpr-command    %S
      ps-lpr-switches   %S
      ps-printer-name   %S

      ps-paper-type          %S
      ps-landscape-mode      %s
      ps-number-of-columns   %s

      ps-zebra-stripes       %s
      ps-zebra-stripe-height %s
      ps-line-number         %s

      ps-print-control-characters %S

      ps-print-background-image %S

      ps-print-background-text %S

      ps-print-prologue-header %S

      ps-left-margin           %s
      ps-right-margin          %s
      ps-inter-column          %s
      ps-bottom-margin         %s
      ps-top-margin            %s
      ps-header-offset         %s
      ps-header-line-pad       %s
      ps-print-header          %s
      ps-print-only-one-header %s
      ps-print-header-frame    %s
      ps-header-lines          %s
      ps-show-n-of-n           %s
      ps-spool-duplex          %s

      ps-multibyte-buffer       %S
      ps-font-family            %S
      ps-font-size              %s
      ps-header-font-family     %S
      ps-header-font-size       %s
      ps-header-title-font-size %s)
"
   ps-print-color-p
   ps-lpr-command
   (ps-print-quote ps-lpr-switches)
   ps-printer-name
   (ps-print-quote ps-paper-type)
   ps-landscape-mode
   ps-number-of-columns
   ps-zebra-stripes
   ps-zebra-stripe-height
   ps-line-number
   (ps-print-quote ps-print-control-characters)
   (ps-print-quote ps-print-background-image)
   (ps-print-quote ps-print-background-text)
   (ps-print-quote ps-print-prologue-header)
   ps-left-margin
   ps-right-margin
   ps-inter-column
   ps-bottom-margin
   ps-top-margin
   ps-header-offset
   ps-header-line-pad
   ps-print-header
   ps-print-only-one-header
   ps-print-header-frame
   ps-header-lines
   ps-show-n-of-n
   ps-spool-duplex
   (ps-print-quote ps-multibyte-buffer)
   (ps-print-quote ps-font-family)
   ps-font-size
   (ps-print-quote ps-header-font-family)
   ps-header-font-size
   ps-header-title-font-size))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utility functions and variables:

(defun ps-print-quote (sym)
  (and sym
       (if (or (symbolp sym) (listp sym))
	   (format "'%S" sym)
	 sym)))

(defvar ps-print-emacs-type
  (cond ((string-match "XEmacs" emacs-version) 'xemacs)
	((string-match "Lucid" emacs-version) 'lucid)
	((string-match "Epoch" emacs-version) 'epoch)

(defvar ps-background-all-pages nil)
(defvar ps-background-text-count 0)
(defvar ps-background-image-count 0)

(defvar ps-current-font 0)
(defvar ps-default-color (and ps-print-color-p ps-default-fg)) ; black
(defvar ps-current-color ps-default-color)
(defvar ps-current-bg nil)

(defvar ps-razchunk 0)

(defvar ps-color-p nil)
(defvar ps-color-format
  (if (eq ps-print-emacs-type 'emacs)

      ;; Emacs understands the %f format; we'll use it to limit color RGB
      ;; values to three decimals to cut down some on the size of the

which long lines wrap around."
  (get font-sym 'avg-char-width))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; For handling multibyte characters -- Begin.
;;
;; The following comments apply only to this part (through the next ^L).
;; Author:	Kenichi Handa <[e-mail]>
;; Maintainer:	Kenichi Handa <[e-mail]>

(eval-and-compile
  (if (not (string< mule-version "4.0"))
      (progn
	(defalias 'ps-mule-next-point '1+)
	(defalias 'ps-mule-chars-in-string 'length)
	(defalias 'ps-mule-string-char 'aref)
	(defsubst ps-mule-next-index (str i) (1+ i)))

    (defun ps-mule-next-index (str i)
      (1+ i)))
  )

(defvar ps-mule-font-info-database
  nil
  "Alist of charsets with the corresponding font information.
Each element has the form:

	(CHARSET (FONT-TYPE FONT-SRC FONT-NAME ENCODING BYTES) ...)

Where

CHARSET is a charset (symbol) for this font family,

FONT-TYPE is a font type: normal, bold, italic, or bold-italic.

FONT-SRC is a font source: builtin, bdf, vflib, or nil.

  If FONT-SRC is builtin, FONT-NAME is a buitin PostScript font name.

  If FONT-SRC is bdf, FONT-NAME is a BDF font file name.  To use this font,
  the external library `bdf' is required.

  If FONT-SRC is vflib, FONT-NAME is the name of a font that VFlib knows.
  To use this font, the external library `vflib' is required.

  If FONT-SRC is nil, a proper ASCII font in the variable
  `ps-font-info-database' is used.  This is useful for Latin-1 characters.

ENCODING is a coding system to encode a string of characters of CHARSET into a
proper string matching an encoding of the specified font.  ENCODING may be a
function that does this encoding.  In this case, the function is called with
one argument, the string to encode, and it should return an encoded string.

BYTES specifies how many bytes each character has in the encoded byte
sequence; it should be 1 or 2. 

All multibyte characters are printed by fonts specified in this database
regardless of a font family of ASCII characters.  The exception is Latin-1
characters which are printed by the same font as ASCII characters, thus obey
font family.

See also the variable `ps-font-info-database'.")

(defconst ps-mule-font-info-database-latin
  '((latin-iso8859-1
     (normal nil nil iso-latin-1)))
  "Sample setting of `ps-mule-font-info-database' to use latin fonts.")

(defconst ps-mule-font-info-database-ps
  '((katakana-jisx0201
     (normal builtin "Ryumin-Light.Katakana" ps-mule-encode-7bit 1)
     (bold builtin "GothicBBB-Medium.Katakana" ps-mule-encode-7bit 1)

    (indian-2-column
     (normal bdf "mule-indian-24.bdf" ps-mule-encode-7bit 2))
    (tibetan
     (normal bdf "mule-tibmdx-24.bdf" ps-mule-encode-7bit 2)))
  "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.
BDF (Bitmap Distribution Format) is a format used for distributing X's font
source file.

Current default value list for BDF fonts is included in `intlfonts-1.1' which is
a collection of X11 fonts for all characters supported by Emacs.

Using this list as default value to `ps-mule-font-info-database', all characters
including ASCII and Latin-1 are printed by BDF fonts.

See also `ps-mule-font-info-database-ps-bdf'.")

(defconst ps-mule-font-info-database-ps-bdf
  (cons (car ps-mule-font-info-database-latin)
	(cdr (cdr ps-mule-font-info-database-bdf)))
  "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.

Current default value list for BDF fonts is included in `intlfonts-1.1' which is
a collection of X11 fonts for all characters supported by Emacs.

Using this list as default value to `ps-mule-font-info-database', all characters
except ASCII and Latin-1 characters are printed by BDF fonts.  ASCII and Latin-1
characters are printed by PostScript font specified by `ps-font-family' and
`ps-header-font-family'.

See also `ps-mule-font-info-database-bdf'.")

;; Two typical encoding functions for PostScript fonts.

(defun ps-mule-encode-7bit (string)
  (ps-mule-encode-bit string 0))

(defun ps-mule-encode-8bit (string)
  (ps-mule-encode-bit string 128))

(defun ps-mule-encode-bit (string delta)
  (let* ((dim (charset-dimension (char-charset (ps-mule-string-char string 0))))
	 (len (* (ps-mule-chars-in-string string) dim))
	 (str (make-string len 0))
	 (i 0)
	 (j 0))
    (if (= dim 1)
	(while (< j len)
	  (aset str j
		(+ (nth 1 (split-char (ps-mule-string-char string i))) delta))
	  (setq i (ps-mule-next-index string i)
		j (1+ j)))
      (while (< j len)
	(let ((split (split-char (ps-mule-string-char string i))))
	  (aset str j (+ (nth 1 split) delta))
	  (aset str (1+ j) (+ (nth 2 split) delta))
	  (setq i (ps-mule-next-index string i)
		j (+ j 2)))))
    str))

;; Special encoding function for Ethiopic.

;; A charset which we are now processing.
(defvar ps-mule-current-charset nil)

(defun ps-mule-get-font-spec (charset font-type)
  "Return FONT-SPEC for printing characters CHARSET with FONT-TYPE.
FONT-SPEC is a list that has the form:

	(FONT-SRC FONT-NAME ENCODING BYTES)

FONT-SPEC is extracted from `ps-mule-font-info-database'.

See the documentation of `ps-mule-font-info-database' for the meaning of each
element of the list."
  (let ((slot (cdr (assq charset ps-mule-font-info-database))))
    (and slot
	 (cdr (or (assq font-type slot)
		  (and (eq font-type 'bold-italic)
		       (or (assq 'bold slot) (assq 'italic slot)))
		  (assq 'normal slot))))))

;; Functions to access each element of FONT-SPEC.
(defsubst ps-mule-font-spec-src (font-spec) (car font-spec))
(defsubst ps-mule-font-spec-name (font-spec) (nth 1 font-spec))
(defsubst ps-mule-font-spec-encoding (font-spec) (nth 2 font-spec))

	 pcf-generate-prologue pcf-generate-font pcf-generate-glyphs)
    (vflib nil
	   vflib-generate-prologue vflib-generate-font vflib-generate-glyphs))
  "Alist of information of external libraries to support PostScript printing.
Each element has the form:

    (FONT-SRC INITIALIZED-P PROLOGUE-FUNC FONT-FUNC GLYPHS-FUNC)

FONT-SRC is the font source: builtin, bdf, pcf, or vflib.  Except for `builtin',
libraries must have the same name as indicated by FONT-SRC.  Currently, we only
have the `bdf' library.

INITIALIZED-P indicates if this library is initialized or not.

PROLOGUE-FUNC is a function to generate PostScript code which define several
PostScript procedures that will be called by FONT-FUNC and GLYPHS-FUNC.  It is
called with no argument, and should return a list of strings.

FONT-FUNC is a function to generate PostScript code which define a new font.  It
is called with one argument FONT-SPEC, and should return a list of strings.

GLYPHS-FUNC is a function to generate PostScript code which define glyphs of
characters.  It is called with three arguments FONT-SPEC, CODE-LIST, and BYTES,
and should return a list of strings.")

(defun ps-mule-init-external-library (font-spec)
  "Initialize external library specified by FONT-SPEC for PostScript printing.
See the documentation of `ps-mule-get-font-spec' for FONT-SPEC's meaning."
  (let* ((font-src (ps-mule-font-spec-src font-spec))
	 (slot (assq font-src ps-mule-external-libraries)))
    (or (not font-src)
	(nth 1 slot)
	(let ((func (nth 2 slot)))

	 (scaled-font-name
	  (if (eq charset 'ascii)
	      (format "f%d" ps-current-font)
	    (format "f%02x-%d"
		    (charset-id charset) ps-current-font))))
    (and func (not font-cache)
	 (ps-output-prologue (funcall func charset font-spec)))
    (ps-output-prologue
     (list (format "/%s %f /%s Def%sFontMule\n"
		   scaled-font-name ps-font-size font-name
		   (if (eq ps-mule-current-charset 'ascii) "Ascii" ""))))
    (if font-cache
	(setcar (cdr font-cache)
		(cons (cons ps-current-font scaled-font-name)
		      (nth 1 font-cache)))
      (setq font-cache (list font-name
			     (list (cons ps-current-font scaled-font-name))
			     'cache)
	    ps-mule-font-cache (cons font-cache ps-mule-font-cache)))
    font-cache))

(defun ps-mule-generate-glyphs (font-spec code-list)
  "Generate PostScript codes which generate glyphs for CODE-LIST of FONT-SPEC."
  (let* ((font-src (ps-mule-font-spec-src font-spec))
	 (func (nth 4 (assq font-src ps-mule-external-libraries))))
    (and func
	 (ps-output-prologue
	  (funcall func font-spec code-list
		   (ps-mule-font-spec-bytes font-spec))))))

(defvar ps-last-font nil)

(defun ps-mule-prepare-font (font-spec string charset &optional no-setfont)
  "Generate PostScript codes to print STRING of CHARSET by font FONT-SPEC.

The generated code is inserted on prologue part except the code that sets the
current font (using PostScript procedure `FM').

If optional arg NO-SETFONT is non-nil, don't generate the code for setting the
current font."
  (let ((font-cache (assoc (ps-mule-font-spec-name font-spec)
			   ps-mule-font-cache)))
    (or (and font-cache (assq ps-current-font (nth 1 font-cache)))
	(setq font-cache (ps-mule-generate-font font-spec charset)))
    (or no-setfont

	       (bytes (ps-mule-font-spec-bytes font-spec))
	       (len (length string))
	       (i 0)
	       code)
	  (while (< i len)
	    (setq code (if (= bytes 1)
			   (aref string i)
			 (+ (* (aref string i) 256) (aref string (1+ i)))))
	    (or (memq code cached-codes)
		(progn
		  (setq newcodes (cons code newcodes))
		  (setcdr cached-codes (cons code (cdr cached-codes)))))
	    (setq i (+ i bytes)))
	  (and newcodes
	       (ps-mule-generate-glyphs font-spec newcodes))))))

;; List of charsets of multibyte characters in a text being printed.
;; If the text doesn't contain any multibyte characters (i.e. only
;; ASCII), the value is nil.
(defvar ps-mule-charset-list nil)

(defvar ps-mule-prologue-generated nil)

;; This is a PostScript code inserted in the header of generated PostScript.
(defconst ps-mule-prologue
  "%%%% Start of Mule Section

%% Working dictionary for general use.
/MuleDict 10 dict def

%% Define already scaled font for non-ASCII character sets.
/DefFontMule {			% fontname size basefont  |-  --
  findfont exch scalefont definefont pop

"
  "PostScript code for printing multibyte characters.")

(defun ps-mule-skip-same-charset (charset)
  "Skip characters of CHARSET following the current point."
  (while (eq (charset-after) charset)
    (forward-char 1)))

(defun ps-mule-find-wrappoint (from to char-width)
  "Find the longest sequence which is printable in the current line.

The search starts at FROM and goes until TO.  It is assumed that all characters
between FROM and TO belong to a charset in `ps-mule-current-charset'.

CHAR-WIDTH is the average width of ASCII characters in the current font.

Returns the value:

	(ENDPOS . RUN-WIDTH)

Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
the sequence."
  (let (run-width)
    (if (eq ps-mule-current-charset 'composition)
	;; We must draw one char by one.
	(let ((ch (char-after from)))
	  (setq run-width (* (char-width ch) char-width))

	  (setq from to))))
    (cons from run-width)))

(defun ps-mule-plot-string (from to &optional bg-color)
  "Generate PostScript code for ploting characters in the region FROM and TO.

It is assumed that all characters in this region belong to a charset in
`ps-mule-current-charset'.

Optional argument BG-COLOR specifies background color.

Returns the value:

	(ENDPOS . RUN-WIDTH)

Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
the sequence."
  (let* ((wrappoint (ps-mule-find-wrappoint
		     from to (ps-avg-char-width 'ps-font-for-text)))
	 (to (car wrappoint))
	 (font-type (car (nth ps-current-font
			      (ps-font-alist 'ps-font-for-text))))
	 (font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type))
	 (string (buffer-substring-no-properties from to)))
    (cond
     ((= from to)
      ;; We can't print any more characters in the current line.
      nil)

     (font-spec
      ;; We surely have a font for printing this character set.
      (ps-output-string (ps-mule-string-encoding font-spec string))
      (ps-output " S\n"))

     ((eq ps-mule-current-charset 'latin-iso8859-1)
      ;; Latin-1 can be printed by a normal ASCII font.
      (ps-output-string (ps-mule-string-ascii string))
      (ps-output " S\n"))

     ((eq ps-mule-current-charset 'composition)
      (let* ((ch (char-after from))
	     (width (char-width ch))

    top HIGH gt { /HIGH top def } if
    btm LOW lt { /LOW btm def } if
    currentpoint pop btm LLY sub moveto
    S
    grestore
} bind def

%% Relative composition
/RLC {				% str  |-  --
    gsave
    dup GetPathBox

  "PostScript code for printing composite characters.")

(defun ps-mule-plot-rule-cmpchar (ch-rule-list total-width font-type)
  (let* ((leftmost 0.0)
	 (rightmost (float (char-width (car ch-rule-list))))
	 (the-list (cons '(3 . 3) ch-rule-list))
	 (cmpchar-elements nil))
    (while the-list
      (let* ((this (car the-list))
	     (gref (car this))
	     (nref (cdr this))
	     ;; X-axis info (0:left, 1:center, 2:right)
	     (gref-x (% gref 3))
	     (nref-x (% nref 3))
	     ;; Y-axis info (0:top, 1:base, 2:bottom, 3:center)
	     (gref-y (if (= gref 4) 3 (/ gref 3)))
	     (nref-y (if (= nref 4) 3 (/ nref 3)))
	     (width (float (char-width (car (cdr the-list)))))
	     left)
	(setq left (+ leftmost
		      (/ (* (- rightmost leftmost) gref-x) 2.0)
		      (- (/ (* nref-x width) 2.0)))
	      cmpchar-elements (cons (list (car (cdr the-list))
					   left gref-y nref-y)
				     cmpchar-elements)
	      leftmost (min left leftmost)
	      rightmost (max (+ left width) rightmost)
	      the-list (nthcdr 2 the-list))))
    (if (< leftmost 0)
	(let ((the-list cmpchar-elements))
	  (while the-list
	    (setcar (cdr (car the-list))
		    (- (nth 1 (car the-list)) leftmost))
	    (setq the-list (cdr the-list)))))
    (ps-mule-plot-cmpchar (nreverse cmpchar-elements)
			  total-width nil font-type)))

(defun ps-mule-plot-cmpchar (elements total-width relativep font-type)
  (let* ((elt (car elements))
	 (ch (if relativep elt (car elt))))
    (ps-output-string (ps-mule-prepare-cmpchar-font ch font-type))
    (ps-output (format " %d %d BC "
		       (if relativep 0 (nth 1 elt))
		       total-width))
    (while (setq elements (cdr elements))
      (setq elt (car elements)
	    ch (if relativep elt (car elt)))
      (ps-output-string (ps-mule-prepare-cmpchar-font ch font-type))
      (ps-output (if relativep
		     " RLC "
		   (format " %d %d %d RBC "
			   (nth 1 elt) (nth 2 elt) (nth 3 elt))))))
  (ps-output "EC\n"))

(defun ps-mule-prepare-cmpchar-font (char font-type)
  (let* ((ps-mule-current-charset (char-charset char))
	 (font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type)))
    (cond (font-spec
	   (ps-mule-string-encoding font-spec (char-to-string char)))

	  ((eq ps-mule-current-charset 'latin-iso8859-1)
	   (ps-mule-string-ascii (char-to-string char)))

	  (t
	   ;; No font for CHAR.
	   (ps-set-font ps-current-font)
	   " "))))

(defun ps-mule-string-ascii (str)
  (ps-set-font ps-current-font)
  (string-as-unibyte (encode-coding-string str 'iso-latin-1)))

(defun ps-mule-string-encoding (font-spec str)
  (let ((encoding (ps-mule-font-spec-encoding font-spec)))
    (cond ((coding-system-p encoding)
	   (setq str (encode-coding-string str encoding)))
	  ((functionp encoding)
	   (setq str (funcall encoding str)))
	  (encoding
	   (error "Invalid coding system or function: %s" encoding)))
    (setq str (string-as-unibyte str))
    (if (ps-mule-font-spec-src font-spec)
	(ps-mule-prepare-font font-spec str ps-mule-current-charset)
      (ps-set-font ps-current-font))
    str))

;; Bitmap font support

(defvar ps-mule-bitmap-prologue-generated nil)

%% bitmap dictionary.
/GlobalCharName {		% fontidx code1 code2  |-  gloval-charname
    exch 256 mul add exch 65536 mul add 16777216 add 16 str7 cvrs 0 66 put
    str7 cvn
} bind def

%% Character code holder for a 2-byte character.
/FirstCode -1 def

%% Glyph rendering procedure
/BuildGlyphCommon {		% fontdict charname  |-  --

	    [ size 0 0 size neg bmp 3 get neg bmp 2 get bmp 4 get add ] % matrix
	    bmp 5 1 getinterval cvx	% datasrc
	    imagemask
	} if
    } ifelse
} bind def

/BuildCharCommon {
    1 index /Encoding get exch get
    1 index /BuildGlyph get exec
} bind def

;; Mule specific initializers.

(defun ps-mule-initialize ()
  "Produce Poscript code in the prologue part for multibyte characters."
  (setq ps-mule-font-info-database
	(cond ((eq ps-multibyte-buffer 'non-latin-printer)
	       ps-mule-font-info-database-ps)
	      ((eq ps-multibyte-buffer 'bdf-font)
	       ps-mule-font-info-database-bdf)
	      ((eq ps-multibyte-buffer 'bdf-font-except-latin)
	       ps-mule-font-info-database-ps-bdf)
	      (t
	       ps-mule-font-info-database-latin))
	ps-mule-current-charset 'ascii
	ps-mule-font-cache nil
	ps-mule-prologue-generated nil
	ps-mule-cmpchar-prologue-generated nil
	ps-mule-bitmap-prologue-generated nil)
  (mapcar `(lambda (x) (setcar (cdr x) nil))
	  ps-mule-external-libraries))

(defun ps-mule-begin (from to)
  (and (boundp 'enable-multibyte-characters)
       enable-multibyte-characters
       ;; Initialize `ps-mule-charset-list'.  If some characters aren't
       ;; printable, warn it.
       (let ((charsets (delete 'ascii (find-charset-region from to))))
	 (setq ps-mule-charset-list charsets)
	 (save-excursion
	   (goto-char from)
	   (and (search-forward "\200" to t)
		(setq ps-mule-charset-list
		      (cons 'composition ps-mule-charset-list))))
	 (while charsets
	   (cond
	    ((or (eq (car charsets) 'composition)
		 (ps-mule-printable-p (car charsets)))
	     (setq charsets (cdr charsets)))
	    ((y-or-n-p "Font for some characters not found, continue anyway? ")
	     (setq charsets nil))
	    (t
	     (error "Printing cancelled"))))))

  (if ps-mule-charset-list
      (let ((the-list ps-mule-charset-list)
	    font-spec)
	(unless ps-mule-prologue-generated
	  (ps-output-prologue ps-mule-prologue)
	  (setq ps-mule-prologue-generated t))
	;; If external functions are necessary, generate prologues for them.
	(while the-list
	  (cond ((and (eq (car the-list) 'composition)
		      (not ps-mule-cmpchar-prologue-generated))
		 (ps-output-prologue ps-mule-cmpchar-prologue)
		 (setq ps-mule-cmpchar-prologue-generated t))
		((setq font-spec (ps-mule-get-font-spec (car the-list) 'normal))
		 (ps-mule-init-external-library font-spec)))
	  (setq the-list (cdr the-list)))))

  ;; If ASCII font is also specified in ps-mule-font-info-database,
  ;; use it istead of what specified in ps-font-info-database.
  (let ((font-spec (ps-mule-get-font-spec 'ascii 'normal)))
    (if font-spec

	      (let ((ps-current-font i))
		;; Be sure to download a glyph for SPACE in advance.
		(ps-mule-prepare-font
		 (ps-mule-get-font-spec 'ascii (car font))
		 " " 'ascii 'no-setfont))
	      (setq font (cdr font)
		    i (1+ i))))))))

;; For handling multibyte characters -- End.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun ps-line-lengths-internal ()
  "Display the correspondence between a line length and a font size,
using the current ps-print setup.
Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"

(defun ps-print-preprint (&optional filename)
  (and filename
       (or (numberp filename)
	   (listp filename))
       (let* ((name   (concat (file-name-nondirectory (or (buffer-file-name)
							  (buffer-name)))
			      ".ps"))
	      (prompt (format "Save PostScript to file: (default %s) " name))
	      (res    (read-file-name prompt default-directory name nil)))
	 (while (cond ((not (file-writable-p res))
		       (ding)
		       (setq prompt "is unwritable"))
		      ((file-exists-p res)
		       (setq prompt "exists")
		       (not (y-or-n-p (format "File `%s' exists; overwrite? "
					      res))))
		      (t nil))
	   (setq res (read-file-name
		      (format "File %s; save PostScript to file: " prompt)
		      (file-name-directory res) nil nil
		      (file-name-nondirectory res))))
	 (if (file-directory-p res)
	     (expand-file-name name (file-name-as-directory res))
	   res))))

;; The following functions implement a simple list-buffering scheme so

	     " (using ps-print v" ps-print-version
	     ")\n%%CreationDate: "
	     (time-stamp-hh:mm:ss) " " (time-stamp-mon-dd-yyyy)
	     "\n%%Orientation: "
	     (if ps-landscape-mode "Landscape" "Portrait")
	     "\n%%DocumentNeededResources: font Times-Roman Times-Italic\n%%+ font "
	     (mapconcat 'identity
			(ps-remove-duplicates
			 (append (ps-fonts 'ps-font-for-text)
				 (list (ps-font 'ps-font-for-header 'normal)
				       (ps-font 'ps-font-for-header 'bold))))
			"\n%%+ font ")
	     "\n%%Pages: (atend)\n%%Requirements:"
	     (if ps-spool-duplex " duplex\n" "\n"))

  (let ((comments (if (functionp ps-print-prologue-header)
		      (funcall ps-print-prologue-header)
		    ps-print-prologue-header)))
    (and (stringp comments)
	 (ps-output comments)))

  (ps-output "%%EndComments\n\n%%BeginPrologue\n\n")

  (ps-output-boolean "LandscapeMode"             ps-landscape-mode)
  (ps-output (format "/NumberOfColumns %d def\n" ps-number-of-columns)

	     (format "/LandscapePageHeight %s def\n" ps-landscape-page-height)

(defun ps-color-value (x-color-value)
  ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
  (/ x-color-value ps-print-color-scale))


(cond ((eq ps-print-emacs-type 'emacs)  ; emacs

       (defun ps-color-values (x-color)
	 (if (fboundp 'x-color-values)
	     (x-color-values x-color)
	   (error "No available function to determine X color values.")))
       )
					; xemacs
					; lucid
      (t				; epoch
       (defun ps-color-values (x-color)
	 (cond ((fboundp 'x-color-values)
		(x-color-values x-color))
	       ((and (fboundp 'color-instance-rgb-components)
		     (ps-color-device))
		(color-instance-rgb-components
		 (if (color-instance-p x-color)
		     x-color
		   (make-color-instance
		    (if (color-specifier-p x-color)
			(color-name x-color)
		      x-color)))))
	       (t (error "No available function to determine X color values."))))
       ))


(defun ps-face-attributes (face)
  "Return face attribute vector.

   (t					; otherwise, text has a valid face
    (let* ((face-bit   (ps-face-attribute-list face))
	   (effect     (aref face-bit 0))
	   (foreground (aref face-bit 1))
	   (background (aref face-bit 2))
	   (fg-color (if (and ps-color-p foreground)
			 (mapcar 'ps-color-value
				 (ps-color-values foreground))
		       ps-default-color))
	   (bg-color (and ps-color-p background
			  (mapcar 'ps-color-value
				  (ps-color-values background)))))
      (ps-plot-region
       from to
       (ps-font-number 'ps-font-for-text

			   face))
       fg-color bg-color (lsh effect -2)))))
  (goto-char to))


(cond ((eq ps-print-emacs-type 'emacs)  ; emacs

       (defun ps-face-bold-p (face)
	 (or (face-bold-p face)
	     (memq face ps-bold-faces)))

	     (memq face ps-italic-faces)))
       )
					; xemacs
					; lucid
      (t				; epoch
       (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list)
	 (let* ((frame-font (or (face-font-instance face)
				(face-font-instance 'default)))
		(kind-cons (and frame-font
				(assq kind
				      (font-instance-properties frame-font))))
		(kind-spec (cdr-safe kind-cons))
		(case-fold-search t))
	   (or (and kind-spec (string-match kind-regex kind-spec))
	       ;; Kludge-compatible:
	       (memq face kind-list))))

       (defun ps-face-bold-p (face)
	 (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold"
				ps-bold-faces))

       (defun ps-face-italic-p (face)
	 (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o" ps-italic-faces)
	     (ps-xemacs-face-kind-p face 'SLANT "i\\|o" ps-italic-faces)))
       ))

			(if (ps-face-underlined-p face) 4 0)) ; underline
		(face-foreground face)
		(face-background face))))


(cond ((not (eq ps-print-emacs-type 'emacs))
					; xemacs
					; lucid
					; epoch
       (defun ps-mapper (extent list)
	 (nconc list (list (list (extent-start-position extent) 'push extent)
			   (list (extent-end-position extent) 'pull extent)))
	 nil)

       (defun ps-extent-sorter (a b)
	 (< (extent-priority a) (extent-priority b)))
       ))


(defun ps-print-ensure-fontified (start end)
  (and (boundp 'lazy-lock-mode) (symbol-value 'lazy-lock-mode)
       (lazy-lock-fontify-region start end)))

(defun ps-generate-postscript-with-faces (from to)
  ;; Some initialization...
  (setq ps-current-effect 0)

	(message "Collecting face information...")
	(ps-build-reference-face-lists)))
  ;; Set the color scale.  We do it here instead of in the defvar so
  ;; that ps-print can be dumped into emacs.  This expression can't be
  ;; evaluated at dump-time because X isn't initialized.
  (setq ps-color-p           (and ps-print-color-p (ps-color-device))
	ps-print-color-scale (if ps-color-p
				 (float (car (ps-color-values "white")))
			       1.0))
  ;; Generate some PostScript.
  (save-restriction
    (narrow-to-region from to)
    (ps-print-ensure-fontified from to)
    (let ((face 'default)
	  (position to))
      (cond
       ((or (eq ps-print-emacs-type 'lucid)
	    (eq ps-print-emacs-type 'xemacs))
	;; Build the list of extents...
	(let ((a (cons 'dummy nil))

	    (and (>= from (point-min)) (<= position (point-max))
		 (ps-plot-with-face from position face))

	    (cond
	     ((eq type 'push)
	      (and (extent-face extent)
		   (setq extent-list (sort (cons extent extent-list)
					   'ps-extent-sorter))))

	     ((eq type 'pull)
	      (setq extent-list (sort (delq extent extent-list)
				      'ps-extent-sorter))))

	    (setq face (if extent-list
			   (extent-face (car extent-list))
			 'default)
		  from position
		  a (cdr a)))))

       ((eq ps-print-emacs-type 'emacs)
	(let ((property-change from)
	      (overlay-change from)
	      (save-buffer-invisibility-spec buffer-invisibility-spec)
	      (buffer-invisibility-spec nil))
	  (while (< from to)
	    (and (< property-change to)	; Don't search for property change
					; unless previous search succeeded.
		 (setq property-change (next-property-change from nil to)))
	    (and (< overlay-change to)	; Don't search for overlay change
					; unless previous search succeeded.
		 (setq overlay-change (min (next-overlay-change from) to)))
	    (setq position (min property-change overlay-change))
	    ;; The code below is not quite correct,
	    ;; because a non-nil overlay invisible property
	    ;; which is inactive according to the current value
	    ;; of buffer-invisibility-spec nonetheless overrides
	    ;; a face text property.

			 'emacs--invisible--face)
			((get-text-property from 'face))
			(t 'default)))
	    (let ((overlays (overlays-at from))
		  (face-priority -1))	; text-property
	      (while (and overlays
			  (not (eq face 'emacs--invisible--face)))
		(let* ((overlay (car overlays))
		       (overlay-invisible (overlay-get overlay 'invisible))
		       (overlay-priority (or (overlay-get overlay 'priority)
					     0)))
		  (and (> overlay-priority face-priority)
		       (setq face
			     (cond ((if (eq save-buffer-invisibility-spec t)
					(not (null overlay-invisible))
				      (or (memq overlay-invisible
						save-buffer-invisibility-spec)
					  (assq overlay-invisible
						save-buffer-invisibility-spec)))
				    'emacs--invisible--face)
				   ((overlay-get overlay 'face))
				   (t face))
			     face-priority overlay-priority)))
		(setq overlays (cdr overlays))))
	    ;; Plot up to this record.
	    (ps-plot-with-face from position face)
	    (setq from position)))))

		(goto-char (point-min))
		(or (looking-at (regexp-quote ps-adobe-tag))
		    (setq needs-begin-file t))
		(save-excursion
		  (set-buffer ps-source-buffer)
		  (and needs-begin-file (ps-begin-file))
		  (ps-mule-begin from to)
		  (ps-begin-job)
		  (ps-begin-page))
		(set-buffer ps-source-buffer)
		(funcall genfunc from to)

		   (set-buffer ps-spool-buffer)
		   (delete-region (marker-position safe-marker) (point-max))))))

	(and ps-razzle-dazzle (message "Formatting...done"))))))


;; Permit dynamic evaluation at print time of `ps-lpr-switches'.
(defun ps-do-despool (filename)
  (if (or (not (boundp 'ps-spool-buffer))
	  (not (symbol-value 'ps-spool-buffer)))

	       (ps-lpr-switches
		(append (and (stringp ps-printer-name)
			     (list (concat "-P" ps-printer-name)))
			ps-lpr-switches)))
	  (if (and (memq system-type '(ms-dos windows-nt))
		   (stringp ps-printer-name))
	      (write-region (point-min) (point-max) ps-printer-name t 0)
	    (apply 'call-process-region
		   (point-min) (point-max) ps-lpr-command nil
		   (and (fboundp 'start-process) 0)
		   nil
		   (ps-flatten-list	; dynamic evaluation

    (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
	 (buffer-modified-p ps-buffer)
	 (not (yes-or-no-p "Unprinted PostScript waiting; exit anyway? "))
	 (error "Unprinted PostScript"))))

(cond ((fboundp 'add-hook)
       (funcall 'add-hook 'kill-emacs-hook 'ps-kill-emacs-check))
      (kill-emacs-hook
       (message "Won't override existing `kill-emacs-hook'"))
      (t
       (setq kill-emacs-hook 'ps-kill-emacs-check)))

;;; Sample Setup Code:

;; This stuff is for anybody that's brave enough to look this far,
;; and able to figure out how to use it.  It isn't really part of