1
2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3;;
4;; MODULE      : tmhtml.scm
5;; DESCRIPTION : conversion of TeXmacs trees into Html trees
6;; COPYRIGHT   : (C) 2002  Joris van der Hoeven, David Allouche
7;;
8;; This software falls under the GNU general public license version 3 or later.
9;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
10;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
11;;
12;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13
14(texmacs-module (convert html tmhtml)
15  (:use (convert tools tmconcat)
16	(convert mathml tmmath)
17	(convert tools stm)
18	(convert tools tmlength)
19	(convert tools tmtable)
20	(convert tools old-tmtable)
21	(convert tools sxml)
22	(convert tools sxhtml)
23	(convert html htmlout)))
24
25;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26;; Initialization
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(define tmhtml-env (make-ahash-table))
30(define tmhtml-css? #t)
31(define tmhtml-mathml? #f)
32(define tmhtml-images? #f)
33(define tmhtml-image-serial 0)
34(define tmhtml-image-cache (make-ahash-table))
35(define tmhtml-image-root-url (unix->url "image"))
36(define tmhtml-image-root-string "image")
37
38(tm-define (tmhtml-initialize opts)
39  (set! tmhtml-env (make-ahash-table))
40  (set! tmhtml-css?
41	(== (assoc-ref opts "texmacs->html:css") "on"))
42  (set! tmhtml-mathml?
43	(== (assoc-ref opts "texmacs->html:mathml") "on"))
44  (set! tmhtml-images?
45	(== (assoc-ref opts "texmacs->html:images") "on"))
46  (set! tmhtml-image-cache (make-ahash-table))
47  (let* ((suffix (url-suffix current-save-target))
48	 (n (+ (string-length suffix) 1)))
49    (if (in? suffix '("html" "xhtml"))
50	(begin
51	  (set! tmhtml-image-serial 0)
52	  (set! tmhtml-image-root-url (url-unglue current-save-target n))
53	  (set! tmhtml-image-root-string
54		(url->unix (url-tail tmhtml-image-root-url))))
55	(begin
56	  (set! tmhtml-image-serial 0)
57	  (set! tmhtml-image-root-url (unix->url "image"))
58	  (set! tmhtml-image-root-string "image")))))
59
60;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
61;; Empty handler and strings
62;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
63
64(define (tmhtml-noop l) '())
65
66(define (cork->html s)
67  (utf8->html (cork->utf8 s)))
68
69(define (tmhtml-sub-token s pos)
70  (with ss (substring s pos (- (string-length s) 1))
71    (if (= (string-length ss) 1) ss
72	(tmhtml-math-token (string-append "<" ss ">")))))
73
74(define (tmhtml-math-token s)
75  (cond ((= (string-length s) 1)
76	 (cond ((== s "*") " ")
77	       ((in? s '("+" "-" "=")) (string-append " " s " "))
78	       ((char-alphabetic? (string-ref s 0)) `(h:var ,s))
79	       (else s)))
80	((string-starts? s "<cal-")
81	 `(h:font (@ (face "Zapf Chancery")) ,(tmhtml-sub-token s 5)))
82	((string-starts? s "<b-cal-")
83	 `(h:u (h:font (@ (face "Zapf Chancery")) ,(tmhtml-sub-token s 7))))
84	((string-starts? s "<frak-")
85	 `(h:u ,(tmhtml-sub-token s 6)))
86	((string-starts? s "<bbb-") `(h:u (h:b ,(tmhtml-sub-token s 5))))
87	((string-starts? s "<b-") `(h:b (h:var ,(tmhtml-sub-token s 3))))
88	((string-starts? s "<")
89	 (with encoded (cork->utf8 s)
90           (if (== s encoded)
91             (utf8->html (old-tm->xml-cdata s))
92             `(h:var ,(utf8->html encoded)))))
93	(else s)))
94
95(define (tmhtml-string s)
96  (if (ahash-ref tmhtml-env :math)
97      (tmhtml-post-simplify-nodes
98       (map tmhtml-math-token (tmconcat-tokenize-math s)))
99      (list (cork->html s))))
100
101(define (tmhtml-text s)
102  (if (or (ahash-ref tmhtml-env :math) (ahash-ref tmhtml-env :preformatted))
103      (tmhtml-string s)
104      (tmhtml-string (make-ligatures s))))
105
106(define cork-endash (char->string (integer->char 21)))
107(define cork-ldquo (char->string (integer->char 16)))
108(define cork-rdquo (char->string (integer->char 17)))
109
110(define (make-ligatures s)
111  ;; Make texmacs ligatures in Cork encoding
112  (string-replace
113   (string-replace
114    (string-replace s "--" cork-endash) "``" cork-ldquo) "''" cork-rdquo))
115
116;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
117;; Entire documents
118;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
119
120(define (tmhtml-find-title doc)
121  (cond ((npair? doc) #f)
122	((func? doc 'doc-title 1) (cadr doc))
123	((func? doc 'tmdoc-title 1) (cadr doc))
124	((func? doc 'tmdoc-title* 2) (cadr doc))
125	((func? doc 'tmdoc-title** 3) (caddr doc))
126	((func? doc 'hidden-title 1) (cadr doc))
127	(else (with title (tmhtml-find-title (car doc))
128		(if title title
129		    (tmhtml-find-title (cdr doc)))))))
130
131(define (tmhtml-css-header)
132  ;; TODO: return only used CSS properties
133  (let ((html
134	 (string-append
135	  "body { text-align: justify } "
136	  "h5 { display: inline; padding-right: 1em } "
137	  "h6 { display: inline; padding-right: 1em } "
138	  "table { border-collapse: collapse } "
139	  "td { padding: 0.2em; vertical-align: baseline } "
140	  ".subsup { display: inline; vertical-align: -0.2em } "
141	  ".subsup td { padding: 0px; text-align: left} "
142	  ".fraction { display: inline; vertical-align: -0.8em } "
143	  ".fraction td { padding: 0px; text-align: center } "
144	  ".wide { position: relative; margin-left: -0.4em } "
145	  ".accent { position: relative; margin-left: -0.4em; top: -0.1em } "
146	  ".title-block { width: 100%; text-align: center } "
147	  ".title-block p { margin: 0px } "
148	  ".compact-block p { margin-top: 0px; margin-bottom: 0px } "
149	  ".left-tab { text-align: left } "
150	  ".center-tab { text-align: center } "
151          ".balloon-anchor { border-bottom: 1px dotted #000000; outline:none;"
152          "                  cursor: help; position: relative; }"
153          ".balloon-anchor [hidden] { margin-left: -999em; position: absolute;"
154                                    " display: none; }"
155          ".balloon-anchor:hover [hidden] { position: absolute; left: 1em;"
156                                 " top: 2em; z-index: 99; margin-left: 0;"
157                                 " width: 500px; display: inline-block; }"
158          ".balloon-body { }"
159	  ".ornament  { border-width: 1px; border-style: solid; border-color: "
160                      " black; display: inline-block; padding: 0.2em; } "
161	  ".right-tab { float: right; position: relative; top: -1em } "))
162	(mathml "math { font-family: cmr, times, verdana } "))
163    (if tmhtml-mathml? (string-append html mathml) html)))
164
165(define (with-extract w var)
166  (cond ((and (pair? w) (== (car w) 'with)
167	      (pair? (cdr w)) (== (cadr w) var)
168	      (pair? (cddr w)))
169	 (tmhtml-force-string (caddr w)))
170	((and (pair? w) (== (car w) 'with)
171	      (pair? (cdr w)) (pair? (cddr w)))
172	 (with-extract `(with ,@(cdddr w)) var))
173	(else #f)))
174
175(define (tmhtml-file l)
176  ;; This handler is special:
177  ;; Since !file is a special node used only at the top of trees
178  ;; it produces a single node, and not a nodeset like other handlers.
179  (let* ((doc (car l))
180	 (styles (cdadr l))
181	 (lang (caddr l))
182	 (tmpath (cadddr l))
183	 (title (tmhtml-find-title doc))
184	 (css `(h:style (@ (type "text/css")) ,(tmhtml-css-header)))
185	 (xhead '())
186	 (body (tmhtml doc)))
187    (set! title
188	  (cond ((with-extract doc "html-title")
189		 (with-extract doc "html-title"))
190		((not title) "No title")
191		((or (in? "tmdoc" styles) (in? "tmweb" styles))
192		 `(concat ,(tmhtml-force-string title)
193			  " (FSF GNU project)"))
194		(else (tmhtml-force-string title))))
195    (set! css
196	  (cond ((with-extract doc "html-css")
197		 `(h:link (@ (rel "stylesheet")
198			     (href ,(with-extract doc "html-css"))
199			     (type "text/css"))))
200		(else css)))
201    (if (with-extract doc "html-head-javascript-src")
202	(let* ((src (with-extract doc "html-head-javascript-src"))
203	       (script `(h:script (@ (language "javascript") (src ,src)))))
204	  (set! xhead (append xhead (list script)))))
205    (if (with-extract doc "html-head-javascript")
206	(let* ((code (with-extract doc "html-head-javascript"))
207	       (script `(h:script (@ (language "javascript")) ,code)))
208	  (set! xhead (append xhead (list script)))))
209    (if (or (in? "tmdoc" styles) (in? "tmweb" styles)
210            (in? "mmxdoc" styles) (in? "magix-web" styles)
211            (in? "max-web" styles))
212	(set! body (tmhtml-tmdoc-post body)))
213    `(h:html
214      (h:head
215       (h:title ,@(tmhtml title))
216       (h:meta (@ (name "generator")
217		  (content ,(string-append "TeXmacs " (texmacs-version)))))
218       ,css
219       ,@xhead)
220      (h:body ,@body))))
221
222(define (tmhtml-finalize-document top)
223  ;; @top must be a node produced by tmhtml-file
224  "Prepare a XML document for serialization"
225  (define xmlns-attrs
226    '((xmlns "http://www.w3.org/1999/xhtml")
227      (xmlns:m "http://www.w3.org/1998/Math/MathML")
228      (xmlns:x "http://www.texmacs.org/2002/extensions")))
229  (define doctype-list
230    (let ((html       "-//W3C//DTD XHTML 1.1//EN")
231          (mathml     "-//W3C//DTD XHTML 1.1 plus MathML 2.0//EN")
232	  (html-drd   "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
233	  (mathml-drd (string-append
234                        "http://www.w3.org/2002/04/xhtml-math-svg/"
235                        "xhtml-math-svg.dtd")))
236      (if tmhtml-mathml? (list mathml mathml-drd) (list html html-drd))))
237  `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")
238	  (*DOCTYPE* html PUBLIC ,@doctype-list)
239	  ,((cut sxml-set-attrs <> xmlns-attrs)
240	    (sxml-strip-ns-prefix "h" (sxml-strip-ns-prefix "m" top)))))
241
242(define (tmhtml-finalize-selection l)
243  ;; @l is a nodeset produced by any handler _but_ tmhtml-file
244  "Prepare a HTML node-set for serialization."
245  `(*TOP* ,@(map (cut sxml-strip-ns-prefix "h" <>) l)))
246
247;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
248;; Block structures
249;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
250
251(define (tmhtml-document-elem x)
252  ;; NOTE: this should not really be necessary, but it improves
253  ;; the layout of verbatim environments with a missing block structure
254  (if (and (list-2? x)
255	   (or (== (car x) 'verbatim) (== (car x) 'code))
256	   (not (func? (cadr x) 'document)))
257      (tmhtml (list (car x) (list 'document (cadr x))))
258      (tmhtml x)))
259
260(define (tmhtml-compute-max-vspace l after?)
261  (and (nnull? l)
262    (with s1 (tmhtml-compute-vspace (car l) after?)
263      (with s2 (tmhtml-compute-max-vspace (cdr l) after?)
264	(cond ((not s1) s2)
265	      ((not s2) s1)
266	      (else
267		(with l1 (string->tmlength s1)
268		  (with l2 (string->tmlength s2)
269		    (if (== (tmlength-unit l1) (tmlength-unit l2))
270			(if (>= (tmlength-value l1) (tmlength-value l2)) s1 s2)
271			l1 ;; FIXME: do something more subtle here
272			)))))))))
273
274(define (tmhtml-compute-vspace x after?)
275  (cond ((and (not after?) (func? x 'vspace* 1)) (tmhtml-force-string (cadr x)))
276	((and after? (func? x 'vspace 1)) (tmhtml-force-string (cadr x)))
277	;;((and (not after?) (func? x 'document)) (tmhtml-compute-vspace (cadr x) #f))
278	;;((and after? (func? x 'document)) (tmhtml-compute-vspace (cAr x) #t))
279	((func? x 'concat) (tmhtml-compute-max-vspace (cdr x) after?))
280	((func? x 'with) (tmhtml-compute-vspace (cAr x) after?))
281	;;((func? x 'surround) (tmhtml-compute-max-vspace (cDdr x) after?))
282	;;((func? x 'surround) (tmhtml-compute-max-vspace (cdr x) after?))
283	(else #f)))
284
285(define (tmhtml-document-p x)
286  (let* ((body (tmhtml-document-elem x))
287	 (l1 (tmhtml-compute-vspace x #f))
288	 (l2 (tmhtml-compute-vspace x #t))
289	 (h1 (and l1 (tmlength->htmllength l1 #t)))
290	 (h2 (and l2 (tmlength->htmllength l2 #t)))
291	 (s1 (and h1 (string-append "margin-top: " h1)))
292	 (s2 (and h2 (string-append "margin-bottom: " h2)))
293	 (s (cond ((and s1 s2) (string-append s1 "; " s2))
294		  (s1 s2)
295		  (s2 s1)
296		  (else #f))))
297    ;;(display* "paragraph= " x "\n")
298    ;;(display* "style    = " s "\n")
299    (if s `(h:p (@ (style ,s)) ,@body) `(h:p ,@body))))
300
301(define (xtmhtml-document-p x)
302  (with body (tmhtml-document-elem x)
303    `(h:p ,@body)))
304
305(define (tmhtml-document l)
306  (cond ((null? l) '())
307	((ahash-ref tmhtml-env :preformatted)
308	 (tmhtml-post-simplify-nodes
309	  (list-concatenate
310	   ((cut list-intersperse <> '("\n"))
311	    (map tmhtml l)))))
312	(else
313	  (tmhtml-post-paragraphs (map tmhtml-document-p l)))))
314
315(define (tmhtml-paragraph l)
316  (let rec ((l l))
317    (if (null? l) '()
318	(let ((h (tmhtml (car l)))
319	      (r (rec (cdr l))))
320	  (cond ((null? h) r)		; correct when r is null too
321		((null? r) h)
322		(else `(,@h (h:br) ,@r)))))))
323
324(define (tmhtml-post-paragraphs l)
325  ;; Post process a collection of h:p elements
326  ;;
327  ;; If a h:p contains a h:hN, remove the h:p node and prepend the rest of the
328  ;; contents to the next h:p. If the next element, after post processing is
329  ;; not a h:p, create an intermediate h:p to hold the data.
330  ;;
331  ;; If a h:p contains a list element, remove the enclosing h:p. The TeXmacs
332  ;; editor ensures that an <item-list> or <desc-list> is the only element
333  ;; contained in its enclosing <doc-item>.
334  ;;
335  ;; If a h:p contains a h:pre element, remove the enclosing h:p. The VERBATIM
336  ;; handler ensures that block VERBATIM and CODE environment are alone in the
337  ;; paragraph.
338  ;;
339  ;; NOTE: assumes the heading is at the start of a paragraph. That is
340  ;; consistent with the fact that (as of 2003-02-04) the only converted
341  ;; invisible markup is <label> and correct usage requires it to be after the
342  ;; section title.
343  (let rec ((in l) (out '()) (trail #f))
344    (let* ((para (and (pair? in) (car in)))
345	   (cont (and para (sxml-content para)))
346	   (first (and cont (pair? cont) (car cont)))
347	   (next (lambda (o t) (rec (cdr in) o t)))
348	   (flush (lambda () (if trail `((h:p ,@trail) ,@out) out)))
349	   (accept (lambda () (if trail (sxml-prepend para trail) para)))
350	   (give (lambda () (and (pair? (cdr cont)) (cdr cont)))))
351      ;; invariant: (xor prev prev-trail)
352      (cond ((null? in) (reverse (flush)))
353	    ((or (null? cont) (string? first))
354	     (next (cons (accept) out) #f))
355	    ((sxhtml-heading? first)
356	     ;; tmhtml-post-heading should be called by concat handler
357	     (next (cons first (flush)) (give)))
358	    ((sxhtml-list? first)
359	     ;; texmacs editor ensures there is no trail after a list
360	     (next (append cont (flush)) #f))
361	    ((== 'h:pre (sxml-name first))
362	     ;; handlers and editor ensure there is no trail after a h:pre
363	     (next (append cont (flush)) #f))
364	    ((and (sxhtml-table? first) (null? (cdr cont)))
365	     ;; if table is not alone, we cannot help but produce bad html
366	     ;; if table is alone, drop the enclosing <h:p>
367	     (next (append cont (flush)) #f))
368	    (else (next (cons (accept) out) #f))))))
369
370;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
371;; Surrounding block structures
372;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
373
374(define document-done '())
375(define concat-done '())
376
377(define (serialize-print x)
378  (set! concat-done (cons x concat-done)))
379
380(define (serialize-paragraph x)
381  (serialize-concat x)
382  (with l (tmconcat-simplify (reverse concat-done))
383    (set! document-done (cons (cons 'concat l) document-done))
384    (set! concat-done '())))
385
386(define (serialize-concat x)
387  (cond ((in? x '("" (document) (concat))) (noop))
388	((func? x 'document)
389	 (for-each serialize-paragraph (cDdr x))
390	 (serialize-concat (cAr x)))
391	((func? x 'concat)
392	 (for-each serialize-concat (cdr x)))
393	((func? x 'surround 3)
394	 (serialize-concat (cadr x))
395	 (serialize-concat (cadddr x))
396	 (serialize-concat (caddr x)))
397	((func? x 'with)
398	 (let* ((r (simplify-document (cAr x)))
399		(w (lambda (y) `(with ,@(cDdr x) ,y))))
400	   (if (not (func? r 'document))
401	       (serialize-print (w r))
402	       (let* ((head (cadr r))
403		      (body `(document ,@(cDr (cddr r))))
404		      (tail (cAr r)))
405		 (serialize-paragraph (w head))
406		 (set! document-done (cons (w body) document-done))
407		 (serialize-concat (w tail))))))
408	(else (serialize-print x))))
409
410(define (simplify-document x)
411  (with-global document-done '()
412    (with-global concat-done '()
413      (serialize-paragraph x)
414      (if (list-1? document-done)
415	  (car document-done)
416	  (cons 'document (reverse document-done))))))
417
418(define (block-document? x)
419  (cond ((func? x 'document) #t)
420	((func? x 'concat) (list-any block-document? (cdr x)))
421	((func? x 'surround 3) (block-document? (cAr x)))
422	((func? x 'with) (block-document? (cAr x)))
423	(else #f)))
424
425(define (blockify x)
426  (cond ((func? x 'document) x)
427	((or (func? x 'surround 3) (func? x 'with))
428	 (rcons (cDr x) (blockify (cAr x))))
429	(else `(document ,x))))
430
431(define (tmhtml-surround l)
432  (let* ((r1 `(surround ,@l))
433	 (r2 (simplify-document r1))
434	 (f? (and (block-document? r1) (not (func? r2 'document))))
435	 (r3 (if f? (blockify r2) r2)))
436    (tmhtml r3)))
437
438;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
439;; Horizontal concatenations
440;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
441
442(define (tmhtml-glue-scripts l)
443  (cond ((or (null? l) (null? (cdr l))) l)
444	((and (func? (car l) 'rsub 1) (func? (cadr l) 'rsup 1))
445	 (cons `(rsubsup ,(cadar l) ,(cadadr l))
446	       (tmhtml-glue-scripts (cddr l))))
447	(else (cons (car l) (tmhtml-glue-scripts (cdr l))))))
448
449(define (heading? l)
450  (cond ((null? l) #f)
451	((sxhtml-label? (car l)) (heading? (cdr l)))
452	((sxhtml-heading? (car l)) #t)
453	(else #f)))
454
455(define (tmhtml-post-heading l)
456  ;; Post-process the converted result of a concat containing a section title.
457  ;;
458  ;; Any label preceding the section is moved after it.
459  ;;
460  ;; The first label after the section is changed to an 'id' attribute in the
461  ;; heading element, if it has not already an 'id' attribute.
462  ;;
463  ;; NOTE: assumes the heading is the first node (not counting labels)
464  (receive (labels-before rest) (list-span l sxhtml-label?)
465    (receive (heading rest) (car+cdr rest)
466      (if (sxml-attr heading 'id)
467	  `(,heading ,@labels-before ,@rest)
468	  (receive (labels-after rest) (list-partition rest sxhtml-label?)
469	    (let ((labels (append labels-before labels-after)))
470	      (if (null? labels) l
471		  (cons (sxml-prepend (sxhtml-glue-label heading (car labels))
472				      (cdr labels))
473			rest))))))))
474
475(define (tmhtml-post-table l)
476  ;; Post process the converted result of a concat containing a table.
477  ;;
478  ;; If a label is adjacent to the table, use it to set the table id. If there
479  ;; are several labels adjacent to the table, leave all but one label
480  ;; untouched. There is no guarantee on which label is glued.
481  (define (glue-label-to-table x knil)
482    (cond ((null? knil) (list x))
483	  ((and (sxhtml-label? x)
484		(sxhtml-table? (car knil))
485		(not (sxml-attr (car knil) 'id)))
486	   (cons (sxhtml-glue-label (car knil) x)
487		 (cdr knil)))
488	  ((and (sxhtml-table? x)
489		(not (sxml-attr x 'id))
490		(sxhtml-label? (car knil)))
491	   (cons (sxhtml-glue-label x (car knil))
492		 (cdr knil)))
493	  (else (cons x knil))))
494  (list-fold-right glue-label-to-table '() l))
495
496(define (tmhtml-concat l)
497  (set! l (tmhtml-glue-scripts l))
498  ;;(display* "l << " l "\n")
499  (set! l (tmconcat-structure-tabs l))
500  ;;(display* "l >> " l "\n")
501  (tmhtml-post-simplify-nodes
502   (let ((l (tmhtml-list l)))
503     (cond ((null? l) '())
504	   ((string? (car l)) l)
505	   ((heading? l) (tmhtml-post-heading l))
506	   ((list-any sxhtml-table? l) (tmhtml-post-table l))
507	   ((and (null? (cdr l)) (pair? (car l))
508		 (== (caar l) 'h:div) (== (cadar l) '(@ (class "left-tab"))))
509	    (cddar l))
510	   (else l)))))
511
512(define (tmhtml-align-left l)
513  (with r (tmhtml-concat l)
514    (if (in? r '(() (""))) '()
515	`((h:div (@ (class "left-tab")) ,@r)))))
516
517(define (tmhtml-align-middle l)
518  (with r (tmhtml-concat l)
519    (if (in? r '(() (""))) '()
520	`((h:div (@ (class "center-tab")) ,@r)))))
521
522(define (tmhtml-align-right l)
523  (with r (tmhtml-concat l)
524    (if (in? r '(() (""))) '()
525	`((h:div (@ (class "right-tab")) ,@r)))))
526
527(define (tmhtml-post-simplify-nodes l)
528  ;; Catenate adjacent string nodes and remove empty string nodes
529  (let rec ((l l))
530    (cond ((null? l) '())
531	  ((and (string? (car l)) (string-null? (car l)))
532	   (rec (cdr l)))
533	  ((null? (cdr l)) l)
534	  ((and (string? (car l)) (string? (cadr l)))
535	   (rec (cons (string-append (car l) (cadr l)) (cddr l))))
536	  (else (cons (car l) (rec (cdr l)))))))
537
538(define (tmhtml-post-simplify-element e)
539  ;; Simplify the nodes of the element content
540  (list (append (sxml-element-head e)
541		(tmhtml-post-simplify-nodes (sxml-content e)))))
542
543;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
544;; Formatting text
545;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
546
547(define (tmhtml-hspace l)
548  (with len (tmlength->htmllength (if (list-1? l) (car l) (cadr l)) #t)
549    (if (not len) '()
550	`((span (@ (style ,(string-append "margin-left: " len))))))))
551
552(define (tmhtml-vspace l)
553  '())
554
555(define (tmhtml-move l)
556  (tmhtml (car l)))
557
558(define (tmhtml-resize l)
559  (tmhtml (car l)))
560
561(define (tmhtml-float l)
562  (tmhtml (cAr l)))
563
564(define (tmhtml-repeat l)
565  (tmhtml (car l)))
566
567(define (tmhtml-datoms l)
568  (tmhtml (cAr l)))
569
570(define (tmhtml-new-line l)
571  '((h:br)))
572
573(define (tmhtml-next-line l)
574  '((h:br)))
575
576;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
577;; Mathematics
578;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
579
580(define (tmhtml-id l)
581  (tmhtml (car l)))
582
583(define (tmhtml-big l)
584  (cond ((in? (car l) '("sum" "prod" "int" "oint" "amalg"))
585	 (tmhtml (string-append "<" (car l) ">")))
586	((in? (car l) '("<cap>" "<cup>" "<vee>" "<wedge>"))
587	 (with s (substring (car l) 1 (- (string-length (car l)) 1))
588	   (tmhtml (string-append "<big" s ">"))))
589	((== (car l) ".") '())
590	(else (tmhtml (car l)))))
591
592(define (tmhtml-below l)
593  `("below (" ,@(tmhtml (car l)) ", " ,@(tmhtml (cadr l)) ")"))
594
595(define (tmhtml-above l)
596  `("above (" ,@(tmhtml (car l)) ", " ,@(tmhtml (cadr l)) ")"))
597
598(define (tmhtml-sub l)
599  `((h:sub ,@(tmhtml (car l)))))
600
601(define (tmhtml-sup l)
602  `((h:sup ,@(tmhtml (car l)))))
603
604(define (tmhtml-subsup l)
605  (let* ((sub (tmhtml (car l)))
606	 (sup (tmhtml (cadr l)))
607	 (r1 `(h:tr (h:td ,@sup)))
608	 (r2 `(h:tr (h:td ,@sub))))
609    `((h:sub (h:table (@ (class "subsup")) ,r1 ,r2)))))
610
611;;(define (tmhtml-frac l)
612;;  (let* ((num (tmhtml (car l)))
613;;	 (den (tmhtml (cadr l))))
614;;    `("frac (" ,@num ", " ,@den ")")))
615
616(define (tmhtml-frac l)
617  (let* ((num (tmhtml (car l)))
618	 (den (tmhtml (cadr l)))
619	 (n `(h:tr (h:td (@ (style "border-bottom: solid 1px")) ,@num)))
620	 (d `(h:tr (h:td ,@den))))
621    `((h:table (@ (class "fraction")) ,n ,d))))
622
623(define (tmhtml-sqrt l)
624  (if (= (length l) 1)
625      `("sqrt (" ,@(tmhtml (car l)) ")")
626      `("sqrt" (h:sub ,@(tmhtml (cadr l)))
627	" (" ,@(tmhtml (car l)) ")")))
628
629(define (tmhtml-short? l)
630  (and (list-1? l)
631       (or (string? (car l))
632	   (and (func? (car l) 'h:i) (tmhtml-short? (cdar l)))
633	   (and (func? (car l) 'h:b) (tmhtml-short? (cdar l)))
634	   (and (func? (car l) 'h:u) (tmhtml-short? (cdar l)))
635	   (and (func? (car l) 'h:var) (tmhtml-short? (cdar l)))
636	   (and (func? (car l) 'h:font) (tmhtml-short? (cdar l))))))
637
638(define (tmhtml-wide l)
639  (let* ((body (tmhtml (car l)))
640	 (acc (tmhtml (cadr l)))
641	 (class (if (in? acc '(("^") ("~"))) "accent" "wide")))
642    (if (tmhtml-short? body)
643	`(,@body (h:sup (@ (class ,class)) ,@acc))
644	`("(" ,@body ")" (h:sup ,@acc)))))
645
646(define (tmhtml-neg l)
647  `("not(" ,@(tmhtml (car l)) ")"))
648
649;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
650;; Shape conversions
651;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
652
653(define (tmshape->htmllength x)
654  (if (== (tmhtml-force-string x) "rounded") "15px" "0px"))
655
656 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
657;; Color conversions
658;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
659
660(define (tmcolor->htmlcolor x)
661  (with s (tmhtml-force-string x)
662    (cond ((== s "light grey") "#d0d0d0")
663	  ((== s "pastel grey") "#dfdfdf")
664	  ((== s "dark grey") "#707070")
665	  ((== s "dark red") "#800000")
666	  ((== s "dark green") "#008000")
667	  ((== s "dark blue") "#000080")
668	  ((== s "dark yellow") "#808000")
669	  ((== s "dark magenta") "#800080")
670	  ((== s "dark cyan") "#008080")
671	  ((== s "dark orange") "#804000")
672	  ((== s "dark brown") "#401000")
673	  ((== s "broken white") "#ffffdf")
674	  ((== s "pastel red") "#ffdfdf")
675	  ((== s "pastel green") "#dfffdf")
676	  ((== s "pastel blue") "#dfdfff")
677	  ((== s "pastel yellow") "#ffffdf")
678	  ((== s "pastel magenta") "#ffdfff")
679	  ((== s "pastel cyan") "#dfffff")
680	  ((== s "pastel orange") "#ffdfbf")
681	  ((== s "pastel brown") "#dfbfbf")
682	  (else s))))
683
684;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
685;; Length conversions
686;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
687
688(define-table tmhtml-length-table
689  ("mm" . 0.1)
690  ("cm" . 1.0)
691  ("in" . 2.54)
692  ("pt" . 3.514598e-2)
693  ("tmpt" . 2.7457797e-5)
694  ("fn" . 0.4)
695  ("em" . 0.4)
696  ("ex" . 0.2)
697  ("spc" . 0.2)
698  ("pc" . 0.42175)
699  ("par" . 16)
700  ("pag" . 12)
701  ("px" . 0.025)
702  ("ln" . 0.025))
703
704(define (make-exact x)
705  (number->string (inexact->exact x)))
706
707(define (number->htmlstring x)
708  (number->string (if (exact? x)
709		      (if (integer? x) x (exact->inexact x))
710		      (if (and (integer? (inexact->exact x))
711			       (= x (exact->inexact (inexact->exact x))))
712			  (inexact->exact x) x))))
713
714(define (tmlength->htmllength len . css?)
715  (if (list>0? css?) (set! css? (car css?)) (set! css? #t))
716  (and-let* ((len-str (tmhtml-force-string len))
717	     (tmlen (string->tmlength len-str))
718	     (dummy2? (not (tmlength-null? tmlen)))
719	     (val (tmlength-value tmlen))
720	     (unit (symbol->string (tmlength-unit tmlen)))
721	     (incm (ahash-ref tmhtml-length-table unit))
722	     (cmpx (/ 1 (ahash-ref tmhtml-length-table "px"))))
723    (cond ((== unit "px") (number->htmlstring val))
724	  ((in? unit '("par" "pag"))
725	   (string-append (number->htmlstring (* 100 val)) "%"))
726	  ((and css? (== unit "tmpt"))
727	   (string-append (number->htmlstring (* cmpx val incm)) "px"))
728	  ((and css? (== unit "fn"))
729	   (string-append (number->htmlstring val) "em"))
730	  ((and css? (== unit "spc"))
731	   (string-append (number->htmlstring (/ val 2)) "em"))
732	  ((and css? (== unit "ln"))
733	   (string-append (number->htmlstring val) "px"))
734	  (css? len)
735	  (else (number->htmlstring (* cmpx val incm))))))
736
737(define (tmlength->px len)
738  (and-let* ((tmlen (string->tmlength len))
739	     (dummy? (not (tmlength-null? tmlen)))
740	     (val (tmlength-value tmlen))
741	     (unit (symbol->string (tmlength-unit tmlen)))
742	     (incm (ahash-ref tmhtml-length-table unit))
743	     (cmpx (/ 1 (ahash-ref tmhtml-length-table "px"))))
744    (* cmpx val incm)))
745
746;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
747;; Local environment changes
748;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
749
750(define (tmhtml-with-mode val arg)
751  (ahash-with tmhtml-env :math (== val "math")
752    (tmhtml (if (== val "prog") `(verbatim ,arg) arg))))
753
754(define (tmhtml-with-color val arg)
755  `((h:font (@ (color ,(tmcolor->htmlcolor val))) ,@(tmhtml arg))))
756
757(define (tmhtml-with-font-size val arg)
758  (ahash-with tmhtml-env :mag val
759    (let* ((x (* (string->number val) 100))
760	   (s (cond ((< x 1) "-4") ((< x 55) "-4") ((< x 65) "-3")
761		    ((< x 75) "-2") ((< x 95) "-1") ((< x 115) "0")
762		    ((< x 135) "+1") ((< x 155) "+2") ((< x 185) "+3")
763		    ((< x 225) "+4") ((< x 500) "+5") (else "+5"))))
764      (if s `((h:font (@ (size ,s)) ,@(tmhtml arg))) (tmhtml arg)))))
765
766(define (tmhtml-with-block style arg)
767  (with r (tmhtml (blockify arg))
768    (if (in? r '(() ("") ((h:p)) ((h:p "")))) '()
769	`((h:div (@ (style ,style)) ,@r)))))
770
771(define (tmhtml-with-par-left val arg)
772  (with x (tmlength->px val)
773    (if (not x) (tmhtml arg)
774	(with d (- x (ahash-ref tmhtml-env :left-margin))
775	  (with s (string-append "margin-left: " (number->htmlstring d) "px")
776	    (ahash-with tmhtml-env :left-margin x
777	      (tmhtml-with-block s arg)))))))
778
779(define (tmhtml-with-par-right val arg)
780  (with x (tmlength->px val)
781    (if (not x) (tmhtml arg)
782	(with d (- x (ahash-ref tmhtml-env :right-margin))
783	  (with s (string-append "margin-right: " (number->htmlstring d) "px")
784	    (ahash-with tmhtml-env :right-margin x
785	      (tmhtml-with-block s arg)))))))
786
787(define (tmhtml-with-par-first val arg)
788  (with x (tmlength->htmllength val #t)
789    (if (not x) (tmhtml arg)
790	(with s (string-append "text-indent: " x)
791	  (tmhtml-with-block s arg)))))
792
793(define (tmhtml-with-par-par-sep val arg)
794  (with x (tmlength->px val)
795    (if (and x (== (inexact->exact x) 0))
796	`((h:div (@ (class "compact-block")) ,@(tmhtml arg)))
797	(tmhtml arg))))
798
799(define (tmhtml-with-one var val arg)
800  (cond ((logic-ref tmhtml-with-cmd% (list var val)) =>
801	 (lambda (w) (list (append w (tmhtml arg)))))
802	((logic-ref tmhtml-with-cmd% (list var)) =>
803	 (lambda (x) (ahash-with tmhtml-env x val (tmhtml arg))))
804	((logic-ref tmhtml-with-cmd% var) =>
805	 (lambda (h) (h val arg)))
806	(else (tmhtml arg))))
807
808(define (tmhtml-force-string x)
809  (cond ((string? x) x)
810	((func? x 'quote 1) (tmhtml-force-string (cadr x)))
811	((func? x 'tmlen 1)
812	 (string-append (tmhtml-force-string (cadr x)) "tmpt"))
813	((func? x 'tmlen 3)
814	 (string-append (tmhtml-force-string (caddr x)) "tmpt"))
815	((func? x 'tuple)
816         (apply string-append (list-intersperse
817                                (map tmhtml-force-string (cdr x)) ";")))
818	;;(else (force-string x))))
819	(else (texmacs->code x "utf-8"))))
820
821(define (tmhtml-with l)
822  (cond ((null? l) '())
823	((null? (cdr l)) (tmhtml (car l)))
824	((null? (cddr l)) '())
825	((func? (cAr l) 'graphics) (tmhtml-png (cons 'with l)))
826	(else
827	 (let* ((var (tmhtml-force-string (car l)))
828		(val (tmhtml-force-string (cadr l)))
829		(next (cddr l)))
830	   (tmhtml-with-one var val `(with ,@next))))))
831
832;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
833;; Other macro-related primitives
834;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
835
836(define (tmhtml-compound l)
837  ;; Explicit expansions are converted and handled as implicit expansions.
838  (tmhtml-implicit-compound (cons (string->symbol (car l)) (cdr l))))
839
840(define (tmhtml-mark l)
841  ;; Explicit expansions are converted and handled as implicit expansions.
842  (tmhtml (cadr l)))
843
844;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
845;; Source code
846;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
847
848(define (blue sym)
849  `(h:font (@ (color "blue")) ,sym))
850
851(define (tmhtml-src-args l)
852  (if (null? l) l
853      `(,(blue "|")
854	,@(tmhtml (car l))
855	,@(tmhtml-src-args (cdr l)))))
856
857(define (tmhtml-inline-tag l)
858  `(,(blue "&lt;")
859    ,@(tmhtml (car l))
860    ,@(tmhtml-src-args (cdr l))
861    ,(blue "&gt;")))
862
863(define (tmhtml-open-tag l)
864  `(,(blue "&lt;\\")
865    ,@(tmhtml (car l))
866    ,@(tmhtml-src-args (cdr l))
867    ,(blue "|")))
868
869(define (tmhtml-middle-tag l)
870  `(,@(tmhtml-src-args (cdr l))
871    ,(blue "|")))
872
873(define (tmhtml-close-tag l)
874  `(,@(tmhtml-src-args (cdr l))
875    ,(blue "&gt;")))
876
877;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
878;; Other primitives
879;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
880
881(define (tmhtml-label l)
882  ;; WARNING: bad conversion if ID is not a string.
883  `((h:a (@ (id ,(cork->html (force-string (car l))))))))
884
885;(define (tmhtml-reference l)
886;  (list 'ref (cork->html (force-string (car l)))))
887
888;(define (tmhtml-pageref l)
889;  (list 'pageref (cork->html (force-string (car l)))))
890
891(define (tmhtml-suffix s)
892  ;; Change .tm suffix to .xhtml suffix for local files for correct
893  ;; conversion of entire web-sites. We might create an option
894  ;; in order to disable this suffix change
895  (let* ((sdir (string-rindex s #\/))
896	 (sep (string-rindex s #\#)))
897    (cond ((or (string-starts? s "http:") (string-starts? s "ftp:")) s)
898          ((and sep (or (not sdir) (< sdir sep)))
899	   (string-append (tmhtml-suffix (substring s 0 sep))
900			  (string-drop s sep)))
901	  ((string-ends? s ".tm")
902	   (string-append (string-drop-right s 3)
903			  (if tmhtml-mathml? ".xhtml" ".html")))
904	  ((string-ends? s ".texmacs")
905	   (string-append (string-drop-right s 8) ".tm"))
906	  (else s))))
907
908(define (tmhtml-hyperlink l)
909  ;; WARNING: bad conversion if URI is not a string.
910  ;; TODO: change label at start of content into ID attribute, move other
911  ;; labels out (A elements cannot be nested!).
912  (let* ((body (tmhtml (first l)))
913	 (to (cork->html (force-string (second l)))))
914    (if (string-starts? to "$")
915	body ;; temporary fix for URLs like $TEXMACS_PATH/...
916	`((h:a (@ (href ,(tmhtml-suffix to))) ,@body)))))
917
918(define (tmhtml-specific l)
919  (cond ((== (car l) "html") (list (tmstring->string (force-string (cadr l)))))
920	((== (car l) "html*") (tmhtml (cadr l)))
921	((== (car l) "image") (tmhtml-png (cadr l)))
922	(else '())))
923
924(define (tmhtml-action l)
925  `((h:u ,@(tmhtml (car l)))))
926
927;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
928;;; Tables
929;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
930
931(define (map* fun l)
932  (list-filter (map fun l) identity))
933
934(define (html-css-attrs l)
935  ;; l is a list of either key-value lists (XML) or strings (CSS)
936  ;; we return a list with the corresponding @-style attribute
937  (if (null? l) '()
938      (receive (css html) (list-partition l string?)
939	(if (nnull? css)
940	    (with style (apply string-append (list-intersperse css "; "))
941	      (set! html (cons `(style ,style) html))))
942	`((@ ,@html)))))
943
944(define (length-attr what x . opt)
945  (with len (tmlength->htmllength x #t)
946    (and len (apply string-append (cons* what ": " len opt)))))
947
948(define (border-attr what x)
949  (length-attr what x " solid"))
950
951(define (tmhtml-make-cell-attr x all)
952  (cond ((== (car x) "cell-width") (length-attr "width" (cadr x)))
953	((== (car x) "cell-height") (length-attr "height" (cadr x)))
954	((== x '("cell-halign" "l")) "text-align: left")
955	((== x '("cell-halign" "c")) "text-align: center")
956	((== x '("cell-halign" "r")) "text-align: right")
957	((== x '("cell-valign" "t")) "vertical-align: top")
958	((== x '("cell-valign" "c")) "vertical-align: middle")
959	((== x '("cell-valign" "b")) "vertical-align: bottom")
960	((== x '("cell-valign" "B")) "vertical-align: baseline")
961	((== (car x) "cell-background")
962	 `(bgcolor ,(tmcolor->htmlcolor (cadr x))))
963	((== (car x) "cell-lborder") (border-attr "border-left" (cadr x)))
964	((== (car x) "cell-rborder") (border-attr "border-right" (cadr x)))
965	((== (car x) "cell-tborder") (border-attr "border-top" (cadr x)))
966	((== (car x) "cell-bborder") (border-attr "border-bottom" (cadr x)))
967	((== (car x) "cell-lsep") (length-attr "padding-left" (cadr x)))
968	((== (car x) "cell-rsep") (length-attr "padding-right" (cadr x)))
969	((== (car x) "cell-tsep") (length-attr "padding-top" (cadr x)))
970	((== (car x) "cell-bsep") (length-attr "padding-bottom" (cadr x)))
971	((== (car x) "cell-bsep") (length-attr "padding-bottom" (cadr x)))
972	((== x '("cell-block" "no")) "white-space: nowrap")
973	((== x '("cell-block" "yes")) #f)
974	((== x '("cell-block" "auto"))
975         (if (or (in? '("cell-hyphen" "t") all)
976                 (in? '("cell-hyphen" "c") all)
977                 (in? '("cell-hyphen" "b") all))
978             #f
979             "white-space: nowrap"))
980	(else #f)))
981
982(define (tmhtml-make-cell c cellf)
983  (if (not (tm-func? c 'cell 1)) (set! c `(cell ,c)))
984  (ahash-with tmhtml-env :left-margin 0
985    (with make (lambda (attr) (tmhtml-make-cell-attr attr cellf))
986      `(h:td ,@(html-css-attrs (map* make cellf))
987             ,@(tmhtml (cadr c))))))
988
989(define (tmhtml-make-cells-bis l cellf)
990  (if (null? l) l
991      (cons (tmhtml-make-cell (car l) (car cellf))
992	    (tmhtml-make-cells-bis (cdr l) (cdr cellf)))))
993
994(define (tmhtml-width-part attrl)
995  (cond ((null? attrl) 0)
996	((== (caar attrl) "cell-hpart") (string->number (cadar attrl)))
997	(else (tmhtml-width-part (cdr attrl)))))
998
999(define (tmhtml-width-replace attrl sum)
1000  (with part (tmhtml-width-part attrl)
1001    (if (== part 0) attrl
1002	(with l (list-filter attrl (lambda (x) (!= (car x) "cell-width")))
1003	  (with w (number->htmlstring (/ part sum))
1004	    (cons (list "cell-width" (string-append w "par")) l))))))
1005
1006(define (tmhtml-make-cells l cellf)
1007  (let* ((partl (map tmhtml-width-part cellf))
1008	 (sum (apply + partl)))
1009    (if (!= sum 0) (set! cellf (map (cut tmhtml-width-replace <> sum) cellf)))
1010    (tmhtml-make-cells-bis l cellf)))
1011
1012(define (tmhtml-make-row-attr x)
1013  (tmhtml-make-cell-attr x))
1014
1015(define (tmhtml-make-row r rowf cellf)
1016  `(h:tr ,@(html-css-attrs (map* tmhtml-make-row-attr rowf))
1017	 ,@(tmhtml-make-cells (cdr r) cellf)))
1018
1019(define (tmhtml-make-rows l rowf cellf)
1020  (if (null? l) l
1021      (cons (tmhtml-make-row  (car l) (car rowf) (car cellf))
1022	    (tmhtml-make-rows (cdr l) (cdr rowf) (cdr cellf)))))
1023
1024(define (tmhtml-make-column-attr x)
1025  (tmhtml-make-cell-attr x))
1026
1027(define (tmhtml-make-col colf)
1028  `(h:col ,@(html-css-attrs (map* tmhtml-make-column-attr colf))))
1029
1030(define (tmhtml-make-column-group colf)
1031  (if (list-every null? colf) '()
1032      `((h:colgroup ,@(map tmhtml-make-col colf)))))
1033
1034(define (tmhtml-make-table-attr x)
1035  (cond ((== (car x) "table-width") (length-attr "width" (cadr x)))
1036	((== (car x) "table-height") (length-attr "height" (cadr x)))
1037	((== (car x) "table-lborder") (border-attr "border-left" (cadr x)))
1038	((== (car x) "table-rborder") (border-attr "border-right" (cadr x)))
1039	((== (car x) "table-tborder") (border-attr "border-top" (cadr x)))
1040	((== (car x) "table-bborder") (border-attr "border-bottom" (cadr x)))
1041	((== (car x) "table-lsep") (length-attr "padding-left" (cadr x)))
1042	((== (car x) "table-rsep") (length-attr "padding-right" (cadr x)))
1043	((== (car x) "table-tsep") (length-attr "padding-top" (cadr x)))
1044	((== (car x) "table-bsep") (length-attr "padding-bottom" (cadr x)))
1045	(else #f)))
1046
1047(define (tmhtml-make-table t tablef colf rowf cellf)
1048  (let* ((attrs (map* tmhtml-make-table-attr tablef))
1049	 (em (- (* (tmtable-rows t) 0.55)))
1050	 (va (string-append "vertical-align: " (number->htmlstring em) "em")))
1051    (if (not (list-find attrs (cut == <> "width: 100%")))
1052	(set! attrs (cons* "display: inline" va attrs)))
1053    `(h:table ,@(html-css-attrs attrs)
1054	      ,@(tmhtml-make-column-group colf)
1055	      (h:tbody ,@(tmhtml-make-rows (cdr t) rowf cellf)))))
1056
1057(define (tmhtml-table l)
1058  (list (tmhtml-make-table (cons 'table l) '() '() '() '())))
1059
1060(define (tmhtml-tformat l)
1061  (with t (tmtable-normalize (cons 'tformat l))
1062    (receive (tablef colf rowf cellf) (tmtable-properties* t)
1063      (list (tmhtml-make-table (cAr t) tablef colf rowf cellf)))))
1064
1065;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1066;;; Pictures
1067;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1068
1069(define (tmhtml-collect-labels x)
1070  (cond ((nlist? x) '())
1071	((and (func? x 'label 1) (string? (cadr x))) `((id ,(cadr x))))
1072	(else (append-map tmhtml-collect-labels (cdr x)))))
1073
1074(define (tmhtml-image-names ext)
1075  (set! tmhtml-image-serial (+ tmhtml-image-serial 1))
1076  (let* ((postfix (string-append
1077		   "-" (number->string tmhtml-image-serial) "." ext))
1078	 (name-url (url-glue tmhtml-image-root-url postfix))
1079	 (name-string (string-append tmhtml-image-root-string postfix)))
1080    (values name-url name-string)))
1081
1082(define (tmhtml-png y)
1083  (let* ((mag (ahash-ref tmhtml-env :mag))
1084	 (x (if (or (nstring? mag) (== mag "1")) y
1085		`(with "font-size" ,mag ,y)))
1086	 (l1 (tmhtml-collect-labels y))
1087	 (l2 (if (null? l1) l1 (list (car l1)))))
1088    (with cached (ahash-ref tmhtml-image-cache x)
1089      (if (not cached)
1090	  (receive (name-url name-string) (tmhtml-image-names "png")
1091	    ;;(display* x " -> " name-url ", " name-string "\n")
1092	    (let* ((extents (print-snippet name-url x))
1093		   ;;(pixels (inexact->exact (/ (second extents) 2100)))
1094		   (pixels (inexact->exact (/ (second extents) 2000)))
1095		   (valign (number->htmlstring pixels))
1096		   (style (string-append "vertical-align: " valign "px")))
1097	      ;;(display* x " -> " extents "\n")
1098	      (set! cached
1099		    `((h:img (@ (src ,name-string) (style ,style) ,@l2))))
1100	      (ahash-set! tmhtml-image-cache x cached)))
1101	  cached))))
1102
1103(define (tmhtml-graphics l)
1104  (tmhtml-png (cons 'graphics l)))
1105
1106(define (tmhtml-image-name name)
1107  ;; FIXME: we should replace ~, environment variables, etc.
1108  (with u (url-relative current-save-target (unix->url name))
1109    (if (and (or (string-ends? name ".ps")
1110                 (string-ends? name ".eps")
1111                 (string-ends? name ".pdf"))
1112	     (url-exists? u))
1113	(receive (name-url name-string) (tmhtml-image-names "png")
1114	  (system-2 "convert" u name-url)
1115	  name-string)
1116	name)))
1117
1118(define (tmhtml-image l)
1119  ;; FIXME: Should also test that width and height are not magnifications.
1120  ;; Currently, magnifications make tmlength->htmllength return #f.
1121  (cond ((and (func? (car l) 'tuple 2)
1122              (func? (cadar l) 'raw-data 1)
1123              (string? (cadr (cadar l)))
1124              (string? (caddar l))
1125              (not (in? (caddar l) '("ps" "eps" "pdf"))))
1126	  (receive (name-url name-string) (tmhtml-image-names (caddar l))
1127            (string-save (cadr (cadar l)) name-url)
1128            (tmhtml-image (cons name-string (cdr l)))))
1129        ((nstring? (first l))
1130         (tmhtml-png (cons 'image l)))
1131        (else
1132          (let* ((s (tmhtml-image-name (cork->html (first l))))
1133                 (w (tmlength->htmllength (second l) #f))
1134                 (h (tmlength->htmllength (third l) #f)))
1135            `((h:img (@ (src ,s)
1136                        ,@(if w `((width ,w)) '())
1137                        ,@(if h `((height ,h)) '()))))))))
1138
1139(define (tmhtml-ornament-get-env-style)
1140  (let* ((l0 (hash-map->list list tmhtml-env))
1141         (l1 (filter (lambda (x)
1142                       (and (list>0? (car x))
1143                            (cadr x)
1144                            (string-prefix? "#:ornament-"
1145                                            (object->string (caar x))))) l0))
1146         (l2   (map car l1))
1147         (args (map cadr l1))
1148         (funs (map cAr l2))
1149         (stys (map (lambda (x) (cdr (cDr x))) l2)))
1150    (apply
1151      string-append
1152      (list-intersperse
1153        (map (lambda (f arg sty)
1154               (with args (string-tokenize-by-char arg #\;)
1155                 (apply
1156                   string-append
1157                   (list-intersperse
1158                     (cond ((== (length args) (length sty))
1159                            (map (lambda (x y)
1160                                   (string-append x ":" (f y))) sty args))
1161                           ((>= 1 (length sty))
1162                            (map (lambda (y)
1163                                   (string-append (car sty) ":" (f y))) args))
1164                           (else '()))
1165                     ";"))))
1166             funs args stys) ";"))))
1167
1168(define (contains-surround? l)
1169  (cond ((nlist? l) #f)
1170        ((func? l 'surround 3) #t)
1171        (else (with r #f
1172                (for-each (lambda (x)
1173                            (set! r (or r (contains-surround? x)))) l)
1174                r))))
1175
1176(define (tmhtml-ornament l)
1177  (let* ((body (tmhtml (car l)))
1178         (styl (tmhtml-ornament-get-env-style))
1179         (styl (if (contains-surround? l)
1180                 (string-append styl ";display:block;") styl))
1181         (args (if (== styl "") '() `((style ,styl))))
1182         (tag  (if (stm-block-structure? (car l)) 'h:div 'h:span)))
1183    `((,tag (@ (class "ornament") ,@args) ,@body))))
1184
1185(define (tmhtml-balloon l)
1186  (let* ((anch (tmhtml (car  l)))
1187         (body (tmhtml (cadr l)))
1188         (tag1 (if (stm-block-structure? (car  l)) 'h:div 'h:span))
1189         (tag2 (if (stm-block-structure? (cadr l)) 'h:div 'h:span)))
1190    `((,tag1 (@ (class "balloon-anchor")) ,@anch
1191             (,tag2 (@ (class "balloon-body") (hidden "hidden")) ,@body)))))
1192
1193;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1194;;; Standard markup
1195;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1196
1197(define (transform-item-post l)
1198  (if (not (tm-is? (car l) '!item))
1199      `(document ,@l)
1200      `(!item ,(cadar l) (document ,(caddar l) ,@(cdr l)))))
1201
1202(define (transform-items x)
1203  (cond ((and (tm-is? x 'concat)
1204              (nnull? (cdr x))
1205              (tm-in? (cadr x) '(item item*)))
1206         `(!item ,(cadr x) (concat ,@(cddr x))))
1207        ((tm-is? x 'document)
1208         (let* ((r  (map transform-items (cdr x)))
1209                (p? (lambda (i) (tm-is? i '!item)))
1210                (sr (list-scatter r p? #t))
1211                (fr (list-filter sr nnull?)))
1212           `(document ,@(map transform-item-post fr))))
1213        (else x)))
1214
1215;; TODO: when the first data of the list is a label, it must be used to set the
1216;; ID attribute of the resulting xhtml element. When that is done, remove the
1217;; warning comment from htmltm-handler.
1218
1219(define (tmhtml-post-item args)
1220  (let* ((i (car args))
1221         (r (tmhtml (cadr args))))
1222    (if (or (tm-is? i 'item) (null? (cdr i)))
1223        `((h:li ,@r))
1224        `((h:dt ,@(tmhtml (cadr i)))
1225          (h:dd ,@r)))))
1226
1227(define (tmhtml-itemize args)
1228  `((h:ul ,@(tmhtml (transform-items (car args))))))
1229
1230(define (tmhtml-enumerate args)
1231  `((h:ol ,@(tmhtml (transform-items (car args))))))
1232
1233(define (tmhtml-description args)
1234  `((h:dl ,@(tmhtml (transform-items (car args))))))
1235
1236;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1237;; Verbatim
1238;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1239
1240(define (tmhtml-verbatim args)
1241  ;; Block-level verbatim environments should only contain inline elements.
1242  ;;
1243  ;; @args should be a single element list, we will call this element @body.
1244  ;;
1245  ;; If @body is a block structure, it will be either:
1246  ;; -- a simple DOCUMENT (normal case), and @(tmhtml body) will produce a list
1247  ;;    of h:p elements;
1248  ;; -- a block structure producing a single element (degenerate case).
1249  ;;
1250  ;; Verbatim structures which do not contain a DOCUMENT but are direct
1251  ;; children of a DOCUMENT (i.e. they occupy a whole paragraph) are degenerate
1252  ;; cases of block-level verbatim and must be exported as PRE.
1253  ;;
1254  ;; Inline verbatim has little special significance for display in TeXmacs. In
1255  ;; LaTeX it is used to escape special characters (and protect multiple inline
1256  ;; spaces, yuck!), but in TeXmacs there is no such problem.
1257  (with body (first args)
1258    (if (stm-block-structure? body)
1259	(verbatim-pre
1260	 (ahash-with tmhtml-env :preformatted #t
1261		     (tmhtml body)))
1262	(verbatim-tt (tmhtml body)))))
1263
1264(define (verbatim-tt content)
1265  `((h:tt (@ (class "verbatim")) ,@content)))
1266
1267(define (verbatim-pre content)
1268  `((h:pre (@ (class "verbatim") (xml:space "preserve")) ,@content)))
1269
1270;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1271;; Additional tags
1272;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1273
1274(define (tmhtml-doc-title-block l)
1275  `((h:table (@ (class "title-block"))
1276	     (h:tr (h:td ,@(tmhtml (car l)))))))
1277
1278(define (tmhtml-equation* l)
1279  (with first (simplify-document (car l))
1280    (with x `(with "mode" "math" (with "math-display" "true" ,first))
1281      `((h:center ,@(tmhtml x))))))
1282
1283(define (tmhtml-equation-lab l)
1284  (with first (simplify-document (car l))
1285    (with x `(with "mode" "math" (with "math-display" "true" ,first))
1286      `((h:table (@ (width "100%"))
1287		 (h:tr (h:td (@ (align "center") (width "100%"))
1288			     ,@(tmhtml x))
1289		       (h:td (@ (align "right"))
1290			     "(" ,@(tmhtml (cadr l)) ")")))))))
1291
1292;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1293;; Tags for customized html generation
1294;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1295
1296(define (tmhtml-html-div l)
1297  (list `(h:div (@ (class ,(tmhtml-force-string (car l))))
1298		,@(tmhtml (cadr l)))))
1299
1300(define (tmhtml-html-style l)
1301  (list `(h:div (@ (style ,(tmhtml-force-string (car l))))
1302		,@(tmhtml (cadr l)))))
1303
1304(define (tmhtml-html-javascript l)
1305  (list `(h:script (@ (language "javascript"))
1306		   ,(tmhtml-force-string (car l)))))
1307
1308(define (tmhtml-html-javascript-src l)
1309  (list `(h:script (@ (language "javascript")
1310		      (src ,(tmhtml-force-string (car l)))))))
1311
1312(define (tmhtml-html-video l)
1313  (let* ((dest (cork->html (force-string (car l))))
1314         (mp4 (string-append dest ".mp4"))
1315         (ogg (string-append dest ".ogg"))
1316         (webm (string-append dest ".webm"))
1317         (swf (string-append dest ".swf"))
1318         (width (force-string (cadr l)))
1319         (height (force-string (caddr l))))
1320    (list `(h:video (@ (width ,width) (height ,height) (controls "controls"))
1321             (h:source (@ (src ,mp4) (type "video/mp4")))
1322             (h:source (@ (src ,ogg) (type "video/ogg")))
1323             (h:source (@ (src ,webm) (type "video/webm")))
1324             (h:object (@ (data ,mp4) (width ,width) (height ,height))
1325               (h:embed (@ (src ,swf) (width ,width) (height ,height))))))))
1326
1327;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1328;; Tmdoc tags
1329;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1330
1331(define (tmhtml-make-block content)
1332  (let* ((l '(h:td
1333	      (@ (align "left"))
1334	      (h:img (@ (src "http://www.texmacs.org/Images/tm_gnu1b.png")))))
1335	 (c `(h:td
1336	      (@ (align "center") (width "100%"))
1337	      ,@(tmhtml content)))
1338	 (r '(h:td
1339	      (@ (align "right"))
1340	      (h:img (@ (src "http://www.texmacs.org/Images/tm_gnu2b.png")))))
1341	 (row `(h:tr ,l ,c ,r)))
1342    `(h:table (@ (width "100%") (cellspacing "0") (cellpadding "3")) ,row)))
1343
1344(define (tmhtml-tmdoc-title l)
1345  (list `(h:div (@ (class "tmdoc-title-1"))
1346		,(tmhtml-make-block (car l)))))
1347
1348(define (tmhtml-tmdoc-title* l)
1349  (list `(h:div (@ (class "tmdoc-title-2"))
1350		,(tmhtml-make-block (car l)))
1351	`(h:div (@ (class "tmdoc-navbar")) ,@(tmhtml (cadr l)))))
1352
1353(define (tmhtml-tmdoc-title** l)
1354  (list `(h:div (@ (class "tmdoc-navbar")) ,@(tmhtml (car l)))
1355	`(h:div (@ (class "tmdoc-title-3")) ,(tmhtml-make-block (cadr l)))
1356	`(h:div (@ (class "tmdoc-navbar")) ,@(tmhtml (caddr l)))))
1357
1358(define (tmhtml-tmdoc-flag l)
1359  ;(tmhtml (car l)))
1360  (list `(h:div (@ (class "tmdoc-flag")) ,@(tmhtml (car l)))))
1361
1362(define (tmhtml-tmdoc-copyright* l)
1363  (if (null? l) l
1364      `(", " ,@(tmhtml (car l)) ,@(tmhtml-tmdoc-copyright* (cdr l)))))
1365
1366(define (tmhtml-tmdoc-copyright l)
1367  (with content
1368      `("&copy;" " " ,@(tmhtml (car l))
1369	" " ,@(tmhtml (cadr l))
1370	,@(tmhtml-tmdoc-copyright* (cddr l)))
1371    (list `(h:div (@ (class "tmdoc-copyright")) ,@content))))
1372
1373(define (tmhtml-tmdoc-license l)
1374  (list `(h:div (@ (class "tmdoc-license")) ,@(tmhtml (car l)))))
1375
1376(define (tmhtml-key l)
1377  ;; `((h:u (h:tt ,@(tmhtml (tm->stree (tmdoc-key (car l))))))))
1378  `((h:u (h:tt ,@(tmhtml (car l))))))
1379
1380(define (tmhtml-tmdoc-bar? y)
1381  (or (func? y 'h:h1)
1382      (func? y 'h:h2)
1383      (and (func? y 'h:div)
1384	   (nnull? (cdr y))
1385	   (func? (cadr y) '@ 1)
1386	   (== (first (cadadr y)) 'class)
1387	   (string-starts? (second (cadadr y)) "tmdoc"))))
1388
1389(define (tmhtml-tmdoc-post-sub x)
1390  ;; FIXME: these rewritings are quite hacky;
1391  ;; better simplification would be nice...
1392  (cond ((and (func? x 'h:p) (list-find (cdr x) tmhtml-tmdoc-bar?)) (cdr x))
1393	((func? x 'h:p)
1394	 (with r (append-map tmhtml-tmdoc-post-sub (cdr x))
1395	   (if (== (cdr x) r) (list x) r)))
1396	(else (list x))))
1397
1398(define (tmhtml-tmdoc-post body)
1399  (with r (append-map tmhtml-tmdoc-post-sub body)
1400    `((h:div (@ (class "tmdoc-body")) ,@r))))
1401
1402;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1403;; Main conversion routines
1404;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1405
1406(define (tmhtml-list l)
1407  (append-map tmhtml l))
1408
1409(define (tmhtml-dispatch htable l)
1410  (let ((x (logic-ref ,htable (car l))))
1411    (cond ((not x) #f)
1412	  ((procedure? x) (x (cdr l)))
1413	  (else (tmhtml-post-simplify-element
1414		 (append x (tmhtml-list (cdr l))))))))
1415
1416(define (tmhtml-implicit-compound l)
1417  (or (tmhtml-dispatch 'tmhtml-stdmarkup% l)
1418      '()))
1419
1420(tm-define (tmhtml-root x)
1421  (ahash-with tmhtml-env :mag "1"
1422    (ahash-with tmhtml-env :math #f
1423      (ahash-with tmhtml-env :preformatted #f
1424	(ahash-with tmhtml-env :left-margin 0
1425	  (ahash-with tmhtml-env :right-margin 0
1426	    (tmhtml x)))))))
1427
1428(define (tmhtml x)
1429  ;; Main conversion function.
1430  ;; Takes a TeXmacs tree in Scheme notation and produce a SXML node-set.
1431  ;; All handler functions have a similar prototype.
1432  (cond ((and tmhtml-mathml? (ahash-ref tmhtml-env :math))
1433	 `((m:math (@ (xmlns "http://www.w3.org/1998/Math/MathML"))
1434		   ,(texmacs->mathml x tmhtml-env))))
1435	((and tmhtml-images? (ahash-ref tmhtml-env :math))
1436	 (tmhtml-png `(with "mode" "math" ,x)))
1437	((string? x)
1438	 (if (string-null? x) '() (tmhtml-text x))) ; non-verbatim string nodes
1439	(else (or (tmhtml-dispatch 'tmhtml-primitives% x)
1440		  (tmhtml-implicit-compound x)))))
1441
1442;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1443;; Dispatching
1444;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1445
1446(logic-dispatcher tmhtml-primitives%
1447  (document tmhtml-document)
1448  (para tmhtml-paragraph)
1449  (surround tmhtml-surround)
1450  (concat tmhtml-concat)
1451  (rigid tmhtml-id)
1452  (format tmhtml-noop)
1453  (hspace tmhtml-hspace)
1454  (vspace* tmhtml-vspace)
1455  (vspace tmhtml-vspace)
1456  (space tmhtml-hspace)
1457  (htab tmhtml-hspace)
1458  (split tmhtml-noop)
1459  (move tmhtml-move)
1460  (resize tmhtml-resize)
1461  (float tmhtml-float)
1462  (repeat tmhtml-repeat)
1463  (datoms tmhtml-datoms)
1464  (dlines tmhtml-datoms)
1465  (dpages tmhtml-datoms)
1466  (dbox tmhtml-datoms)
1467  (locus tmhtml-datoms)
1468
1469  (with-limits tmhtml-noop)
1470  (line-break tmhtml-noop)
1471  (new-line tmhtml-new-line)
1472  (line-sep tmhtml-noop)
1473  (next-line tmhtml-next-line)
1474  (no_break tmhtml-noop)
1475  (no-indent tmhtml-noop)
1476  (yes-indent tmhtml-noop)
1477  (no-indent* tmhtml-noop)
1478  (yes-indent* tmhtml-noop)
1479  (page-break* tmhtml-noop)
1480  (page-break tmhtml-noop)
1481  (no-page-break* tmhtml-noop)
1482  (no-page-break tmhtml-noop)
1483  (new-page* tmhtml-noop)
1484  (new-page tmhtml-noop)
1485  (new-dpage* tmhtml-noop)
1486  (new-dpage tmhtml-noop)
1487
1488  ((:or around around* big-around) tmhtml-concat)
1489  (left tmhtml-id)
1490  (mid tmhtml-id)
1491  (right tmhtml-id)
1492  (big tmhtml-big)
1493  (lprime tmhtml-id)
1494  (rprime tmhtml-id)
1495  (below tmhtml-below)
1496  (above tmhtml-above)
1497  (lsub tmhtml-sub)
1498  (lsup tmhtml-sup)
1499  (rsub tmhtml-sub)
1500  (rsup tmhtml-sup)
1501  (rsubsup tmhtml-subsup)
1502  (frac tmhtml-frac)
1503  (sqrt tmhtml-sqrt)
1504  (wide tmhtml-wide)
1505  (neg tmhtml-neg)
1506  ((:or tree old-matrix old-table old-mosaic old-mosaic-item)
1507   tmhtml-noop)
1508  (table tmhtml-table)
1509  (tformat tmhtml-tformat)
1510  ((:or twith cwith tmarker row cell sub-table) tmhtml-noop)
1511
1512  (assign tmhtml-noop)
1513  (with tmhtml-with)
1514  (provides tmhtml-noop)
1515  ((:or value quote-value) tmhtml-compound)
1516  ((:or macro drd-props arg quote-arg) tmhtml-noop)
1517  (compound tmhtml-compound)
1518  ((:or xmacro get-label get-arity map-args eval-args) tmhtml-noop)
1519  (mark tmhtml-mark)
1520  (eval tmhtml-noop)
1521  ((:or if if* case while for-each extern include use-package) tmhtml-noop)
1522
1523  ((:or or xor and not plus minus times over div mod merge length range
1524	number date translate is-tuple look-up equal unequal less lesseq
1525	greater greatereq if case while extern authorize)
1526   tmhtml-noop)
1527
1528  ((:or style-with style-with* style-only style-only*
1529	active active* inactive inactive* rewrite-inactive) tmhtml-noop)
1530  (inline-tag tmhtml-inline-tag)
1531  (open-tag tmhtml-open-tag)
1532  (middle-tag tmhtml-middle-tag)
1533  (close-tag tmhtml-close-tag)
1534  (symbol tmhtml-noop)
1535  (latex tmhtml-noop)
1536  (hybrid tmhtml-noop)
1537
1538  ((:or tuple collection associate) tmhtml-noop)
1539  (label tmhtml-label)
1540  (reference tmhtml-noop)
1541  (pageref tmhtml-noop)
1542  (write tmhtml-noop)
1543  (specific tmhtml-specific)
1544  (hlink tmhtml-hyperlink)
1545  (action tmhtml-action)
1546  ((:or tag meaning) tmhtml-noop)
1547  ((:or switch fold exclusive progressive superposed) tmhtml-noop)
1548  (graphics tmhtml-graphics)
1549  ((:or point line arc bezier) tmhtml-noop)
1550  (image tmhtml-image)
1551  (ornament tmhtml-ornament)
1552  ((:or mouse-over-balloon mouse-over-balloon*) tmhtml-balloon)
1553
1554  (!file tmhtml-file))
1555
1556(logic-table tmhtml-stdmarkup%
1557  ;; special auxiliary tags
1558  (!left ,tmhtml-align-left)
1559  (!middle ,tmhtml-align-middle)
1560  (!right ,tmhtml-align-right)
1561  ;; Sectioning
1562  (chapter-title (h:h1))
1563  (section-title (h:h2))
1564  (subsection-title (h:h3))
1565  (subsubsection-title (h:h4))
1566  (paragraph-title (h:h5))
1567  (subparagraph-title (h:h6))
1568  ;; Lists
1569  ((:or itemize itemize-minus itemize-dot itemize-arrow)
1570   ,tmhtml-itemize)
1571  ((:or enumerate enumerate-numeric enumerate-roman enumerate-Roman
1572	enumerate-alpha enumerate-Alpha)
1573   ,tmhtml-enumerate)
1574  ((:or description description-compact description-dash
1575	description-align description-long)
1576   ,tmhtml-description)
1577  (item* (h:dt))
1578  (!item ,tmhtml-post-item)
1579  ;; Phrase elements
1580  (strong (h:strong))
1581  (em (h:em))
1582  (dfn (h:dfn))
1583  (code* (h:code))
1584  (samp (h:samp)) ; WARNING: semantic documentation does not match HTML4
1585  (kbd (h:kbd))
1586  (var (h:var))
1587  (abbr (h:abbr))
1588  (acronym (h:acronym))
1589  (verbatim ,tmhtml-verbatim)
1590  (code ,tmhtml-verbatim)
1591  (nbsp ,(lambda x '("&nbsp;")))
1592  ;; Presentation
1593  (tt (h:tt))
1594  (hrule (h:hr))
1595  ;; Names
1596  (TeXmacs ,(lambda x '("TeXmacs")))
1597  (TeX ,(lambda x '("TeX")))
1598  (LaTeX ,(lambda x '("LaTeX")))
1599  ;; additional tags
1600  (hidden-title ,tmhtml-noop)
1601  (doc-title-block ,tmhtml-doc-title-block)
1602  (equation* ,tmhtml-equation*)
1603  (equation-lab ,tmhtml-equation-lab)
1604  (equations-base ,tmhtml-equation*)
1605  ;; tags for customized html generation
1606  (html-div ,tmhtml-html-div)
1607  (html-style ,tmhtml-html-style)
1608  (html-javascript ,tmhtml-html-javascript)
1609  (html-javascript-src ,tmhtml-html-javascript-src)
1610  (html-video ,tmhtml-html-video)
1611  ;; tmdoc tags
1612  (tmdoc-title ,tmhtml-tmdoc-title)
1613  (tmdoc-title* ,tmhtml-tmdoc-title*)
1614  (tmdoc-title** ,tmhtml-tmdoc-title**)
1615  (tmdoc-flag ,tmhtml-tmdoc-flag)
1616  (tmdoc-copyright ,tmhtml-tmdoc-copyright)
1617  (tmdoc-license ,tmhtml-tmdoc-license)
1618  (key ,tmhtml-key)
1619  (hyper-link ,tmhtml-hyperlink))
1620
1621;;    (name (h:name)) ; not in HTML4
1622;;    (person (h:person)))) ; not in HTML4
1623
1624(logic-table tmhtml-with-cmd%
1625  ("mode" ,tmhtml-with-mode)
1626  ("color" ,tmhtml-with-color)
1627  ("font-size" ,tmhtml-with-font-size)
1628  ("par-left" ,tmhtml-with-par-left)
1629  ("par-right" ,tmhtml-with-par-right)
1630  ("par-first" ,tmhtml-with-par-first)
1631  ("par-par-sep" ,tmhtml-with-par-par-sep)
1632  (("ornament-hpadding")      (:ornament-hpadding
1633                                "padding-left" "padding-right"
1634                                ,tmlength->htmllength))
1635  (("ornament-vpadding")      (:ornament-vpadding
1636                                "padding-top"  "padding-bottom"
1637                                ,tmlength->htmllength))
1638  (("ornament-border")        (:ornament-border
1639                                "border-width"     ,tmlength->htmllength))
1640  (("ornament-shape")         (:ornament-shape
1641                                "border-radius"    ,tmshape->htmllength))
1642  (("ornament-color")         (:ornament-color
1643                                "background-color" ,tmcolor->htmlcolor))
1644  (("ornament-shadow-color")  (:ornament-shadow-color
1645                                "border-bottom-color" "border-right-color"
1646                                ,tmcolor->htmlcolor))
1647  (("ornament-sunny-color")   (:ornament-sunny-color
1648                                "border-left-color" "border-top-color"
1649                                ,tmcolor->htmlcolor))
1650  ;;(("ornament-extra-color")   :ornament-extra-color ""  ,tmcolor->htmlcolor))
1651  ;;(("ornament-swell")        :ornament-swell "" ,identity))
1652  ;;(("ornament-title-style")   :ornament-title-style "" ,identity))
1653  (("font-family" "tt") (h:tt))
1654  (("font-family" "ss") (h:class (@ (style "font-family: sans-serif"))))
1655  (("font-series" "bold") (h:b))
1656  (("font-shape" "italic") (h:i))
1657  (("font" "roman") (h:class (@ (style "font-family: Times New Roman"))))
1658  (("font" "times") (h:class (@ (style "font-family: Times New Roman"))))
1659  (("font" "helvetica") (h:class (@ (style "font-family: Helvetica"))))
1660  (("font" "courier") (h:class (@ (style "font-family: Coutier"))))
1661  (("math-font" "cal") (h:class (@ (style "font-family: Flemish Script"))))
1662  (("math-font" "frak") (h:class (@ (style "font-family: Bernhard Modern"))))
1663  (("font-series" "medium") (h:class (@ (style "font-weight: normal"))))
1664  (("font-shape" "right") (h:class (@ (style "font-style: normal"))))
1665  (("font-shape" "small-caps")
1666   (h:class (@ (style "font-variant: small-caps")))))
1667
1668(logic-table tmhtml-with-cmd% ; deprecated
1669  (("par-mode" "left") (h:div (@ (align "left"))))
1670  (("par-mode" "justify") (h:div (@ (align "justify"))))
1671  (("par-mode" "center") (h:center)))
1672
1673(logic-table tmhtml-with-cmd% ; netscape4
1674  (("par-columns" "1") (h:multicol (@ (cols "1"))))
1675  (("par-columns" "2") (h:multicol (@ (cols "2"))))
1676  (("par-columns" "3") (h:multicol (@ (cols "3"))))
1677  (("par-columns" "4") (h:multicol (@ (cols "4"))))
1678  (("par-columns" "5") (h:multicol (@ (cols "5")))))
1679
1680;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1681;; Interface
1682;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1683
1684(tm-define (texmacs->html x opts)
1685  (if (tmfile? x)
1686      (let* ((body (tmfile-extract x 'body))
1687	     (style* (tmfile-extract x 'style))
1688	     (style (if (list? style*) style* (list style*)))
1689	     (lan (tmfile-language x))
1690	     (doc (list '!file body style lan
1691                        (url->string (get-texmacs-path)))))
1692	(texmacs->html doc opts))
1693      (begin
1694	(tmhtml-initialize opts)
1695	((if (func? x '!file)
1696	     tmhtml-finalize-document
1697	     tmhtml-finalize-selection)
1698	 (tmhtml-root x)))))
1699