;;;; -*-Scheme-*-
;;;;
;;;; $Revision: 1.20 $
;;;;
;;;; Common definitions for HTML output format


;;; --------------------------------------------------------------------------
;;; Configurable, site-specific definitions.

(define-option 'troff-to-gif  'string
  "psroff -me -t | sed -e 's/showpage//g' > %1%; pstogif %1% -density 100")

;;; (define-option 'troff-to-text 'string
;;;    "groff -Tlatin1 -P-b -P-u |sed '/^[ \t]*$/d' > %1%")
(define-option 'troff-to-text 'string
   "neqn | nroff | col -b | sed '/^[ \t]*$/d' > %1%")

(define-option 'troff-to-pic  
		 'string "pictogif %1% -ps %2%")

(define-option 'tbl 'string 'tbl)
(define-option 'eqn 'string 'eqn)
(define-option 'pic 'string 'pic)


;; A non-breaking space that is really non-breaking even in broken browsers:

(define nbsp "&#160;<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 "pic")  ;



;;; --------------------------------------------------------------------------
;;; Preformatted text.

;;; This is used in various contexts:
;;; 1. eqn text that is generated by running through neqn (see troff-to-text
;;;    and troff-to-preformat)
;;; 2. .nf/.fi pair

;;; .nf/.fi text is suffixed with <br> at the end of each line.
;;; Might prefer using <pre> </pre> if: 1) the tt-preformat option is asserted;
;;; or 2) a constant pitch font is selected (via the .cs x y; turned off
;;; by .cs x).

(define preform? #f)

(define (preform on? . pre?)
  (set! pre? (if (null? pre?) #f (car pre?)))
  (cond ((and on? (not preform?))
          (defsentence #f)
          (with-font-preserved
	    (begin
	      (set! preform? #t)
	      (if pre?
		"<pre>"
		 (begin (defevent 'line 45 nofill-processor) "")))))
        ((and (not on?) preform?)
          (defsentence sentence-event)
          (with-font-preserved
	    (begin
	      (set! preform? #f)
	      (if (eventdef 'line 45)
		(begin (defevent 'line 45 #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))

(define (nofill-processor c)
  (if (eqv? c #\newline)
      (emit "<br>\n")))


;;; --------------------------------------------------------------------------
;;; 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 "<br>\n")
(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 &#160; (doesn't work in Mosaic)
(defescape #\0 #\space)
(defescape #\s "")
(defescape #\e #\\)
(defescape #\\ #\\)
(defescape #\' #\')
(defescape #\` #\`)
(defescape #\p "<br>")     ; just break - can't spread like troff
(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 "&#173;")   ; `soft hyphen'
(defspecial 'co "&#169;")   ; copyright
(defspecial 'ap #\~)        ; approximates
(defspecial '~= #\~)
(defspecial 'cd "&#183;")   ; centered dot
(defspecial 'de "&#176;")   ; degree
(defspecial '>= "&gt;=")
(defspecial '<= "&lt;=")
(defspecial 'eq #\=)
(defspecial '== "==")
(defspecial 'mu "&#215;")   ; multiplication
(defspecial 'tm "&#174;")
(defspecial 'rg "&#174;")
(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" "&#188;")
(defspecial "12" "&#189;")
(defspecial "34" "&#190;")
(defspecial 'es "&#216;")
(defspecial '+- "&#177;")
(defspecial 'sc "&#167;")
(defspecial 'fm #\')        ; foot mark
(defspecial 'lh "&lt;=")
(defspecial 'rh "=&gt;")
(defspecial '-> "-&gt;")
(defspecial '<- "&lt;-")
(defspecial 'no "&#172;")   ; negation
(defspecial 'di "&#247;")   ; division
(defspecial 'ss "&#223;")
(defspecial ':a "&#228;")
(defspecial 'a: "&#228;")
(defspecial ':o "&#246;")
(defspecial 'o: "&#246;")
(defspecial ':u "&#252;")
(defspecial 'u: "&#252;")
(defspecial ':A "&#196;")
(defspecial 'A: "&#196;")
(defspecial ':O "&#214;")
(defspecial 'O: "&#214;")
(defspecial ':U "&#220;")
(defspecial 'U: "&#220;")
(defspecial 'ct "&#162;")   ; cent
(defspecial 'Po "&#163;")   ; pound
(defspecial 'Cs "&#164;")   ; currency sign
(defspecial 'Ye "&#165;")   ; yen
(defspecial 'ff "ff")
(defspecial 'fi "fi")
(defspecial 'fl "fl")
(defspecial 'Fi "ffi")
(defspecial 'Fl "ffl")
(defspecial 'S1 "&#185;")
(defspecial 'S2 "&#178;")
(defspecial 'S3 "&#179;")
(defspecial 'bb "&#166;")   ; broken bar
(defspecial 'r! "&#161;")   ; reverse exclamation mark
(defspecial 'r? "&#191;")   ; reverse question mark
(defspecial '!< "<")        ; the real < for generating html elements
(defspecial '!> ">")        ; the real > for generating html elements

(defspecial '*A "A")        ; greek
(defspecial '*B "B")        ; greek
(defspecial '*G (lambda _ (gifchar '*G)))
(defspecial '*D (lambda _ (gifchar '*D)))
(defspecial '*E "E")        ; greek
(defspecial '*Z "Z")        ; greek
(defspecial '*Y "H")        ; greek 
(defspecial '*H (lambda _ (gifchar '*H)))
(defspecial '*I "I")        ; greek
(defspecial '*K "K")        ; greek
(defspecial '*L (lambda _ (gifchar '*L)))
(defspecial '*M "M")        ; greek
(defspecial '*N "N")        ; greek
(defspecial '*C (lambda _ (gifchar '*C)))
(defspecial '*O "O")        ; greek
(defspecial '*P (lambda _ (gifchar '*P)))
(defspecial '*R "P")        ; greek
(defspecial '*S (lambda _ (gifchar '*S)))
(defspecial '*T "T")        ; greek
(defspecial '*U (lambda _ (gifchar '*U)))
(defspecial '*F (lambda _ (gifchar '*F)))
(defspecial '*X "X")        ; greek
(defspecial '*Q (lambda _ (gifchar '*Q)))
(defspecial '*W (lambda _ (gifchar '*W)))
(defspecial '*a (lambda _ (gifchar '*a)))
(defspecial '*b (lambda _ (gifchar '*b)))
(defspecial '*g (lambda _ (gifchar '*g)))
(defspecial '*d (lambda _ (gifchar '*d)))
(defspecial '*e (lambda _ (gifchar '*e)))
(defspecial '*z (lambda _ (gifchar '*z)))
(defspecial '*y (lambda _ (gifchar '*y)))
(defspecial '*h (lambda _ (gifchar '*h)))
(defspecial '*i (lambda _ (gifchar '*i)))
(defspecial '*k (lambda _ (gifchar '*k)))
(defspecial '*l (lambda _ (gifchar '*l)))
(defspecial '*m "&#181;")
(defspecial '*n (lambda _ (gifchar '*n)))
(defspecial '*c (lambda _ (gifchar '*c)))
(defspecial '*o (lambda _ (gifchar '*o)))
(defspecial '*p (lambda _ (gifchar '*p)))
(defspecial '*r (lambda _ (gifchar '*r)))
(defspecial '*s (lambda _ (gifchar '*s)))
(defspecial 'ts (lambda _ (gifchar 'ts)))
(defspecial '*t (lambda _ (gifchar '*t)))
(defspecial '*u (lambda _ (gifchar '*u)))
(defspecial '*f (lambda _ (gifchar '*f)))
(defspecial '*x (lambda _ (gifchar '*x)))
(defspecial '*q (lambda _ (gifchar '*q)))
(defspecial '*w (lambda _ (gifchar '*w)))

(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 `***'") "***"))

(define gif-table (make-table 100))

(define (gif-greek char gif align)
  (table-store! gif-table char (list gif align 'no)))

(gif-greek '*G "Gamma" "b")
(gif-greek '*D "Delta" "b")
(gif-greek '*H "Theta" "b")
(gif-greek '*L "Lambda" "b")
(gif-greek '*C "Xi" "b")
(gif-greek '*P "Pi" "b")
(gif-greek '*S "Sigma" "b")
(gif-greek '*U "Upsilon" "b")
(gif-greek '*F "Phi" "b")
(gif-greek '*Q "Psi" "b")
(gif-greek '*W "Omega" "b")
(gif-greek '*a "alpha" "b")
(gif-greek '*b "beta" "t")
(gif-greek '*g "gamma" "b")
(gif-greek '*d "delta" "b")
(gif-greek '*e "epsilon" "b")
(gif-greek '*z "zeta" "t")
(gif-greek '*y "eta" "t")
(gif-greek '*h "theta" "b")
(gif-greek '*i "iota" "b")
(gif-greek '*k "kappa" "b")
(gif-greek '*l "lambda" "b")
(gif-greek '*n "nu" "b")
(gif-greek '*c "xi" "t")
(gif-greek '*o "omicron" "b")
(gif-greek '*p "pi" "b")
(gif-greek '*r "rho" "t")
(gif-greek '*s "sigma" "b")
(gif-greek 'ts "sigma" "b")
(gif-greek '*t "tau" "b")
(gif-greek '*u "upsilon" "b")
(gif-greek '*f "phi" "b")
(gif-greek '*x "chi" "b")
(gif-greek '*q "psi" "b")
(gif-greek '*w "omega" "b")

(define (gifchar char)
  (let ((result (table-lookup gif-table char))
	(docname (option 'document)))
    (cond
      (result
	(if (not docname) (begin
	   (warn "can't translate \\(~a if no document given, ? used" char) 
	   "?")
	(let* ((charname (list-ref result 0))
	       (align (if (string=? "t" (list-ref result 1)) " align=top" ""))
	       (gifname (concat docname "." charname ".gif"))
	       (ref (concat "<img src=\"" gifname
				"\" alt=\"[" charname "]\"" align ">")))
	  (begin
	    (if (eq? 'no (list-ref result 2))
	      (begin
	        (if (not (= 0 (shell-command
	          (substitute "/bin/cp %directory%/misc/gifs/%1%.gif %2%" charname gifname))))
	      (warn "couldn't copy \\(~a - system problem" gifname))
	      (set-car! (cddr result) 'yes)))
	   ref))))
      (else (warn "no translation for \\(~a, ? used" char) "?"))))


;;; --------------------------------------------------------------------------
;;; 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 #\< "&lt;")
(defchar #\> "&gt;")
(defchar #\& "&amp;")

;;; Like parse, but also take char of `"':

(define (parse-unquote s)
  (let ((old (defchar #\" "&quot;")))
    (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.

;;; Processing for eqn saves all preceding eqn environment commands, which
;;; are emitted at the beginning of any equation to configure the environment.
;;; (G. Helffrich/U. Bristol)
;;;
;;; ***FIX*** If equation is in-line, it should be centered rather than
;;; aligned to the baseline.

(define (first-token x)
   (let loopi ((i 0) (imax (string-length x)))
      (cond
	 ((>= i imax) #f)
	 ((char=? #\space (string-ref x i)) (loopi (+ i 1) imax))
	 (else
	    (let loopj ((j i))
	       (cond
		  ((>= j imax) (substring x i imax))
		  ((not (char=? #\space (string-ref x j))) (loopj (+ j 1)))
		  (else (substring x i j))))))))

(define (filter-eqn-state x)
   (let ((token (first-token x)))
     (cond
       ((or (string=? token "delim")
	   (string=? token "gfont")
	   (string=? token "gsize")
	   (string=? token "ndefine")
	   (string=? token "tdefine")
	   (string=? token "define")) 
	  (begin
	     (with-output-appended-to-stream "[eqn-state]" (emit x))
	  #f))
       ((not token) #f)
       (else #t))))
   
(define (copy-preprocess for-eqn? proc-1 proc-2 stop inline)
  (cond
    (inline
      (emit inline #\newline stop #\newline)
      (filter-eqn-line inline))
    (else
      (let ((stop-len (string-length stop)))
      (let loop ((x (read-line-expand))
	         (use-output? (not for-eqn?)))
	   (let ((x-len (string-length x)))
           (cond ((eof-object? x) use-output?)
	         (else
	           (proc-1 (proc-2 x))
	           (if (string=? stop (substring x 0 (min x-len stop-len)))
		       ;; end of processing.  Check if .EN C, in which case
		       ;; following line should start .EQ, and both should
		       ;; be processed simultaneously.
		       (let ((mesee (substring x (min stop-len x-len)
					     (min (+ stop-len 2) x-len))))
		       (if (and for-eqn? (string=? " C" mesee))
			   (let* ((next (read-line))
				  (next-len (- (string-length next) 1)))
			     (if (string=? ".EQ C"
				   (substring next 0 (min 5 next-len)))
			       (begin
				 (emit (parse-expand next))
				 (loop (read-line-expand) use-output?))
			       (unread-line next))))
		       use-output?)
		       (loop (read-line-expand)
			     (or (not for-eqn?) 
				;; Bug fix.  filter-eqn-line does not recognize
				;; "delim off" because it includes the newline
				;; at the end-of-line in the test.  Strip \n
				;; before passing to filter-eqn-line
				(begin (filter-eqn-line (substring x 0 (- (string-length x) 1)))
				       (filter-eqn-state x)))))))))))))

(define image-seqnum 1)
(define troff-to-gif
    (lambda (processor start stop what args inline)
      (let ((docname (option 'document))
	    (filter (if (eq? processor 'tbl)
			 (apply spread (list (option 'tbl) "|" (option 'eqn)))
			 (option processor))))
        (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 "]\">"))
		   (use-output? #f))
	      (++ image-seqnum)
              (with-output-to-stream
	        (substitute (concat #\| filter
				    #\| (option 'troff-to-gif)) psname gifname)
		;; If generating tbl output, handle equations in table text by
		;; emitting an .EQ/.EN with the state information for eqn.  If
		;; no equations, this will do nothing, but if there are the
		;; proper initial eqn state will be set up.
		(if (eq? processor 'tbl) (begin
		   (emit ".EQ\n")
		   (emit (stream->string "[eqn-state]"))
		   (emit ".EN\n")))
	        (emit start #\space (apply spread args) #\newline)
		;; Emit saved state of eqn before any new equations
		(if (eq? processor 'eqn) (emit (stream->string "[eqn-state]")))
		(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-pic
    (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 "]\">"))
		   (use-output? #f))
	      (++ image-seqnum)
              (with-output-to-stream
	        (substitute
		   (concat #\| (option 'troff-to-pic))
		   (apply spread (if (null? (cddr args)) '("/dev/null") (cddr args)))
		   psname)
	        (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)
      ;; If generating tbl output, handle equations in table text by
      ;; emitting an .EQ/.EN with the state information for eqn.  If
      ;; no equations, this will do nothing, but if there are the
      ;; proper initial eqn state will be set up.
      (if (eq? processor 'tbl) (begin
        (emit ".EQ\n")
        (emit (stream->string "[eqn-state]"))
        (emit ".EN\n")))
      (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 #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)
	  ((string=? method "pic") troff-to-pic)
	  (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" "table" args #f)))

(defmacro 'EQ
  (lambda (EQ . args)
    ((troff-select-method 'handle-eqn) 'eqn ".EQ" ".EN" "equation" args #f)))

(defmacro 'PS
  (lambda (PS . args)
    ((troff-select-method 'handle-pic) 'pic ".PS" ".PE" "picture" args #f)))

(defmacro 'TE "")
(defmacro 'EN "")
(defmacro 'PE "")

(defequation
  (lambda (eqn)
    ((troff-select-method 'handle-eqn) 'eqn ".EQ" ".EN" "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)
	  (begin
	     (warn "negative indent on .ti ignored")
	    "<br>\n")
          (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
	  (concat (preform #t) (center (round (1+ n))))
	  (warn ".ce argument `~a' not understood" num)))))

(define lines-to-center 0)

(define (center n . previous?)
    (let ((centering? (if (null? previous?) (positive? lines-to-center) (car previous?))))
    (set! lines-to-center n)
    (defevent 'line 50 (if (positive? n) center-processor #f))
    (if (positive? n) "<center>" (if centering? "</center>\n" ""))))

(define (center-processor c)
  (let ((centering? (positive? lines-to-center)))
    (if (not (positive? (1- (-- lines-to-center))))
      (emit (concat (center 0 centering?) (preform #f))))))



;;; --------------------------------------------------------------------------
;;; 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 "<!-- This file has been generated by "
	  (substitute "%progname% %version%, %date% %time%. -->\n")
	  "<!-- Do not edit! -->\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
