From: Anand Tamariya <atamariya@gmail.com>
To: emacs-devel@gnu.org
Subject: [Patch] Basic WYSIWYG printing in GNU Emacs
Date: Tue, 10 Aug 2021 14:59:46 +0530 [thread overview]
Message-ID: <CADm7Y4koL=dLOpsUi9TOx0-_XQkgW=Wc_44OaTbZ-QUfeyhzPQ@mail.gmail.com> (raw)
[-- Attachment #1.1: Type: text/plain, Size: 615 bytes --]
Here's a patch for basic WYSIWYG printing in GNU Emacs. This should enable
following print features in Emacs:
- Size and colour variation in text
- Unicode text (including Hindi, script for Eastern European
languages, logographic scripts like Chinese, Japanese and Korean (CJK),
right to left (RTL) scripts like Arabic and Hebrew, and music symbols)
- Fancy fonts
- Tables
- Images
- Zero font setup (Tip: Use Truetype fonts in your system)
*Screenshots:*
https://lifeofpenguin.blogspot.com/2021/06/basic-wysiwyg-printing-in-gnu-emacs.html
*Note:* This disables ps-mule.el for printing.
[-- Attachment #1.2: Type: text/html, Size: 931 bytes --]
[-- Attachment #2: patch.txt --]
[-- Type: text/plain, Size: 34554 bytes --]
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)
+ )))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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
[-- Attachment #3: psname.txt --]
[-- Type: text/plain, Size: 3476 bytes --]
diff --git a/src/font.c b/src/font.c
index 0c9e752e08..2031cc8eca 100644
--- a/src/font.c
+++ b/src/font.c
@@ -665,6 +665,7 @@ font_prop_validate_otf (Lisp_Object prop, Lisp_Object val)
/* The order of the above entries must match with enum
font_property_index. */
{ SYMBOL_INDEX (QClang), font_prop_validate_symbol },
+ { SYMBOL_INDEX (QCpostscriptname), font_prop_validate_symbol },
{ SYMBOL_INDEX (QCscript), font_prop_validate_symbol },
{ SYMBOL_INDEX (QCotf), font_prop_validate_otf }
};
@@ -4129,6 +4130,10 @@ DEFUN ("font-get", Ffont_get, Sfont_get, 2, 2, 0,
if (fontp->driver->combining_capability)
val = fontp->driver->combining_capability (fontp);
}
+ else if (EQ (key, QCpostscriptname)) {
+ if (fontp->driver->postscriptname)
+ val = fontp->driver->postscriptname (fontp);
+ }
}
else
val = Fcdr (val);
@@ -5376,6 +5381,7 @@ syms_of_font (void)
DEFSYM (QCavgwidth, ":avgwidth");
DEFSYM (QCfont_entity, ":font-entity");
DEFSYM (QCcombining_capability, ":combining-capability");
+ DEFSYM (QCpostscriptname, ":postscriptname");
/* Symbols representing values of font spacing property. */
DEFSYM (Qc, "c");
diff --git a/src/font.h b/src/font.h
index 8614e7fa10..5e15ef4457 100644
--- a/src/font.h
+++ b/src/font.h
@@ -692,6 +692,7 @@ #define FONT_INVALID_CODE 0xFFFFFFFF
GSUB and GPOS are lists of the form
((SCRIPT (LANGSYS FEATURE ...) ...) ...) */
Lisp_Object (*otf_capability) (struct font *font);
+ Lisp_Object (*postscriptname) (struct font *font);
/* Optional.
Apply FONT's OTF-FEATURES to the glyph string.
@@ -893,6 +894,7 @@ valid_font_driver (struct font_driver const *d)
#ifdef HAVE_HARFBUZZ
extern Lisp_Object hbfont_otf_capability (struct font *);
+extern Lisp_Object hbfont_postscriptname (struct font *);
extern Lisp_Object hbfont_shape (Lisp_Object, Lisp_Object);
extern Lisp_Object hbfont_combining_capability (struct font *);
#endif
diff --git a/src/ftcrfont.c b/src/ftcrfont.c
index a0e18e13cf..365671b036 100644
--- a/src/ftcrfont.c
+++ b/src/ftcrfont.c
@@ -621,6 +621,7 @@ syms_of_ftcrfont_for_pdumper (void)
ftcrhbfont_driver.list = ftcrhbfont_list;
ftcrhbfont_driver.match = ftcrhbfont_match;
ftcrhbfont_driver.otf_capability = hbfont_otf_capability;
+ ftcrhbfont_driver.postscriptname = hbfont_postscriptname;
ftcrhbfont_driver.shape = hbfont_shape;
ftcrhbfont_driver.combining_capability = hbfont_combining_capability;
ftcrhbfont_driver.begin_hb_font = ftcrhbfont_begin_hb_font;
diff --git a/src/hbfont.c b/src/hbfont.c
index 576c5fe7f6..7587d933cc 100644
--- a/src/hbfont.c
+++ b/src/hbfont.c
@@ -212,6 +212,31 @@ hbfont_otf_features (hb_face_t *face, hb_tag_t table_tag)
return scripts;
}
+Lisp_Object
+hbfont_postscriptname (struct font *font)
+{
+ double position_unit;
+ hb_font_t *hb_font
+ = font->driver->begin_hb_font
+ ? font->driver->begin_hb_font (font, &position_unit)
+ : NULL;
+ if (!hb_font)
+ return Qnil;
+
+ hb_face_t *face = hb_font_get_face (hb_font);
+
+ // Postscript name
+ unsigned int text_size = 127;
+ char *text = xmalloc (text_size * sizeof (char));
+ hb_ot_name_get_utf8 (face, 6, NULL, &text_size, text);
+ Lisp_Object psname = make_unibyte_string (text, text_size);
+
+ if (font->driver->end_hb_font)
+ font->driver->end_hb_font (font, hb_font);
+
+ return psname;
+}
+
Lisp_Object
hbfont_otf_capability (struct font *font)
{
next reply other threads:[~2021-08-10 9:29 UTC|newest]
Thread overview: 13+ messages / expand[flat|nested] mbox.gz Atom feed top
2021-08-10 9:29 Anand Tamariya [this message]
2021-08-10 12:31 ` [Patch] Basic WYSIWYG printing in GNU Emacs Eli Zaretskii
2021-08-10 18:12 ` Pankaj Jangid
2021-08-11 3:39 ` Anand Tamariya
2021-08-11 4:32 ` Anand Tamariya
2021-08-11 11:41 ` Eli Zaretskii
2021-08-11 15:49 ` Anand Tamariya
2021-08-11 16:51 ` Eli Zaretskii
2021-08-11 16:58 ` Eli Zaretskii
2021-08-12 5:34 ` Anand Tamariya
2021-08-12 6:11 ` Eli Zaretskii
2021-08-12 6:45 ` Anand Tamariya
2021-08-12 8:08 ` Eli Zaretskii
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to='CADm7Y4koL=dLOpsUi9TOx0-_XQkgW=Wc_44OaTbZ-QUfeyhzPQ@mail.gmail.com' \
--to=atamariya@gmail.com \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).