comparison lisp/ps-print.el @ 23167:ada869918064

(ps-mule-font-info-database-bdf): The include ASCII entry and change Latin-1 entry in the default value. (ps-mule-font-info-database-ps-bdf): New variable. (ccl-encode-ethio-unicode): Bug of CCL code fixed. (ps-mule-generate-font): Give CHARSET arg to FONT-FUNC function registerd in FONT-SPEC. (ps-mule-bitmap-prologue): Fix PostScript code to realize correct charcter width of bitmap fonts. (ps-mule-generate-bitmap-font): Give COLUMNS arg to PostScript procedure NF. (ps-begin-file): Output PostScript code for setting SpaceWidthRatio. (ps-plot-region): Use line-beginning-position to get a position of the beginning of the current line.

23166:6072f28afec9

  "Sample setting of the `ps-mule-font-info-database' to use builtin PS font.

Currently, data for Japanese and Korean PostScript printers are listed.")

(defconst ps-mule-font-info-database-bdf
  '(;;(ascii
    ;; (normal bdf "etl24-latin1.bdf" nil 1)
    ;; (bold bdf "etl16b-latin1.bdf" iso-latin-1 1)
    ;; (italic bdf "etl16i-latin1.bdf" iso-latin-1 1)
    ;; (bold-italic bdf "etl16bi-latin1.bdf" iso-latin-1 1))
    ;;(latin-iso8859-1
    ;; (normal bdf "etl24-latin1.bdf" iso-latin-1 1)
    ;; (bold bdf "etl16b-latin1.bdf" iso-latin-1 1)
    ;; (italic bdf "etl16i-latin1.bdf" iso-latin-1 1)
    ;; (bold-italic bdf "etl16bi-latin1.bdf" iso-latin-1 1))
    (latin-iso8859-1
     (normal nil nil iso-latin-1))
    (latin-iso8859-2
     (normal bdf "etl24-latin2.bdf" iso-latin-2 1))
    (latin-iso8859-3

    (indian-2-column
     (normal bdf "mule-indian-24.bdf" ps-mule-encode-7bit 2))
    (tibetan
     (normal bdf "mule-tibmdx-24.bdf" ps-mule-encode-7bit 2)))
  "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.

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

;; Two typical encoding functions for PostScript fonts.

