;;;; -*-Scheme-*-
;;;;
;;;; $Revision: 1.14 $
;;;;
;;;; `me' specific definitions for HTML output format
;;;; Hacked from ms version by G. Helffrich/U. Bristol


;;; --------------------------------------------------------------------------
;;; 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    "<b>[%1%]</b>")
(define-option 'footnote-anchor    'string    "")



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

(defstring 'lq  "``")
(defstring 'rq  "''")
(defstring '-  "--")    ; em-dash
(defstring 'mo (substitute "%monthname+%"))
(defstring 'dw (substitute "%weekday+%"))
(defstring 'dy (substitute "%day%"))
(defstring 'td (substitute "%monthname+% %day%, %year%"))

(defnumreg '$c #\1)
(defnumreg '$f #\1)
(defnumreg '$m #\2)
(defnumreg '$n #\2)
(defnumreg '$0 "")
(defnumreg '$1 "")
(defnumreg '$2 "")
(defnumreg '$3 "")
(defnumreg '$4 "")
(defnumreg '$5 "")
(defnumreg '$6 "")
(defstring '$n "")


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


(define para-number 0)         ; numbered paragraph number
(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 compact>\n" "</dl>\n")
(define-pair list-para  list-para?  "<ul>\n"         "</ul>\n")
(define-pair quoted     quoted?     "<blockquote>\n" "</blockquote>\n")

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

(define-nested-pair indent  indent-level  "<dl><dt><dd>" "</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>") ""))))

(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? (not (zero? (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 footnotes '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))))

(define in-section #f)

(defmacro '+c
  (lambda (_ . hdr)
    (if (not (null? hdr))
      (cond
	((not in-section) (parse (car hdr)))
	((string=? in-section "P")
	   (concat (title #t) (parse (car hdr)) (title #f)))
	((string=? in-section "AB")
	   (concat (abstract #t) (parse (car hdr)) nbsp))
	((or (string=? in-section "A")
	     (string=? in-section "B")
	     (string=? in-section "C")
	     (string=? in-section "RC")
	     (string=? in-section "RA"))
		(concat (secthdr #t) (parse (car hdr)) (secthdr #f)))
	(else (begin (warn ".+c unknown section ~a" in-section) (parse hdr))))
      "")))

(defmacro '++
  (lambda (_ section . arg)
    (if (not (member (parse section) '("C" "A" "P" "AB" "B" "RC" "RA")))
      (warn ".++ ~a ignored" section)
      (set! in-section (parse section)))
      (if abstract? (abstract #f) "")))


;;; --------------------------------------------------------------------------
;;; Sections.

;; If splitting sections, only prefix the header text with the section number
;; if dealing with sections > 0.
(define header-processor
  (let ((seq 0))
    (lambda (hdr depth)
    (cond
      ((and split-sections? (option 'toc))
	  (++ seq)
	  (auto-toc-entry hdr "" depth (stringdef '$n))
	  (emit "<h2>" 
		(make-anchor 'section seq (stringdef '$n))))
      (else
        (if (macrodef '$0)
	  (emit (parse-line
		  (format #f ".$0 \"~a\" ~a ~a" hdr (stringdef '$n) depth))))
	  (emit "<h2>")))
    (emit hdr "</h2>\n")
      "")))

;;; @d from -me macros
;;;   1st param is level, next (up to) 6 are the level values to set
(define (@d . args)
    (if (and (not (null? args)) (string->number (car args)))
      (defnumreg '$0 (car args)))
    (if (and (positive? (string->number (numregdef '$0))) (not (null? (cdr args))))
      (let ((reg (format #f "$~a" (numregdef '$0))))
	(defnumreg reg
	  (number->string (if (and (numregdef reg)
				   (string->number (numregdef reg)))
				   (1+ (string->number (numregdef reg)))
				   1)))))
    (let (($n ""))
      (if (>= (string->number (numregdef '$0)) 1)
	(begin
	  (if (or (not (numregdef '$1)) (string=? "" (numregdef '$1)))
	    (defnumreg '$1 "1"))
	  (if (and (>= (length args) 3) (not (string=? "-" (list-ref args 2))))
	    (defnumreg '$1 (list-ref args 2)))
	  (set! $n (format #f "~a" (numregdef '$1))))
	(defnumreg '$1 ""))
      (do
	((i 2 (+ i 1)))
	((> i 6))
	 (let ((reg (format #f "$~a" i)))
	   (if (>= (string->number (numregdef '$0)) i)
	     (begin
	       (if (or (not (numregdef reg)) (string=? "" (numregdef reg)))
	         (defnumreg reg "1"))
	       (if (and (>= (length args) (+ i 2)) (not (string=? "-" (list-ref args (1+ i)))))
	         (defnumreg reg (list-ref args (1+ i))))
	     (set! $n (format #f "~a.~a" $n (numregdef reg))))
	   (defnumreg reg ""))))
      (defstring '$n $n)))

;; .uh headings are considered level zero, and are split if split<0.
(defmacro 'uh
  (lambda (uh . args)
    (let ((hdr (if (> 1 (length args)) (parse (cadr args)) '())))
      (reset-everything)
      (header-processor hdr 0))))

(defmacro 'sh
  (lambda (sh . args)
    (let ((level (if (null? args) args (parse (car args))))
	  (hdr (if (> (length args) 1) (parse (cadr args)) '()))
	  (rest  (if (> (length args) 2) (parse (cddr args)) '())))
      (reset-everything)
      (apply @d (append (list level '+ ) rest))
      (header-processor hdr (if (null? level) 0 (string->number level))))))


;;; --------------------------------------------------------------------------
;;; 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 (lambda (i . args)
   (apply with-font (cons "I" args))))
(defmacro 'b (lambda (b . args) 
   (apply with-font (cons "B" args))))
(defmacro 'r (lambda (r . args)
   (apply with-font (cons "R" args))))
(defmacro 'rb (lambda (rb . args)
   (apply with-font (cons "R" args))
   (change-font "B")))

(defmacro 'bi (requestdef 'rb))

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

(defmacro 'q
  (lambda (q . args)
    (let ((old current-font))
    (if (null? args) ""
      (concat "``" (parse (car args)) "''" (if (null? (cdr args)) "" (parse (cadr args))) #\newline)))))

(defmacro 'bx
  (lambda (bx word)
    (parse word #\newline)))

(defmacro 'sz "")

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

(define (indented-paragraph op . arg)
  (define (non-tagged? s)
    (or (null? s) (member (car s) '("\\(bu" "\\(sq" "\\-"))))
  (if (equal? op "np")
    (begin
      (++ para-number)
      (indented-paragraph "ip" (number->string para-number)))
    (begin
    (emit (reset-font) (preform #f) (secthdr #f) (reset-title-features))
    (cond
      (tag-para?
        (if (null? arg)
	  "<dt><dd>"
	  (concat "<dt>" (parse (car arg)) "<dd>")))
      (list-para?
        (cond
	  ((non-tagged? arg)
	    "<li>")
	  (else
            (warn ".~a `arg' in a list that was begun as non-tagged" op)
            (concat "<li>" (parse (car arg)) "<br>\n"))))
      ((non-tagged? arg)
        (concat (list-para #t) (indented-paragraph op)))
      (else
        (concat (tag-para #t) (indented-paragraph op (car arg))))))))

(defmacro 'ip indented-paragraph)

(defmacro 'np indented-paragraph)


;;; --------------------------------------------------------------------------
;;; Displays.
;;; 
;;; **.(z .)z problem - .(q and .(c should be nestable inside these.
;;; **should be treated more like a footnote or delayed text rather than a
;;; **block.

(define left-paren-b "(b")
(define right-paren-b ")b")
(define left-paren-q "(q")
(define right-paren-q ")q")
(define left-paren-c "(c")
(define right-paren-c ")c")
(define left-paren-l "(l")
(define right-paren-l ")l")
(define left-paren-z "(z")
(define right-paren-z ")z")
(define display-saved-font #f)
(define inside-display? #f)
(define indented-display? #f)

(define (display-start type fill)
  (cond
    ((or (not (= (string-length type) 1))
	 (not (memq (string-ref type 0) '(#\I #\L #\C #\M))))
      (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)
      (if (not (string=? fill "F")) (emit (preform #t)))))
  "")

(defmacro left-paren-b
  (lambda (_ . args)
    (apply display-start
      (cond
        ((null? args) '("I" "U"))
	((null? (cdr args)) (if (string=? (car args) "F") '("I" "F") (list (car args) "U")))
	(else args)))
    ""))

(defmacro left-paren-l (macrodef left-paren-b))
(defmacro left-paren-z
  (lambda (_ . args)
    (apply display-start
      (cond
        ((null? args) '("M" "U"))
	((null? (cdr args)) (if (string=? (car args) "F") '("M" "F") (list (car args) "U")))
	(else args)))
    ""))

(define (display-end what)
   (cond
     ((not inside-display?)
	(warn ".~a without matching display start" what))
      (else
	(set! inside-display? #f)
	(emit
	  (with-font-preserved
	    (preform #f)
	    (if indented-display? (indent '-) "")
	    (center 0))
	  (change-font display-saved-font)))))

(defmacro right-paren-b 
  (lambda _ (display-end right-paren-b)))

(defmacro right-paren-l 
  (lambda _ (display-end right-paren-l)))

(defmacro right-paren-z 
  (lambda _ (display-end right-paren-z)))

(defmacro left-paren-c         ; can't center in a block like troff
  (lambda (_ . args)
    (concat (preform #t) (center 999))))

(defmacro right-paren-c 
  (lambda (_ . args)
    (concat (center 0) (preform #f))))

(defmacro left-paren-q
  (lambda (_ . args)
    (emit
      (reset-font)
      (center 0)
      (quoted #f)
      (preform #f)
      (quoted #t))))

(defmacro right-paren-q
  (lambda (_ . args)
    (emit (quoted #f))))


;;; --------------------------------------------------------------------------
;;; Footnotes and delayed text.

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

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

(define **-count (cons 1 #f))

(defspecial '***
  (lambda _
    (let ((inside? (cadr footnotes))
	  (anchor (substitute (option 'footnote-reference)
				 (number->string (car **-count)))))
      (set-cdr! **-count #t)
      (if inside? anchor (footnote-anchor anchor (car **-count))))))

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


;; Both footnotes and delayed text are processed here.  Delayed text never gets
;; split off into another document, but waits for .pd for inclusion.

(define footnotes (list '".(f" '#f '#f '"[footnotes]"))
(define delayed   (list '".(d" '#f '#f '"[delayed-text%1%]"))
(define delayed-number 0)

(define footnote-processor
   (lambda (what op . arg)
     (let  ((stream-name (substitute (cadddr what) (number->string delayed-number)))
	    (inside? (cadr what))
	    (stream (caddr what))
	    (req (car what))
	    (footnotes? (eq? what footnotes)))
     (case op
     (begin
        (cond
	  (inside?
	    (warn "nested ~a" req))
	  (else
	    (set! inside? #t) (set-car! (cdr what) #t)
	    (if footnotes? (set-cdr! **-count #f))
	    (set! stream (set-output-stream!
			   (append-output-stream stream-name)))
	    (set-car! (cddr what) stream)
	    (emit "<br>\n")
	    (let ((anchor
		    (cond ((not (null? arg))
			    (parse (car arg)))
			  ((positive? (car **-count))
			    (substitute (option 'footnote-anchor)
					(number->string (car **-count))))
			  (else #f))))
	      (if anchor
		  (emit (make-anchor 'footnote (car **-count) anchor)))))))
      (end
	(cond
	  (inside?
	    (set! inside? #f) (set-car! (cdr what) #f)
	    (close-stream (set-output-stream! stream))
	    (set-car! (cddr what) #f)
	    (if (and footnotes? (cdr **-count)) (set-car! **-count (1+ (car **-count)))))
	  (else (warn ".)~a without matching ~a" (string-ref req 2) req))))
      (spill
	(if inside? (quit "unterminated ~a at end of document" req))
	(let ((contents (stream->string stream-name))
	      (hdr (substitute (if footnotes? (option 'footnotes-header) ""))))
	  (close-stream stream) (set! stream #f) (set-car! (cddr what) #f)
	  (cond
	    ((not (eqv? contents ""))
	       (if (and split-sections? footnotes?)
		   (push-HTML-stream "-notes" ", footnotes"))
	       (cond ((and split-sections? footnotes? (option 'toc))
		       (auto-toc-entry hdr "" 1 0)
		       (emit "<h2>" (make-anchor 'section 0 hdr) "</h2>\n"))
		     (else (if (not (eq? hdr "")) (emit "<h2>" hdr "</h2>\n"))))
	       (emit contents "<br>\n"))
	    ((and footnotes? (cdr **-count))
	      (warn "footnote anchor used, but no .(f"))))))
    "")))

(define left-paren-f "(f")
(define right-paren-f ")f")
(define left-paren-d "(d")
(define right-paren-d ")d")

(defmacro left-paren-f
  (lambda (left-paren-f . arg)
    (apply footnote-processor footnotes 'begin arg)))

(defmacro right-paren-f
  (lambda _ (footnote-processor footnotes 'end)))

(define delayed-# 1)
(define delayed-#-refs 0)
(define delayed-#-refs-save 0)
(defnumreg '$d 
  (lambda _
    (number->string delayed-#)))

(defstring '\#
  (lambda _
    (++ delayed-#-refs)
    (number->string delayed-#)))

(defmacro left-paren-d
  (lambda (left-paren-d . arg)
    (set! delayed-#-refs-save delayed-#-refs)
    (apply footnote-processor delayed 'begin arg)))

(defmacro right-paren-d
  (lambda _ 
    (footnote-processor delayed 'end)
    (if (not (eq? delayed-#-refs-save delayed-#-refs)) (++ delayed-#))
    ""))

(defmacro 'pd
  (lambda _
     (footnote-processor delayed 'spill)
     (++ delayed-number)
     ""))



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


(define toc-keys
   (lambda new 
      (list (cons 'name new) (cons 'stream #f) (cons 'inside? #f))))

(define toc-list (list (cons "toc" (toc-keys "toc"))))

(define toc-processor
  (let ((seq 0))
  (lambda (op . arg)
  (define (toc-stream x) (string-append "[" x "]"))
  (define (toc-field x y) (if y (cdr (assq x y)) #f))
  (define (toc-field-set x y z) (set-cdr! (assq x y) z))
    (let* ((x (string-append "toc" (parse (car arg))))
	   (toc (assoc x toc-list)))
      (if (not toc) (begin
	(set! toc-list (append toc-list (list (cons x (toc-keys x)))))
	(set! toc (assoc x toc-list))))
      (case op
      (begin
        (cond
	  ((toc-field 'inside? toc)
	    (warn "nested .~a" left-paren-x))
	  (else
	    (toc-field-set 'inside? toc #t)
	    (emit (make-anchor 'toc seq "&#160;") #\newline)
	    (toc-field-set 'stream toc
	       (set-output-stream! (append-output-stream (toc-stream x))))
	    (if (option 'document)
	        (emit (make-href 'toc seq #f)))
	    (++ seq))))
      (end
	(cond
	  ((toc-field 'inside? toc)
	    (toc-field-set 'inside? toc #f)
	    (if (option 'document) (emit "</a>\n"))
	    (emit "<br>\n")
	    (close-stream (set-output-stream! (toc-field 'stream toc))))
	  (else (warn ".~a without matching .~a" right-paren-x left-paren-x))))
      (spill
	(if (toc-field 'inside? toc) (warn "unterminated .~a" right-paren-x))
	(emit (stream->string (toc-stream x)))))
      )
    "")))

(define left-paren-x "(x")
(define right-paren-x ")x")
(define toc-active "x")

(defmacro left-paren-x
  (lambda (_ . arg)
    (let ((this (if (null? arg) toc-active (parse (car arg)))))
      (apply toc-processor 'begin this (if (null? arg) '() (cdr arg)))
      (set! toc-active this)
      "")))

(defmacro right-paren-x 
  (lambda (_ . arg)
    (apply toc-processor 'end toc-active arg)))

(defmacro 'xp
  (lambda (xp . arg)
    (reset-everything)
    (apply toc-processor 'spill (if (null? arg) '(x) 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)))

(defmacro 'hl "<hr>\n") ; horizontal line across page

;;; Base indent applies to paragraphs, everything except titles & footnotes
;;; so it persists even across sections.  Only .ba 0 shuts it off.
(defmacro 'ba
  (lambda (ba . arg)
    (cond
      ((null? arg) (indent '-))
      ((and (string? (car arg)) (zero? (string->number (car arg)))) (indent 0))
      (else (indent '+)))))


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

(defmacro 're "")    ; reset tabs
(defmacro 'll "")    ; line length
(defmacro 'xl "")    ; line length
(defmacro 'lh "")    ; letterhead
(defmacro 'he "")    ; header
(defmacro 'fo "")    ; footer
(defmacro 'eh "")    ; even header
(defmacro 'oh "")    ; odd header
(defmacro 'ef "")    ; even footer
(defmacro 'of "")    ; odd footer
(defmacro 'hx "")    ; suppress headers & footers on next page
(defmacro 'm1 "")    ; top of page spacing
(defmacro 'm2 "")    ; header to first line spacing
(defmacro 'm3 "")    ; footer to last line spacing
(defmacro 'm4 "")    ; footer to bottom of page spacint
(defmacro '$h "")    ; print header
(defmacro '$f "")    ; print footer
(defmacro '$H "")    ; top-of-page macro
(defmacro 'th "")    ; UCB thesis mode
(defmacro 'ac "")    ; ACM mode
(defmacro 'sk "")    ; skip page
(defmacro 'ro "")    ; roman page number
(defmacro 'ar "")    ; arabic page number
(defmacro 'pa "")    ; begin page N

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

(defmacro '1c multi-column-ignored)
(defmacro '2c multi-column-ignored)
(defmacro 'bc multi-column-ignored)

(define (section-ignored request . _)
  (warn "section heading request .~a not supported" request))

(defmacro 'tp section-ignored)
(defmacro 'sx section-ignored)
(defmacro '$p section-ignored)
(defmacro '$0 section-ignored)
(defmacro '$1 section-ignored)
(defmacro '$2 section-ignored)
(defmacro '$3 section-ignored)
(defmacro '$4 section-ignored)
(defmacro '$5 section-ignored)
(defmacro '$6 section-ignored)
