599 lines
16 KiB
Scheme
599 lines
16 KiB
Scheme
;;;; -*-Scheme-*-
|
|
;;;;
|
|
;;;; $Revision: 1.20 $
|
|
;;;;
|
|
;;;; Common definitions for HTML output format
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; Configurable, site-specific definitions.
|
|
|
|
(define-option 'troff-to-gif 'string
|
|
"groff -ms > %1%; /usr/www/lib/latex2html/pstogif %1% -out %2%")
|
|
|
|
(define-option 'troff-to-text 'string
|
|
"groff -Tlatin1 -P-b -P-u |sed '/^[ \t]*$/d' > %1%")
|
|
|
|
(define-option 'tbl 'string 'gtbl)
|
|
(define-option 'eqn 'string 'geqn)
|
|
(define-option 'pic 'string 'gpic)
|
|
|
|
|
|
;; A non-breaking space that is really non-breaking even in broken browsers:
|
|
|
|
(define nbsp " <tt> </tt>")
|
|
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; Options.
|
|
|
|
|
|
(define-option 'title 'string #f) ; May be used for <title>
|
|
(define-option 'mail-address 'string #f) ; May be used for `mailto:'
|
|
(define-option 'document 'string #f) ; Prefix for output file(s)
|
|
(define-option 'tt-preformat 'boolean #f) ; do <tt>-changes inside .nf/.fi
|
|
|
|
(define-option 'handle-eqn 'string "gif") ; gif/text/copy
|
|
(define-option 'handle-tbl 'string "text") ;
|
|
(define-option 'handle-pic 'string "gif") ;
|
|
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; Preformatted text.
|
|
|
|
(define preform? #f)
|
|
|
|
(define (preform on?)
|
|
(cond ((and on? (not preform?))
|
|
(defsentence #f)
|
|
(with-font-preserved
|
|
(begin (set! preform? #t) "<pre>\n")))
|
|
((and (not on?) preform?)
|
|
(defsentence sentence-event)
|
|
(with-font-preserved
|
|
(begin (set! preform? #f) "</pre>\n")))
|
|
(else "")))
|
|
|
|
(defrequest 'nf (lambda _ (preform #t)))
|
|
(defrequest 'fi (lambda _ (preform #f)))
|
|
|
|
(define-macro (with-preform-preserved . body)
|
|
`(let (($p preform?))
|
|
(concat (preform #f) ,@body (preform $p))))
|
|
|
|
(defchar #\tab
|
|
(lambda (c)
|
|
(if (not preform?) (surprise "tab outside .nf/.fi")) c))
|
|
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; Silently ignoring these requests probably will not harm. There is
|
|
;;; nothing sensible we can do.
|
|
|
|
(defrequest 'ne "")
|
|
(defrequest 'hw "")
|
|
(defrequest 'nh "")
|
|
(defrequest 'hy "")
|
|
(defrequest 'lg "")
|
|
(defrequest 'ps "")
|
|
(defrequest 'vs "")
|
|
(defrequest 'pl "")
|
|
(defrequest 'bp "")
|
|
(defrequest 'ns "")
|
|
(defrequest 'rs "")
|
|
(defrequest 'wh "")
|
|
(defrequest 'ch "")
|
|
(defrequest 'fl "")
|
|
(defrequest 'na "")
|
|
(defrequest 'ad "")
|
|
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; Basic escape sequences and special characters.
|
|
|
|
(defescape #\c "") ; swallows its character argument
|
|
(defescape #\& "")
|
|
(defescape #\- #\-)
|
|
(defescape #\| "")
|
|
(defescape #\^ "")
|
|
(defescape #\space #\space) ; should be   (doesn't work in Mosaic)
|
|
(defescape #\0 #\space)
|
|
(defescape #\s "")
|
|
(defescape #\e #\\)
|
|
(defescape #\\ #\\)
|
|
(defescape #\' #\')
|
|
(defescape #\` #\`)
|
|
(defescape #\% "")
|
|
|
|
(defescape ""
|
|
(lambda (c . _)
|
|
(warn "escape sequence `\\~a' expands to `~a'" c c)
|
|
(translate c)))
|
|
|
|
(defspecial 'em "--")
|
|
(defspecial 'en #\-)
|
|
(defspecial 'mi #\-)
|
|
(defspecial 'pl #\+) ; plus
|
|
(defspecial 'lq "``")
|
|
(defspecial 'rq "''")
|
|
(defspecial '** #\*)
|
|
(defspecial 'bv #\|) ; bold vertical (what is this?)
|
|
(defspecial 'hy "­") ; `soft hyphen'
|
|
(defspecial 'co "©") ; copyright
|
|
(defspecial 'ap #\~) ; approximates
|
|
(defspecial '~= #\~)
|
|
(defspecial 'cd "·") ; centered dot
|
|
(defspecial 'de "°") ; degree
|
|
(defspecial '>= ">=")
|
|
(defspecial '<= "<=")
|
|
(defspecial 'eq #\=)
|
|
(defspecial '== "==")
|
|
(defspecial 'mu "×") ; multiplication
|
|
(defspecial 'tm "®")
|
|
(defspecial 'rg "®")
|
|
(defspecial '*m "µ") ; mu
|
|
(defspecial '*b "ß") ; beta (#223 is German sharp-s actually)
|
|
(defspecial 'aa #\') ; acute accent
|
|
(defspecial 'ga #\`) ; grave accent
|
|
(defspecial 'br #\|) ; vertical box rule
|
|
(defspecial 'or #\|)
|
|
(defspecial 'sl #\/)
|
|
(defspecial 'ru #\_)
|
|
(defspecial 'ul #\_)
|
|
(defspecial 'ci #\O)
|
|
(defspecial "14" "¼")
|
|
(defspecial "12" "½")
|
|
(defspecial "34" "¾")
|
|
(defspecial 'es "Ø")
|
|
(defspecial '+- "±")
|
|
(defspecial 'sc "§")
|
|
(defspecial 'fm #\') ; foot mark
|
|
(defspecial 'lh "<=")
|
|
(defspecial 'rh "=>")
|
|
(defspecial '-> "->")
|
|
(defspecial '<- "<-")
|
|
(defspecial 'no "¬") ; negation
|
|
(defspecial 'di "÷") ; division
|
|
(defspecial 'ss "ß")
|
|
(defspecial ':a "ä")
|
|
(defspecial 'a: "ä")
|
|
(defspecial ':o "ö")
|
|
(defspecial 'o: "ö")
|
|
(defspecial ':u "ü")
|
|
(defspecial 'u: "ü")
|
|
(defspecial ':A "Ä")
|
|
(defspecial 'A: "Ä")
|
|
(defspecial ':O "Ö")
|
|
(defspecial 'O: "Ö")
|
|
(defspecial ':U "Ü")
|
|
(defspecial 'U: "Ü")
|
|
(defspecial 'ct "¢") ; cent
|
|
(defspecial 'Po "£") ; pound
|
|
(defspecial 'Cs "¤") ; currency sign
|
|
(defspecial 'Ye "¥") ; yen
|
|
(defspecial 'ff "ff")
|
|
(defspecial 'fi "fi")
|
|
(defspecial 'fl "fl")
|
|
(defspecial 'Fi "ffi")
|
|
(defspecial 'Fl "ffl")
|
|
(defspecial 'S1 "¹")
|
|
(defspecial 'S2 "²")
|
|
(defspecial 'S3 "³")
|
|
(defspecial 'bb "¦") ; broken bar
|
|
(defspecial 'r! "¡") ; reverse exclamation mark
|
|
(defspecial 'r? "¿") ; reverse question mark
|
|
|
|
|
|
(defspecial 'bu (lambda _ (warn "rendering \\(bu as `+'") #\+))
|
|
(defspecial 'sq (lambda _ (warn "rendering \\(sq as `o'") #\o))
|
|
(defspecial 'dg (lambda _ (warn "rendering \\(dg as `**'") "**"))
|
|
(defspecial 'dd (lambda _ (warn "rendering \\(dd as `***'") "***"))
|
|
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; Local motion requests and related stuff (mostly ignored).
|
|
|
|
(define (motion-ignored request . _)
|
|
(warn "local motion request \\~a ignored" request))
|
|
|
|
(defescape #\u motion-ignored)
|
|
(defescape #\d motion-ignored)
|
|
(defescape #\v motion-ignored)
|
|
|
|
(define (motion-no-effect request arg)
|
|
(warn "local motion request \\~a has no effect" request)
|
|
(parse arg))
|
|
|
|
(defescape #\o motion-no-effect)
|
|
(defescape #\z motion-no-effect)
|
|
|
|
(defescape #\k
|
|
(lambda (k reg)
|
|
((requestdef 'nr) 'nr reg "0" "")))
|
|
|
|
(defescape #\h
|
|
(lambda (h arg)
|
|
(let* ((x (parse arg))
|
|
(n (get-hunits (parse-expression x 0 #\m))))
|
|
(if (negative? n)
|
|
(warn "\\h with negative argument ignored")
|
|
(make-string n #\space)))))
|
|
|
|
(defescape #\w
|
|
(lambda (w s)
|
|
(let ((scale (get-scaling #\m))
|
|
(len (string-length (parse s))))
|
|
(number->string (quotient (* len (car scale)) (cdr scale))))))
|
|
|
|
;; Heuristic: generate <hr> if length could be line length, else
|
|
;; repeat specified character:
|
|
|
|
(defescape #\l
|
|
(lambda (l s)
|
|
(let* ((p (parse-expression-rest s '(0 . "") #\m))
|
|
(n (get-hunits (car p)))
|
|
(c (parse (cdr p))))
|
|
(if (>= n line-length)
|
|
"<hr>"
|
|
(repeat-string n (if (eqv? c "") "_" c))))))
|
|
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; Output translations for HTML special characters.
|
|
|
|
(defchar #\< "<")
|
|
(defchar #\> ">")
|
|
(defchar #\& "&")
|
|
|
|
;;; Like parse, but also take char of `"':
|
|
|
|
(define (parse-unquote s)
|
|
(let ((old (defchar #\" """)))
|
|
(begin1 (parse s) (defchar #\" old))))
|
|
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; Font handling.
|
|
|
|
(define font-table (make-table 100))
|
|
|
|
(define (define-font name open close)
|
|
(table-store! font-table name (cons open close)))
|
|
|
|
(define-font "R" "" "")
|
|
(define-font "I" '<i> '</i>)
|
|
(define-font "B" '<b> '</b>)
|
|
(define-font "C" '<tt> '</tt>)
|
|
(define-font "CW" '<tt> '</tt>)
|
|
(define-font "CO" '<i> '</i>) ; a kludge for Courier-Oblique
|
|
|
|
(define font-positions (make-vector 10 #f))
|
|
|
|
(define (find-font f start)
|
|
(cond
|
|
((= start (vector-length font-positions)) #f)
|
|
((equal? (vector-ref font-positions start) f) start)
|
|
(else (find-font f (1+ start)))))
|
|
|
|
(define (font->position f)
|
|
(let* ((m (find-font f 1)) (n (if m m (find-font #f 1))))
|
|
(cond
|
|
(n (mount-font n f) n)
|
|
(else
|
|
(warn "no free font position for font ~a" f) #f))))
|
|
|
|
(define (get-font-name name)
|
|
(cond
|
|
((table-lookup font-table name) name)
|
|
(else (warn "unknown font: ~a" name) "R")))
|
|
|
|
(define (mount-font i name)
|
|
(if (and (>= i 1) (< i (vector-length font-positions)))
|
|
(vector-set! font-positions i (get-font-name name))
|
|
(warn "invalid font position: `~a'" i)))
|
|
|
|
(mount-font 1 "R")
|
|
(mount-font 2 "I")
|
|
(mount-font 3 "B")
|
|
(mount-font 4 "R")
|
|
|
|
(defrequest 'fp
|
|
(lambda (fp where name)
|
|
(if (not (string->number where))
|
|
(warn "invalid font position `~a' in .fp" where)
|
|
(mount-font (string->number where) name) "")))
|
|
|
|
(define previous-font 1)
|
|
(define current-font 1)
|
|
|
|
(define (reset-font)
|
|
(concat (change-font 1) (change-font 1))) ; current and previous
|
|
|
|
(define (change-font-at i)
|
|
(cond
|
|
((or (< i 1) (>= i (vector-length font-positions)))
|
|
(warn "invalid font position: `~a'" i))
|
|
((vector-ref font-positions i)
|
|
(let ((o (table-lookup font-table
|
|
(vector-ref font-positions current-font)))
|
|
(n (table-lookup font-table (vector-ref font-positions i))))
|
|
(set! previous-font current-font)
|
|
(set! current-font i)
|
|
(if (and preform? (not (option 'tt-preformat)))
|
|
(concat (if (eq? (cdr o) '</tt>) "" (cdr o))
|
|
(if (eq? (car n) '<tt>) "" (car n)))
|
|
(concat (cdr o) (car n)))))
|
|
(else (warn "no font mounted at position ~a" i))))
|
|
|
|
(define (change-font f)
|
|
(cond
|
|
((number? f)
|
|
(change-font-at f))
|
|
((string->number f)
|
|
(change-font-at (string->number f)))
|
|
((string=? f "P")
|
|
(change-font-at previous-font))
|
|
(else
|
|
(let ((n (font->position (get-font-name f))))
|
|
(if n (change-font-at n) "")))))
|
|
|
|
(defrequest 'ft
|
|
(lambda (ft font)
|
|
(change-font (if (eqv? font "") "P" font))))
|
|
|
|
(defescape #\f (requestdef 'ft))
|
|
|
|
(defnumreg '.f (lambda _ (number->string current-font)))
|
|
|
|
(define-macro (with-font-preserved . body)
|
|
`(let (($f current-font))
|
|
(concat (change-font "R") ,@body (change-font $f))))
|
|
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; tbl, eqn, pic.
|
|
|
|
(define (copy-preprocess for-eqn? proc-1 proc-2 stop inline)
|
|
(cond
|
|
(inline
|
|
(emit inline #\newline stop)
|
|
(filter-eqn-line inline))
|
|
(else
|
|
(let loop ((x (read-line-expand))
|
|
(use-output? (not for-eqn?)))
|
|
(cond ((eof-object? x) use-output?)
|
|
(else
|
|
(proc-1 (proc-2 x))
|
|
(if (string=? x stop)
|
|
use-output?
|
|
(loop (read-line-expand)
|
|
(or (not for-eqn?) (filter-eqn-line x))))))))))
|
|
|
|
(define troff-to-gif
|
|
(let ((image-seqnum 1))
|
|
(lambda (processor start stop what args inline)
|
|
(let ((docname (option 'document)))
|
|
(if (not docname)
|
|
(begin
|
|
(warn "~a skipped, because no `document' option given" what)
|
|
(if (not inline)
|
|
(skip-lines stop))
|
|
"")
|
|
(let* ((num (number->string image-seqnum))
|
|
(psname (concat docname #\- num ".ps"))
|
|
(gifname (concat docname #\- num ".gif"))
|
|
(ref (concat "<img src=\"" gifname
|
|
"\" alt=\"[" what "]\">\n"))
|
|
(use-output? #f))
|
|
(++ image-seqnum)
|
|
(with-output-to-stream
|
|
(substitute (concat #\| (option processor)
|
|
#\| (option 'troff-to-gif)) psname gifname)
|
|
(emit start #\space (apply spread args) #\newline)
|
|
(set! use-output? (copy-preprocess (eq? processor 'eqn)
|
|
emit identity stop inline)))
|
|
(remove-file psname)
|
|
(if use-output?
|
|
(if inline ref (concat "<p>" ref "<p>\n"))
|
|
(remove-file gifname) "")))))))
|
|
|
|
(define (troff-to-text processor start stop what args inline)
|
|
(let* ((tmpname (substitute "%tmpname%"))
|
|
(use-output? #f))
|
|
(with-output-to-stream
|
|
(substitute (concat #\| (option processor) #\| (option 'troff-to-text))
|
|
tmpname)
|
|
(emit start #\space (apply spread args) #\newline)
|
|
(set! use-output? (copy-preprocess (eq? processor 'eqn)
|
|
emit identity stop inline)))
|
|
(let ((text (translate (stream->string tmpname))))
|
|
(remove-file tmpname)
|
|
(if use-output?
|
|
(if inline
|
|
(with-font-preserved (concat (change-font 2) text))
|
|
(concat (preform #t) text (preform #f)))
|
|
""))))
|
|
|
|
(define (troff-to-preform processor start stop what args inline)
|
|
(cond
|
|
(inline (with-font-preserved (concat (change-font 2) inline)))
|
|
(else
|
|
(emit (preform #t) start #\space (apply spread args) #\newline)
|
|
(copy-preprocess (eq? processor 'eqn) emit translate stop)
|
|
(preform #f))))
|
|
|
|
(define (troff-select-method option-name)
|
|
(let ((method (option option-name)))
|
|
(cond ((string=? method "gif") troff-to-gif)
|
|
((string=? method "text") troff-to-text)
|
|
((string=? method "copy") troff-to-preform)
|
|
(else
|
|
(warn "bad value `~a' for ~a, assuming `text'" method option-name)
|
|
troff-to-text))))
|
|
|
|
(defmacro 'TS
|
|
(lambda (TS . args)
|
|
((troff-select-method 'handle-tbl) 'tbl ".TS" ".TE\n" "table" args #f)))
|
|
|
|
(defmacro 'EQ
|
|
(lambda (EQ . args)
|
|
((troff-select-method 'handle-eqn) 'eqn ".EQ" ".EN\n" "equation" args #f)))
|
|
|
|
(defmacro 'PS
|
|
(lambda (PS . args)
|
|
((troff-select-method 'handle-pic) 'pic ".PS" ".PE\n" "picture" args #f)))
|
|
|
|
(defmacro 'TE "")
|
|
(defmacro 'EN "")
|
|
(defmacro 'PE "")
|
|
|
|
(defequation
|
|
(lambda (eqn)
|
|
((troff-select-method 'handle-eqn) 'eqn ".EQ" ".EN\n" "equation" '() eqn)))
|
|
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; Miscellaneous troff requests.
|
|
|
|
(defrequest 'br
|
|
(lambda _
|
|
(if (positive? lines-to-center) "" "<br>\n")))
|
|
|
|
(defrequest 'sp
|
|
(lambda (sp num)
|
|
(let ((n (if (eqv? num "") 1 (get-vunits (parse-expression num 0 #\v)))))
|
|
(cond
|
|
((negative? n)
|
|
(warn ".sp with negative spacing ignored"))
|
|
(preform?
|
|
(repeat-string n "\n"))
|
|
((zero? n)
|
|
"<br>\n")
|
|
(else
|
|
(with-font-preserved (repeat-string n "<p>\n")))))))
|
|
|
|
(defrequest 'ti
|
|
(lambda (ti num)
|
|
(let ((n (if (eqv? num "") 0 (get-hunits (parse-expression num 0 #\m)))))
|
|
(if (negative? n)
|
|
(warn ".ti with negative indent ignored")
|
|
(concat "<br>\n" (repeat-string n nbsp))))))
|
|
|
|
|
|
;;; There is no reasonable way to create markup for .tl; just emit the
|
|
;;; argument:
|
|
|
|
(defrequest 'tl
|
|
(lambda (tl s)
|
|
(let* ((p (parse s))
|
|
(t (parse-triple p)))
|
|
(cond
|
|
(t
|
|
(spread (car t) (cadr t) (cddr t) #\newline))
|
|
((eqv? s "")
|
|
"")
|
|
(else
|
|
(warn "badly formed .tl argument: `~a'" p))))))
|
|
|
|
|
|
;;; Until HTML can center, at least generate a <br> after each line:
|
|
|
|
(defrequest 'ce
|
|
(lambda (ce num)
|
|
(let ((n (if (eqv? num "") 1 (string->number num))))
|
|
(if n
|
|
(center (round n))
|
|
(warn ".ce argument `~a' not understood" num)))))
|
|
|
|
(define lines-to-center 0)
|
|
|
|
(define (center n)
|
|
(set! lines-to-center n)
|
|
(defevent 'line 50 (if (positive? n) center-processor #f))
|
|
"")
|
|
|
|
(define (center-processor c)
|
|
(if (positive? (-- lines-to-center))
|
|
(if (eqv? c #\newline)
|
|
(emit "<br>\n")))
|
|
(if (not (positive? lines-to-center))
|
|
(center 0)))
|
|
|
|
|
|
|
|
;;; --------------------------------------------------------------------------
|
|
;;; Other definitions.
|
|
|
|
;;; Suppress comment if writing to a buffer, because in this case the
|
|
;;; output is likely to be re-read later (e.g. it may be a macro):
|
|
|
|
(defescape #\"
|
|
(lambda (_ x)
|
|
(let ((c (string-prune-right x "\n" x))
|
|
(old (defchar #\tab #f)))
|
|
(if (and (not (eqv? c "")) (not (stream-buffer? (output-stream))))
|
|
(emit "<!-- " (translate c) " -->\n"))
|
|
(defchar #\tab old)
|
|
#\newline)))
|
|
|
|
|
|
;;; Extra white space at end of sentence:
|
|
|
|
(define sentence-event
|
|
(lambda (c)
|
|
(concat c "<tt> </tt>\n")))
|
|
|
|
(defsentence sentence-event)
|
|
|
|
|
|
;;; Emit standardized output file prolog:
|
|
|
|
(define (emit-HTML-prolog)
|
|
(let ((mailto (option 'mail-address)))
|
|
(emit "<html>\n<head>\n")
|
|
(emit "<meta name=\"generator\""
|
|
" content=\""
|
|
(substitute "%progname% %version%")
|
|
"\">\n")
|
|
(if mailto (emit "<link rev=\"made\" href=\"mailto:" mailto "\">\n"))))
|
|
|
|
|
|
;;; Define a scaling for the usual scaling indicators. Note that the
|
|
;;; vertical spacing and character width will never change; and the
|
|
;;; device's vertical/horizontal resolution is 1.
|
|
|
|
(define inch 240) ; units per inch
|
|
|
|
(set-scaling! #\i inch 1)
|
|
(set-scaling! #\c (* 50 inch) 127)
|
|
(set-scaling! #\P inch 6) ; Pica
|
|
(set-scaling! #\m inch 10)
|
|
(set-scaling! #\n inch 10)
|
|
(set-scaling! #\p inch 72)
|
|
(set-scaling! #\v inch 7)
|
|
|
|
;;; Convert from units back to ems and Vs:
|
|
|
|
(define (get-hunits x)
|
|
(let ((s (get-scaling #\m)))
|
|
(if x (inexact->exact (/ (* x (cdr s)) (car s))) x)))
|
|
|
|
(define (get-vunits x)
|
|
(let ((s (get-scaling #\v)))
|
|
(if x (inexact->exact (/ (* x (cdr s)) (car s))) x)))
|
|
|
|
;;; Fake line length:
|
|
|
|
(define line-length 65)
|
|
|
|
(defnumreg '.l "1560") ; 65 ems
|