Support copy math content from Kimi Chat

progs/convert/data/css.scm

@@ -0,0 +1,72 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : css.scm
+;; DESCRIPTION : tools for manipulation of CSS attributes
+;; COPYRIGHT   : (C) 2020  Joris van der Hoeven
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (convert data css)
+  (:use (convert data sxml)))
+
+(define (css-style-item->pair s)
+  (with l (string-tokenize-by-char s #\:)
+    (and (== (length l) 2)
+         (cons (tm-string-trim-both (car l))
+               (tm-string-trim-both (cadr l))))))
+
+(define (css-style->assoc s)
+  (let* ((l1 (string-tokenize-by-char s #\;))
+         (l2 (map css-style-item->pair l1)))
+    (list-filter l2 (lambda (x) x))))
+
+(define (pair->css-style-item p)
+  (string-append (car p) ": " (cdr p)))
+
+(define (assoc->css-style a)
+  (with l (map pair->css-style-item a)
+    (string-recompose l "; ")))
+
+(define (css-max l1 l2)
+  (if (and (length? l1) (length? l2))
+      (length-max l1 l2)
+      l2))
+
+(define (css-add l1 l2)
+  (if (and (length? l1) (length? l2))
+      (length-add l1 l2)
+      l2))
+
+(define (assoc-change a k v)
+  (cond ((null? a) a)
+        ((== (caar a) k) (cons (cons k v) (cdr a)))
+        (else (cons (car a) (assoc-change (cdr a) k v)))))
+
+(define (css-merge-attrs a1 a2)
+  (cond ((null? a1) a2)
+        ((not (assoc-ref a2 (caar a1)))
+         (cons (car a1) (css-merge-attrs (cdr a1) a2)))
+        ((in? (caar a1) '("margin-top" "margin-bottom"
+                          "padding-top" "padding-bottom"))
+         (let* ((k (caar a1))
+                (v (css-max (assoc-ref a1 k) (assoc-ref a2 k)))
+                (a2* (assoc-change a2 k v)))
+           (css-merge-attrs (cdr a1) a2*)))
+        ((in? (caar a1) '("margin-left" "margin-right"
+                          "padding-left" "padding-right"))
+         (let* ((k (caar a1))
+                (v (css-add (assoc-ref a1 k) (assoc-ref a2 k)))
+                (a2* (assoc-change a2 k v)))
+           (css-merge-attrs (cdr a1) a2*)))
+        (else (cons (car a1) (css-merge-attrs (cdr a1) a2)))))
+
+(tm-define (css-merge-styles s1 s2)
+  (let* ((a1 (css-style->assoc s1))
+         (a2 (css-style->assoc s2))
+         (a  (css-merge-attrs a1 a2)))
+    (assoc->css-style a)))

progs/convert/data/sxhtml.scm

@@ -0,0 +1,275 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : sxhtml.scm
+;; DESCRIPTION : Utilities for HTML in SXML format
+;; COPYRIGHT   : (C) 2002  David Allouche
+;;
+;; This software falls under the GNU general public license version 3 or later.
+;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
+;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(texmacs-module (convert data sxhtml)
+  (:use (convert data sxml)))
+
+;; TODO: rewrite the predicates using DRD
+;; TODO: consolidate with htmltm dispatch DRD
+
+;; Is the node x a HTML element whose name is a given set?
+;; (tm-define sxhtml-heading? (ntype-names?? '(h:h1 h:h2 h:h3 h:h4 h:h5 h:h6)))
+;; NOTE: outcommented in order to keep inline nature of h5 and h6
+(tm-define sxhtml-heading? (ntype-names?? '(h:h1 h:h2 h:h3 h:h4)))
+(tm-define sxhtml-list? (ntype-names?? '(h:ul h:ol h:dl)))
+(tm-define sxhtml-table? (ntype-names?? '(h:table)))
+
+(tm-define (sxhtml-label? x)
+  ;; Is the node x a h:a element with an id attribute?
+  (and (sxml-element? x)
+       (eq? 'h:a (sxml-name x))
+       (sxml-attr x 'id)))
+
+(tm-define (sxhtml-glue-label x label)
+  ;; Set the id attribute of element x from the id of element label.
+  (sxml-set-attr x (list 'id (sxml-attr label 'id))))
+
+(define table-kid?
+  (ntype-names?? '(h:tr h:td h:th h:col h:colgroup h:tbody h:thead h:tfoot)))
+(define row-group-kid? (ntype-names?? '(h:tr h:td h:th)))
+(define row-group? (ntype-names?? '(h:tbody h:thead h:tfoot)))
+(define tfoot? (ntype-names?? '(h:tfoot)))
+(define col-data? (ntype-names?? '(h:col h:colgroup)))
+(define row? (ntype-names?? '(h:tr)))
+(define cell? (ntype-names?? '(h:td h:th)))
+
+(define (shtml-attr-number as name)
+  (and-let* ((x (shtml-attr-non-null as name)))
+    (string->number x)))
+
+(define (shtml-attr-positive-integer as name)
+  (and-let* ((n (shtml-attr-number as name)))
+    (if (< n 0) #f (inexact->exact n))))
+
+(tm-define (shtml-decode-span as name)
+  ;; FIXME: zero spans (until end of group) are not supported
+  (let ((n (shtml-attr-positive-integer as name)))
+    (cond ((not n) 1) ((zero? n) 1) (else n))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Correct invalid element nesting in HTML tables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; A correct TABLE contains only COL, COLGROUP, THEAD, TFOOT and TBODY
+;; elements. THEAD, TFOOT and TBODY (row groups) contains only TR elements. TR
+;; elements contain only TD elements.
+;;
+;; Correcting a table is inferring TBODY and TR elements when they are missing
+;; and filtering illegal nodes out.
+;;
+;; TODO: filter contents of COLGROUP elements.
+
+(tm-define (sxhtml-correct-table x)
+  ;; Correct all TABLEs in postorder in the sxml tree @x.
+  (let sub ((x x))
+    (cond ((sxhtml-table? x)
+	   (correct-table (sxml-set-content x (map sub (sxml-content x)))))
+	  ((sxml-element? x)
+	   (sxml-set-content x (map sub (sxml-content x))))
+	  (else x))))
+
+(define (correct-table e)
+  ;; @e must be a h:table element (ns-prefixes must be normalized)
+  ;; Make TBODY elements explicit.
+  ;; Collect lone TD elements in TR.
+  ;; Drop table data not in TD.
+  (correct-table-content e table-kid?
+			 (lambda (tr tbody) (cons `(h:tr ,@tr) tbody))
+			 (lambda (tbody kdr) (cons `(h:tbody ,@tbody) kdr))))
+
+(define (correct-row-group e)
+  ;; Collect lone TD elements in TR inside of @e.
+  ;; Drop table data not in TD.
+  (correct-table-content e row-group-kid?
+			 (lambda (tr tbody) (cons `(h:tr ,@tr) tbody))
+			 (lambda (tbody kdr) tbody)))
+
+(define (correct-row e)
+  ;; Drop everything but TD elements.
+  (sxml-set-content e (list-filter (sxml-content e) cell? )))
+
+(define (correct-table-content e accept? make-tr make-tbody)
+  (sxml-set-content
+   e ((cut <> #f) (list-fold-right
+		   (lambda (kar kdr) (kdr kar))
+		   (cut correct-table-content/step
+			accept? make-tr make-tbody <> '() '() '())
+		   (sxml-content e)))))
+
+(define (correct-table-content/step accept? cons-tr cons-tbody
+				    kar tr tbody kdr)
+  (define (state kar tr tbody kdr)
+    (correct-table-content/step accept? cons-tr cons-tbody kar tr tbody kdr))
+  (define (flush-tr curry-tbody-kdr)
+    ;; curry-tbody-kdr: (proc tbody -> state)
+    ;; curries @proc like (cut proc <> tbody kdr) with an updated @tbody.
+    (curry-tbody-kdr (cut state <> '() <> <>)
+		     (if (null? tr) tbody (cons-tr tr tbody))))
+  (define (flush-tbody curry-kdr)
+    ;; curry-kdr: (proc kdr -> state)
+    ;; curries @proc like (cut proc <> kdr) with an updated @kdr.
+    (flush-tr
+     (lambda (proc tbody)
+       (curry-kdr (cut proc <> '() <>)
+		  (if (null? tbody) kdr (cons-tbody tbody kdr))))))
+  (cond ((not kar) (flush-tbody (lambda (proc kdr) kdr)))
+	((not (accept? kar)) (cut state <> tr tbody kdr))
+	((cell? kar) (cut state <> (cons kar tr) tbody kdr))
+	((row? kar)
+	 (flush-tr (lambda (proc tbody)
+		     (cut proc <> (cons (correct-row kar) tbody) kdr))))
+	((row-group? kar)
+	 (flush-tbody (lambda (proc kdr)
+			(cut proc <> (cons (correct-row-group kar) kdr)))))
+	((col-data? kar)
+	 (flush-tbody (lambda (proc kdr) (cut proc <> (cons kar kdr)))))
+	;; no "else" clause needed (assuming @accept is correct)
+	))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Table iterator
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Iterating over cells of a table while maintaining the coordinates of the
+;; current cell is a complex operation because table positions which are
+;; covered by spanned cells are not represented by cell elements in HTML.
+;; Also, the TFOOT element is present before TBODY element but is logically
+;; located at the end of the table.
+
+;;;; MISSING FEATURE ;;;;
+;; HTML-4.01 says that ROWSPAN=0 or COLSPAN=0 spans the cell to the end of its
+;; containing group (colgroup, tbody, thead, tfoot). However, neither
+;; Mozilla-1.4 nor Konqueror 3.1.3 implement this part of the specification.
+;; Since this feature also requires a significant added complexity, it is left
+;; out.
+
+(tm-define (sxhtml-table-fold kons knil table)
+  ;; Fundamental HTML table content iterator.
+  ;; knil: T
+  ;; kons: symbol (int @i) (int @j) sxml T -> T
+  ;; table: sxml
+  ;; Fold @kons over elements of @table, with (@i @j) the cell position.
+  ;;
+  ;; @kons is applied in the following modes:
+  ;;   Entering a row-group  : (kons :in-row-group i #f row-group kdr)
+  ;;   Entering a row        : (kons :in-row i #f row kdr)
+  ;;   (possible extension: entering a colgroup and iterating over a col)
+  ;;   Leaving a row-group   : (kons :out-row-group nrows #f #f kdr)
+  ;;   Leaving a row         : (kons :out-row #f ncols #f kdr)
+  ;;   Iterating over a cell : (kons :cell i j cell kdr)
+  ((cut <> #f) (list-fold (lambda (kar kdr) (kdr kar))
+			  (cut table-fold/table <> 0 '() '() kons knil)
+			  (sxml-content table))))
+
+(define (table-fold/table kar i rowspans footers kons kdr)
+  ;; @kar is a child element of the TABLE element.
+  (cond ((not kar)
+	 (if (not footers) kdr
+	     ((cut <> #f)
+	      (list-fold (lambda (kar kdr) (kdr kar))
+			 (cut table-fold/table <> i rowspans #f kons kdr)
+			 (reverse! footers)))))
+	((and footers (tfoot? kar))
+	 (cut table-fold/table <> i rowspans (cons kar footers) kons kdr))
+	((row-group? kar)
+	 ((cut <> #f)
+	  (list-fold (lambda (kar kdr) (kdr kar))
+		     (cut table-fold/group <> i i rowspans footers kons
+			  (kons :in-row-group i #f kar kdr))
+		     (sxml-content kar))))
+	;; ELSE clause for col-data elements.
+	;; NOTE: could be extended to support parsing of col-data
+	(else (cut table-fold/table <> i rowspans footers kons kdr))))
+
+(define (table-fold/group kar i0 i rowspans footers kons kdr)
+  ;; @kar is a child element of a THEAD, TBODY or TFOOT element.
+  (cond ((not kar) (cut table-fold/table <> i rowspans footers kons
+			(kons :out-row-group (- i i0) #f #f kdr)))
+	((row? kar)
+	 ((cut <> #f)
+	  (list-fold (lambda (kar kdr) (kdr kar))
+		     (cut table-fold/row <> i0 i 0 rowspans footers kons
+			  (kons :in-row i #f kar kdr))
+		     (sxml-content kar))))
+	;; ELSE clause should never be reached (the table is corrected).
+	(else (cut table-fold/group <> i0 i rowspans footers kons kdr))))
+
+(define (table-fold/row kar i0 i j rowspans footers kons kdr)
+  ;; @kar is a child element of a TR element.
+  (cond ((not kar)
+	 (cut table-fold/group <> i0 (1+ i) (next-rowspans rowspans) footers
+	      kons (kons :out-row #f (skip-spanned-cols j rowspans) #f kdr)))
+	((cell? kar)
+	 (let ((j (skip-spanned-cols j rowspans))
+	       (a (sxml-attr-list kar)))
+	   (let ((rspan (shtml-decode-span a 'rowspan))
+		 (cspan (shtml-decode-span a 'colspan)))
+	 (cut table-fold/row <> i0 i (+ j cspan)
+	      (if (= 1 rspan) rowspans
+		  (add-rowspan rowspans j rspan cspan))
+	      footers kons (kons :cell i j kar kdr)))))
+	;; ELSE clause should never be reached (the table is corrected).
+	(else (cut table-fold/row <> i0 i j rowspans footers kons kdr))))
+
+;(set-trace-level! sxhtml-table-fold
+;		  table-fold/table table-fold/group table-fold/row)
+
+;; Columns on which a cell is spanned are remember in a sorted ROWSPANS list.
+;; Items of ROWSPANS are lists (J SPAN) where:
+;;   J    : column number (zero-based). ROWSPANS is sorted by ascending J.
+;;   SPAN : count of additional rows (incl. the current row) where this column
+;;          is occupied by a spanned cell.
+
+(define (skip-spanned-cols j rowspans)
+  (let next ((j j) (rowspans rowspans))
+    (cond ((null? rowspans) j)
+	  ((< j (first (car rowspans))) j)
+	  ((= j (first (car rowspans))) (next (1+ j) (cdr rowspans)))
+	  (else (next j (cdr rowspans))))))
+
+(define (add-rowspan rowspans j rspan cspan)
+  (let next ((rowspans rowspans) (j j) (cspan cspan))
+    (cond ((zero? cspan) rowspans)
+	  ((null? rowspans)
+	   (cons (list j rspan) (next '() (1+ j) (1- cspan))))
+	  ((< j (first (car rowspans)))
+	   (cons (list j rspan) (next rowspans (1+ j) (1- cspan))))
+	  ((= j (first (car rowspans)))
+	   ;; This can only happen with some very vicious incorrect HTML.
+	   (cons (list j (max rspan (second (car rowspans))))
+		 (next (cdr rowspans) (1+ j) (1- cspan))))
+	  (else (cons (car rowspans)
+		      (next (cdr rowspans) (1+ j) (1- cspan)))))))
+
+(define (next-rowspans rowspans)
+  (reverse! (list-fold (lambda (kar kdr)
+			 (with (col old-span) kar
+			   (let ((span (1- old-span)))
+			     (if (zero? span)
+				 kdr
+				 (cons (list col span) kdr)))))
+		       '() rowspans)))
+
+;(set-trace-level! skip-spanned-cols add-rowspan next-rowspans)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Table iterator applications
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(tm-define (sxhtml-table-dimension table)
+  (sxhtml-table-fold
+   (lambda (msg i j kar kdr)
+     (with (nrows ncols) kdr
+       (list (if (eq? msg :out-row-group) (+ nrows i) nrows)
+	     (if (eq? msg :out-row) (max ncols j) ncols))))
+   '(0 0) table))