1;;;; -*-Scheme-*-
2;;;;
3;;;; $Revision: 1.20 $
4;;;;
5;;;; Common definitions for HTML output format
6
7
8;;; --------------------------------------------------------------------------
9;;; Configurable, site-specific definitions.
10
11(define-option 'troff-to-gif  'string
12  "psroff -me -t | sed -e 's/showpage//g' > %1%; pstogif %1% -density 100")
13
14;;; (define-option 'troff-to-text 'string
15;;;    "groff -Tlatin1 -P-b -P-u |sed '/^[ \t]*$/d' > %1%")
16(define-option 'troff-to-text 'string
17   "neqn | nroff | col -b | sed '/^[ \t]*$/d' > %1%")
18
19(define-option 'troff-to-pic
20		 'string "pictogif %1% -ps %2%")
21
22(define-option 'tbl 'string 'tbl)
23(define-option 'eqn 'string 'eqn)
24(define-option 'pic 'string 'pic)
25
26
27;; A non-breaking space that is really non-breaking even in broken browsers:
28
29(define nbsp "&#160;<tt> </tt>")
30
31
32
33;;; --------------------------------------------------------------------------
34;;; Options.
35
36
37(define-option 'title         'string  #f)    ; May be used for <title>
38(define-option 'mail-address  'string  #f)    ; May be used for `mailto:'
39(define-option 'document      'string  #f)    ; Prefix for output file(s)
40(define-option 'tt-preformat  'boolean #f)    ; do <tt>-changes inside .nf/.fi
41
42(define-option 'handle-eqn    'string "gif")  ; gif/text/copy
43(define-option 'handle-tbl    'string "text") ;
44(define-option 'handle-pic    'string "pic")  ;
45
46
47
48;;; --------------------------------------------------------------------------
49;;; Preformatted text.
50
51;;; This is used in various contexts:
52;;; 1. eqn text that is generated by running through neqn (see troff-to-text
53;;;    and troff-to-preformat)
54;;; 2. .nf/.fi pair
55
56;;; .nf/.fi text is suffixed with <br> at the end of each line.
57;;; Might prefer using <pre> </pre> if: 1) the tt-preformat option is asserted;
58;;; or 2) a constant pitch font is selected (via the .cs x y; turned off
59;;; by .cs x).
60
61(define preform? #f)
62
63(define (preform on? . pre?)
64  (set! pre? (if (null? pre?) #f (car pre?)))
65  (cond ((and on? (not preform?))
66          (defsentence #f)
67          (with-font-preserved
68	    (begin
69	      (set! preform? #t)
70	      (if pre?
71		"<pre>"
72		 (begin (defevent 'line 45 nofill-processor) "")))))
73        ((and (not on?) preform?)
74          (defsentence sentence-event)
75          (with-font-preserved
76	    (begin
77	      (set! preform? #f)
78	      (if (eventdef 'line 45)
79		(begin (defevent 'line 45 #f) "")
80		"</pre>\n"))))
81        (else "")))
82
83(defrequest 'nf (lambda _ (preform #t)))
84(defrequest 'fi (lambda _ (preform #f)))
85
86(define-macro (with-preform-preserved . body)
87  `(let (($p preform?))
88     (concat (preform #f) ,@body (preform $p))))
89
90(defchar #\tab
91  (lambda (c)
92    (if (not preform?) (surprise "tab outside .nf/.fi")) c))
93
94(define (nofill-processor c)
95  (if (eqv? c #\newline)
96      (emit "<br>\n")))
97
98
99;;; --------------------------------------------------------------------------
100;;; Silently ignoring these requests probably will not harm.  There is
101;;; nothing sensible we can do.
102
103(defrequest 'ne "")
104(defrequest 'hw "")
105(defrequest 'nh "")
106(defrequest 'hy "")
107(defrequest 'lg "")
108(defrequest 'ps "")
109(defrequest 'vs "")
110(defrequest 'pl "")
111(defrequest 'bp "<br>\n")
112(defrequest 'ns "")
113(defrequest 'rs "")
114(defrequest 'wh "")
115(defrequest 'ch "")
116(defrequest 'fl "")
117(defrequest 'na "")
118(defrequest 'ad "")
119
120
121
122;;; --------------------------------------------------------------------------
123;;; Basic escape sequences and special characters.
124
125(defescape #\c "")    ; swallows its character argument
126(defescape #\& "")
127(defescape #\- #\-)
128(defescape #\| "")
129(defescape #\^ "")
130(defescape #\space #\space)    ; should be &#160; (doesn't work in Mosaic)
131(defescape #\0 #\space)
132(defescape #\s "")
133(defescape #\e #\\)
134(defescape #\\ #\\)
135(defescape #\' #\')
136(defescape #\` #\`)
137(defescape #\p "<br>")     ; just break - can't spread like troff
138(defescape #\% "")
139
140(defescape ""
141  (lambda (c . _)
142    (warn "escape sequence `\\~a' expands to `~a'" c c)
143    (translate c)))
144
145(defspecial 'em "--")
146(defspecial 'en #\-)
147(defspecial 'mi #\-)
148(defspecial 'pl #\+)        ; plus
149(defspecial 'lq "``")
150(defspecial 'rq "''")
151(defspecial '** #\*)
152(defspecial 'bv #\|)        ; bold vertical (what is this?)
153(defspecial 'hy "&#173;")   ; `soft hyphen'
154(defspecial 'co "&#169;")   ; copyright
155(defspecial 'ap #\~)        ; approximates
156(defspecial '~= #\~)
157(defspecial 'cd "&#183;")   ; centered dot
158(defspecial 'de "&#176;")   ; degree
159(defspecial '>= "&gt;=")
160(defspecial '<= "&lt;=")
161(defspecial 'eq #\=)
162(defspecial '== "==")
163(defspecial 'mu "&#215;")   ; multiplication
164(defspecial 'tm "&#174;")
165(defspecial 'rg "&#174;")
166(defspecial 'aa #\')        ; acute accent
167(defspecial 'ga #\`)        ; grave accent
168(defspecial 'br #\|)        ; vertical box rule
169(defspecial 'or #\|)
170(defspecial 'sl #\/)
171(defspecial 'ru #\_)
172(defspecial 'ul #\_)
173(defspecial 'ci #\O)
174(defspecial "14" "&#188;")
175(defspecial "12" "&#189;")
176(defspecial "34" "&#190;")
177(defspecial 'es "&#216;")
178(defspecial '+- "&#177;")
179(defspecial 'sc "&#167;")
180(defspecial 'fm #\')        ; foot mark
181(defspecial 'lh "&lt;=")
182(defspecial 'rh "=&gt;")
183(defspecial '-> "-&gt;")
184(defspecial '<- "&lt;-")
185(defspecial 'no "&#172;")   ; negation
186(defspecial 'di "&#247;")   ; division
187(defspecial 'ss "&#223;")
188(defspecial ':a "&#228;")
189(defspecial 'a: "&#228;")
190(defspecial ':o "&#246;")
191(defspecial 'o: "&#246;")
192(defspecial ':u "&#252;")
193(defspecial 'u: "&#252;")
194(defspecial ':A "&#196;")
195(defspecial 'A: "&#196;")
196(defspecial ':O "&#214;")
197(defspecial 'O: "&#214;")
198(defspecial ':U "&#220;")
199(defspecial 'U: "&#220;")
200(defspecial 'ct "&#162;")   ; cent
201(defspecial 'Po "&#163;")   ; pound
202(defspecial 'Cs "&#164;")   ; currency sign
203(defspecial 'Ye "&#165;")   ; yen
204(defspecial 'ff "ff")
205(defspecial 'fi "fi")
206(defspecial 'fl "fl")
207(defspecial 'Fi "ffi")
208(defspecial 'Fl "ffl")
209(defspecial 'S1 "&#185;")
210(defspecial 'S2 "&#178;")
211(defspecial 'S3 "&#179;")
212(defspecial 'bb "&#166;")   ; broken bar
213(defspecial 'r! "&#161;")   ; reverse exclamation mark
214(defspecial 'r? "&#191;")   ; reverse question mark
215(defspecial '!< "<")        ; the real < for generating html elements
216(defspecial '!> ">")        ; the real > for generating html elements
217
218(defspecial '*A "A")        ; greek
219(defspecial '*B "B")        ; greek
220(defspecial '*G (lambda _ (gifchar '*G)))
221(defspecial '*D (lambda _ (gifchar '*D)))
222(defspecial '*E "E")        ; greek
223(defspecial '*Z "Z")        ; greek
224(defspecial '*Y "H")        ; greek
225(defspecial '*H (lambda _ (gifchar '*H)))
226(defspecial '*I "I")        ; greek
227(defspecial '*K "K")        ; greek
228(defspecial '*L (lambda _ (gifchar '*L)))
229(defspecial '*M "M")        ; greek
230(defspecial '*N "N")        ; greek
231(defspecial '*C (lambda _ (gifchar '*C)))
232(defspecial '*O "O")        ; greek
233(defspecial '*P (lambda _ (gifchar '*P)))
234(defspecial '*R "P")        ; greek
235(defspecial '*S (lambda _ (gifchar '*S)))
236(defspecial '*T "T")        ; greek
237(defspecial '*U (lambda _ (gifchar '*U)))
238(defspecial '*F (lambda _ (gifchar '*F)))
239(defspecial '*X "X")        ; greek
240(defspecial '*Q (lambda _ (gifchar '*Q)))
241(defspecial '*W (lambda _ (gifchar '*W)))
242(defspecial '*a (lambda _ (gifchar '*a)))
243(defspecial '*b (lambda _ (gifchar '*b)))
244(defspecial '*g (lambda _ (gifchar '*g)))
245(defspecial '*d (lambda _ (gifchar '*d)))
246(defspecial '*e (lambda _ (gifchar '*e)))
247(defspecial '*z (lambda _ (gifchar '*z)))
248(defspecial '*y (lambda _ (gifchar '*y)))
249(defspecial '*h (lambda _ (gifchar '*h)))
250(defspecial '*i (lambda _ (gifchar '*i)))
251(defspecial '*k (lambda _ (gifchar '*k)))
252(defspecial '*l (lambda _ (gifchar '*l)))
253(defspecial '*m "&#181;")
254(defspecial '*n (lambda _ (gifchar '*n)))
255(defspecial '*c (lambda _ (gifchar '*c)))
256(defspecial '*o (lambda _ (gifchar '*o)))
257(defspecial '*p (lambda _ (gifchar '*p)))
258(defspecial '*r (lambda _ (gifchar '*r)))
259(defspecial '*s (lambda _ (gifchar '*s)))
260(defspecial 'ts (lambda _ (gifchar 'ts)))
261(defspecial '*t (lambda _ (gifchar '*t)))
262(defspecial '*u (lambda _ (gifchar '*u)))
263(defspecial '*f (lambda _ (gifchar '*f)))
264(defspecial '*x (lambda _ (gifchar '*x)))
265(defspecial '*q (lambda _ (gifchar '*q)))
266(defspecial '*w (lambda _ (gifchar '*w)))
267
268(defspecial 'bu (lambda _ (warn "rendering \\(bu as `+'") #\+))
269(defspecial 'sq (lambda _ (warn "rendering \\(sq as `o'") #\o))
270(defspecial 'dg (lambda _ (warn "rendering \\(dg as `**'") "**"))
271(defspecial 'dd (lambda _ (warn "rendering \\(dd as `***'") "***"))
272
273(define gif-table (make-table 100))
274
275(define (gif-greek char gif align)
276  (table-store! gif-table char (list gif align 'no)))
277
278(gif-greek '*G "Gamma" "b")
279(gif-greek '*D "Delta" "b")
280(gif-greek '*H "Theta" "b")
281(gif-greek '*L "Lambda" "b")
282(gif-greek '*C "Xi" "b")
283(gif-greek '*P "Pi" "b")
284(gif-greek '*S "Sigma" "b")
285(gif-greek '*U "Upsilon" "b")
286(gif-greek '*F "Phi" "b")
287(gif-greek '*Q "Psi" "b")
288(gif-greek '*W "Omega" "b")
289(gif-greek '*a "alpha" "b")
290(gif-greek '*b "beta" "t")
291(gif-greek '*g "gamma" "b")
292(gif-greek '*d "delta" "b")
293(gif-greek '*e "epsilon" "b")
294(gif-greek '*z "zeta" "t")
295(gif-greek '*y "eta" "t")
296(gif-greek '*h "theta" "b")
297(gif-greek '*i "iota" "b")
298(gif-greek '*k "kappa" "b")
299(gif-greek '*l "lambda" "b")
300(gif-greek '*n "nu" "b")
301(gif-greek '*c "xi" "t")
302(gif-greek '*o "omicron" "b")
303(gif-greek '*p "pi" "b")
304(gif-greek '*r "rho" "t")
305(gif-greek '*s "sigma" "b")
306(gif-greek 'ts "sigma" "b")
307(gif-greek '*t "tau" "b")
308(gif-greek '*u "upsilon" "b")
309(gif-greek '*f "phi" "b")
310(gif-greek '*x "chi" "b")
311(gif-greek '*q "psi" "b")
312(gif-greek '*w "omega" "b")
313
314(define (gifchar char)
315  (let ((result (table-lookup gif-table char))
316	(docname (option 'document)))
317    (cond
318      (result
319	(if (not docname) (begin
320	   (warn "can't translate \\(~a if no document given, ? used" char)
321	   "?")
322	(let* ((charname (list-ref result 0))
323	       (align (if (string=? "t" (list-ref result 1)) " align=top" ""))
324	       (gifname (concat docname "." charname ".gif"))
325	       (ref (concat "<img src=\"" gifname
326				"\" alt=\"[" charname "]\"" align ">")))
327	  (begin
328	    (if (eq? 'no (list-ref result 2))
329	      (begin
330	        (if (not (= 0 (shell-command
331	          (substitute "/bin/cp %directory%/misc/gifs/%1%.gif %2%" charname gifname))))
332	      (warn "couldn't copy \\(~a - system problem" gifname))
333	      (set-car! (cddr result) 'yes)))
334	   ref))))
335      (else (warn "no translation for \\(~a, ? used" char) "?"))))
336
337
338;;; --------------------------------------------------------------------------
339;;; Local motion requests and related stuff (mostly ignored).
340
341(define (motion-ignored request . _)
342  (warn "local motion request \\~a ignored" request))
343
344(defescape #\u motion-ignored)
345(defescape #\d motion-ignored)
346(defescape #\v motion-ignored)
347
348(define (motion-no-effect request arg)
349  (warn "local motion request \\~a has no effect" request)
350  (parse arg))
351
352(defescape #\o motion-no-effect)
353(defescape #\z motion-no-effect)
354
355(defescape #\k
356  (lambda (k reg)
357    ((requestdef 'nr) 'nr reg "0" "")))
358
359(defescape #\h
360  (lambda (h arg)
361    (let* ((x (parse arg))
362	   (n (get-hunits (parse-expression x 0 #\m))))
363      (if (negative? n)
364	  (warn "\\h with negative argument ignored")
365	  (make-string n #\space)))))
366
367(defescape #\w
368  (lambda (w s)
369    (let ((scale (get-scaling #\m))
370	  (len (string-length (parse s))))
371      (number->string (quotient (* len (car scale)) (cdr scale))))))
372
373;; Heuristic: generate <hr> if length could be line length, else
374;; repeat specified character:
375
376(defescape #\l
377  (lambda (l s)
378    (let* ((p (parse-expression-rest s '(0 . "") #\m))
379	   (n (get-hunits (car p)))
380	   (c (parse (cdr p))))
381      (if (>= n line-length)
382	  "<hr>"
383	  (repeat-string n (if (eqv? c "") "_" c))))))
384
385
386
387;;; --------------------------------------------------------------------------
388;;; Output translations for HTML special characters.
389
390(defchar #\< "&lt;")
391(defchar #\> "&gt;")
392(defchar #\& "&amp;")
393
394;;; Like parse, but also take char of `"':
395
396(define (parse-unquote s)
397  (let ((old (defchar #\" "&quot;")))
398    (begin1 (parse s) (defchar #\" old))))
399
400
401
402;;; --------------------------------------------------------------------------
403;;; Font handling.
404
405(define font-table (make-table 100))
406
407(define (define-font name open close)
408  (table-store! font-table name (cons open close)))
409
410(define-font "R"  ""    "")
411(define-font "I"  '<i>  '</i>)
412(define-font "B"  '<b>  '</b>)
413(define-font "C"  '<tt> '</tt>)
414(define-font "CW" '<tt> '</tt>)
415(define-font "CO" '<i>  '</i>)    ; a kludge for Courier-Oblique
416
417(define font-positions (make-vector 10 #f))
418
419(define (find-font f start)
420  (cond
421    ((= start (vector-length font-positions)) #f)
422    ((equal? (vector-ref font-positions start) f) start)
423    (else (find-font f (1+ start)))))
424
425(define (font->position f)
426  (let* ((m (find-font f 1)) (n (if m m (find-font #f 1))))
427    (cond
428      (n (mount-font n f) n)
429      (else
430	(warn "no free font position for font ~a" f) #f))))
431
432(define (get-font-name name)
433  (cond
434    ((table-lookup font-table name) name)
435    (else (warn "unknown font: ~a" name) "R")))
436
437(define (mount-font i name)
438  (if (and (>= i 1) (< i (vector-length font-positions)))
439      (vector-set! font-positions i (get-font-name name))
440      (warn "invalid font position: `~a'" i)))
441
442(mount-font 1 "R")
443(mount-font 2 "I")
444(mount-font 3 "B")
445(mount-font 4 "R")
446
447(defrequest 'fp
448  (lambda (fp where name)
449    (if (not (string->number where))
450	(warn "invalid font position `~a' in .fp" where)
451	(mount-font (string->number where) name) "")))
452
453(define previous-font 1)
454(define current-font  1)
455
456(define (reset-font)
457  (concat (change-font 1) (change-font 1)))    ; current and previous
458
459(define (change-font-at i)
460  (cond
461    ((or (< i 1) (>= i (vector-length font-positions)))
462      (warn "invalid font position: `~a'" i))
463    ((vector-ref font-positions i)
464      (let ((o (table-lookup font-table
465			     (vector-ref font-positions current-font)))
466	    (n (table-lookup font-table (vector-ref font-positions i))))
467        (set! previous-font current-font)
468        (set! current-font i)
469	(if (and preform? (not (option 'tt-preformat)))
470	    (concat (if (eq? (cdr o) '</tt>) "" (cdr o))
471		    (if (eq? (car n) '<tt>)  "" (car n)))
472            (concat (cdr o) (car n)))))
473    (else (warn "no font mounted at position ~a" i))))
474
475(define (change-font f)
476  (cond
477    ((number? f)
478      (change-font-at f))
479    ((string->number f)
480      (change-font-at (string->number f)))
481    ((string=? f "P")
482      (change-font-at previous-font))
483    (else
484      (let ((n (font->position (get-font-name f))))
485	(if n (change-font-at n) "")))))
486
487(defrequest 'ft
488  (lambda (ft font)
489    (change-font (if (eqv? font "") "P" font))))
490
491(defescape #\f (requestdef 'ft))
492
493(defnumreg '.f (lambda _ (number->string current-font)))
494
495(define-macro (with-font-preserved . body)
496  `(let (($f current-font))
497     (concat (change-font "R") ,@body (change-font $f))))
498
499
500
501;;; --------------------------------------------------------------------------
502;;; tbl, eqn, pic.
503
504;;; Processing for eqn saves all preceding eqn environment commands, which
505;;; are emitted at the beginning of any equation to configure the environment.
506;;; (G. Helffrich/U. Bristol)
507;;;
508;;; ***FIX*** If equation is in-line, it should be centered rather than
509;;; aligned to the baseline.
510
511(define (first-token x)
512   (let loopi ((i 0) (imax (string-length x)))
513      (cond
514	 ((>= i imax) #f)
515	 ((char=? #\space (string-ref x i)) (loopi (+ i 1) imax))
516	 (else
517	    (let loopj ((j i))
518	       (cond
519		  ((>= j imax) (substring x i imax))
520		  ((not (char=? #\space (string-ref x j))) (loopj (+ j 1)))
521		  (else (substring x i j))))))))
522
523(define (filter-eqn-state x)
524   (let ((token (first-token x)))
525     (cond
526       ((or (string=? token "delim")
527	   (string=? token "gfont")
528	   (string=? token "gsize")
529	   (string=? token "ndefine")
530	   (string=? token "tdefine")
531	   (string=? token "define"))
532	  (begin
533	     (with-output-appended-to-stream "[eqn-state]" (emit x))
534	  #f))
535       ((not token) #f)
536       (else #t))))
537
538(define (copy-preprocess for-eqn? proc-1 proc-2 stop inline)
539  (cond
540    (inline
541      (emit inline #\newline stop #\newline)
542      (filter-eqn-line inline))
543    (else
544      (let ((stop-len (string-length stop)))
545      (let loop ((x (read-line-expand))
546	         (use-output? (not for-eqn?)))
547	   (let ((x-len (string-length x)))
548           (cond ((eof-object? x) use-output?)
549	         (else
550	           (proc-1 (proc-2 x))
551	           (if (string=? stop (substring x 0 (min x-len stop-len)))
552		       ;; end of processing.  Check if .EN C, in which case
553		       ;; following line should start .EQ, and both should
554		       ;; be processed simultaneously.
555		       (let ((mesee (substring x (min stop-len x-len)
556					     (min (+ stop-len 2) x-len))))
557		       (if (and for-eqn? (string=? " C" mesee))
558			   (let* ((next (read-line))
559				  (next-len (- (string-length next) 1)))
560			     (if (string=? ".EQ C"
561				   (substring next 0 (min 5 next-len)))
562			       (begin
563				 (emit (parse-expand next))
564				 (loop (read-line-expand) use-output?))
565			       (unread-line next))))
566		       use-output?)
567		       (loop (read-line-expand)
568			     (or (not for-eqn?)
569				;; Bug fix.  filter-eqn-line does not recognize
570				;; "delim off" because it includes the newline
571				;; at the end-of-line in the test.  Strip \n
572				;; before passing to filter-eqn-line
573				(begin (filter-eqn-line (substring x 0 (- (string-length x) 1)))
574				       (filter-eqn-state x)))))))))))))
575
576(define image-seqnum 1)
577(define troff-to-gif
578    (lambda (processor start stop what args inline)
579      (let ((docname (option 'document))
580	    (filter (if (eq? processor 'tbl)
581			 (apply spread (list (option 'tbl) "|" (option 'eqn)))
582			 (option processor))))
583        (if (not docname)
584	    (begin
585	      (warn "~a skipped, because no `document' option given" what)
586	      (if (not inline)
587		  (skip-lines stop))
588	      "")
589            (let* ((num (number->string image-seqnum))
590	           (psname (concat docname #\- num ".ps"))
591	           (gifname (concat docname #\- num ".gif"))
592		   (ref (concat "<img src=\"" gifname
593				"\" alt=\"[" what "]\">"))
594		   (use-output? #f))
595	      (++ image-seqnum)
596              (with-output-to-stream
597	        (substitute (concat #\| filter
598				    #\| (option 'troff-to-gif)) psname gifname)
599		;; If generating tbl output, handle equations in table text by
600		;; emitting an .EQ/.EN with the state information for eqn.  If
601		;; no equations, this will do nothing, but if there are the
602		;; proper initial eqn state will be set up.
603		(if (eq? processor 'tbl) (begin
604		   (emit ".EQ\n")
605		   (emit (stream->string "[eqn-state]"))
606		   (emit ".EN\n")))
607	        (emit start #\space (apply spread args) #\newline)
608		;; Emit saved state of eqn before any new equations
609		(if (eq? processor 'eqn) (emit (stream->string "[eqn-state]")))
610		(set! use-output? (copy-preprocess (eq? processor 'eqn)
611				     emit identity stop inline)))
612	      (remove-file psname)
613	      (if use-output?
614                  (if inline ref (concat "<p>" ref "<p>\n"))
615		  (remove-file gifname) ""))))))
616
617(define troff-to-pic
618    (lambda (processor start stop what args inline)
619      (let ((docname (option 'document)))
620        (if (not docname)
621	    (begin
622	      (warn "~a skipped, because no `document' option given" what)
623	      (if (not inline)
624		  (skip-lines stop))
625	      "")
626            (let* ((num (number->string image-seqnum))
627	           (psname (concat docname #\- num ".ps"))
628	           (gifname (concat docname #\- num ".gif"))
629		   (ref (concat "<img src=\"" gifname
630				"\" alt=\"[" what "]\">"))
631		   (use-output? #f))
632	      (++ image-seqnum)
633              (with-output-to-stream
634	        (substitute
635		   (concat #\| (option 'troff-to-pic))
636		   (apply spread (if (null? (cddr args)) '("/dev/null") (cddr args)))
637		   psname)
638	        (emit start #\space (apply spread args) #\newline)
639		(set! use-output? (copy-preprocess (eq? processor 'eqn)
640				     emit identity stop inline)))
641	      (remove-file psname)
642	      (if use-output?
643                  (if inline ref (concat "<p>" ref "<p>\n"))
644		  (remove-file gifname) ""))))))
645
646(define (troff-to-text processor start stop what args inline)
647  (let* ((tmpname (substitute "%tmpname%"))
648	 (use-output? #f))
649    (with-output-to-stream
650      (substitute (concat #\| (option processor) #\| (option 'troff-to-text))
651		  tmpname)
652      ;; If generating tbl output, handle equations in table text by
653      ;; emitting an .EQ/.EN with the state information for eqn.  If
654      ;; no equations, this will do nothing, but if there are the
655      ;; proper initial eqn state will be set up.
656      (if (eq? processor 'tbl) (begin
657        (emit ".EQ\n")
658        (emit (stream->string "[eqn-state]"))
659        (emit ".EN\n")))
660      (emit start #\space (apply spread args) #\newline)
661      (set! use-output? (copy-preprocess (eq? processor 'eqn)
662			  emit identity stop inline)))
663    (let ((text (translate (stream->string tmpname))))
664      (remove-file tmpname)
665      (if use-output?
666	  (if inline
667	      (with-font-preserved (concat (change-font 2) text))
668	      (concat (preform #t #t) text (preform #f)))
669	  ""))))
670
671(define (troff-to-preform processor start stop what args inline)
672  (cond
673    (inline (with-font-preserved (concat (change-font 2) inline)))
674    (else
675      (emit (preform #t) start #\space (apply spread args) #\newline)
676      (copy-preprocess (eq? processor 'eqn) emit translate stop)
677      (preform #f))))
678
679(define (troff-select-method option-name)
680  (let ((method (option option-name)))
681    (cond ((string=? method "gif")  troff-to-gif)
682	  ((string=? method "text") troff-to-text)
683	  ((string=? method "copy") troff-to-preform)
684	  ((string=? method "pic") troff-to-pic)
685	  (else
686	    (warn "bad value `~a' for ~a, assuming `text'" method option-name)
687	    troff-to-text))))
688
689(defmacro 'TS
690  (lambda (TS . args)
691    ((troff-select-method 'handle-tbl) 'tbl ".TS" ".TE" "table" args #f)))
692
693(defmacro 'EQ
694  (lambda (EQ . args)
695    ((troff-select-method 'handle-eqn) 'eqn ".EQ" ".EN" "equation" args #f)))
696
697(defmacro 'PS
698  (lambda (PS . args)
699    ((troff-select-method 'handle-pic) 'pic ".PS" ".PE" "picture" args #f)))
700
701(defmacro 'TE "")
702(defmacro 'EN "")
703(defmacro 'PE "")
704
705(defequation
706  (lambda (eqn)
707    ((troff-select-method 'handle-eqn) 'eqn ".EQ" ".EN" "equation" '() eqn)))
708
709
710
711;;; --------------------------------------------------------------------------
712;;; Miscellaneous troff requests.
713
714(defrequest 'br
715  (lambda _
716    (if (positive? lines-to-center) "" "<br>\n")))
717
718(defrequest 'sp
719  (lambda (sp num)
720    (let ((n (if (eqv? num "") 1 (get-vunits (parse-expression num 0 #\v)))))
721      (cond
722	((negative? n)
723	  (warn ".sp with negative spacing ignored"))
724	(preform?
725	  (repeat-string n "\n"))
726	((zero? n)
727	  "<br>\n")
728	(else
729	  (with-font-preserved (repeat-string n "<p>\n")))))))
730
731(defrequest 'ti
732  (lambda (ti num)
733    (let ((n (if (eqv? num "") 0 (get-hunits (parse-expression num 0 #\m)))))
734      (if (negative? n)
735	  (begin
736	     (warn "negative indent on .ti ignored")
737	    "<br>\n")
738          (concat "<br>\n" (repeat-string n nbsp))))))
739
740
741;;; There is no reasonable way to create markup for .tl; just emit the
742;;; argument:
743
744(defrequest 'tl
745  (lambda (tl s)
746    (let* ((p (parse s))
747	   (t (parse-triple p)))
748      (cond
749	(t
750	  (spread (car t) (cadr t) (cddr t) #\newline))
751	((eqv? s "")
752	   "")
753	(else
754	   (warn "badly formed .tl argument: `~a'" p))))))
755
756
757;;; Until HTML can center, at least generate a <br> after each line:
758
759(defrequest 'ce
760  (lambda (ce num)
761    (let ((n (if (eqv? num "") 1 (string->number num))))
762      (if n
763	  (concat (preform #t) (center (round (1+ n))))
764	  (warn ".ce argument `~a' not understood" num)))))
765
766(define lines-to-center 0)
767
768(define (center n . previous?)
769    (let ((centering? (if (null? previous?) (positive? lines-to-center) (car previous?))))
770    (set! lines-to-center n)
771    (defevent 'line 50 (if (positive? n) center-processor #f))
772    (if (positive? n) "<center>" (if centering? "</center>\n" ""))))
773
774(define (center-processor c)
775  (let ((centering? (positive? lines-to-center)))
776    (if (not (positive? (1- (-- lines-to-center))))
777      (emit (concat (center 0 centering?) (preform #f))))))
778
779
780
781;;; --------------------------------------------------------------------------
782;;; Other definitions.
783
784;;; Suppress comment if writing to a buffer, because in this case the
785;;; output is likely to be re-read later (e.g. it may be a macro):
786
787(defescape #\"
788  (lambda (_ x)
789    (let ((c (string-prune-right x "\n" x))
790	  (old (defchar #\tab #f)))
791      (if (and (not (eqv? c "")) (not (stream-buffer? (output-stream))))
792          (emit "<!-- " (translate c) " -->\n"))
793      (defchar #\tab old)
794      #\newline)))
795
796
797;;; Extra white space at end of sentence:
798
799(define sentence-event
800  (lambda (c)
801    (concat c "<tt> </tt>\n")))
802
803(defsentence sentence-event)
804
805
806;;; Emit standardized output file prolog:
807
808(define (emit-HTML-prolog)
809  (let ((mailto (option 'mail-address)))
810    (emit "<html>\n<head>\n")
811    (emit "<!-- This file has been generated by "
812	  (substitute "%progname% %version%, %date% %time%. -->\n")
813	  "<!-- Do not edit! -->\n")
814    (if mailto (emit "<link rev=\"made\" href=\"mailto:" mailto "\">\n"))))
815
816
817;;; Define a scaling for the usual scaling indicators.  Note that the
818;;; vertical spacing and character width will never change; and the
819;;; device's vertical/horizontal resolution is 1.
820
821(define inch 240)    ; units per inch
822
823(set-scaling! #\i inch 1)
824(set-scaling! #\c (* 50 inch) 127)
825(set-scaling! #\P inch 6)    ; Pica
826(set-scaling! #\m inch 10)
827(set-scaling! #\n inch 10)
828(set-scaling! #\p inch 72)
829(set-scaling! #\v inch 7)
830
831;;; Convert from units back to ems and Vs:
832
833(define (get-hunits x)
834  (let ((s (get-scaling #\m)))
835    (if x (inexact->exact (/ (* x (cdr s)) (car s))) x)))
836
837(define (get-vunits x)
838  (let ((s (get-scaling #\v)))
839    (if x (inexact->exact (/ (* x (cdr s)) (car s))) x)))
840
841;;; Fake line length:
842
843(define line-length 65)
844
845(defnumreg '.l "1560")    ; 65 ems
846