(defun ps-mule-encode-7bit (string)
  (let* ((dim (charset-dimension

    str))

;; Special encoding function for Ethiopic.
(define-ccl-program ccl-encode-ethio-unicode
  `(1
    (read r2)
    (loop
     (if (r2 == ,leading-code-private-22)
	 ((read r0)
	  (if (r0 == ,(charset-id 'ethiopic))
	      ((read r1 r2)
	       (r1 &= 127) (r2 &= 127)
	       (call ccl-encode-ethio-font)
	       (write r1)
	       (write-read-repeat r2))
	    ((write r2 r0)
	     (repeat))))
       (write-read-repeat r2)))))

(defun ps-mule-encode-ethiopic (string)
  (ccl-execute-on-string (symbol-value 'ccl-encode-ethio-unicode)
			 (make-vector 9 nil)
			 string))

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

	/FirstCode exch store
	pop
	0 0 setcharwidth
    } {
	1 index /FontSize get /size exch def
	1 index /FontIndex get exch FirstCode exch
	GlobalCharName GetBitmap /bmp exch def
	%% bmp == [ DWIDTH BBX-WIDTH BBX-HEIGHT BBX-XOFF BBX-YOFF BITMAP ]
	Cmpchar { %ifelse
	    /FontMatrix get [ exch { size div } forall ] /mtrx exch def

	} {
	    pop
	} ifelse
	/FirstCode -1 store

	bmp 0 get size div 0		% wx wy
	setcharwidth			% We can't use setcachedevice here.

	bmp 1 get 0 gt bmp 2 get 0 gt and {
	    bmp 1 get bmp 2 get		% width height
	    true			% polarity

    NameIndexDict idxname idx put
} for

/GlobalFontIndex 0 def

%% fontname dimension fontsize relative-compose baseline-offset fbbx  |-  --
/BitmapFont {
    14 dict begin
    /FontBBox exch def
    /BaselineOffset exch def
    /RelativeCompose exch def
    /FontSize exch def
    /FontBBox [ FontBBox { FontSize div } forall ] def
    /FontDimension exch def
    /FontIndex GlobalFontIndex def
    /FontType 3 def
    /FontMatrix matrix def
    /Encoding EncodingCommon def

    definefont pop
    /GlobalFontIndex GlobalFontIndex 1 add def
} bind def

%% Define a new bitmap font.
%% fontname dimension fontsize relative-compose baseline-offset fbbx  |-  --
/NF {
    /fbbx exch def
    %% Convert BDF's FontBoundingBox to PostScript's FontBBox
    [ fbbx 2 get fbbx 3 get
      fbbx 2 get fbbx 0 get add fbbx 3 get fbbx 1 get add ]

  (unless ps-mule-bitmap-prologue-generated
    (setq ps-mule-bitmap-prologue-generated t)
    (list ps-mule-bitmap-prologue)))

(defun ps-mule-generate-bitmap-font (&rest args)
  (list (apply 'format "/%s %d %f %S %d %S NF\n" args)))

(defun ps-mule-generate-bitmap-glyph (font-name code dwidth bbx bitmap)
  (format "/%s %d [ %d %d %d %d %d <%s> ] NG\n"
	  font-name code
	  dwidth (aref bbx 0) (aref bbx 1) (aref bbx 2) (aref bbx 3)

			 ps-font-size
			 (ps-font 'ps-font-for-text (car (car font)))))
      (setq font (cdr font)
	    i (1+ i))))

  (ps-mule-initialize)

  (ps-output "\nBeginDoc\n\n"
	     "%%EndPrologue\n"))

		(ps-set-font ps-current-font)
		(setq ps-mule-current-charset 'ascii))
	      (ps-plot 'ps-basic-plot-string from match-point bg-color))
	    (cond
	     ((= match ?\t)		; tab
	      (let ((linestart (save-excursion (beginning-of-line) (point))))
		(forward-char -1)
		(setq from (+ linestart (current-column)))
		(when (re-search-forward "[ \t]+" to t)
		  (unless (eq ps-mule-current-charset 'ascii)
		    (ps-set-font ps-current-font)

23167:ada869918064

  "Sample setting of the `ps-mule-font-info-database' to use builtin PS font.

Currently, data for Japanese and Korean PostScript printers are listed.")

(defconst ps-mule-font-info-database-bdf
  '((ascii
     (normal bdf "etl24-latin1.bdf" nil 1)
     (bold bdf "etl16b-latin1.bdf" iso-latin-1 1)
     (italic bdf "etl16i-latin1.bdf" iso-latin-1 1)
     (bold-italic bdf "etl16bi-latin1.bdf" iso-latin-1 1))
    (latin-iso8859-1
     (normal bdf "etl24-latin1.bdf" iso-latin-1 1)
     (bold bdf "etl16b-latin1.bdf" iso-latin-1 1)
     (italic bdf "etl16i-latin1.bdf" iso-latin-1 1)
     (bold-italic bdf "etl16bi-latin1.bdf" iso-latin-1 1))
    (latin-iso8859-1
     (normal nil nil iso-latin-1))
    (latin-iso8859-2
     (normal bdf "etl24-latin2.bdf" iso-latin-2 1))
    (latin-iso8859-3

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

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

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

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

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

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

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

;; Two typical encoding functions for PostScript fonts.

(defun ps-mule-encode-7bit (string)
  (let* ((dim (charset-dimension

    str))

;; Special encoding function for Ethiopic.
(define-ccl-program ccl-encode-ethio-unicode
  `(1
    ((read r2)
     (loop
      (if (r2 == ,leading-code-private-22)
	  ((read r0)
	   (if (r0 == ,(charset-id 'ethiopic))
	       ((read r1 r2)
		(r1 &= 127) (r2 &= 127)
		(call ccl-encode-ethio-font)
		(write r1)
		(write-read-repeat r2))
	     ((write r2 r0)
	      (repeat))))
	(write-read-repeat r2))))))

(defun ps-mule-encode-ethiopic (string)
  (ccl-execute-on-string (symbol-value 'ccl-encode-ethio-unicode)
			 (make-vector 9 nil)
			 string))

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

	/FirstCode exch store
	pop
	0 0 setcharwidth
    } {
	1 index /FontSize get /size exch def
	1 index /FontSpaceWidthRatio get /ratio exch def
	1 index /FontIndex get exch FirstCode exch
	GlobalCharName GetBitmap /bmp exch def
	%% bmp == [ DWIDTH BBX-WIDTH BBX-HEIGHT BBX-XOFF BBX-YOFF BITMAP ]
	Cmpchar { %ifelse
	    /FontMatrix get [ exch { size div } forall ] /mtrx exch def

	} {
	    pop
	} ifelse
	/FirstCode -1 store

	bmp 0 get SpaceWidthRatio ratio div mul size div 0	% wx wy
	setcharwidth			% We can't use setcachedevice here.

	bmp 1 get 0 gt bmp 2 get 0 gt and {
	    bmp 1 get bmp 2 get		% width height
	    true			% polarity

    NameIndexDict idxname idx put
} for

/GlobalFontIndex 0 def

%% fontname dim col fontsize relative-compose baseline-offset fbbx  |-  --
/BitmapFont {
    15 dict begin
    /FontBBox exch def
    /BaselineOffset exch def
    /RelativeCompose exch def
    /FontSize exch def
    /FontBBox [ FontBBox { FontSize div } forall ] def
    FontBBox 2 get FontBBox 0 get sub exch div
    /FontSpaceWidthRatio exch def
    /FontDimension exch def
    /FontIndex GlobalFontIndex def
    /FontType 3 def
    /FontMatrix matrix def
    /Encoding EncodingCommon def

    definefont pop
    /GlobalFontIndex GlobalFontIndex 1 add def
} bind def

%% Define a new bitmap font.
%% fontname dim col fontsize relative-compose baseline-offset fbbx  |-  --
/NF {
    /fbbx exch def
    %% Convert BDF's FontBoundingBox to PostScript's FontBBox
    [ fbbx 2 get fbbx 3 get
      fbbx 2 get fbbx 0 get add fbbx 3 get fbbx 1 get add ]

  (unless ps-mule-bitmap-prologue-generated
    (setq ps-mule-bitmap-prologue-generated t)
    (list ps-mule-bitmap-prologue)))

(defun ps-mule-generate-bitmap-font (&rest args)
  (list (apply 'format "/%s %d %d %f %S %d %S NF\n" args)))

(defun ps-mule-generate-bitmap-glyph (font-name code dwidth bbx bitmap)
  (format "/%s %d [ %d %d %d %d %d <%s> ] NG\n"
	  font-name code
	  dwidth (aref bbx 0) (aref bbx 1) (aref bbx 2) (aref bbx 3)

			 ps-font-size
			 (ps-font 'ps-font-for-text (car (car font)))))
      (setq font (cdr font)
	    i (1+ i))))

  (let ((font-entry (cdr (assq ps-font-family ps-font-info-database))))
    (ps-output (format "/SpaceWidthRatio %f def\n"
		       (/ (ps-lookup 'space-width) (ps-lookup 'size)))))

  (ps-mule-initialize)

  (ps-output "\nBeginDoc\n\n"
	     "%%EndPrologue\n"))

		(ps-set-font ps-current-font)
		(setq ps-mule-current-charset 'ascii))
	      (ps-plot 'ps-basic-plot-string from match-point bg-color))
	    (cond
	     ((= match ?\t)		; tab
	      (let ((linestart (line-beginning-position)))
		(forward-char -1)
		(setq from (+ linestart (current-column)))
		(when (re-search-forward "[ \t]+" to t)
		  (unless (eq ps-mule-current-charset 'ascii)
		    (ps-set-font ps-current-font)