master 72b7fcc: Add new package pixel-fill.el

[Lars Ingebrigtsen]

branch: master
commit 72b7fccc15cadd5ab3c6996888527ae6a2886b76
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Add new package pixel-fill.el
    
    * lisp/net/shr.el (shr-char-breakable-p, shr-char-nospace-p)
    (shr-char-kinsoku-bol-p, shr-char-kinsoku-eol-p)
    (shr-find-fill-point): Moved to pixel-fill.el and renamed.
    (shr-pixel-region): Made obsolete.
    (shr-fill-line): Use pixel-fill-region.
    
    * lisp/textmodes/pixel-fill.el: New package.
---
 etc/NEWS                     |   7 ++
 lisp/net/shr.el              | 108 ++---------------------
 lisp/textmodes/pixel-fill.el | 202 +++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 214 insertions(+), 103 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 715a57a..1ca5c86 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -295,6 +295,13 @@ received.
 
 * Changes in Specialized Modes and Packages in Emacs 29.1
 
+** pixel-fill
+
+*** This is a new package that deals with filling variable-pitch text.
+
+*** New function 'pixel-fill-region'.
+This fills the region to be no wider than a specified pixel width.
+
 ** Info
 
 ---
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index d59b0ed..5d38a7e 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -40,6 +40,7 @@
 (require 'image)
 (require 'puny)
 (require 'url-cookie)
+(require 'pixel-fill)
 (require 'text-property-search)
 
 (defgroup shr nil
@@ -240,7 +241,6 @@ and other things:
 (defvar shr-internal-width nil)
 (defvar shr-list-mode nil)
 (defvar shr-content-cache nil)
-(defvar shr-kinsoku-shorten nil)
 (defvar shr-table-depth 0)
 (defvar shr-stylesheet nil)
 (defvar shr-base nil)
@@ -641,28 +641,6 @@ size, and full-buffer size."
        (shr-fill-lines (point-min) (point-max))
        (buffer-string)))))
 
-(define-inline shr-char-breakable-p (char)
-  "Return non-nil if a line can be broken before and after CHAR."
-  (inline-quote (aref fill-find-break-point-function-table ,char)))
-(define-inline shr-char-nospace-p (char)
-  "Return non-nil if no space is required before and after CHAR."
-  (inline-quote (aref fill-nospace-between-words-table ,char)))
-
-;; KINSOKU is a Japanese word meaning a rule that should not be violated.
-;; In Emacs, it is a term used for characters, e.g. punctuation marks,
-;; parentheses, and so on, that should not be placed in the beginning
-;; of a line or the end of a line.
-(define-inline shr-char-kinsoku-bol-p (char)
-  "Return non-nil if a line ought not to begin with CHAR."
-  (inline-letevals (char)
-    (inline-quote (and (not (eq ,char ?'))
-                       (aref (char-category-set ,char) ?>)))))
-(define-inline shr-char-kinsoku-eol-p (char)
-  "Return non-nil if a line ought not to end with CHAR."
-  (inline-quote (aref (char-category-set ,char) ?<)))
-(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
-  (load "kinsoku" nil t))
-
 (defun shr-pixel-column ()
   (if (not shr-use-fonts)
       (current-column)
@@ -676,6 +654,7 @@ size, and full-buffer size."
       (car (window-text-pixel-size nil (line-beginning-position) (point))))))
 
 (defun shr-pixel-region ()
+  (declare (obsolete nil "29.1"))
   (- (shr-pixel-column)
      (save-excursion
        (goto-char (mark))
@@ -795,7 +774,7 @@ size, and full-buffer size."
       (while (not (eolp))
         ;; We have to do some folding.  First find the first
         ;; previous point suitable for folding.
-        (if (or (not (shr-find-fill-point (line-beginning-position)))
+        (if (or (not (pixel-fill-find-fill-point (line-beginning-position)))
                (= (point) start))
            ;; We had unbreakable text (for this width), so just go to
            ;; the first space and carry on.
@@ -836,84 +815,6 @@ size, and full-buffer size."
         (when (looking-at " $")
          (delete-region (point) (line-end-position)))))))
 
-(defun shr-find-fill-point (start)
-  (let ((bp (point))
-       (end (point))
-       failed)
-    (while (not (or (setq failed (<= (point) start))
-                   (eq (preceding-char) ? )
-                   (eq (following-char) ? )
-                   (shr-char-breakable-p (preceding-char))
-                   (shr-char-breakable-p (following-char))
-                   (and (shr-char-kinsoku-bol-p (preceding-char))
-                        (shr-char-breakable-p (following-char))
-                        (not (shr-char-kinsoku-bol-p (following-char))))
-                   (shr-char-kinsoku-eol-p (following-char))
-                   (bolp)))
-      (backward-char 1))
-    (if failed
-       ;; There's no breakable point, so we give it up.
-       (let (found)
-         (goto-char bp)
-          ;; Don't overflow the window edge, even if
-          ;; shr-kinsoku-shorten is nil.
-         (unless (or shr-kinsoku-shorten (null shr-width))
-           (while (setq found (re-search-forward
-                               "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
-                               (line-end-position) 'move)))
-           (if (and found
-                    (not (match-beginning 1)))
-               (goto-char (match-beginning 0)))))
-      (or
-       (eolp)
-       ;; Don't put kinsoku-bol characters at the beginning of a line,
-       ;; or kinsoku-eol characters at the end of a line.
-       (cond
-        ;; Don't overflow the window edge, even if shr-kinsoku-shorten
-        ;; is nil.
-       ((or shr-kinsoku-shorten (null shr-width))
-        (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
-                    (or (shr-char-kinsoku-eol-p (preceding-char))
-                         (shr-char-kinsoku-bol-p (following-char))))
-          (backward-char 1))
-        (when (setq failed (<= (point) start))
-          ;; There's no breakable point that doesn't violate kinsoku,
-          ;; so we look for the second best position.
-          (while (and (progn
-                        (forward-char 1)
-                        (<= (point) end))
-                      (progn
-                        (setq bp (point))
-                        (shr-char-kinsoku-eol-p (following-char)))))
-          (goto-char bp)))
-       ((shr-char-kinsoku-eol-p (preceding-char))
-        ;; Find backward the point where kinsoku-eol characters begin.
-        (let ((count 4))
-          (while
-              (progn
-                (backward-char 1)
-                (and (> (setq count (1- count)) 0)
-                     (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
-                     (or (shr-char-kinsoku-eol-p (preceding-char))
-                         (shr-char-kinsoku-bol-p (following-char)))))))
-        (when (setq failed (<= (point) start))
-          ;; There's no breakable point that doesn't violate kinsoku,
-          ;; so we go to the second best position.
-          (if (looking-at "\\(\\c<+\\)\\c<")
-              (goto-char (match-end 1))
-            (forward-char 1))))
-       ((shr-char-kinsoku-bol-p (following-char))
-        ;; Find forward the point where kinsoku-bol characters end.
-        (let ((count 4))
-          (while (progn
-                   (forward-char 1)
-                   (and (>= (setq count (1- count)) 0)
-                        (shr-char-kinsoku-bol-p (following-char))
-                        (shr-char-breakable-p (following-char))))))))
-       (when (eq (following-char) ? )
-        (forward-char 1))))
-    (not failed)))
-
 (defun shr-parse-base (url)
   ;; Always chop off anchors.
   (when (string-match "#.*" url)
@@ -2077,7 +1978,8 @@ BASE is the URL of the HTML being rendered."
   (setq dom (or (dom-child-by-tag dom 'tbody) dom))
   (let* ((shr-inhibit-images t)
         (shr-table-depth (1+ shr-table-depth))
-        (shr-kinsoku-shorten t)
+         ;; Fill hard in CJK languages.
+        (pixel-fill-respect-kinsoku nil)
         ;; Find all suggested widths.
         (columns (shr-column-specs dom))
         ;; Compute how many pixels wide each TD should be.
diff --git a/lisp/textmodes/pixel-fill.el b/lisp/textmodes/pixel-fill.el
new file mode 100644
index 0000000..eff09df
--- /dev/null
+++ b/lisp/textmodes/pixel-fill.el
@@ -0,0 +1,202 @@
+;;; pixel-fill.el --- variable pitch filling functions  -*- lexical-binding: 
t; -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Maintainer: emacs-devel@gnu.org
+;; Keywords: filling
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The main entry point is `pixel-fill-region', but
+;; `pixel-fill-find-fill-point' can also be useful by itself.
+
+;;; Code:
+
+(require 'kinsoku)
+
+(defgroup pixel-fill nil
+  "Filling based on pixel widths."
+  :group 'fill
+  :version "29.1")
+
+(defcustom pixel-fill-respect-kinsoku t
+  "If nil, fill even if we can't find a good kinsoku point.
+Kinsoku is a Japanese word meaning a rule that should not be violated.
+In Emacs, it is a term used for characters, e.g. punctuation marks,
+parentheses, and so on, that should not be placed in the beginning
+of a line or the end of a line."
+  :type 'boolean
+  :version "29.1")
+
+(defun pixel-fill-region (start end pixel-width)
+  "Fill the region between START and END.
+This will attempt to reformat the text in the region to have no
+lines that are visually wider than PIXEL-WIDTH.
+
+If START isn't at the start of a line, that pixel position will
+be used as the indentation prefix on subsequent lines."
+  (save-excursion
+    (goto-char start)
+    (let ((indentation
+           (car (window-text-pixel-size nil (line-beginning-position)
+                                        (point)))))
+      (when (> indentation pixel-width)
+        (error "The indentation (%s) is wider than the fill width (%s)"
+               indentation pixel-width))
+      (save-restriction
+        (narrow-to-region start end)
+        (goto-char start)
+        ;; First replace all whitespace with space.
+        (while (re-search-forward "[ \t\n]+" nil t)
+          (if (= (match-beginning 0) start)
+              (delete-region (match-beginning 0) (match-end 0))
+            (replace-match " ")))
+        (goto-char start)
+        (pixel-fill--fill-line pixel-width indentation)))))
+
+(defun pixel-fill--goto-pixel (width)
+  (vertical-motion (cons (/ width (frame-char-width)) 0)))
+
+(defun pixel-fill--fill-line (width &optional indentation)
+  (let ((start (point)))
+    (pixel-fill--goto-pixel width)
+    (while (not (eolp))
+      ;; We have to do some folding.  First find the first previous
+      ;; point suitable for folding.
+      (if (or (not (pixel-fill-find-fill-point (line-beginning-position)))
+             (= (point) start))
+         ;; We had unbreakable text (for this width), so just go to
+         ;; the first space and carry on.
+         (progn
+           (beginning-of-line)
+           (skip-chars-forward " ")
+           (search-forward " " (line-end-position) 'move)))
+      ;; Success; continue.
+      (when (= (preceding-char) ?\s)
+       (delete-char -1))
+      (insert ?\n)
+      (when (> indentation 0)
+        (insert (propertize " " 'display
+                            (list 'space :align-to (list indentation)))))
+      (setq start (point))
+      (pixel-fill--goto-pixel width))))
+
+(define-inline pixel-fill--char-breakable-p (char)
+  "Return non-nil if a line can be broken before and after CHAR."
+  (inline-quote (aref fill-find-break-point-function-table ,char)))
+
+(define-inline pixel-fill--char-nospace-p (char)
+  "Return non-nil if no space is required before and after CHAR."
+  (inline-quote (aref fill-nospace-between-words-table ,char)))
+
+(define-inline pixel-fill--char-kinsoku-bol-p (char)
+  "Return non-nil if a line ought not to begin with CHAR."
+  (inline-letevals (char)
+    (inline-quote (and (not (eq ,char ?'))
+                       (aref (char-category-set ,char) ?>)))))
+
+(define-inline pixel-fill--char-kinsoku-eol-p (char)
+  "Return non-nil if a line ought not to end with CHAR."
+  (inline-quote (aref (char-category-set ,char) ?<)))
+
+(defun pixel-fill-find-fill-point (start)
+  "Find a place suitable for breaking the current line.
+START should be the earliest buffer position that should be considered
+(typically the start of the line), and this function will search
+backward in the current buffer from the current position."
+  (let ((bp (point))
+       (end (point))
+       failed)
+    (while (not
+            (or (setq failed (<= (point) start))
+               (eq (preceding-char) ?\s)
+               (eq (following-char) ?\s)
+               (pixel-fill--char-breakable-p (preceding-char))
+               (pixel-fill--char-breakable-p (following-char))
+               (and (pixel-fill--char-kinsoku-bol-p (preceding-char))
+                    (pixel-fill--char-breakable-p (following-char))
+                    (not (pixel-fill--char-kinsoku-bol-p (following-char))))
+               (pixel-fill--char-kinsoku-eol-p (following-char))
+               (bolp)))
+      (backward-char 1))
+    (if failed
+       ;; There's no breakable point, so we give it up.
+       (let (found)
+         (goto-char bp)
+          ;; Don't overflow the window edge, even if
+          ;; `pixel-fill-respect-kinsoku' is t.
+         (when pixel-fill-respect-kinsoku
+           (while (setq found (re-search-forward
+                               "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
+                               (line-end-position) 'move)))
+           (if (and found
+                    (not (match-beginning 1)))
+               (goto-char (match-beginning 0)))))
+      (or
+       (eolp)
+       ;; Don't put kinsoku-bol characters at the beginning of a line,
+       ;; or kinsoku-eol characters at the end of a line.
+       (cond
+        ;; Don't overflow the window edge, even if `pixel-fill-respect-kinsoku'
+        ;; is t.
+       ((not pixel-fill-respect-kinsoku)
+        (while (and (not (eq (preceding-char) ?\s))
+                    (or (pixel-fill--char-kinsoku-eol-p (preceding-char))
+                         (pixel-fill--char-kinsoku-bol-p (following-char))))
+          (backward-char 1))
+        (when (setq failed (<= (point) start))
+          ;; There's no breakable point that doesn't violate kinsoku,
+          ;; so we look for the second best position.
+          (while (and (progn
+                        (forward-char 1)
+                        (<= (point) end))
+                      (progn
+                        (setq bp (point))
+                        (pixel-fill--char-kinsoku-eol-p (following-char)))))
+          (goto-char bp)))
+       ((pixel-fill--char-kinsoku-eol-p (preceding-char))
+        ;; Find backward the point where kinsoku-eol characters begin.
+        (let ((count 4))
+          (while
+              (progn
+                (backward-char 1)
+                (and (> (setq count (1- count)) 0)
+                     (not (eq (preceding-char) ?\s))
+                     (or (pixel-fill--char-kinsoku-eol-p (preceding-char))
+                         (pixel-fill--char-kinsoku-bol-p (following-char)))))))
+        (when (setq failed (<= (point) start))
+          ;; There's no breakable point that doesn't violate kinsoku,
+          ;; so we go to the second best position.
+          (if (looking-at "\\(\\c<+\\)\\c<")
+              (goto-char (match-end 1))
+            (forward-char 1))))
+       ((pixel-fill--char-kinsoku-bol-p (following-char))
+        ;; Find forward the point where kinsoku-bol characters end.
+        (let ((count 4))
+          (while (progn
+                   (forward-char 1)
+                   (and (>= (setq count (1- count)) 0)
+                        (pixel-fill--char-kinsoku-bol-p (following-char))
+                        (pixel-fill--char-breakable-p (following-char))))))))
+       (when (eq (following-char) ?\s)
+        (forward-char 1))))
+    (not failed)))
+
+(provide 'pixel-fill)
+
+;;; pixel-fill.el ends here