;;;; -*-Scheme-*-
;;;;
;;;; $Revision: 1.14 $
;;;;
;;;; `ms' specific definitions for HTML output format


;;; --------------------------------------------------------------------------
;;; Options.

(define-option 'signature          'string    "")
(define-option 'split              'integer   0)
(define-option 'toc                'boolean   #t)
(define-option 'toc-header         'string    "Table of Contents")
(define-option 'pp-indent          'integer   3)
(define-option 'footnotes-header   'string    "Footnotes")
(define-option 'footnote-reference 'string    "[note %1%]")
(define-option 'footnote-anchor    'string    "[%1%]")



;;; --------------------------------------------------------------------------
;;; Predefined strings and number registers.

(defstring 'Q  "``")
(defstring 'U  "''")
(defstring '-  "--")    ; em-dash
(defstring 'MO (substitute "%monthname+%"))
(defstring 'DY (substitute "%monthname+% %day%, %year%"))

(defnumreg 'PN #\0)



;;; --------------------------------------------------------------------------
;;; General bookkeeping.


(define split-sections? #f)    ; #t if `split' option is positive


(define-pair abstract   abstract?   ""               "<hr>\n")
(define-pair title      title?      "<h1>\n"         "</h1>\n")
(define-pair secthdr    secthdr?    "<h2>\n"         "</h2>\n")
(define-pair tag-para   tag-para?   "<dl>\n"         "</dl>\n")
(define-pair list-para  list-para?  "<ul>\n"         "</ul>\n")
(define-pair quoted     quoted?     "<blockquote>\n" "</blockquote>\n")

