lisp/ps-mule.el

   1 ;;; ps-mule.el --- provide multi-byte character facility to ps-print
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
   4 ;; Free Software Foundation, Inc.
   5
   6 ;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br>
   7 ;;      Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
   8 ;; Maintainer: Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
   9 ;;      Vinicius Jose Latorre <vinicius@cpqd.com.br>
  10 ;; Keywords: wp, print, PostScript, multibyte, mule
  11 ;; Time-stamp: <2003/05/14 22:19:41 vinicius>
  12
  13 ;; This file is part of GNU Emacs.
  14
  15 ;; GNU Emacs is free software; you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License as published by
  17 ;; the Free Software Foundation; either version 2, or (at your option)
  18 ;; any later version.
  19
  20 ;; GNU Emacs is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  28 ;; Boston, MA 02111-1307, USA.
  29
  30 ;;; Commentary:
  31
  32 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 ;;
  34 ;; About ps-mule
  35 ;; -------------
  36 ;;
  37 ;; This package is used for ps-print to print multi-byte buffer.
  38 ;;
  39 ;; See also ps-print.el.
  40 ;;
  41 ;;
  42 ;; Printing Multi-byte Buffer
  43 ;; --------------------------
  44 ;;
  45 ;; The variable `ps-multibyte-buffer' specifies the ps-print multi-byte buffer
  46 ;; handling.
  47 ;;
  48 ;; Valid values for `ps-multibyte-buffer' are:
  49 ;;
  50 ;;  nil                     This is the value to use the default settings which
  51 ;;                          is by default for printing buffer with only ASCII
  52 ;;                          and Latin characters.   The default setting can be
  53 ;;                          changed by setting the variable
  54 ;;                          `ps-mule-font-info-database-default' differently.
  55 ;;                          The initial value of this variable is
  56 ;;                          `ps-mule-font-info-database-latin' (see
  57 ;;                          documentation).
  58 ;;
  59 ;;  `non-latin-printer'     This is the value to use when you have a japanese
  60 ;;                          or korean PostScript printer and want to print
  61 ;;                          buffer with ASCII, Latin-1, Japanese (JISX0208 and
  62 ;;                          JISX0201-Kana) and Korean characters.  At present,
  63 ;;                          it was not tested the Korean characters printing.
  64 ;;                          If you have a korean PostScript printer, please,
  65 ;;                          test it.
  66 ;;
  67 ;;  `bdf-font'              This is the value to use when you want to print
  68 ;;                          buffer with BDF fonts.  BDF fonts include both latin
  69 ;;                          and non-latin fonts.  BDF (Bitmap Distribution
  70 ;;                          Format) is a format used for distributing X's font
  71 ;;                          source file.  BDF fonts are included in
  72 ;;                          `intlfonts-1.2' which is a collection of X11 fonts
  73 ;;                          for all characters supported by Emacs.  In order to
  74 ;;                          use this value, be sure to have installed
  75 ;;                          `intlfonts-1.2' and set the variable
  76 ;;                          `bdf-directory-list' appropriately (see ps-bdf.el
  77 ;;                          for documentation of this variable).
  78 ;;
  79 ;;  `bdf-font-except-latin' This is like `bdf-font' except that it is used
  80 ;;                          PostScript default fonts to print ASCII and Latin-1
  81 ;;                          characters.  This is convenient when you want or
  82 ;;                          need to use both latin and non-latin characters on
  83 ;;                          the same buffer.  See `ps-font-family',
  84 ;;                          `ps-header-font-family' and `ps-font-info-database'.
  85 ;;
  86 ;; Any other value is treated as nil.
  87 ;;
  88 ;; The default is nil.
  89 ;;
  90 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91
  92 ;;; Code:
  93
  94 (eval-and-compile
  95   (require 'ps-print)
  96
  97   ;; to avoid XEmacs compilation gripes
  98   (defvar leading-code-private-22 157)
  99   (or (fboundp 'charset-bytes)
 100       (defun charset-bytes (charset) 1)) ; ascii
 101   (or (fboundp 'charset-dimension)
 102       (defun charset-dimension (charset) 1)) ; ascii
 103   (or (fboundp 'charset-id)
 104       (defun charset-id (charset) 0))   ; ascii
 105   (or (fboundp 'charset-width)
 106       (defun charset-width (charset) 1)) ; ascii
 107   (or (fboundp 'find-charset-region)
 108       (defun find-charset-region (beg end &optional table)
 109         (list 'ascii)))
 110   (or (fboundp 'char-valid-p)
 111       (defun char-valid-p (char)
 112         (< (following-char) 256)))
 113   (or (fboundp 'split-char)
 114       (defun split-char (char)
 115         (list (if (char-valid-p char)
 116                   'ascii
 117                 'unknow)
 118               char)))
 119   (or (fboundp 'char-width)
 120       (defun char-width (char) 1))      ; ascii
 121   (or (fboundp 'chars-in-region)
 122       (defun chars-in-region (beg end)
 123         (- (max beg end) (min beg end))))
 124   (or (fboundp 'forward-point)
 125       (defun forward-point (arg)
 126         (save-excursion
 127           (let ((count (abs arg))
 128                 (step  (if (zerop arg)
 129                            0
 130                          (/ arg arg))))
 131             (while (and (> count 0)
 132                         (< (point-min) (point)) (< (point) (point-max)))
 133               (forward-char step)
 134               (setq count (1- count)))
 135             (+ (point) (* count step))))))
 136   (or (fboundp 'decompose-composite-char)
 137       (defun decompose-composite-char (char &optional type
 138                                             with-composition-rule)
 139         nil))
 140   (or (fboundp 'encode-coding-string)
 141       (defun encode-coding-string (string coding-system &optional nocopy)
 142         (if nocopy
 143             string
 144           (copy-sequence string))))
 145   (or (fboundp 'coding-system-p)
 146       (defun coding-system-p (obj) nil))
 147   (or (fboundp 'ccl-execute-on-string)
 148       (defun ccl-execute-on-string (ccl-prog status str
 149                                              &optional contin unibyte-p)
 150         str))
 151   (or (fboundp 'define-ccl-program)
 152       (defmacro define-ccl-program (name ccl-program &optional doc)
 153         `(defconst ,name nil ,doc)))
 154   (or (fboundp 'multibyte-string-p)
 155       (defun multibyte-string-p (str)
 156         (let ((len (length str))
 157               (i 0)
 158               multibyte)
 159           (while (and (< i len) (not (setq multibyte (> (aref str i) 255))))
 160             (setq i (1+ i)))
 161           multibyte)))
 162   (or (fboundp 'string-make-multibyte)
 163       (defalias 'string-make-multibyte 'copy-sequence))
 164   (or (fboundp 'encode-char)
 165       (defun encode-char (ch ccs)
 166         ch)))
 167
 168
 169 ;;;###autoload
 170 (defcustom ps-multibyte-buffer nil
 171   "*Specifies the multi-byte buffer handling.
 172
 173 Valid values are:
 174
 175   nil                     This is the value to use the default settings which
 176                           is by default for printing buffer with only ASCII
 177                           and Latin characters.   The default setting can be
 178                           changed by setting the variable
 179                           `ps-mule-font-info-database-default' differently.
 180                           The initial value of this variable is
 181                           `ps-mule-font-info-database-latin' (see
 182                           documentation).
 183
 184   `non-latin-printer'     This is the value to use when you have a Japanese
 185                           or Korean PostScript printer and want to print
 186                           buffer with ASCII, Latin-1, Japanese (JISX0208 and
 187                           JISX0201-Kana) and Korean characters.  At present,
 188                           it was not tested the Korean characters printing.
 189                           If you have a korean PostScript printer, please,
 190                           test it.
 191
 192   `bdf-font'              This is the value to use when you want to print
 193                           buffer with BDF fonts.  BDF fonts include both latin
 194                           and non-latin fonts.  BDF (Bitmap Distribution
 195                           Format) is a format used for distributing X's font
 196                           source file.  BDF fonts are included in
 197                           `intlfonts-1.2' which is a collection of X11 fonts
 198                           for all characters supported by Emacs.  In order to
 199                           use this value, be sure to have installed
 200                           `intlfonts-1.2' and set the variable
 201                           `bdf-directory-list' appropriately (see ps-bdf.el for
 202                           documentation of this variable).
 203
 204   `bdf-font-except-latin' This is like `bdf-font' except that it is used
 205                           PostScript default fonts to print ASCII and Latin-1
 206                           characters.  This is convenient when you want or
 207                           need to use both latin and non-latin characters on
 208                           the same buffer.  See `ps-font-family',
 209                           `ps-header-font-family' and `ps-font-info-database'.
 210
 211 Any other value is treated as nil."
 212   :type '(choice (const non-latin-printer)     (const bdf-font)
 213                  (const bdf-font-except-latin) (const :tag "nil" nil))
 214   :group 'ps-print-font)
 215
 216
 217 (eval-and-compile
 218   ;; For Emacs 20.2 and the earlier version.
 219   (if (and (boundp 'mule-version)
 220            (not (string< (symbol-value 'mule-version) "4.0")))
 221       ;; mule package is loaded
 222       (progn
 223         (defalias 'ps-mule-next-point '1+)
 224         (defalias 'ps-mule-chars-in-string 'length)
 225         (defalias 'ps-mule-string-char 'aref)
 226         (defsubst ps-mule-next-index (str i) (1+ i)))
 227     ;; mule package isn't loaded or mule version lesser than 4.0
 228     (defun ps-mule-next-point (arg)
 229       (save-excursion (goto-char arg) (forward-char 1) (point)))
 230     (defun ps-mule-chars-in-string (string)
 231       (/ (length string)
 232          (charset-bytes (char-charset (string-to-char string)))))
 233     (defun ps-mule-string-char (string idx)
 234       (string-to-char (substring string idx)))
 235     (defun ps-mule-next-index (string i)
 236       (+ i (charset-bytes (char-charset (string-to-char string)))))
 237     )
 238   ;; For Emacs 20.4 and the earlier version.
 239   (if (and (boundp 'mule-version)
 240            (string< (symbol-value 'mule-version) "5.0"))
 241       ;; mule package is loaded and mule version is lesser than 5.0
 242       (progn
 243         (defun encode-composition-rule (rule)
 244           (if (= (car rule) 4) (setcar rule 10))
 245           (if (= (cdr rule) 4) (setcdr rule 10))
 246           (+ (* (car rule) 12) (cdr rule)))
 247         (defun find-composition (pos &rest ignore)
 248           (let ((ch (char-after pos)))
 249             (and ch (eq (char-charset ch) 'composition)
 250                  (let ((components (decompose-composite-char ch 'vector t)))
 251                    (list pos (ps-mule-next-point pos) components
 252                          (integerp (aref components 1)) nil
 253                          (char-width ch)))))))
 254     ;; mule package isn't loaded
 255     (or (fboundp 'encode-composition-rule)
 256         (defun encode-composition-rule (rule)
 257           130))
 258     (or (fboundp 'find-composition)
 259         (defun find-composition (pos &rest ignore)
 260           nil))
 261     ))
 262
 263 (defvar ps-mule-font-info-database
 264   nil
 265   "Alist of charsets with the corresponding font information.
 266 Each element has the form:
 267
 268         (CHARSET (FONT-TYPE FONT-SRC FONT-NAME ENCODING BYTES) ...)
 269
 270 Where
 271
 272 CHARSET is a charset (symbol) for this font family,
 273
 274 FONT-TYPE is a font type: normal, bold, italic, or bold-italic.
 275
 276 FONT-SRC is a font source: builtin, ps-bdf, vflib, or nil.
 277
 278   If FONT-SRC is builtin, FONT-NAME is a built-in PostScript font name.
 279
 280   If FONT-SRC is bdf, FONT-NAME is a BDF font file name, or a list of
 281   alternative font names.  To use this font, the external library `ps-bdf'
 282   is required.
 283
 284   If FONT-SRC is vflib, FONT-NAME is the name of a font that VFlib knows.
 285   To use this font, the external library `vflib' is required.
 286
 287   If FONT-SRC is nil, a proper ASCII font in the variable
 288   `ps-font-info-database' is used.  This is useful for Latin-1 characters.
 289
 290 ENCODING is a coding system to encode a string of characters of CHARSET into a
 291 proper string matching an encoding of the specified font.  ENCODING may be a
 292 function that does this encoding.  In this case, the function is called with
 293 one argument, the string to encode, and it should return an encoded string.
 294
 295 BYTES specifies how many bytes each character has in the encoded byte
 296 sequence; it should be 1 or 2.
 297
 298 All multi-byte characters are printed by fonts specified in this database
 299 regardless of a font family of ASCII characters.  The exception is Latin-1
 300 characters which are printed by the same font as ASCII characters, thus obey
 301 font family.
 302
 303 See also the variable `ps-font-info-database'.")
 304
 305 (defconst ps-mule-font-info-database-latin
 306   '((latin-iso8859-1
 307      (normal nil nil iso-latin-1)))
 308   "Sample setting of `ps-mule-font-info-database' to use latin fonts.")
 309
 310 (defcustom ps-mule-font-info-database-default
 311   ps-mule-font-info-database-latin
 312   "*The default setting to use when `ps-multibyte-buffer' is nil."
 313   :type '(symbol :tag "Multi-Byte Buffer Database Font Default")
 314   :group 'ps-print-font)
 315
 316 (defconst ps-mule-font-info-database-ps
 317   '((katakana-jisx0201
 318      (normal builtin "Ryumin-Light.Katakana" ps-mule-encode-7bit 1)
 319      (bold builtin "GothicBBB-Medium.Katakana" ps-mule-encode-7bit 1)
 320      (bold-italic builtin "GothicBBB-Medium.Katakana" ps-mule-encode-7bit 1))
 321     (latin-jisx0201
 322      (normal builtin "Ryumin-Light.Hankaku" ps-mule-encode-7bit 1)
 323      (bold builtin "GothicBBB-Medium.Hankaku" ps-mule-encode-7bit 1))
 324     (japanese-jisx0208
 325      (normal builtin "Ryumin-Light-H" ps-mule-encode-7bit 2)
 326      (bold builtin "GothicBBB-Medium-H" ps-mule-encode-7bit 2))
 327     (korean-ksc5601
 328      (normal builtin "Munhwa-Regular-KSC-EUC-H" ps-mule-encode-7bit 2)
 329      (bold builtin "Munhwa-Bold-KSC-EUC-H" ps-mule-encode-7bit 2))
 330     )
 331   "Sample setting of the `ps-mule-font-info-database' to use builtin PS font.
 332
 333 Currently, data for Japanese and Korean PostScript printers are listed.")
 334
 335 (defconst ps-mule-font-info-database-bdf
 336   '((ascii
 337      (normal bdf ("lt1-24-etl.bdf" "etl24-latin1.bdf") nil 1)
 338      (bold bdf ("lt1-16b-etl.bdf" "etl16b-latin1.bdf") nil 1)
 339      (italic bdf ("lt1-16i-etl.bdf" "etl16i-latin1.bdf") nil 1)
 340      (bold-italic bdf ("lt1-16bi-etl.bdf" "etl16bi-latin1.bdf") nil 1))
 341     (latin-iso8859-1
 342      (normal bdf ("lt1-24-etl.bdf" "etl24-latin1.bdf") iso-latin-1 1)
 343      (bold bdf ("lt1-16b-etl.bdf" "etl16b-latin1.bdf") iso-latin-1 1)
 344      (italic bdf ("lt1-16i-etl.bdf" "etl16i-latin1.bdf") iso-latin-1 1)
 345      (bold-italic bdf ("lt1-16bi-etl.bdf" "etl16bi-latin1.bdf") iso-latin-1 1))
 346     (latin-iso8859-2
 347      (normal bdf ("lt2-24-etl.bdf" "etl24-latin2.bdf") iso-latin-2 1))
 348     (latin-iso8859-3
 349      (normal bdf ("lt3-24-etl.bdf" "etl24-latin3.bdf") iso-latin-3 1))
 350     (latin-iso8859-4
 351      (normal bdf ("lt4-24-etl.bdf" "etl24-latin4.bdf") iso-latin-4 1))
 352     (thai-tis620
 353      (normal bdf ("thai24.bdf" "thai-24.bdf") thai-tis620 1))
 354     (greek-iso8859-7
 355      (normal bdf ("grk24-etl.bdf" "etl24-greek.bdf") greek-iso-8bit 1))
 356     ;; (arabic-iso8859-6        nil) ; not yet available
 357     (hebrew-iso8859-8
 358      (normal bdf ("heb24-etl.bdf" "etl24-hebrew.bdf") hebrew-iso-8bit 1))
 359     (katakana-jisx0201
 360      (normal bdf "12x24rk.bdf" ps-mule-encode-8bit 1))
 361     (latin-jisx0201
 362      (normal bdf "12x24rk.bdf" ps-mule-encode-7bit 1))
 363     (cyrillic-iso8859-5
 364      (normal bdf ("cyr24-etl.bdf" "etl24-cyrillic.bdf") cyrillic-iso-8bit 1))
 365     (latin-iso8859-9
 366      (normal bdf ("lt5-24-etl.bdf" "etl24-latin5.bdf") iso-latin-5 1))
 367     (japanese-jisx0208-1978
 368      (normal bdf "jiskan24.bdf" ps-mule-encode-7bit 2))
 369     (chinese-gb2312
 370      (normal bdf "gb24st.bdf" ps-mule-encode-7bit 2))
 371     (japanese-jisx0208
 372      (normal bdf "jiskan24.bdf" ps-mule-encode-7bit 2))
 373     (korean-ksc5601
 374      (normal bdf "hanglm24.bdf" ps-mule-encode-7bit 2))
 375     (japanese-jisx0212
 376      (normal bdf ("jksp40.bdf" "jisksp40.bdf") ps-mule-encode-7bit 2))
 377     (chinese-cns11643-1
 378      (normal bdf ("cns1-40.bdf" "cns-1-40.bdf") ps-mule-encode-7bit 2))
 379     (chinese-cns11643-2
 380      (normal bdf ("cns2-40.bdf" "cns-2-40.bdf") ps-mule-encode-7bit 2))
 381     (chinese-big5-1
 382      (normal bdf "taipei24.bdf" chinese-big5 2))
 383     (chinese-big5-2
 384      (normal bdf "taipei24.bdf" chinese-big5 2))
 385     (chinese-sisheng
 386      (normal bdf ("sish24-etl.bdf" "etl24-sisheng.bdf") ps-mule-encode-7bit 1))
 387     (ipa
 388      (normal bdf ("ipa24-etl.bdf" "etl24-ipa.bdf") ps-mule-encode-8bit 1))
 389     (vietnamese-viscii-lower
 390      (normal bdf ("visc24-etl.bdf" "etl24-viscii.bdf") vietnamese-viscii 1))
 391     (vietnamese-viscii-upper
 392      (normal bdf ("visc24-etl.bdf" "etl24-viscii.bdf") vietnamese-viscii 1))
 393     (arabic-digit
 394      (normal bdf ("arab24-0-etl.bdf" "etl24-arabic0.bdf") ps-mule-encode-7bit 1))
 395     (arabic-1-column
 396      (normal bdf ("arab24-1-etl.bdf" "etl24-arabic1.bdf") ps-mule-encode-7bit 1))
 397     ;; (ascii-right-to-left nil) ; not yet available
 398     (lao
 399      (normal bdf ("lao24-mule.bdf" "mule-lao-24.bdf") lao 1))
 400     (arabic-2-column
 401      (normal bdf ("arab24-2-etl.bdf" "etl24-arabic2.bdf") ps-mule-encode-7bit 1))
 402     (indian-is13194
 403      (normal bdf ("isci24-mule.bdf" "mule-iscii-24.bdf") ps-mule-encode-7bit 1))
 404     (indian-1-column
 405      (normal bdf ("ind1c24-mule.bdf" "mule-indian-1col-24.bdf") ps-mule-encode-7bit 2))
 406     (tibetan-1-column
 407      (normal bdf ("tib1c24-mule.bdf" "mule-tibmdx-1col-24.bdf") ps-mule-encode-7bit 2))
 408     (ethiopic
 409      (normal bdf ("ethio24f-uni.bdf" "ethiomx24f-uni.bdf") ps-mule-encode-ethiopic 2))
 410     (chinese-cns11643-3
 411      (normal bdf ("cns3-40.bdf" "cns-3-40.bdf") ps-mule-encode-7bit 2))
 412     (chinese-cns11643-4
 413      (normal bdf ("cns4-40.bdf" "cns-4-40.bdf") ps-mule-encode-7bit 2))
 414     (chinese-cns11643-5
 415      (normal bdf ("cns5-40.bdf" "cns-5-40.bdf") ps-mule-encode-7bit 2))
 416     (chinese-cns11643-6
 417      (normal bdf ("cns6-40.bdf" "cns-6-40.bdf") ps-mule-encode-7bit 2))
 418     (chinese-cns11643-7
 419      (normal bdf ("cns7-40.bdf" "cns-7-40.bdf") ps-mule-encode-7bit 2))
 420     (indian-2-column
 421      (normal bdf ("ind24-mule.bdf" "mule-indian-24.bdf") ps-mule-encode-7bit 2))
 422     (tibetan
 423      (normal bdf ("tib24p-mule.bdf" "tib24-mule.bdf" "mule-tibmdx-24.bdf")
 424              ps-mule-encode-7bit 2))
 425     (mule-unicode-0100-24ff
 426      (normal bdf "etl24-unicode.bdf" ps-mule-encode-ucs2 2))
 427     (mule-unicode-2500-33ff
 428      (normal bdf "etl24-unicode.bdf" ps-mule-encode-ucs2 2))
 429     (mule-unicode-e000-ffff
 430      (normal bdf "etl24-unicode.bdf" ps-mule-encode-ucs2 2)))
 431   "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.
 432 BDF (Bitmap Distribution Format) is a format used for distributing X's font
 433 source file.
 434
 435 Current default value list for BDF fonts is included in `intlfonts-1.2'
 436 which is a collection of X11 fonts for all characters supported by Emacs.
 437
 438 Using this list as default value to `ps-mule-font-info-database', all
 439 characters including ASCII and Latin-1 are printed by BDF fonts.
 440
 441 See also `ps-mule-font-info-database-ps-bdf'.")
 442
 443 (defconst ps-mule-font-info-database-ps-bdf
 444   (cons (car ps-mule-font-info-database-latin)
 445         (cdr (cdr ps-mule-font-info-database-bdf)))
 446   "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.
 447
 448 Current default value list for BDF fonts is included in `intlfonts-1.2'
 449 which is a collection of X11 fonts for all characters supported by Emacs.
 450
 451 Using this list as default value to `ps-mule-font-info-database', all
 452 characters except ASCII and Latin-1 characters are printed with BDF fonts.
 453 ASCII and Latin-1 characters are printed with PostScript font specified
 454 by `ps-font-family' and `ps-header-font-family'.
 455
 456 See also `ps-mule-font-info-database-bdf'.")
 457
 458 ;; Two typical encoding functions for PostScript fonts.
 459
 460 (defun ps-mule-encode-7bit (string)
 461   (ps-mule-encode-bit string 0))
 462
 463 (defun ps-mule-encode-8bit (string)
 464   (ps-mule-encode-bit string 128))
 465
 466 (defun ps-mule-encode-bit (string delta)
 467   (let* ((dim (charset-dimension (char-charset (string-to-char string))))
 468          (len (* (ps-mule-chars-in-string string) dim))
 469          (str (make-string len 0))
 470          (i 0)
 471          (j 0))
 472     (if (= dim 1)
 473         (while (< j len)
 474           (aset str j
 475                 (+ (nth 1 (split-char (ps-mule-string-char string i))) delta))
 476           (setq i (ps-mule-next-index string i)
 477                 j (1+ j)))
 478       (while (< j len)
 479         (let ((split (split-char (ps-mule-string-char string i))))
 480           (aset str j (+ (nth 1 split) delta))
 481           (aset str (1+ j) (+ (nth 2 split) delta))
 482           (setq i (ps-mule-next-index string i)
 483                 j (+ j 2)))))
 484     str))
 485
 486 ;; Special encoding function for Ethiopic.
 487 (if (boundp 'mule-version)              ; only if mule package is loaded
 488     (define-ccl-program ccl-encode-ethio-unicode
 489       `(1
 490         ((read r2)
 491          (loop
 492           (if (r2 == ,leading-code-private-22)
 493               ((read r0)
 494                (if (r0 == ,(charset-id 'ethiopic))
 495                    ((read r1 r2)
 496                     (r1 &= 127) (r2 &= 127)
 497                     (call ccl-encode-ethio-font)
 498                     (write r1)
 499                     (write-read-repeat r2))
 500                  ((write r2 r0)
 501                   (repeat))))
 502             (write-read-repeat r2))))))
 503   ;; to avoid compilation gripes
 504   (defvar ccl-encode-ethio-unicode nil))
 505
 506 (if (boundp 'mule-version)
 507     ;; bound mule-version
 508     (defun ps-mule-encode-ethiopic (string)
 509       (ccl-execute-on-string (symbol-value 'ccl-encode-ethio-unicode)
 510                              (make-vector 9 nil)
 511                              string))
 512   ;; unbound mule-version
 513   (defun ps-mule-encode-ethiopic (string)
 514     string))
 515
 516 ;; Special encoding for mule-unicode-* characters.
 517 (defun ps-mule-encode-ucs2 (string)
 518   (let* ((len (ps-mule-chars-in-string string))
 519          (str (make-string (* 2 len) 0))
 520          (i 0)
 521          (j 0)
 522          ch hi lo)
 523     (while (< i len)
 524       (setq ch (encode-char (ps-mule-string-char string i) 'ucs)
 525             hi (lsh ch -8)
 526             lo (logand ch 255))
 527       (aset str j hi)
 528       (aset str (1+ j) lo)
 529       (setq i (1+ i)
 530             j (+ j 2)))
 531     str))
 532
 533 ;; A charset which we are now processing.
 534 (defvar ps-mule-current-charset nil)
 535
 536 (defun ps-mule-get-font-spec (charset font-type)
 537   "Return FONT-SPEC for printing characters CHARSET with FONT-TYPE.
 538 FONT-SPEC is a list that has the form:
 539
 540         (FONT-SRC FONT-NAME ENCODING BYTES)
 541
 542 FONT-SPEC is extracted from `ps-mule-font-info-database'.
 543
 544 See the documentation of `ps-mule-font-info-database' for the meaning of each
 545 element of the list."
 546   (let ((slot (cdr (assq charset ps-mule-font-info-database))))
 547     (and slot
 548          (cdr (or (assq font-type slot)
 549                   (and (eq font-type 'bold-italic)
 550                        (or (assq 'bold slot) (assq 'italic slot)))
 551                   (assq 'normal slot))))))
 552
 553 ;; Functions to access each element of FONT-SPEC.
 554 (defsubst ps-mule-font-spec-src (font-spec) (car font-spec))
 555 (defsubst ps-mule-font-spec-name (font-spec) (nth 1 font-spec))
 556 (defsubst ps-mule-font-spec-encoding (font-spec) (nth 2 font-spec))
 557 (defsubst ps-mule-font-spec-bytes (font-spec) (nth 3 font-spec))
 558
 559 (defsubst ps-mule-printable-p (charset)
 560   "Non-nil if characters in CHARSET is printable."
 561   (ps-mule-get-font-spec charset 'normal))
 562
 563 (defconst ps-mule-external-libraries
 564   '((builtin nil nil
 565              nil nil nil)
 566     (bdf ps-bdf nil
 567          bdf-generate-prologue bdf-generate-font bdf-generate-glyphs)
 568     (pcf nil nil
 569          pcf-generate-prologue pcf-generate-font pcf-generate-glyphs)
 570     (vflib nil nil
 571            vflib-generate-prologue vflib-generate-font vflib-generate-glyphs))
 572   "Alist of information of external libraries to support PostScript printing.
 573 Each element has the form:
 574
 575     (FONT-SRC FEATURE INITIALIZED-P PROLOGUE-FUNC FONT-FUNC GLYPHS-FUNC)
 576
 577 FONT-SRC is the font source: builtin, bdf, pcf, or vflib.
 578
 579 FEATURE is the feature that provide a facility to handle FONT-SRC.  Except for
 580 `builtin' FONT-SRC, this feature is automatically `require'd before handling
 581 FONT-SRC.  Currently, we only have the feature `ps-bdf'.
 582
 583 INITIALIZED-P indicates if this library is initialized or not.
 584
 585 PROLOGUE-FUNC is a function to generate PostScript code which define several
 586 PostScript procedures that will be called by FONT-FUNC and GLYPHS-FUNC.  It is
 587 called with no argument, and should return a list of strings.
 588
 589 FONT-FUNC is a function to generate PostScript code which define a new font.  It
 590 is called with one argument FONT-SPEC, and should return a list of strings.
 591
 592 GLYPHS-FUNC is a function to generate PostScript code which define glyphs of
 593 characters.  It is called with three arguments FONT-SPEC, CODE-LIST, and BYTES,
 594 and should return a list of strings.")
 595
 596 (defun ps-mule-init-external-library (font-spec)
 597   "Initialize external library specified by FONT-SPEC for PostScript printing.
 598 See the documentation of `ps-mule-get-font-spec' for FONT-SPEC's meaning."
 599   (let* ((font-src (ps-mule-font-spec-src font-spec))
 600          (slot (assq font-src ps-mule-external-libraries)))
 601     (or (not font-src)
 602         (nth 2 slot)
 603         (let ((func (nth 3 slot)))
 604           (if func
 605               (progn
 606                 (require (nth 1 slot))
 607                 (ps-output-prologue (funcall func))))
 608           (setcar (nthcdr 2 slot) t)))))
 609
 610 ;; Cached glyph information of fonts, alist of:
 611 ;;      (FONT-NAME ((FONT-TYPE-NUMBER . SCALED-FONT-NAME) ...)
 612 ;;       cache CODE0 CODE1 ...)
 613 (defvar ps-mule-font-cache nil)
 614
 615 (defun ps-mule-generate-font (font-spec charset &optional header-p)
 616   "Generate PostScript codes to define a new font in FONT-SPEC for CHARSET.
 617
 618 If optional 3rd arg HEADER-P is non-nil, generate codes to define a header
 619 font."
 620   (let* ((font-name (ps-mule-font-spec-name font-spec))
 621          (font-name (if (consp font-name) (car font-name) font-name))
 622          (font-cache (assoc font-name ps-mule-font-cache))
 623          (font-src (ps-mule-font-spec-src font-spec))
 624          (func (nth 4 (assq font-src ps-mule-external-libraries)))
 625          (font-size (if header-p (if (eq ps-current-font 0)
 626                                      ps-header-title-font-size-internal
 627                                    ps-header-font-size-internal)
 628                       ps-font-size-internal))
 629          (current-font (+ ps-current-font (if header-p 10 0)))
 630          (scaled-font-name
 631           (cond (header-p
 632                  (format "h%d" ps-current-font))
 633                 ((eq charset 'ascii)
 634                  (format "f%d" ps-current-font))
 635                 (t
 636                  (format "f%02x-%d" (charset-id charset) ps-current-font)))))
 637     (and func (not font-cache)
 638          (ps-output-prologue (funcall func charset font-spec)))
 639     (ps-output-prologue
 640      (list (format "/%s %f /%s Def%sFontMule\n"
 641                    scaled-font-name font-size font-name
 642                    (if (or header-p
 643                            (eq ps-mule-current-charset 'ascii))
 644                        "Ascii" ""))))
 645     (if font-cache
 646         (setcar (cdr font-cache)
 647                 (cons (cons current-font scaled-font-name)
 648                       (nth 1 font-cache)))
 649       (setq font-cache (list font-name
 650                              (list (cons current-font scaled-font-name))
 651                              'cache)
 652             ps-mule-font-cache (cons font-cache ps-mule-font-cache)))
 653     font-cache))
 654
 655 (defun ps-mule-generate-glyphs (font-spec code-list)
 656   "Generate PostScript codes which generate glyphs for CODE-LIST of FONT-SPEC."
 657   (let* ((font-src (ps-mule-font-spec-src font-spec))
 658          (func (nth 5 (assq font-src ps-mule-external-libraries))))
 659     (and func
 660          (ps-output-prologue
 661           (funcall func font-spec code-list
 662                    (ps-mule-font-spec-bytes font-spec))))))
 663
 664 (defun ps-mule-prepare-font (font-spec string charset
 665                                        &optional no-setfont header-p)
 666   "Generate PostScript codes to print STRING of CHARSET by font FONT-SPEC.
 667
 668 The generated code is inserted on prologue part except the code that sets the
 669 current font (using PostScript procedure `FM').
 670
 671 If optional 4th arg NO-SETFONT is non-nil, don't generate the code for setting
 672 the current font.
 673
 674 If optional 5th arg HEADER-P is non-nil, generate a code for setting a header
 675 font."
 676   (let* ((font-name (ps-mule-font-spec-name font-spec))
 677          (font-name (if (consp font-name) (car font-name) font-name))
 678          (current-font (+ ps-current-font (if header-p 10 0)))
 679          (font-cache (assoc font-name ps-mule-font-cache)))
 680     (or (and font-cache (assq current-font (nth 1 font-cache)))
 681         (setq font-cache (ps-mule-generate-font font-spec charset header-p)))
 682     (or no-setfont
 683         (let ((new-font (cdr (assq current-font (nth 1 font-cache)))))
 684           (or (equal new-font ps-last-font)
 685               (progn
 686                 (ps-output (format "/%s FM\n" new-font))
 687                 (setq ps-last-font new-font)))))
 688     (if (nth 5 (assq (ps-mule-font-spec-src font-spec)
 689                      ps-mule-external-libraries))
 690         ;; We have to generate PostScript codes which define glyphs.
 691         (let* ((cached-codes (nthcdr 2 font-cache))
 692                (bytes (ps-mule-font-spec-bytes font-spec))
 693                (len (length string))
 694                (i 0)
 695                newcodes code)
 696           (while (< i len)
 697             (setq code (if (= bytes 1)
 698                            (aref string i)
 699                          (+ (* (aref string i) 256) (aref string (1+ i)))))
 700             (or (memq code cached-codes)
 701                 (progn
 702                   (setq newcodes (cons code newcodes))
 703                   (setcdr cached-codes (cons code (cdr cached-codes)))))
 704             (setq i (+ i bytes)))
 705           (and newcodes
 706                (ps-mule-generate-glyphs font-spec newcodes))))))
 707
 708 ;;;###autoload
 709 (defun ps-mule-prepare-ascii-font (string)
 710   "Setup special ASCII font for STRING.
 711 STRING should contain only ASCII characters."
 712   (let ((font-spec
 713          (ps-mule-get-font-spec
 714           'ascii
 715           (car (nth ps-current-font (ps-font-alist 'ps-font-for-text))))))
 716     (and font-spec
 717          (ps-mule-prepare-font font-spec string 'ascii))))
 718
 719 ;;;###autoload
 720 (defun ps-mule-set-ascii-font ()
 721   (unless (eq ps-mule-current-charset 'ascii)
 722     (ps-set-font ps-current-font)
 723     (setq ps-mule-current-charset 'ascii)))
 724
 725 ;; List of charsets of multi-byte characters in a text being printed.
 726 ;; If the text doesn't contain any multi-byte characters (i.e. only ASCII),
 727 ;; the value is nil.
 728 (defvar ps-mule-charset-list nil)
 729
 730 ;; This is a PostScript code inserted in the header of generated PostScript.
 731 (defconst ps-mule-prologue
 732   "%%%% Start of Mule Section
 733
 734 %% Working dictionary for general use.
 735 /MuleDict 10 dict def
 736
 737 %% Adjust /RelativeCompose properly by checking /BaselineOffset.
 738 /AdjustRelativeCompose {        % fontdict  |-  fontdict
 739   dup length 2 add dict begin
 740     { 1 index /FID ne { def } { pop pop } ifelse } forall
 741     currentdict /BaselineOffset known {
 742         BaselineOffset false eq { /BaselineOffset 0 def } if
 743     } {
 744       /BaselineOffset 0 def
 745     } ifelse
 746     currentdict /RelativeCompose known not {
 747       /RelativeCompose [ 0 0.1 ] def
 748     } {
 749       RelativeCompose false ne {
 750         [ BaselineOffset RelativeCompose BaselineOffset add
 751           [ FontMatrix { FontSize div } forall ] transform ]
 752         /RelativeCompose exch def
 753       } if
 754     } ifelse
 755     currentdict
 756   end
 757 } def
 758
 759 %% Define already scaled font for non-ASCII character sets.
 760 /DefFontMule {                  % fontname size basefont  |-  --
 761   findfont exch scalefont AdjustRelativeCompose definefont pop
 762 } bind def
 763
 764 %% Define already scaled font for ASCII character sets.
 765 /DefAsciiFontMule {             % fontname size basefont  |-
 766   MuleDict begin
 767   findfont dup /Encoding get /ISOLatin1Encoding exch def
 768   exch scalefont AdjustRelativeCompose reencodeFontISO
 769   end
 770 } def
 771
 772 /CurrentFont false def
 773
 774 %% Set the specified font to use.
 775 %% For non-ASCII font, don't install Ascent, etc.
 776 /FM {                           %  fontname  |-  --
 777     /font exch def
 778     font /f0 eq font /f1 eq font /f2 eq font /f3 eq or or or {
 779       font F
 780     } {
 781       font findfont setfont
 782     } ifelse
 783 } bind def
 784
 785 %% Show vacant box for characters which don't have appropriate font.
 786 /SB {                           % count column |-  --
 787     SpaceWidth mul /w exch def
 788     1 exch 1 exch { %for
 789         pop
 790         gsave
 791         0 setlinewidth
 792         0 Descent rmoveto w 0 rlineto
 793         0 LineHeight rlineto w neg 0 rlineto closepath stroke
 794         grestore
 795         w 0 rmoveto
 796     } for
 797 } bind def
 798
 799 %% Flag to tell if we are now handling a composition.  This is
 800 %% defined here because both composition handler and bitmap font
 801 %% handler require it.
 802 /Composing false def
 803
 804 %%%% End of Mule Section
 805
 806 "
 807   "PostScript code for printing multi-byte characters.")
 808
 809 (defvar ps-mule-prologue-generated nil)
 810
 811 (defun ps-mule-prologue-generated ()
 812   (unless ps-mule-prologue-generated
 813     (ps-output-prologue ps-mule-prologue)
 814     (setq ps-mule-prologue-generated t)))
 815
 816 (defun ps-mule-find-wrappoint (from to char-width &optional composition)
 817   "Find the longest sequence which is printable in the current line.
 818
 819 The search starts at FROM and goes until TO.
 820
 821 Optional 4th arg COMPOSITION, if non-nil, is information of
 822 composition starting at FROM.
 823
 824 If COMPOSITION is nil, it is assumed that all characters between FROM
 825 and TO belong to a charset in `ps-mule-current-charset'.  Otherwise,
 826 it is assumed that all characters between FROM and TO belong to the
 827 same composition.
 828
 829 CHAR-WIDTH is the average width of ASCII characters in the current font.
 830
 831 Returns the value:
 832
 833         (ENDPOS . RUN-WIDTH)
 834
 835 Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
 836 the sequence."
 837   (if (or composition (eq ps-mule-current-charset 'composition))
 838       ;; We must draw one char by one.
 839       (let ((run-width (if composition
 840                            (nth 5 composition)
 841                          (* (char-width (char-after from)) char-width))))
 842         (if (> run-width ps-width-remaining)
 843             (cons from ps-width-remaining)
 844           (cons (if composition
 845                     (nth 1 composition)
 846                   (ps-mule-next-point from))
 847                 run-width)))
 848     ;; We assume that all characters in this range have the same width.
 849     (setq char-width (* char-width (charset-width ps-mule-current-charset)))
 850     (let ((run-width (* (chars-in-region from to) char-width)))
 851       (if (> run-width ps-width-remaining)
 852           (cons (min to
 853                      (save-excursion
 854                        (goto-char from)
 855                        (forward-point
 856                         (truncate (/ ps-width-remaining char-width)))))
 857                 ps-width-remaining)
 858         (cons to run-width)))))
 859
 860 ;;;###autoload
 861 (defun ps-mule-plot-string (from to &optional bg-color)
 862   "Generate PostScript code for plotting characters in the region FROM and TO.
 863
 864 It is assumed that all characters in this region belong to the same charset.
 865
 866 Optional argument BG-COLOR specifies background color.
 867
 868 Returns the value:
 869
 870         (ENDPOS . RUN-WIDTH)
 871
 872 Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
 873 the sequence."
 874   (setq ps-mule-current-charset (charset-after from))
 875   (let* ((wrappoint (ps-mule-find-wrappoint
 876                      from to (ps-avg-char-width 'ps-font-for-text)))
 877          (to (car wrappoint))
 878          (font-type (car (nth ps-current-font
 879                               (ps-font-alist 'ps-font-for-text))))
 880          (font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type))
 881          (string (buffer-substring-no-properties from to)))
 882     (cond
 883      ((= from to)
 884       ;; We can't print any more characters in the current line.
 885       nil)
 886
 887      (font-spec
 888       ;; We surely have a font for printing this character set.
 889       (ps-output-string (ps-mule-string-encoding font-spec string))
 890       (ps-output " S\n"))
 891
 892      ((eq ps-mule-current-charset 'latin-iso8859-1)
 893       ;; Latin-1 can be printed by a normal ASCII font.
 894       (ps-output-string (ps-mule-string-ascii string))
 895       (ps-output " S\n"))
 896
 897      ;; This case is obsolete for Emacs 21.
 898      ((eq ps-mule-current-charset 'composition)
 899       (ps-mule-plot-composition from (ps-mule-next-point from) bg-color))
 900
 901      (t
 902       ;; No way to print this charset.  Just show a vacant box of an
 903       ;; appropriate width.
 904       (ps-output (format "%d %d SB\n"
 905                          (length string)
 906                          (if (eq ps-mule-current-charset 'composition)
 907                              (char-width (char-after from))
 908                            (charset-width ps-mule-current-charset))))))
 909     wrappoint))
 910
 911 ;;;###autoload
 912 (defun ps-mule-plot-composition (from to &optional bg-color)
 913   "Generate PostScript code for plotting composition in the region FROM and TO.
 914
 915 It is assumed that all characters in this region belong to the same
 916 composition.
 917
 918 Optional argument BG-COLOR specifies background color.
 919
 920 Returns the value:
 921
 922         (ENDPOS . RUN-WIDTH)
 923
 924 Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
 925 the sequence."
 926   (let* ((composition (find-composition from nil nil t))
 927          (wrappoint (ps-mule-find-wrappoint
 928                      from to (ps-avg-char-width 'ps-font-for-text)
 929                      composition))
 930          (to (car wrappoint))
 931          (font-type (car (nth ps-current-font
 932                               (ps-font-alist 'ps-font-for-text)))))
 933     (if (< from to)
 934         ;; We can print this composition in the current line.
 935         (let ((components (nth 2 composition)))
 936           (ps-mule-plot-components
 937            (ps-mule-prepare-font-for-components components font-type)
 938            (if (nth 3 composition) "RLC" "RBC"))))
 939     wrappoint))
 940
 941 ;; Prepare font of FONT-TYPE for printing COMPONENTS.  By side effect,
 942 ;; change character elements in COMPONENTS to the form:
 943 ;;      ENCODED-STRING or (FONTNAME . ENCODED-STRING)
 944 ;; and change rule elements to the encoded value (integer).
 945 ;; The latter form is used if we much change font for the character.
 946
 947 (defun ps-mule-prepare-font-for-components (components font-type)
 948   (let ((len (length components))
 949         (i 0)
 950         elt)
 951     (while (< i len)
 952       (setq elt (aref components i))
 953       (if (consp elt)
 954           ;; ELT is a composition rule.
 955           (setq elt (encode-composition-rule elt))
 956         ;; ELT is a glyph character.
 957         (let* ((charset (char-charset elt))
 958                (font (or (eq charset ps-mule-current-charset)
 959                          (if (eq charset 'ascii)
 960                              (format "/f%d" ps-current-font)
 961                            (format "/f%02x-%d"
 962                                    (charset-id charset) ps-current-font))))
 963                 str)
 964           (setq ps-mule-current-charset charset
 965                 str (ps-mule-string-encoding
 966                      (ps-mule-get-font-spec charset font-type)
 967                      (char-to-string elt)
 968                      'no-setfont))
 969           (if (stringp font)
 970               (setq elt (cons font str) ps-last-font font)
 971             (setq elt str))))
 972       (aset components i elt)
 973       (setq i (1+ i))))
 974   components)
 975
 976 (defun ps-mule-plot-components (components tail)
 977   (let ((elt (aref components 0))
 978         (len (length components))
 979         (i 1))
 980     (ps-output "[ ")
 981     (if (stringp elt)
 982         (ps-output-string elt)
 983       (ps-output (car elt) " ")
 984       (ps-output-string (cdr elt)))
 985     (while (< i len)
 986       (setq elt (aref components i) i (1+ i))
 987       (ps-output " ")
 988       (cond ((stringp elt)
 989              (ps-output-string elt))
 990             ((consp elt)
 991              (ps-output (car elt) " ")
 992              (ps-output-string (cdr elt)))
 993             (t                          ; i.e. (integerp elt)
 994              (ps-output (format "%d" elt)))))
 995     (ps-output " ] " tail "\n")))
 996
 997 ;; Composite font support
 998
 999 (defvar ps-mule-composition-prologue-generated nil)
1000
1001 (defconst ps-mule-composition-prologue
1002   "%%%% Character composition handler
1003 /RelativeCompositionSkip 0.4 def
1004
1005 %% Get a bounding box (relative to currentpoint) of STR.
1006 /GetPathBox {                   % str  |-  --
1007     gsave
1008     currentfont /FontType get 3 eq { %ifelse
1009         stringwidth pop pop
1010     } {
1011         currentpoint /y exch def /x exch def
1012         false charpath flattenpath pathbbox
1013         y sub /URY exch def x sub /URX exch def
1014         y sub /LLY exch def x sub /LLX exch def
1015     } ifelse
1016     grestore
1017 } bind def
1018
1019 %% Apply effects (underline, strikeout, overline, box) to the
1020 %% rectangle specified by TOP BOTTOM LEFT RIGHT.
1021 /SpecialEffect {                                        % --  |-  --
1022     currentpoint dup TOP add /yy exch def BOTTOM add /YY exch def
1023     dup LEFT add /xx exch def RIGHT add /XX exch def
1024     %% Adjust positions for future shadowing.
1025     Effect 8 and 0 ne {
1026         /yy yy Yshadow add def
1027         /XX XX Xshadow add def
1028     } if
1029     Effect 1 and 0 ne { UnderlinePosition Hline } if    % underline
1030     Effect 2 and 0 ne { StrikeoutPosition Hline } if    % strikeout
1031     Effect 4 and 0 ne { OverlinePosition  Hline } if    % overline
1032     bg {                                                % background
1033         true
1034         Effect 16 and 0 ne {SpaceBackground doBox} { xx yy XX YY doRect} ifelse
1035     } if
1036     Effect 16 and 0 ne { false 0 doBox } if             % box
1037 } def
1038
1039 %% Show STR with effects (shadow, outline).
1040 /ShowWithEffect {                                       % str  |-  --
1041     Effect 8 and 0 ne { dup doShadow } if
1042     Effect 32 and 0 ne { true doOutline } { show } ifelse
1043 } def
1044
1045 %% Draw COMPONENTS which have the form [ font0? [str0 xoff0 yoff0] ... ].
1046 /ShowComponents {                                       % components  |-  -
1047     LEFT 0 lt { LEFT neg 0 rmoveto } if
1048     {
1049         dup type /nametype eq {                         % font
1050             FM
1051         } {                                             % [ str xoff yoff ]
1052             gsave
1053             aload pop rmoveto ShowWithEffect
1054             grestore
1055         } ifelse
1056     } forall
1057     RIGHT 0 rmoveto
1058 } def
1059
1060 %% Show relative composition.
1061 /RLC {          % [ font0? str0 font1? str1 ... fontN? strN ]  |-  --
1062     /components exch def
1063     /Composing true def
1064     /first true def
1065     gsave
1066     [ components {
1067         /elt exch def
1068         elt type /nametype eq {                         % font
1069             elt dup FM
1070         } { first {                                     % first string
1071             /first false def
1072             elt GetPathBox
1073             %% Bounding box of overall glyphs.
1074             /LEFT LLX def
1075             /RIGHT URX def
1076             /TOP URY def
1077             /BOTTOM LLY def
1078             currentfont /RelativeCompose known {
1079                 /relative currentfont /RelativeCompose get def
1080             } {
1081                 %% Disable relative composition by setting sufficiently low
1082                 %% and high positions.
1083                 /relative [ -100000 100000 ] def
1084             } ifelse
1085             [ elt 0 0 ]
1086         } {                                             % other strings
1087             elt GetPathBox
1088             [ elt                                       % str
1089               LLX 0 lt { RIGHT } { 0 } ifelse           % xoff
1090               LLY relative 1 get ge {                   % compose on TOP
1091                   TOP LLY sub RelativeCompositionSkip add       % yoff
1092                   /TOP TOP URY LLY sub add RelativeCompositionSkip add def
1093               } { URY relative 0 get le {               % compose under BOTTOM
1094                   BOTTOM URY sub RelativeCompositionSkip sub % yoff
1095                   /BOTTOM BOTTOM URY LLY sub sub
1096                         RelativeCompositionSkip sub def
1097               } {
1098                   0                                     % yoff
1099                   URY TOP gt { /TOP URY def } if
1100                   LLY BOTTOM lt { /BOTTOM LLY def } if
1101               } ifelse } ifelse
1102               ]
1103             URX RIGHT gt { /RIGHT URX def } if
1104         } ifelse } ifelse
1105     } forall ] /components exch def
1106     grestore
1107
1108     %% Reflect special effects.
1109     SpecialEffect
1110
1111     %% Draw components while ignoring effects other than shadow and outline.
1112     components ShowComponents
1113     /Composing false def
1114
1115 } def
1116
1117 %% Show rule-base composition.
1118 /RBC {          % [ font0? str0 rule1 font1? str1 rule2 ... strN ]  |-  --
1119     /components exch def
1120     /Composing true def
1121     /first true def
1122     gsave
1123     [ components {
1124         /elt exch def
1125         elt type /nametype eq {                         % font
1126             elt dup FM
1127         } { elt type /integertype eq {                  % rule
1128             %% This RULE decoding should be compatible with macro
1129             %% COMPOSITION_DECODE_RULE in emacs/src/composite.h.
1130             elt 12 idiv dup 3 mod /grefx exch def 3 idiv /grefy exch def
1131             elt 12 mod dup 3 mod /nrefx exch def 3 idiv /nrefy exch def
1132         } { first {                                     % first string
1133             /first false def
1134             elt GetPathBox
1135             %% Bounding box of overall glyphs.
1136             /LEFT LLX def
1137             /RIGHT URX def
1138             /TOP URY def
1139             /BOTTOM LLY def
1140             /WIDTH RIGHT LEFT sub def
1141             [ elt 0 0 ]
1142         } {                                             % other strings
1143             elt GetPathBox
1144             /width URX LLX sub def
1145             /height URY LLY sub def
1146             /left LEFT [ 0 WIDTH 2 div WIDTH ] grefx get add
1147                 [ 0 width 2 div width ] nrefx get sub def
1148             /bottom [ TOP 0 BOTTOM TOP BOTTOM add 2 div ] grefy get
1149                 [ height LLY neg 0 height 2 div ] nrefy get sub def
1150             %% Update bounding box
1151             left LEFT lt { /LEFT left def } if
1152             left width add RIGHT gt { /RIGHT left width add def } if
1153             /WIDTH RIGHT LEFT sub def
1154             bottom BOTTOM lt { /BOTTOM bottom def } if
1155             bottom height add TOP gt { /TOP bottom height add def } if
1156             [ elt left LLX sub bottom LLY sub ]
1157         } ifelse } ifelse } ifelse
1158     } forall ] /components exch def
1159     grestore
1160
1161     %% Reflect special effects.
1162     SpecialEffect
1163
1164     %% Draw components while ignoring effects other than shadow and outline.
1165     components ShowComponents
1166
1167     /Composing false def
1168 } def
1169 %%%% End of character composition handler
1170
1171 "
1172   "PostScript code for printing character composition.")
1173
1174 (defun ps-mule-string-ascii (str)
1175   (ps-set-font ps-current-font)
1176   (string-as-unibyte (encode-coding-string str 'iso-latin-1)))
1177
1178 ;; Encode STR for a font specified by FONT-SPEC and return the result.
1179 ;; If necessary, it generates the PostScript code for the font and glyphs to
1180 ;; print STR.  If optional 4th arg HEADER-P is non-nil, it is assumed that STR
1181 ;; is for headers.
1182 (defun ps-mule-string-encoding (font-spec str &optional no-setfont header-p)
1183   (let ((encoding (ps-mule-font-spec-encoding font-spec)))
1184     (setq str
1185           (string-as-unibyte
1186            (cond ((coding-system-p encoding)
1187                   (encode-coding-string str encoding))
1188                  ((functionp encoding)
1189                   (funcall encoding str))
1190                  (encoding
1191                   (error "Invalid coding system or function: %s" encoding))
1192                  (t
1193                   str))))
1194     (if (ps-mule-font-spec-src font-spec)
1195         (ps-mule-prepare-font font-spec str ps-mule-current-charset
1196                               (or no-setfont header-p)
1197                               header-p)
1198       (or no-setfont
1199           (ps-set-font ps-current-font)))
1200     str))
1201
1202 ;; Bitmap font support
1203
1204 (defvar ps-mule-bitmap-prologue-generated nil)
1205
1206 (defconst ps-mule-bitmap-prologue
1207   "%%%% Bitmap font handler
1208
1209 /str7 7 string def              % working area
1210
1211 %% We grow the dictionary one bunch (1024 entries) by one.
1212 /BitmapDictArray 256 array def
1213 /BitmapDictLength 1024 def
1214 /BitmapDictIndex -1 def
1215
1216 /NewBitmapDict {                % --  |-  --
1217     /BitmapDictIndex BitmapDictIndex 1 add def
1218     BitmapDictArray BitmapDictIndex BitmapDictLength dict put
1219 } bind def
1220
1221 %% Make at least one dictionary.
1222 NewBitmapDict
1223
1224 /AddBitmap {                    % gloval-charname bitmap-data  |-  --
1225     BitmapDictArray BitmapDictIndex get
1226     dup length BitmapDictLength ge {
1227         pop
1228         NewBitmapDict
1229         BitmapDictArray BitmapDictIndex get
1230     } if
1231     3 1 roll put
1232 } bind def
1233
1234 /GetBitmap {                    % gloval-charname  |-  bitmap-data
1235     0 1 BitmapDictIndex { BitmapDictArray exch get begin } for
1236     load
1237     0 1 BitmapDictIndex { pop end } for
1238 } bind def
1239
1240 %% Return a global character name which can be used as a key in the
1241 %% bitmap dictionary.
1242 /GlobalCharName {               % fontidx code1 code2  |-  gloval-charname
1243     exch 256 mul add exch 65536 mul add 16777216 add 16 str7 cvrs 0 66 put
1244     str7 cvn
1245 } bind def
1246
1247 %% Character code holder for a 2-byte character.
1248 /FirstCode -1 def
1249
1250 %% Glyph rendering procedure
1251 /BuildGlyphCommon {             % fontdict charname  |-  --
1252     1 index /FontDimension get 1 eq { /FirstCode 0 store } if
1253     NameIndexDict exch get      % STACK: fontdict charcode
1254     FirstCode 0 lt { %ifelse
1255         %% This is the first byte of a 2-byte character.  Just
1256         %% remember it for the moment.
1257         /FirstCode exch store
1258         pop
1259         0 0 setcharwidth
1260     } {
1261         1 index /FontSize get /size exch def
1262         1 index /FontSpaceWidthRatio get /ratio exch def
1263         1 index /FontIndex get exch FirstCode exch
1264         GlobalCharName GetBitmap /bmp exch def
1265         %% bmp == [ DWIDTH BBX-WIDTH BBX-HEIGHT BBX-XOFF BBX-YOFF BITMAP ]
1266         Composing { %ifelse
1267             /FontMatrix get [ exch { size div } forall ] /mtrx exch def
1268             bmp 3 get bmp 4 get mtrx transform
1269             /LLY exch def /LLX exch def
1270             bmp 1 get bmp 3 get add bmp 2 get bmp 4 get add mtrx transform
1271             /URY exch def /URX exch def
1272         } {
1273             pop
1274         } ifelse
1275         /FirstCode -1 store
1276
1277         bmp 0 get SpaceWidthRatio ratio div mul size div 0      % wx wy
1278         setcharwidth                    % We can't use setcachedevice here.
1279
1280         bmp 1 get 0 gt bmp 2 get 0 gt and {
1281             bmp 1 get bmp 2 get         % width height
1282             true                        % polarity
1283             [ size 0 0 size neg bmp 3 get neg bmp 2 get bmp 4 get add ] % matrix
1284             bmp 5 1 getinterval cvx     % datasrc
1285             imagemask
1286         } if
1287     } ifelse
1288 } bind def
1289
1290 /BuildCharCommon {
1291     1 index /Encoding get exch get
1292     1 index /BuildGlyph get exec
1293 } bind def
1294
1295 %% Bitmap font creator
1296
1297 %% Common Encoding shared by all bitmap fonts.
1298 /EncodingCommon 256 array def
1299 %% Mapping table from character name to character code.
1300 /NameIndexDict 256 dict def
1301 0 1 255 { %for
1302     /idx exch def
1303     /idxname idx 256 add 16 (XXX) cvrs dup 0 67 put cvn def % `C' == 67
1304     EncodingCommon idx idxname put
1305     NameIndexDict idxname idx put
1306 } for
1307
1308 /GlobalFontIndex 0 def
1309
1310 %% fontname dim col fontsize relative-compose baseline-offset fbbx  |-  --
1311 /BitmapFont {
1312     15 dict begin
1313     /FontBBox exch def
1314     /BaselineOffset exch def
1315     /RelativeCompose exch def
1316     /FontSize exch def
1317     /FontBBox [ FontBBox { FontSize div } forall ] def
1318     FontBBox 2 get FontBBox 0 get sub exch div
1319     /FontSpaceWidthRatio exch def
1320     /FontDimension exch def
1321     /FontIndex GlobalFontIndex def
1322     /FontType 3 def
1323     /FontMatrix matrix def
1324     /Encoding EncodingCommon def
1325     /BuildGlyph { BuildGlyphCommon } def
1326     /BuildChar { BuildCharCommon } def
1327     currentdict end
1328     definefont pop
1329     /GlobalFontIndex GlobalFontIndex 1 add def
1330 } bind def
1331
1332 %% Define a new bitmap font.
1333 %% fontname dim col fontsize relative-compose baseline-offset fbbx  |-  --
1334 /NF {
1335     /fbbx exch def
1336     %% Convert BDF's FontBoundingBox to PostScript's FontBBox
1337     [ fbbx 2 get fbbx 3 get
1338       fbbx 2 get fbbx 0 get add fbbx 3 get fbbx 1 get add ]
1339     BitmapFont
1340 } bind def
1341
1342 %% Define a glyph for the specified font and character.
1343 /NG {                           % fontname charcode bitmap-data  |-  --
1344     /bmp exch def
1345     exch findfont dup /BaselineOffset get bmp 4 get add bmp exch 4 exch put
1346     /FontIndex get exch
1347     dup 256 idiv exch 256 mod GlobalCharName
1348     bmp AddBitmap
1349 } bind def
1350 %%%% End of bitmap font handler
1351
1352 ")
1353
1354 ;; External library support.
1355
1356 ;; The following three functions are to be called from external
1357 ;; libraries which support bitmap fonts (e.g. `bdf') to get
1358 ;; appropriate PostScript code.
1359
1360 (defun ps-mule-generate-bitmap-prologue ()
1361   (unless ps-mule-bitmap-prologue-generated
1362     (setq ps-mule-bitmap-prologue-generated t)
1363     (list ps-mule-bitmap-prologue)))
1364
1365 (defun ps-mule-generate-bitmap-font (&rest args)
1366   (list (apply 'format "/%s %d %d %f %S %d %S NF\n" args)))
1367
1368 (defun ps-mule-generate-bitmap-glyph (font-name code dwidth bbx bitmap)
1369   (format "/%s %d [ %d %d %d %d %d <%s> ] NG\n"
1370           font-name code
1371           dwidth (aref bbx 0) (aref bbx 1) (aref bbx 2) (aref bbx 3)
1372           bitmap))
1373
1374 ;; Mule specific initializers.
1375
1376 ;;;###autoload
1377 (defun ps-mule-initialize ()
1378   "Initialize global data for printing multi-byte characters."
1379   (setq ps-mule-font-cache nil
1380         ps-mule-prologue-generated nil
1381         ps-mule-composition-prologue-generated nil
1382         ps-mule-bitmap-prologue-generated nil)
1383   (mapcar `(lambda (x) (setcar (nthcdr 2 x) nil))
1384           ps-mule-external-libraries))
1385
1386 (defvar ps-mule-header-charsets nil)
1387
1388 ;;;###autoload
1389 (defun ps-mule-encode-header-string (string fonttag)
1390   "Generate PostScript code for ploting STRING by font FONTTAG.
1391 FONTTAG should be a string \"/h0\" or \"/h1\"."
1392   (setq string (cond ((not (stringp string))
1393                       "")
1394                      ((multibyte-string-p string)
1395                       (copy-sequence string))
1396                      (t
1397                       (string-make-multibyte string))))
1398   (when ps-mule-header-charsets
1399     (if (eq (car ps-mule-header-charsets) 'latin-iso8859-1)
1400         ;; Latin1 characters can be printed by the standard PostScript
1401         ;; font.  Converts the other non-ASCII characters to `?'.
1402         (let ((len (length string))
1403               (i 0))
1404           (while (< i len)
1405             (or (memq (char-charset (aref string i)) '(ascii latin-iso8859-1))
1406                 (aset string i ??))
1407             (setq i (1+ i)))
1408           (setq string (encode-coding-string string 'iso-latin-1)))
1409       ;; We must prepare a font for the first non-ASCII and non-Latin1
1410       ;; character in STRING.
1411       (let* ((ps-current-font (if (string= fonttag "/h0") 0 1))
1412              (ps-mule-current-charset (car ps-mule-header-charsets))
1413              (font-type (car (nth ps-current-font
1414                                   (ps-font-alist 'ps-font-for-header))))
1415              (font-spec (ps-mule-get-font-spec ps-mule-current-charset
1416                                                font-type)))
1417         (if (or (not font-spec)
1418                 (/= (charset-dimension ps-mule-current-charset) 1))
1419             ;; We don't have a proper font, or we can't print them on
1420             ;; header because this kind of charset is not ASCII
1421             ;; compatible.
1422             (let ((len (length string))
1423                   (i 0))
1424               (while (< i len)
1425                 (or (memq (char-charset (aref string i))
1426                           '(ascii latin-iso8859-1))
1427                     (aset string i ??))
1428                 (setq i (1+ i)))
1429               (setq string (encode-coding-string string 'iso-latin-1)))
1430           (let ((charsets (list 'ascii (car ps-mule-header-charsets)))
1431                 (len (length string))
1432                 (i 0))
1433             (while (< i len)
1434               (or (memq (char-charset (aref string i)) charsets)
1435                   (aset string i ??))
1436               (setq i (1+ i))))
1437           (setq string (ps-mule-string-encoding font-spec string nil t))))))
1438   string)
1439
1440 ;;;###autoload
1441 (defun ps-mule-header-string-charsets ()
1442   "Return a list of character sets that appears in header strings."
1443   (let* ((str (ps-header-footer-string))
1444          (len (length str))
1445          (i 0)
1446          charset-list)
1447     (while (< i len)
1448       (let ((charset (char-charset (aref str i))))
1449         (setq i (1+ i))
1450         (or (eq charset 'ascii)
1451             (memq charset charset-list)
1452             (setq charset-list (cons charset charset-list)))))
1453     charset-list))
1454
1455 ;;;###autoload
1456 (defun ps-mule-begin-job (from to)
1457   "Start printing job for multi-byte chars between FROM and TO.
1458 This checks if all multi-byte characters in the region are printable or not."
1459   (setq ps-mule-charset-list nil
1460         ps-mule-header-charsets nil
1461         ps-mule-font-info-database
1462         (cond ((eq ps-multibyte-buffer 'non-latin-printer)
1463                ps-mule-font-info-database-ps)
1464               ((eq ps-multibyte-buffer 'bdf-font)
1465                ps-mule-font-info-database-bdf)
1466               ((eq ps-multibyte-buffer 'bdf-font-except-latin)
1467                ps-mule-font-info-database-ps-bdf)
1468               (t
1469                ps-mule-font-info-database-default)))
1470   (and (boundp 'enable-multibyte-characters)
1471        enable-multibyte-characters
1472        ;; Initialize `ps-mule-charset-list'.  If some characters aren't
1473        ;; printable, warn it.
1474        (let ((charsets (find-charset-region from to)))
1475          (setq charsets (delq 'ascii (delq 'unknown (delq nil charsets)))
1476                ps-mule-charset-list charsets)
1477          (save-excursion
1478            (goto-char from)
1479            (and (search-forward "\200" to t)
1480                 (setq ps-mule-charset-list
1481                       (cons 'composition ps-mule-charset-list))))
1482          ;; We also have to check non-ASCII charsets in the header strings.
1483          (let ((tail (ps-mule-header-string-charsets)))
1484            (while tail
1485              (unless (eq (car tail) 'ascii)
1486                (setq ps-mule-header-charsets
1487                      (cons (car tail) ps-mule-header-charsets))
1488                (or (memq (car tail) charsets)
1489                    (setq charsets (cons (car tail) charsets))))
1490              (setq tail (cdr tail))))
1491          (while charsets
1492            (setq charsets
1493                  (cond
1494                   ((or (eq (car charsets) 'composition)
1495                        (ps-mule-printable-p (car charsets)))
1496                    (cdr charsets))
1497                   ((y-or-n-p
1498                     "Font for some characters not found, continue anyway? ")
1499                    nil)
1500                   (t
1501                    (error "Printing cancelled")))))))
1502
1503   (setq ps-mule-current-charset 'ascii)
1504
1505   (if (and (nth 2 (find-composition from to))
1506            (not ps-mule-composition-prologue-generated))
1507       (progn
1508         (ps-mule-prologue-generated)
1509         (ps-output-prologue ps-mule-composition-prologue)
1510         (setq ps-mule-composition-prologue-generated t)))
1511
1512   (if (or ps-mule-charset-list ps-mule-header-charsets)
1513       (let ((the-list (append ps-mule-header-charsets ps-mule-charset-list))
1514             font-spec elt)
1515         (ps-mule-prologue-generated)
1516         ;; If external functions are necessary, generate prologues for them.
1517         (while the-list
1518           (setq elt (car the-list)
1519                 the-list (cdr the-list))
1520           (cond ((and (eq elt 'composition)
1521                       (not ps-mule-composition-prologue-generated))
1522                  (ps-output-prologue ps-mule-composition-prologue)
1523                  (setq ps-mule-composition-prologue-generated t))
1524                 ((setq font-spec (ps-mule-get-font-spec elt 'normal))
1525                  (ps-mule-init-external-library font-spec))))))
1526
1527   ;; If ASCII font is also specified in ps-mule-font-info-database,
1528   ;; use it instead of what specified in ps-font-info-database.
1529   (let ((font-spec (ps-mule-get-font-spec 'ascii 'normal)))
1530     (if font-spec
1531         (progn
1532           (ps-mule-prologue-generated)
1533           (ps-mule-init-external-library font-spec)
1534           (let ((font (ps-font-alist 'ps-font-for-text))
1535                 (ps-current-font 0))
1536             (while font
1537               ;; Be sure to download a glyph for SPACE in advance.
1538               (ps-mule-prepare-font (ps-mule-get-font-spec 'ascii (car font))
1539                                     " " 'ascii 'no-setfont)
1540               (setq font (cdr font)
1541                     ps-current-font (1+ ps-current-font)))))))
1542
1543   ;; If the header contains non-ASCII and non-Latin1 characters, prepare a font
1544   ;; and glyphs for the first occurrence of such characters.
1545   (if (and ps-mule-header-charsets
1546            (not (eq (car ps-mule-header-charsets) 'latin-iso8859-1)))
1547       (let ((font-spec (ps-mule-get-font-spec (car ps-mule-header-charsets)
1548                                               'normal)))
1549         (if font-spec
1550             ;; Be sure to download glyphs for "0123456789/" in advance for page
1551             ;; numbering.
1552             (let ((ps-current-font 0))
1553               (ps-mule-prepare-font font-spec "0123456789/" 'ascii t t)))))
1554
1555   (if ps-mule-charset-list
1556       ;; We must change this regexp for multi-byte buffer.
1557       (setq ps-control-or-escape-regexp
1558             (cond ((eq ps-print-control-characters '8-bit)
1559                    "[^\040-\176]")
1560                   ((eq ps-print-control-characters 'control-8-bit)
1561                    (string-as-multibyte "[^\040-\176\240-\377]"))
1562                   ((eq ps-print-control-characters 'control)
1563                    (string-as-multibyte "[^\040-\176\200-\377]"))
1564                   (t (string-as-multibyte "[^\000-\011\013\015-\377]"))))))
1565
1566 ;;;###autoload
1567 (defun ps-mule-begin-page ()
1568   (setq ps-mule-current-charset 'ascii))
1569
1570
1571 (provide 'ps-mule)
1572
1573 ;;; arch-tag: bca017b2-66a7-4e59-8584-103e749eadbe
1574 ;;; ps-mule.el ends here