unofficial mirror of emacs-devel@gnu.org 
 help / color / mirror / code / Atom feed
* [Patch] Basic WYSIWYG printing in GNU Emacs
@ 2021-08-10  9:29 Anand Tamariya
  2021-08-10 12:31 ` Eli Zaretskii
  0 siblings, 1 reply; 13+ messages in thread
From: Anand Tamariya @ 2021-08-10  9:29 UTC (permalink / raw)
  To: emacs-devel


[-- 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)
 {

^ permalink raw reply related	[flat|nested] 13+ messages in thread
end of thread, other threads:[~2021-08-12  8:08 UTC | newest]

Thread overview: 13+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-08-10  9:29 [Patch] Basic WYSIWYG printing in GNU Emacs Anand Tamariya
2021-08-10 12:31 ` 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

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).