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