diff --git a/etc/ps-prin1.ps b/etc/ps-prin1.ps index f68174b991..0db2f2f182 100644 --- a/etc/ps-prin1.ps +++ b/etc/ps-prin1.ps @@ -76,6 +76,22 @@ StandardEncoding 46 82 getinterval aload pop 256 packedarray def }ifelse +/DefMetrics{ + /FontHeight Ascent Descent sub def % use `sub' because descent < 0 + + % Define these in case they're not in the FontInfo + % (also, here they're easier to get to). + /UnderlinePosition Descent 0.20 mul def + /OverlinePosition Descent UnderlinePosition sub Ascent add def + /StrikeoutPosition Ascent 0.30 mul def + /LineThickness FontHeight 0.02 mul def + /Xshadow FontHeight 0.08 mul def + /Yshadow FontHeight -0.09 mul def + /SpaceBackground Descent neg UnderlinePosition add def + /XBox Descent neg def + /YBox LineThickness 0.7 mul def +}def + /reencodeFontISO{ %def dup length 12 add dict % Make a new font (a new dict the same size @@ -115,19 +131,7 @@ StandardEncoding 46 82 getinterval aload pop PrimaryFont/FontMatrix get transform/Ascent exch def pop PrimaryFont/FontMatrix get transform/Descent exch def pop}ifelse - /FontHeight Ascent Descent sub def % use `sub' because descent < 0 - - % Define these in case they're not in the FontInfo - % (also, here they're easier to get to). - /UnderlinePosition Descent 0.70 mul def - /OverlinePosition Descent UnderlinePosition sub Ascent add def - /StrikeoutPosition Ascent 0.30 mul def - /LineThickness FontHeight 0.05 mul def - /Xshadow FontHeight 0.08 mul def - /Yshadow FontHeight -0.09 mul def - /SpaceBackground Descent neg UnderlinePosition add def - /XBox Descent neg def - /YBox LineThickness 0.7 mul def + DefMetrics currentdict % Leave the new font on the stack end % Stop using the font as the current dictionary. @@ -138,6 +142,17 @@ StandardEncoding 46 82 getinterval aload pop % Font definition /DefFont{findfont exch scalefont reencodeFontISO}def +/DeriveFont { % newname charstring encoding fontname | font + findfont dup length dict begin + { 1 index /FID ne { def } { pop pop } ifelse } forall + /Encoding exch def + /CharStrings exch def + currentdict + end + definefont + pop +} bind def + % Font selection /F{ findfont @@ -153,9 +168,25 @@ StandardEncoding 46 82 getinterval aload pop dup/SpaceBackground get/SpaceBackground exch def dup/XBox get/XBox exch def dup/YBox get/YBox exch def + % /LineHeight FontHeight def setfont }def +/FS { + exch findfont exch scalefont setfont + + currentfont/FontType get 0 ne + {/PrimaryFont currentfont def} + {/PrimaryFont currentfont /FDepVector get 0 get def} + ifelse + + PrimaryFont/FontBBox get aload pop + PrimaryFont/FontMatrix get transform/Ascent exch def pop + PrimaryFont/FontMatrix get transform/Descent exch def pop + + DefMetrics +}def + /FG/setrgbcolor load def /bg false def @@ -196,9 +227,9 @@ StandardEncoding 46 82 getinterval aload pop dobackground }def -/LineHS LineHeight LineSpacing add def +/LineHS{ LineHeight LineSpacing add }def /ParagraphHS LineHeight ParagraphSpacing add def -/PSL{/h exch def bg{eolbg}if 0 currentpoint exch pop h sub moveto}def +/PSL{currentpoint pop neg LineHS neg rmoveto}def /PLN{PrintLineNumber{doLineNumber}if}def /SL{LineHS PSL isLineStep pop}def % Soft Linefeed @@ -211,12 +242,12 @@ StandardEncoding 46 82 getinterval aload pop /dp{print 2 copy exch 40 string cvs print(, )print =}def /W{ - ( )stringwidth % Get the width of a space in the current font. + (n)stringwidth % Get the en width in the current font. pop % Discard the Y component. mul % Multiply the width of a space % by the number of spaces to plot bg{dup dobackground}if - 0 rmoveto + currentpoint exch pop moveto }def /Effect 0 def @@ -266,6 +297,13 @@ StandardEncoding 46 82 getinterval aload pop EffectOverline {OverlinePosition Hline}if % overline }bind def +% stack: string yposition |- -- +/yS { + /y exch def + 0 y rmoveto S + 0 y neg rmoveto +} def + % stack: position |- -- /Hline{ currentpoint exch pop add dup diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 1dbbd42148..9817accad9 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -842,6 +842,48 @@ describe-char (if text-props-desc (insert text-props-desc)) (setq buffer-read-only t)))))) +(defun composite-char-p (pos) + "Returns non-nil if POS is a non-composite char. + If point is after a composite char on a non-composite char, + `find-composition' returns non-nil. This function is useful in + such cases." + (let ((composition (find-composition pos))) + (when composition + ;; When the composition is trivial (i.e. composed only with the + ;; current character itself without any alternate characters), + ;; we don't show the composition information. Otherwise, store + ;; two descriptive strings in the first two elements of + ;; COMPOSITION. + (or (catch 'tag + (let ((from (car composition)) + (to (nth 1 composition)) + (components (nth 2 composition)) + ) + (if (and (vectorp components) (vectorp (aref components 0))) + (let ((idx (- pos from)) + (nglyphs (lgstring-glyph-len components)) + (i 0) j glyph glyph-from) + ;; COMPONENTS is a gstring. Find a grapheme + ;; cluster containing the current character. + (while (and (< i nglyphs) + (setq glyph (lgstring-glyph components i)) + (< (lglyph-to glyph) idx)) + (setq i (1+ i))) + (if (or (not glyph) (= i nglyphs)) + ;; The composition is broken. + (throw 'tag nil)) + (setq glyph-from (lglyph-from glyph) + to (+ from (lglyph-to glyph) 1) + from (+ from glyph-from) + j i) + (while (and (< j nglyphs) + (setq glyph (lgstring-glyph components j)) + (= (lglyph-from glyph) glyph-from)) + (setq j (1+ j))) + (nconc composition (list i (1- j)))) + ))) + (setq composition nil))))) + ;;; Describe-Char-ElDoc (defun describe-char-eldoc--truncate (name width) diff --git a/lisp/ps-def.el b/lisp/ps-def.el index 49d72d3be5..ccb70e838a 100644 --- a/lisp/ps-def.el +++ b/lisp/ps-def.el @@ -28,6 +28,7 @@ ;; See ps-print.el for documentation. ;;; Code: +(require 'descr-text) (declare-function ps-plot-with-face "ps-print" (from to face)) (declare-function ps-plot-string "ps-print" (string)) @@ -103,6 +104,20 @@ ps-color-format (defvar ps-float-format "%0.3f ") +(defun ps-font-name (font) + "PS font name for FONT object." + (let* ((info (font-info font)) + (file (aref info 12))) + (or (font-get font :postscriptname) + (file-name-base file)))) + +(defvar ps--cmap nil + "Char table containing (FONT CODE (GLYPH INDICES)) for a + character. Glyph indices are indices in PS font.") + +(defvar ps--adjustment nil + "X adjustment for composite glyphs.") + (defun ps-generate-postscript-with-faces1 (from to) ;; Generate some PostScript. (let ((face 'default) @@ -110,31 +125,166 @@ ps-generate-postscript-with-faces1 ;; Emacs (property-change from) (overlay-change from) - before-string after-string) - (while (< from to) + (font-change from) + family char-info glyph glyphs chars + fonts font-index font-glyphs font-chars + pos next ltr + components + ) + ;; Generate a map containing font-family and a list of (font index (glyph indices)) + ;; from that family used in the doc for unicode char + (goto-char from) + (setq ps--cmap (make-char-table 'cmap)) + (setq ps--adjustment (make-char-table 'adjustment)) + (while (and (not (eobp)) + (or (> (char-after) 255) + (and (re-search-forward "[^[:ascii:]]" to t) + (goto-char (match-beginning 0)))) + ) + (if (composite-char-p (point)) + (progn + (setq char-info (find-composition (point)) + pos (nth 0 char-info) + next (nth 1 char-info) + components (nth 2 char-info) + family (ps-font-name (lgstring-font components))) + ) + (setq char-info (internal-char-font (point)) + pos (point) + next (1+ (point)) + components nil + glyph (cdr char-info) + family (ps-font-name (car char-info)))) + + (unless (assoc family fonts) + (setq font-index (length fonts)) + (push (list family font-index (aref char-script-table (char-after))) fonts) + (push (cons font-index nil) font-chars) + (push (cons font-index nil) font-glyphs)) + (setq font-index (nth 1 (assoc family fonts))) + + (setq chars nil) + (setq glyphs (cdr (assoc font-index font-glyphs))) + (if components + ;; Loop for composites + (dotimes (i (lgstring-glyph-len components)) + (setq glyph (lglyph-code (lgstring-glyph components i))) + (unless (memq glyph glyphs) + (push glyph glyphs)) + (push (1- (length (memq glyph glyphs))) chars) + (if (= i 0) + (aset ps--adjustment pos + (lglyph-adjustment (lgstring-glyph components i)))) + ) + ;; For non-composites + (unless (memq glyph glyphs) + (push glyph glyphs)) + (push (1- (length (memq glyph glyphs))) chars)) + (setcdr (assoc font-index font-glyphs) glyphs) + + ;; (message "%s %s" pos (reverse chars)) + (aset ps--cmap pos (cons font-index (reverse chars))) + ;; (message "%s" char-info) + (goto-char next) + ) + ;; (pp fonts) + ;; (pp font-chars) + ;; (pp font-glyphs) + + ;; Use font-glyphs to generate new PS font + (dolist (e font-glyphs) + (let* ((font-index (car e)) + (font (pop fonts)) + (script (nth 2 font)) + (encoding-str nil) + (map-str nil) + (cmap-str nil) + (i 0) + (glyphs (cdr e))) + (when (memq script '(han kana)) + ;; CIDFont for CJK script + (mapc (lambda (k) + (setq cmap-str (concat cmap-str + (format "<%02x> <%02x> %d\n" i i k)) + i (1+ i))) + (nreverse glyphs)) + (setq i (1- i)) + (ps-output (format " +/CIDInit /ProcSet findresource begin +12 dict begin +begincmap /CIDSystemInfo << +/Registry (Adobe) /Ordering (Identity) /Supplement 0 >> def +/CMapName /CM def +/CMapType 1 def +1 begincodespacerange +<%02x> <%02x> +endcodespacerange + +%d begincidrange +%s +endcidrange +endcmap CMapName currentdict /CMap defineresource +pop end end +/F%d /CM [/%s] composefont pop +" + 0 i (1+ i) cmap-str font-index (car font)))) + + (unless (memq script '(han kana)) + ;; Type42 font + (mapc (lambda (k) + (setq encoding-str (concat encoding-str (format "/g%d " k)) + map-str (concat map-str (format "/g%d %d\n" k k)))) + (nreverse glyphs)) + ;; (pp encoding-str) + ;; (pp map-str) + (ps-output (format "/E [%s] def\n" encoding-str)) + (ps-output (format "/C <<%s>> def\n" map-str)) + (ps-output (format "/F%d C E /%s DeriveFont\n" font-index (car font))) + ))) + + (while (and (goto-char from) + (char-after) + (< from to)) + (and (< property-change to) ; Don't search for property change ; unless previous search succeeded. (setq property-change (next-property-change from nil to))) (and (< overlay-change to) ; Don't search for overlay change ; unless previous search succeeded. - (setq overlay-change (min (next-overlay-change from) - to))) - (setq position (min property-change overlay-change) - before-string nil - after-string nil) + (setq overlay-change (next-overlay-change from))) + (and (or (null font-change) (< font-change to)) ; Don't search for property change + ; unless previous search succeeded. + ;; Range of characters sharing same font + ;; Whitespace uses default font usually in between mixed font families. + ;; Hence must be treated separately. + (setq font-change (or (if (= (syntax-class (syntax-after from)) 0) + (+ from (skip-chars-forward "[ \t\n]"))) + (when (eq (char-charset (char-after)) 'ascii) + (and (re-search-forward "[[:multibyte:][:blank:]]" nil t) + (1- (point)))) + (when (eq (char-charset (char-after)) 'unicode) + (and (re-search-forward "[[:ascii:][:blank:]]" nil t) + (1- (point)))) + )) + ) + (setq position + (if (null font-change) + (min property-change overlay-change) + (min property-change overlay-change font-change)) + ltr (get-char-code-property (char-after from) 'bidi-class) + ) + (if (composite-char-p from) + (setq char-info (find-composition from) + position (nth 1 char-info))) + ;; (message "%s %s %s %s %s" from property-change overlay-change font-change ltr) (setq face (cond ((invisible-p from) 'emacs--invisible--face) ((get-char-property from 'face)) (t 'default))) - ;; Plot up to this record. - (and before-string - (ps-plot-string before-string)) - (ps-plot-with-face from position face) - (and after-string - (ps-plot-string after-string)) - (setq from position)) - (ps-plot-with-face from to face))) + (ps-plot-with-face from position face (not (memq ltr '(R AL)))) + (setq from position) + ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lisp/ps-print.el b/lisp/ps-print.el index ace3001781..8c7b87cee3 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -1452,6 +1452,7 @@ ps-print-version (require 'lpr) +(require 'image-converter) ;; Load Emacs definitions (require 'ps-def) @@ -2828,10 +2829,10 @@ ps-font-info-database :version "20" :group 'ps-print-font) -(defcustom ps-font-family 'Courier +(defcustom ps-font-family nil "Font family name for ordinary text, when generating PostScript." :type 'symbol - :version "20" + :version "28" :group 'ps-print-font) (defcustom ps-font-size '(7 . 8.5) @@ -3180,7 +3181,7 @@ ps-underlined-faces :version "20" :group 'ps-print-face) -(defcustom ps-use-face-background nil +(defcustom ps-use-face-background t "Specify if face background should be used. Valid values are: @@ -3399,7 +3400,7 @@ ps-paragraph-spacing :version "21.1" :group 'ps-print-miscellany) -(defcustom ps-paragraph-regexp "[ \t]*$" +(defcustom ps-paragraph-regexp nil "Specify paragraph delimiter. It should be a regexp or nil. @@ -3408,7 +3409,7 @@ ps-paragraph-regexp :type '(choice :menu-tag "Paragraph Delimiter" (const :tag "No Delimiter" nil) (regexp :tag "Delimiter Regexp")) - :version "21.1" + :version "28" :group 'ps-print-miscellany) (defcustom ps-begin-cut-regexp nil @@ -3924,6 +3925,7 @@ ps-default-foreground (defvar ps-default-background nil) (defvar ps-default-color nil) (defvar ps-current-color nil) +(defvar ps-current-height nil) (defvar ps-current-bg nil) (defvar ps-foreground-list nil) @@ -4349,8 +4351,62 @@ ps-nb-pages (defmacro ps-lookup (key) `(cdr (assq ,key font-entry))) (defmacro ps-size-scale (key) `(/ (* (ps-lookup ,key) font-size) size)) +(defun ps-find-font (&optional font-family) + "Populate `ps-font-info-database' with default font +info. Default font is used for displaying ASCII characters." + (or (assq font-family ps-font-info-database) + ;; Every document might have a different default font + ;;ps-font-family + (let (font types name size line-height space-width avg-char-width + info prop old-prop pos empty) + (when (zerop (buffer-size)) + ;; Need atleast one char for analysis + (insert " ") + (setq empty t)) + + (save-excursion + (goto-char (point-min)) + (unless (< (char-after) 255) + (re-search-forward "[:ascii:]" (point-max) t)) + + (setq pos (point) + prop (get-text-property pos 'face) + old-prop (if (listp prop) prop (list prop)))) + (dolist (type '(default bold italic bold-italic)) + (setq prop (append old-prop + (if (eq type 'bold) '(:weight bold)) + (if (eq type 'italic) '(:slant oblique)) + (if (eq type 'bold-italic) '(:weight bold :slant oblique)) + )) + (put-text-property pos (1+ pos) 'face prop) + + (setq info (font-info (font-at pos)) + name (ps-font-name (font-at pos)) + size (aref info 2) + line-height (aref info 3) + space-width (aref info 10) + avg-char-width (aref info 11)) + (when (eq type 'default) + (setq font-family (intern name) + ps-font-family font-family)) + (push (cons type name) types)) + + ;; Restore buffer state + (put-text-property pos (1+ pos) 'face old-prop) + (when empty (erase-buffer)) + + (setq font (cons font-family `((fonts . ,(nreverse types)) + (size . ,size) + (line-height . ,line-height) + (space-width . ,space-width) + (avg-char-width . ,avg-char-width))) + ps-font-size-internal size) + (unless (assq font-family ps-font-info-database) + (push font ps-font-info-database)) + font))) + (defun ps-select-font (font-family sym font-size title-font-size) - (let ((font-entry (cdr (assq font-family ps-font-info-database)))) + (let* ((font-entry (cdr (ps-find-font font-family)))) (or font-entry (error "Don't have data to scale font %s. Known fonts families are %s" font-family @@ -4374,7 +4430,7 @@ ps-get-page-dimensions (error "The number of columns %d should be positive" ps-number-of-columns))) - (ps-select-font ps-font-family 'ps-font-for-text + (ps-select-font nil 'ps-font-for-text ps-font-size-internal ps-font-size-internal) (ps-select-font ps-header-font-family 'ps-font-for-header ps-header-font-size-internal @@ -4581,9 +4637,7 @@ ps-string-escape-codes (defsubst ps-output-string-prim (string) (insert "(") ;insert start-string delimiter (save-excursion ;insert string - (insert (if (multibyte-string-p string) - (encode-coding-string string 'utf-8) - string))) + (insert string)) ;; Find and quote special characters as necessary for PS ;; This skips everything except control chars, non-ASCII chars, (, ) and \. (while (progn (skip-chars-forward " -'*-[]-~") (not (eobp))) @@ -5895,9 +5949,8 @@ ps-begin-page (ps-output (format "%d SetFooterLines\n" ps-footer-lines))) (ps-output (number-to-string ps-lines-printed) " BeginPage\n") - (ps-set-font ps-current-font) - (ps-set-bg ps-current-bg) - (ps-set-color ps-current-color)) + (ps-output (format "PrintWidth %f div dup scale\n" + (window-body-width nil t)))) (defsubst ps-skip-newline (limit) (setq ps-showline-count (1+ ps-showline-count) @@ -5946,15 +5999,15 @@ ps-basic-plot-str wrappoint)) (defun ps-basic-plot-string (from to &optional _bg-color) - (let* ((wrappoint (ps-find-wrappoint from to - (ps-avg-char-width 'ps-font-for-text))) - (to (car wrappoint)) - (string (buffer-substring-no-properties from to))) + (let* ((string (buffer-substring-no-properties from to))) (ps-output-string string) (ps-output " S\n") - wrappoint)) + (cons to (* (ps-space-width 'ps-font-for-text) (- to from))) + )) (defun ps-basic-plot-whitespace (from to &optional _bg-color) + "Used for drawing TAB position. +Since space width may be narrower than char width, use en width." (let* ((wrappoint (ps-find-wrappoint from to (ps-space-width 'ps-font-for-text))) (to (car wrappoint))) @@ -6001,6 +6054,10 @@ ps-set-color (nth 1 ps-current-color) (nth 2 ps-current-color)) " FG\n")) +(defun ps-change-font (family size) + "Use this function when font or size is different from default." + (setq ps-last-font nil) + (ps-output (format "/%s %d FS\n" family size))) (defsubst ps-plot-string (string) (ps-plot 'ps-basic-plot-str 0 (length string) string)) @@ -6022,10 +6079,48 @@ ps-print-translation-table The default value is a table that translates non-Latin-1 Latin characters to the equivalent Latin-1 characters.") -(defun ps-plot-region (from to font &optional fg-color bg-color effects) - (or (equal font ps-current-font) - (ps-set-font font)) +(defun ps-plot-effects (face) + (let* ((face-bit (ps-face-attribute-list face)) + (effect (aref face-bit 0)) + (foreground (aref face-bit 1)) + (background (ps-face-background face (aref face-bit 2))) + (fg-color (if (and ps-color-p foreground) + (ps-color-scale foreground) + ps-default-color)) + (fg (or fg-color ps-default-foreground)) + (effects (ash effect -2)) + (bg-color (and ps-color-p background + (ps-color-scale background)))) + + ;; Specify a foreground color only if: + ;; one's specified, + ;; it's different from the background (if `ps-fg-validate-p' is non-nil) + ;; and it's different from the current. + (if ps-fg-validate-p + (let ((bg (or bg-color ps-default-background)) + (el ps-foreground-list)) + (while (and el (equal fg bg)) + (setq fg (car el) + el (cdr el))))) + (or (equal fg ps-current-color) + (ps-set-color fg)) + + (or (equal bg-color ps-current-bg) + (if (equal bg-color ps-default-background) + (if ps-current-bg (ps-set-bg nil)) + (ps-set-bg bg-color))) + ;; Specify effects (underline, overline, box, etc.) + (cond + ((not (integerp effects)) + (ps-output "0 EF\n") + (setq ps-current-effect 0)) + ((/= effects ps-current-effect) + (ps-output (number-to-string effects) " EF\n") + (setq ps-current-effect effects))) + )) + +(defun ps-plot-region (from to _font &optional fg-color bg-color effects) ;; Specify a foreground color only if: ;; one's specified, ;; it's different from the background (if `ps-fg-validate-p' is non-nil) @@ -6041,7 +6136,9 @@ ps-plot-region (ps-set-color fg))) (or (equal bg-color ps-current-bg) - (ps-set-bg bg-color)) + (if (equal bg-color ps-default-background) + (if ps-current-bg (ps-set-bg nil)) + (ps-set-bg bg-color))) ;; Specify effects (underline, overline, box, etc.) (cond @@ -6080,9 +6177,10 @@ ps-plot-region (let ((linestart (line-beginning-position))) (forward-char -1) (setq from (+ linestart (current-column))) - (when (re-search-forward "[ \t]+" to t) + (when (re-search-forward "[\t]+" to t) (ps-plot 'ps-basic-plot-whitespace - from (+ linestart (current-column)) + ;; Tab stops are fixed + 0 (current-column) bg-color)))) ((= match ?\n) ; newline @@ -6093,7 +6191,7 @@ ps-plot-region (ps-next-page)) ;; \n\f\n ==>> it'll be handled by form feed ;; \ntext\n ==>> next line - (ps-next-line))) + (ps-plot-with-face (1- (point)) (point) 'default))) ((= match ?\f) ; form feed ;; do not skip page if previous character is NEWLINE and @@ -6189,11 +6287,19 @@ ps-face-attributes (cons new-face ps-print-face-alist))) new-face)))) ((ps-face-foreground-color-p (car face)) - (vector 0 (ps-face-extract-color face) nil)) + (vector 0 (ps-face-extract-color face) nil nil)) ((ps-face-background-color-p (car face)) - (vector 0 nil (ps-face-extract-color face))) + (vector 0 nil (ps-face-extract-color face) nil)) (t - (vector 0 nil nil)))) + (vector (if (and (eq 'bold (faces--attribute-at-point :weight)) + (eq 'oblique (faces--attribute-at-point :slant))) + 3 + (if (eq 'bold (faces--attribute-at-point :weight)) + 1 + (if (eq 'oblique (faces--attribute-at-point :slant)) + 2 + 0))) + nil nil nil)))) (defun ps-face-background (face background) @@ -6231,12 +6337,16 @@ ps-face-attribute-list (vector 0 nil (ps-face-extract-color face-or-list))) ;; Anonymous face. ((keywordp (car face-or-list)) - (vector 0 (plist-get face-or-list :foreground) - (plist-get face-or-list :background))) + (vector (logior (if (eq 'bold (plist-get face-or-list :weight)) 1 0) + (if (eq 'oblique (plist-get face-or-list :slant)) 2 0)) + (plist-get face-or-list :foreground) + (plist-get face-or-list :background) + (if (plist-get face-or-list :height) + (/ (plist-get face-or-list :height) 10.0) 0))) ;; list of faces (t (let ((effects 0) - foreground background face-attr face) + foreground background height face-attr face) (while face-or-list (setq face (car face-or-list) face-or-list (cdr face-or-list) @@ -6244,28 +6354,156 @@ ps-face-attribute-list effects (logior effects (aref face-attr 0))) (or foreground (setq foreground (aref face-attr 1))) (or background - (setq background (ps-face-background face (aref face-attr 2))))) - (vector effects foreground background))))) + (setq background (ps-face-background face (aref face-attr 2)))) + (or height (setq height (aref face-attr 3)))) + (vector effects foreground background height))))) (defconst ps-font-type (vector nil 'bold 'italic 'bold-italic)) -(defun ps-plot-with-face (from to face) +(defun ps-plot-with-face (from to face &optional ltr) + (goto-char from) (cond ((null face) ; print text with null face (ps-plot-region from to 0)) ((eq face 'emacs--invisible--face)) ; skip invisible text!!! + ((eolp) + ;; New line doesn't need font change. However, line height must be + ;; restored for next line. + (ps-output (format "/LineHeight %0.3f def\n" + (save-excursion + (let ((h (line-pixel-height))) + (forward-line) + ;; This is required for image. However, breaks tables. + ;; (+ (/ h 2.0) (line-pixel-height)) + (line-pixel-height) + ;; (* (/ (/ (display-mm-width) 25.4) (display-pixel-width)) + ;; 72.0 (+ (/ h 2.0) (line-pixel-height))) + )))) + (ps-next-line) + (when (> to (1+ from)) + (goto-char (1+ from)) + (ps-plot-with-face (1+ from) to face ltr))) + ((eq 'space (car (get-text-property from 'display))) + (let* ((size (posn-object-width-height (posn-at-point from))) + (w (car size))) + (ps-output (format "%d 0 rmoveto\n" w)))) + ((aref ps--cmap (point)) + ;; Plot unicode characters sharing same font + (ps-plot-effects face) + (let (family size str data pos tfamily) + (setq data (aref ps--cmap (point)) + size (font-get (font-at (point)) :size) + family (car data)) + (ps-change-font (format "F%d" family) size) + (unless ltr + (save-excursion + (goto-char (1- to)) + (if (eolp) (forward-char -1)) + (ps-output (format "currentpoint %d exch moveto pop\n" + (car (posn-x-y (posn-at-point))))) + )) + (let ((i 0) + (end (- to from))) + (while (< i end) + (setq pos (if ltr (+ from i) (- to i 1)) + i (1+ i)) + (goto-char pos) + (setq data (aref ps--cmap (point)) + tfamily (or (car data) family)) + (cond ((/= family tfamily) + (setq i (if ltr to from))) + (t + (setq data (aref ps--cmap pos) + str (concat str + (mapconcat + (lambda (a) + (format "\\%003o" a)) + (if ltr (cdr data) (reverse (cdr data))) "")) + ))))) + (cond + ((and (aref ps--adjustment from) + (eq (get-char-code-property (char-after from) 'bidi-class) 'R)) + ;; For Hebrew + (ps-output (format "(%s)%s xshow\n" str (aref ps--adjustment from)))) + ((plist-get (get-text-property from 'display) 'raise) + (ps-output (format "(%s) %0.3f yS\n" str + (* size + (plist-get (get-text-property from 'display) + 'raise) + )))) + ((not (string-empty-p str)) + (ps-output (format "(%s) S\n" str)))) + + (if (/= family tfamily) + ;; Mixed family - might be from different scripts + (ps-plot-with-face pos to face ltr)) + )) + ((plist-get (get-text-property from 'display) 'image) + (let* ((image (get-text-property from 'display)) + (size (image-size image t)) + (data (plist-get (cdr (image-convert + (append image '(:data-p image/mjpeg)))) + :data)) + (w (car size)) + (h (cdr size))) + (ps-output (concat (format " +/w %d def +/h %d def +" w h) +" +currentpoint h 2 div add +gsave + +translate +% 0 700 translate % set lower left of image at (0, 700) +w h scale % size of rendered image is w points by h points +w % number of columns per row +h % number of rows +8 % bits per color channel (1, 2, 4, or 8) +[w 0 0 h neg 0 0] % maps unit square to image space +% (splash.jpg) (r) file /DCTDecode filter % opens the file and filters the image data +% {currentfile picstr readhexstring pop} +{<" + (mapconcat (lambda (ch) (format "%02x" ch)) data "") +">} +/DCTDecode filter +false % pull channels from separate sources +3 % 3 color channels (RGB) +colorimage + +grestore +w 0 rmoveto +/LineHeight h def +" + )))) (t ; otherwise, text has a valid face (let* ((face-bit (ps-face-attribute-list face)) (effect (aref face-bit 0)) (foreground (aref face-bit 1)) (background (ps-face-background face (aref face-bit 2))) + (size nil) + (family nil) + (same nil) + (font (ps-font-number 'ps-font-for-text + (or (aref ps-font-type (logand effect 3)) + face))) (fg-color (if (and ps-color-p foreground) (ps-color-scale foreground) ps-default-color)) (bg-color (and ps-color-p background (ps-color-scale background)))) + (unless (eobp) + (setq family (intern (ps-font-name (font-at (point)))) + size (font-get (font-at (point)) :size) + same (and (eq family ps-font-family) + (= size ps-font-size-internal))) + + (if same + (or (and ps-last-font (equal font ps-current-font)) + (ps-set-font font)) + (ps-change-font family size))) (ps-plot-region from to (ps-font-number 'ps-font-for-text @@ -6312,7 +6550,8 @@ ps-map-face (let ((face-bit (cdr face-map))) (aset ps-face-bit 0 (logior (aref ps-face-bit 0) (aref face-bit 0))) (or (aref ps-face-bit 1) (aset ps-face-bit 1 (aref face-bit 1))) - (or (aref ps-face-bit 2) (aset ps-face-bit 2 (aref face-bit 2)))) + (or (aref ps-face-bit 2) (aset ps-face-bit 2 (aref face-bit 2))) + (or (aref ps-face-bit 3) (aset ps-face-bit 3 (aref face-bit 3)))) ;; if face does not exist, insert it (setq ps-print-face-alist (cons face-map ps-print-face-alist))) face-map)) @@ -6327,7 +6566,10 @@ ps-screen-to-bit-face (if (ps-face-overline-p face) 16 0) ; overline (if (ps-face-box-p face) 64 0)) ; box (ps-face-foreground-name face) - (ps-face-background-name face)))) + (ps-face-background-name face) + (face-attribute-specified-or + (face-attribute face :height) + nil)))) (declare-function jit-lock-fontify-now "jit-lock" (&optional start end)) @@ -6410,13 +6652,14 @@ ps-generate (ps-begin-job genfunc) (when needs-begin-file (ps-begin-file) - (ps-mule-initialize)) - (ps-mule-begin-job from to) + ;; (ps-mule-initialize) + ) + ;; (ps-mule-begin-job from to) (ps-selected-pages))) (ps-begin-page) (funcall genfunc from to) (ps-end-page) - (ps-mule-end-job) + ;; (ps-mule-end-job) (ps-end-job needs-begin-file) ;; Setting this variable tells the unwind form that the