(define (reset-everything)
  (emit
    (reset-font)
    (center 0)
    (quoted #f)
    (secthdr #f)
    (preform #f)
    (tag-para #f)
    (list-para #f)
    (reset-title-features))
  (header-processor #f))

(define-nested-pair indent  indent-level  "<dl><dt><dd>\n" "</dl>\n")



;;; --------------------------------------------------------------------------
;;; Manage HTML output files.

(define HTML-streams '())

(define (push-HTML-stream file-suffix title-suffix)
  (let* ((docname (option 'document))
	 (title (option 'title))
	 (t (concat (if title title docname) title-suffix))
	 (fn (if file-suffix (concat docname file-suffix ".html") #f))
	 (s (if fn (open-output-stream fn) #f)))
    (close-stream (set-output-stream! #f))
    (set-output-stream! s)
    (list-push! HTML-streams fn)
    (emit-HTML-prolog)
    (emit "<title>" (translate t) "</title>\n</head><body>\n")))

(define (pop-HTML-stream)
  (if (not (eqv? (option 'signature) ""))
      (emit "<p><hr>\n" (substitute (option 'signature))) #\newline)
  (emit "</body>\n</html>\n")
  (list-pop! HTML-streams)
  (close-stream (set-output-stream! #f))
  (if (and (not (null? HTML-streams)) (car HTML-streams))
      (set-output-stream! (append-output-stream (car HTML-streams)))))



;;; --------------------------------------------------------------------------
;;; Callback procedure called by hyper.scm when creating hypertext anchor.

(define (query-anchor request label)
  (lambda (op)
    (case op
      (allowed?       #t)
      (emit-anchor?   #t)
      (filename
	(if (not (stream-file? (output-stream)))
	    (car HTML-streams)
	    (stream-target (output-stream)))))))



;;; --------------------------------------------------------------------------
;;; Generate hypertext reference and anchor.

(define (make-href type index contents)
  (let* ((docname (option 'document))
	 (file
	   (case type
	   ((section toc) (car HTML-streams))
	   (footnote (if split-sections? (concat docname "-notes.html") "")))))
    (format #f "<a href=\"~a#~a~a\">~a" file type index
	       (if contents (concat contents "</a>\n") ""))))

(define (make-anchor type index contents)
  (format #f "<a name=\"~a~a\">~a</a>" type index contents))



;;; --------------------------------------------------------------------------
;;; Automatically generated TOC.

(define auto-toc-entry
  (let ((last-level 0))
    (lambda (anchor entry level labelnum)
      (with-output-appended-to-stream "[autotoc]"
	(emit (repeat-string (- level last-level) "<ul>")
	      (repeat-string (- last-level level) "</ul>"))
	(set! last-level level)
	(if (positive? level)
	    (emit "<li>" (make-href 'section labelnum anchor) entry))))))

(define (auto-toc-spill)
  (auto-toc-entry "" "" 0 0)
  (let ((toc (stream->string "[autotoc]")))
    (if (not (eqv? toc ""))
	(emit "<h2>" (substitute (option 'toc-header)) "</h2>\n" toc))))



;;; --------------------------------------------------------------------------
;;; Start and exit event functions.

(defevent 'start 10
  (lambda _
    (set! split-sections? (positive? (option 'split)))
    (let ((docname (option 'document)))
      (if (not (or docname (option 'title)))
	  (quit "you must set either document= or title="))
      (if (and split-sections? (not docname))
	  (quit "you must set document= for non-zero `split'"))
      (push-HTML-stream (if docname "" #f) ""))))

(defevent 'exit 10
  (lambda _
    (reset-everything)
    (emit (indent 0))
    (footnote-processor 'spill)
    (do () ((null? (cdr HTML-streams))) (pop-HTML-stream))
    (if (option 'toc)
        (auto-toc-spill))
    (pop-HTML-stream)))



;;; --------------------------------------------------------------------------
;;; Title features, abstract.

(define got-title? #f)

(define (reset-title-features)
  (concat (title #f)
	  (begin1 (if got-title? "<hr>\n" "") (set! got-title? #f))))

(defmacro 'TL
  (lambda _
    (cond
      (got-title?
	(warn ".TL is only allowed once"))
      (else
        (reset-everything)
        (set! got-title? #t)
        (title #t)))))

(defmacro 'AU
  (lambda _
    (emit (title #f) "<p>\n" (change-font 2))
    (center 999)))

(defmacro 'AI
  (lambda _
    (emit (title #f) "<br>\n" (change-font 1))
    (center 999)))

(defmacro 'AB
  (lambda (AB . args)
    (reset-everything)
    (abstract #t)
    (cond ((null? args)
	    "<h2>ABSTRACT</h2>\n<p>\n")
          ((string=? (car args) "no")
	    "<p>\n")
	  (else
	    (concat "<h2>" (parse (car args)) "</h2>\n<p>\n")))))

(defmacro 'AE
  (lambda _
    (cond (abstract?  (reset-everything) (abstract #f))
	  (else       (warn ".AE without preceding .AB")))))



;;; --------------------------------------------------------------------------
;;; Numbered sections.

(define sections (list 0))

(define (increment-section! s n)
  (if (positive? n)
      (increment-section! (cdr s) (1- n))
      (set-car! s (if (char? (car s))
		      (integer->char (modulo (1+ (char->integer (car s))) 256))
		      (1+ (car s))))
      (set-cdr! s '())))

(define (section-number s n)
  (if (zero? n)
      ""
      (format #f "~a.~a" (car s) (section-number (cdr s) (1- n)))))

(define (verify-section-number s)
  (cond ((eqv? s "") #f)
	((string->number s) (string->number s))
	((char-alphabetic? (string-ref s 0)) (string-ref s 0))
	(else #f)))

(define (numbered-section args)
  (cond
    ((null? args)
      (increment-section! sections 0)
      (defstring 'SN (section-number sections 1))
      1)
    ((string=? (car args) "S")
      (cond
	((null? (cdr args))
	  (warn ".NH with `S' argument but no numbers")
	  1)
	(else
	  (let ((new (map verify-section-number (cdr args))))
	    (if (memq #f new)
		(warn "bad section number in .NH request")
		(set! sections new))
	    (defstring 'SN (section-number new (length new)))
            (length new)))))
    (else
      (let ((level (string->number (car args))))
	(if (not level)
	    (begin
	      (warn "~a is not a valid section level" (car args))
	      (set! level 1)))
	(if (< (length sections) level)
	    (append! sections (make-list (- level (length sections)) 0)))
	(increment-section! sections (1- level))
	(defstring 'SN (section-number sections level))
	level))))

(defmacro 'NH
  (lambda (NH . args)
    (reset-everything)
    (emit (indent 0))
    (let ((level (numbered-section args)))
      (if (and split-sections? (<= level (option 'split)))
	  (let* ((sect (stringdef 'SN))
	         (suff (concat #\- (string-prune-right sect "." sect))))
	    (push-HTML-stream suff (concat ", section " sect))))
      (header-processor #t level))))

(define header-processor
  (let ((stream #f) (inside? #f) (seq 1) (level 0))
    (lambda (enter? . arg)
      (cond
	((and enter? (not inside?))
	  (set! level (car arg))
	  (set! stream (set-output-stream! (open-output-stream "[header]"))))
	((and inside? (not enter?))
	  (close-stream (set-output-stream! stream))
	  (let ((hdr (stream->string "[header]"))
		(sectno (stringdef 'SN)))
	    (cond
	      ((and split-sections? (option 'toc))
	        (auto-toc-entry (concat sectno #\space) hdr level seq)
	        (emit "<h2>" (make-anchor 'section seq sectno)))
	      (else
		(emit "<h2>" sectno)))
	    (emit nbsp hdr "</h2>\n")
	    (++ seq))))
      (set! inside? enter?)
      "")))



;;; --------------------------------------------------------------------------
;;; Font switching and related requests.

(define (with-font font . args)
  (let ((old current-font))
  (cond
    ((null? args)
       (concat (change-font font) #\newline))
    ((null? (cdr args))
       (concat (change-font font) (parse (car args) #\newline)
	       (change-font old)))
    (else
       (concat (change-font font) (parse (car args)) (change-font old)
	       (parse (cadr args) #\newline))))))

(defmacro 'I with-font)
(defmacro 'B with-font)
(defmacro 'R with-font)

(defmacro 'UL (lambda (UL) (with-font "I")))    ; <u> doesn't work

(defmacro 'SM
  (lambda (SM . words)
    (if (null? words) "" (parse (apply spread words) #\newline))))

(defmacro 'LG (requestdef 'SM))



;;; --------------------------------------------------------------------------
;;; Indented paragraph with optional label.

(define (indented-paragraph IP . arg)
  (define (non-tagged? s)
    (or (null? s) (member (car s) '("\\(bu" "\\(sq" "\\-"))))
  (emit (reset-font) (secthdr #f) (reset-title-features))
  (header-processor #f)
  (cond
    (preform?
      (surprise ".IP inside .nf/.fi")
      (if (not (null? arg)) (concat (parse (car arg)) #\newline) #\newline))
    (tag-para?
      (if (null? arg)
	  "<dt><dd><p>\n"
	  (concat "<dt>" (parse (car arg)) "<dd>\n")))
    (list-para?
      (cond
	((non-tagged? arg)
	  "<li>\n")
	(else
          (warn ".IP `arg' in a list that was begun as non-tagged")
          (concat "<li>" (parse (car arg)) "<br>\n"))))
    ((non-tagged? arg)
      (concat (list-para #t) (indented-paragraph IP)))
    (else
      (concat (tag-para #t) (indented-paragraph IP (car arg))))))

(defmacro 'IP indented-paragraph)



;;; --------------------------------------------------------------------------
;;; Relative indent.

(define (relative-indent request . _)
  (if preform?
      (surprise ".RS/.RE inside .nf/.fi"))
  (emit (reset-font) (tag-para #f) (list-para #f))
  (with-preform-preserved
    (indent (if (string=? request "RS") '+ '-))))

(defmacro 'RS relative-indent)
(defmacro 'RE relative-indent)



;;; --------------------------------------------------------------------------
;;; Displays.

(define display-saved-font #f)
(define inside-display? #f)
(define indented-display? #f)

(define (display-start type)
;;(if (or (string=? type "C") (string=? type "B"))
;;    (begin
;;      (warn "display type ~a not supported (using I)" type)
;;      (set! type "I")))
  (cond
    ((or (not (= (string-length type) 1))
	 (not (memq (string-ref type 0) '(#\I #\L #\C #\B))))
      (warn "illegal display type `~a'" type))
    (inside-display?
      (warn "nested display ignored"))
    (preform?
      (warn "display inside .nf/.fi ignored"))
    (else
      (set! display-saved-font current-font)
      (emit (reset-font))
      (set! indented-display? (string=? type "I"))
      (if indented-display?
          (emit (indent '+))
	  (emit "<br>"))
      (if (string=? type "C") (emit (center 999)))
      (set! inside-display? #t)
      (preform #t))))

(defmacro 'DS
  (lambda (DS . args)
    (display-start (if (null? args) "I" (car args)))))

(defmacro 'ID (lambda _ (display-start "I")))
(defmacro 'LD (lambda _ (display-start "L")))
(defmacro 'CD (lambda _ (display-start "C")))
(defmacro 'BD (lambda _ (display-start "B")))

(defmacro 'DE
  (lambda _
    (cond
      ((not inside-display?)
	(warn ".DE without matching display start"))
      (else
	(set! inside-display? #f)
	(emit
	  (with-font-preserved
	    (preform #f)
	    (if indented-display? (indent '-) ""))
	  (change-font display-saved-font))
	""))))



;;; --------------------------------------------------------------------------
;;; Footnotes.

;; Generating \[***] for \** allows us to defer creating the anchor from
;; string expansion time to output time.  Otherwise we couldn't use <...>.

(defstring '* "\\[***]")

(define **-count 0)

(defspecial '***
  (lambda _
    (++ **-count)
    (footnote-anchor (substitute (option 'footnote-reference)
				 (number->string **-count)))))

(define next-footnote 0)

(define (footnote-anchor sym)
  (++ next-footnote)
  (with-font-preserved
    (concat (change-font 1) (make-href 'footnote next-footnote sym))))

;; New request to generate a footnote anchor; an alternative to \**.
;; Should be followed by .FS.  Do not use `.FA \**'.

(defmacro 'FA
  (lambda (FA arg) (footnote-anchor (parse arg))))


(define footnote-processor
  (let ((stream #f) (inside? #f))
    (lambda (op . arg)
      (case op
      (begin
        (cond
	  (inside?
	    (surprise "nested .FS"))
	  (else
	    (set! inside? #t)
	    (set! stream (set-output-stream!
			   (append-output-stream "[footnotes]")))
	    (emit "<p>\n")
	    (let ((anchor
		    (cond ((not (null? arg))
			    (parse (car arg)))
			  ((positive? **-count)
			    (substitute (option 'footnote-anchor)
					(number->string **-count)))
			  (else #f))))
	      (if anchor
		  (emit "<b>" (make-anchor 'footnote next-footnote anchor)
			"</b>" nbsp))))))
      (end
	(cond
	  (inside?
	    (set! inside? #f)
	    (close-stream (set-output-stream! stream)))
	  (else (warn ".FE without matching .FS"))))
      (spill
	(if inside? (quit "unterminated footnote at end of document"))
	(let ((contents (stream->string "[footnotes]"))
	      (hdr (substitute (option 'footnotes-header))))
	  (cond
	    ((not (eqv? contents ""))
	       (if split-sections?
		   (push-HTML-stream "-notes" ", footnotes"))
	       (cond ((and split-sections? (option 'toc))
		       (auto-toc-entry hdr "" 1 0)
		       (emit "<h2>" (make-anchor 'section 0 hdr)))
		     (else (emit "<h2>" hdr)))
	       (emit "</h2>\n" contents))
	    ((positive? next-footnote)
	      (warn "footnote anchor used, but no .FS"))))))
    "")))

(defmacro 'FS
  (lambda (FS . arg)
    (apply footnote-processor 'begin arg)))

(defmacro 'FE
  (lambda _ (footnote-processor 'end)))



;;; --------------------------------------------------------------------------
;;; TOC macros.

(define toc-processor
  (let ((stream #f) (inside? #f) (seq 1))
    (lambda (op . arg)
      (case op
      (begin
        (cond
	  (inside?
	    (surprise "nested .XS"))
	  (else
	    (set! inside? #t)
	    (emit (make-anchor 'toc seq "&#160;") #\newline)
	    (set! stream (set-output-stream! (append-output-stream "[toc]")))
	    (if (>= (length arg) 2)
		(emit
		  (repeat-string
		    (get-hunits (parse-expression (cadr arg) 0 #\n)) nbsp)))
	    (if (option 'document)
	        (emit (make-href 'toc seq #f)))
	    (++ seq))))
      (end
	(cond
	  (inside?
	    (set! inside? #f)
	    (if (option 'document) (emit "</a>\n"))
	    (emit "<br>\n")
	    (close-stream (set-output-stream! stream)))
	  (else (warn ".XE or .XA without matching .XS"))))
      (spill
	(if inside? (quit "unterminated .XE"))
	(if (or (null? arg) (not (string=? (car arg) "no")))
	    (emit "<h2>Table of Contents</h2>\n"))
	(emit (stream->string "[toc]"))))
    "")))

(defmacro 'XS
  (lambda (XS . arg)
    (apply toc-processor 'begin arg)))

(defmacro 'XE (lambda _ (toc-processor 'end)))
(defmacro 'XA (lambda _ (toc-processor 'end) (toc-processor 'begin)))

(defmacro 'PX
  (lambda (PX . arg)
    (apply toc-processor 'spill arg)))


;;; --------------------------------------------------------------------------
;;; Paragraphs of various kinds.

(define-macro (define-paragraph request . body)
  `(defmacro ,request (lambda _ (reset-everything) ,@body)))

(define-paragraph 'LP "<p>\n")
(define-paragraph 'PP (concat "<p>\n"
			      (repeat-string (option 'pp-indent) nbsp)))
(define-paragraph 'QP (quoted #t))
(define-paragraph 'SH (secthdr #t))
(define-paragraph 'RT)



;;; --------------------------------------------------------------------------
;;; Requests that must be ignored, either because the function cannot
;;; be expressed in HTML or because they assume a page structure.

(defmacro 'AM "")    ; better accents
(defmacro 'BT "")    ; bottom title
(defmacro 'CM "")    ; cut mark between pages
(defmacro 'CT "")    ; chapter title
(defmacro 'DA "")    ; force date at page bottom
(defmacro 'EF "")    ; even footer
(defmacro 'EH "")    ; even header
(defmacro 'HD "")    ; optional page header
(defmacro 'KE "")    ; keep end
(defmacro 'KF "")    ; floating keep
(defmacro 'KS "")    ; keep
(defmacro 'ND "")    ; no date in footer
(defmacro 'NL "")    ; reset point size to normal
(defmacro 'OF "")    ; odd footer
(defmacro 'OH "")    ; odd header
(defmacro 'P1 "")    ; print header on 1st page
(defmacro 'PT "")    ; page title
(defmacro 'TM "")    ; UCB thesis mode

(defmacro 'BX        ; boxed word
  (lambda (BX word)
    (parse word #\newline)))

(define (multi-column-ignored request . _)
  (warn "multi-column request .~a not supported" request))

(defmacro 'MC multi-column-ignored)
(defmacro '1C multi-column-ignored)
(defmacro '2C multi-column-ignored)



;;; --------------------------------------------------------------------------
;;; Anachronisms, kludges, etc.

(defmacro 'UX "UNIX")

(defmacro 'B1 "<hr>\n")
(defmacro 'B2 "<hr>\n")
