(in-package :clim-doc)

;;;; -- TODO ----------------------------------------------------------------------------------

;; . better management of links as we also have multiple-exit links
;; . backward links?
;; . full text search?
;; . links might also refer to a whole section.
;; . start to think about the annotation cruft.

;; . "pagination"

;; . I'd like automatic pagination, let the user specify what he
;;   thinks is a reasonable page size and opt to split huger section
;;   automatically.

;; . toc support

;; . numbering of sections

;; . grok files that have \section as their to top-level as well as
;;   those that have just \chapter.

;; . render toc hierarchical

;; . automatic recognition of the document title

;; . do something to the title page?

;; . actually we shouldn't bother generating the .html files as the
;;   regen tool does that

;;   But: make this tool to do that on request.

;; . somehow our table of contents is still fucked up. It winds up
;; without an id and stuff like that.

;; . offer an offline rendering.

;; . natural language support

;; . specify and document the internal DTD.

;; . support for \begin{defun}

(defvar *current-file*)

(defparameter *navbar-p* t)
(defparameter *reverse-links-p* t)

(defparameter *verification-pass-p* t)

(defparameter *nono-attributes* '(:AID :ID :NOANNO))

(defvar *reverse-links*
  (make-hash-table :test #'eq))

(defparameter *mandatory-P-element*
  '(:DD :LI))

(defvar *boo* nil)
(defvar *clean-boo* nil)

(defvar *id-href-hash* (make-hash-table :test #'eq))

(defvar *link-hash* (make-hash-table :test #'equal)
  "Hash table for automatic link introduction. Maps names like (:CONCEPT blah) to a list of link id.")

(defvar *id-title-hash* (make-hash-table :test #'eq)
  "Hash table mapping from node id (link end-points) to their title.")
(defvar *fonts* nil)
(defvar *cur-label-title* nil)
(defvar *skip-label-p* nil)

(defvar *id-counter*)
(defvar *section-level* 0)
(defvar *within-context* nil)

(defvar *aid-hash*
  (make-hash-table :test #'equal))

(defparameter *no-close-tag* '(:BR :IMG))

(defvar *current-tex-label-id* nil
  "Node ID of current TeX label.")

(defvar *cl-link-introduction-inhibit* nil)
(defvar *current-section-title* nil)

(defvar *all-pages* nil)

(defvar *prev-page*)

(defvar *mrindex*)

(defun convert-file (fn)
  (setf *undefined-macros* nil)
  (clrhash *link-hash*)
  (clrhash *id-title-hash*)
  (clrhash *reverse-links*)
  (clrhash *aid-hash*)
  (setf *fonts* nil)
  (setf *signatures* nil)
  (setf *id-counter* 0)
  (setf *prev-page* nil)
  (setf *all-pages* nil)
  (clrhash *id-href-hash*)
  (let ((*input-filename-defaults* fn)
        (*part-number* 0)
        (*chapter-number* 0)
        (*section-number* 0)
        (*subsection-number* 0)
        (*subsubsection-number* 0)
        (*in-appendix* nil)
        )
    (let ((boo (or ;;*boo*
                   (setf *boo*
                         (with-open-file (input fn)
                           (let ((*tex-macros* (copy-hash-table *tex-macros*)))
                             (slurp-stream (make-tex-input input))))))))
      (with-open-file (o "dump0" :direction :output :if-exists :supersede)
        (pprint *boo* o))
      (setf boo (clean-block-children boo))
      (when *backend-numbers-sections-p*
        (setf boo
              (number-sections boo)))
      (setf *clean-boo* (introduce-links
                         (care-for-table-of-contents
                          (care-for-frontmatter
                           boo))))
      (with-open-file (o "dump1" :direction :output :if-exists :supersede)
        (pprint *clean-boo* o))

      (dolist (k *clean-boo*)
        (paginate-section k))

      (dump-all-pages)))

  (let ((fn (merge-pathnames "aidmap" *data-output-directory*)))
    (ensure-directories-exist fn)
    (with-open-file (output fn :direction :output :if-exists :supersede)
      (maphash (lambda (k v)
                 (print (list k (first v)) output))
               *aid-hash*)))
  
  (with-open-file (output (merge-pathnames "mrindex" *data-output-directory*)
                          :direction :output :if-exists :supersede)
    (dolist (id *mrindex*)
      (destructuring-bind (sort-key rendition id) id
        sort-key
        (print (list (all-data* rendition)
                     rendition
                     (link-end-point-href id))
               output))))

  (install-resources)
  ;; regen stuff
  #+NIL
  (when (eql :saphir *variant*)
    (format T "~&;; letting the server regen -- please wait.~%")
    (ext:run-program "w3m" (list
                            "-no-proxy"
                            "-dump"
                            "http://localhost/~gilbert/edit/clim-spec/regen.lml?quux=foobarbeeboo")
                     :error t
                     :output t))
  )

(defun convert-1 (booboo)
  ;; ### don't know how much if the following is superfluous.
  (setf *undefined-macros* nil)
  (clrhash *link-hash*)
  (clrhash *id-title-hash*)
  (clrhash *reverse-links*)
  (clrhash *aid-hash*)
  (setf *fonts* nil)
  (setf *signatures* nil)
  (setf *id-counter* 0)
  (setf *prev-page* nil)
  (setf *all-pages* nil)
  (clrhash *id-href-hash*)
  (let ((boo (or nil;;*boo*
                 (setf *boo* booboo))))
    (setf *clean-boo* (introduce-links
                       (care-for-table-of-contents
                        (care-for-frontmatter
                         (clean-block-children boo)))))
    (with-open-file (o "dump1" :direction :output :if-exists :supersede)
      (pprint *clean-boo* o))

    (dolist (k *clean-boo*)
      (paginate-section k))

    (dump-all-pages)

    (let ((fn (merge-pathnames "aidmap" *data-output-directory*)))
      (ensure-directories-exist fn)
      (with-open-file (output fn :direction :output :if-exists :supersede)
        (maphash (lambda (k v)
                   (print (list k (first v)) output))
                 *aid-hash*)))))

(defun copy-hash-table (ht)
  (let ((res (make-hash-table :test #'equal)))
    (maphash (lambda (k v)
               (setf (gethash k res) v))
             ht)
    res))

(eval-when (compile eval load #|:read|#)
  (defparameter *font-change-elements*
    '(:RM :TT :I :B :SL :SF :EM :CL :COLOR :SUB :SUP :CODE :HUGE)))

(defparameter *inline-elements*
  '(:RM :TT :I :B :SL :SF :EM :CL :COLOR :SUB :SUP :CODE))

(defparameter *block-elements*
  '(:DOCUMENT :SECTION :TABLE :FIGURE :DEFUN :CENTER :PRE :UL :OL :DL))

;;;;

(defun clean-inline (children)
  (let ((x (clean-block-children children)))
    x))

(defun clean-inline* (children)
  (let ((*fonts* nil))
    (let ((x (clean-block-children children)))
      x)))

;    (cond ((null x)
;           nil)
;          (t
;           (assert (= (length x) 1))
;           (assert (eq (node-gi (car x)) :P))
;           (node-children (car x))))))

(defun clean-block-children (children)
  "Cleans children in block context."
  (let ((cur-para nil)                  ;material of current para
        (res nil))
    (labels ((process (x)
               (case (node-gi x)
                 (:pcdata
                  (cond ((and (null cur-para)
                              (every #'white-space-p x))
                         ;; skip it
                         )
                        (t
                         (dolist (f *fonts*)
                           (setf x (append f (list x))))
                         (push x cur-para))))
                 
                 (:group
                  (let ((*fonts* *fonts*))
                    (mapc #'process (node-children x))))
                 
                 (:par
                  (when cur-para
                    (push `(:P ,@(reverse cur-para)) res))
                  (setf cur-para nil))

                 (#.*font-change-elements*
                  (let ((*fonts* (cons (cons (node-gi x) (node-attributes x))
                                       *fonts*)))
                    (mapc #'process (node-children x))))

                 ((:FONT)
                  (assert (member (node-attr x :face) *font-change-elements*))
                  (push (list (node-attr x :face)) *fonts*))

                 ((:LABEL)
                  (unless *skip-label-p*
                    (learn-tex-label (node-attr x :name) *current-tex-label-id*
                                     (if *verification-pass-p*
                                         (list (string-trim (list #\space) (first *cur-label-title*))) ;only the section number, hack, hack, hack.
                                         *cur-label-title*))))
                 
                 ((:REF)
                  (push x cur-para))

                 ;; no change
                 ((:ENTITY :BR :IMG)
                  (push x cur-para))

                 ((:CONCEPT)
                  (let ((id (genid))
                        (node x))
                    (setf node (node-set-attribute node :ID id))
                    (setf node (apply-to-node-children node #'clean-inline))
                    (learn-concept id (all-data* (node-children x)))
                    (push node cur-para)))
                 
                 ((:MATH :TERM)
                  (setf x (apply-to-node-children x #'clean-inline))
                  (push x cur-para))

                 ((:TABULAR)
                  ;; xxx
                  (push (clean-block x) cur-para))

                 ((:PAREN)
                  (push `(,(node-gi x) ,@(node-attributes x)
                          ,@(clean-inline (node-children x)))
                        cur-para))
                 
                                  
                 ((:MATH)
                  ;; hmmm?! %$^#^%
                  (push x cur-para))

                 ;; block stuff
                 ((:DISPMATH :DOCUMENT :SECTION :TABLE :FIGURE :DEFUN :CENTER :PRE
                   :UL :OL :DL :PRINTINDEX :HR :TABLEOFCONTENTS :SIGNATURE)
                  ;; new block level .. so flush paragraph and process block element
                  (process '(:par))
                  (push (clean-block x) res))

                 #+NIL
                 (otherwise
                  )
                 
                 (otherwise
                  (error "Unknown GI: ~S." (node-gi x))) )))
      (mapc #'process children)
      (process '(:par))
      (cond ((and (= (length res) 1)
                  (eq (caar res) :P))
             (cdar res))
            (t
             (reverse res))))))


(defun genid ()
  (incf *id-counter*))

(defvar *cur-section-number* nil)

(defun clean-block (node)
  (case (node-gi node)
    ((:PRINTINDEX :TABLEOFCONTENTS)
     (copy-list node))
    ((:HR)
     node)
    ((:DOCUMENT)
     (let ((*cur-section-number* (list 0)))
       (setf node (apply-to-node-attribute node :title #'clean-inline))
       (apply-to-node-children node #'clean-block-children)))
    
    ((:SECTION)
     ;; Now the bright thing which happens is that the \label's itself
     ;; are sometimes placed right into the section title which
     ;; provides for recursive labels.
     (incf (car *cur-section-number*))
     (let ((*cur-section-number*
            (cons 0 *cur-section-number*)))
       (when *backend-numbers-sections-p*
         (setf node (node-set-attribute node :title
                                        (cons
                                         (format-section-number (reverse (cdr *cur-section-number*)))
                                         (node-attr node :title))))
         (setf node (node-set-attribute node :section-number
                                        (copy-list (reverse (cdr *cur-section-number*))))))
               
       (let* ((*current-tex-label-id* (genid))
              (*cur-label-title*
               (let ((*skip-label-p* t))
                 (clean-inline (node-attr node :title)))))
         (setf node (node-set-attribute node :ID *current-tex-label-id*))
         (setf node (apply-to-node-attribute node :title #'clean-inline))
         (setf node (apply-to-node-children node #'clean-block-children)) )))
    
    ((:DEFUN)
     (setf node (apply-to-node-children node #'clean-block-children)))

    ((:SIGNATURE)
       (setf node (node-set-attribute node :id (genid)))
       (setf node (apply-to-node-attribute node :name #'clean-inline))
       (setf node (apply-to-node-attribute node :params #'clean-inline))
       (setf node (apply-to-node-attribute node :kind #'clean-inline))
       (learn-cl-symbol (node-attr node :id)
                        (all-data* (node-attr node :name))
                        (list (all-data* (node-attr node :name))
                              ", "
                              (list :I (all-data* (node-attr node :kind)))))
       node)

    ((:TABLE :FIGURE)
     (let ((*current-tex-label-id* (genid))
           (*cur-label-title*
            (let ((*skip-label-p* t))
              (if *verification-pass-p*
                  (list (node-attr node :number))
                  (clean-inline (node-attr node :caption))))))
       (setf node (node-set-attribute node :ID *current-tex-label-id*))
       (setf node (apply-to-node-attribute node :caption #'clean-inline))
       (apply-to-node-children node #'clean-block-children)))

    ((:CENTER :DISPMATH)
     (apply-to-node-children node #'clean-block-children))
    
    ((:UL :OL)
     (append (cons (node-gi node) (node-attributes node))
             (mapcar (lambda (y)
                       (assert (eq :LI (node-gi y)))
                       (append (cons (node-gi y) (node-attributes y))
                               (clean-block-children (node-children y))))
                     (node-children node))))
    ((:DL)
     (append (cons (node-gi node) (node-attributes node))
           (mapcar (lambda (y)
                     (assert (member (node-gi y) '(:DT :DD)))
                     (append (cons (node-gi y) (node-attributes y))
                           (clean-block-children (node-children y))))
                   (node-children node))))
    ((:PRE)
     (assert (= (length (node-children node)) 1))
     (assert (stringp (car (node-children node))))
     node)
    
    ((:TABULAR)
     (append (cons (node-gi node) (node-attributes node))
             (mapcar (lambda (y)
                       (assert (eq :TR (node-gi y)))
                       (append (cons (node-gi y) (node-attributes y))
                               (mapcar (lambda (z)
                                         (assert (member (node-gi z) '(:TD :TH)))
                                         (append (cons (node-gi z) (node-attributes z))
                                                 (clean-block-children (node-children z))))
                                       (node-children y))))
                     (node-children node))))
    (otherwise
     (error "Unknown GI: ~S." (node-gi node))) ))

;;;; Table of Contents

;; now this is a bit crude ..

(defun care-for-table-of-contents (xs &optional (whole xs))
  "Misnomer! We also care for printindex here."
  (dolist (x xs)
    (cond ((equal x '(:TABLEOFCONTENTS))
           (let ((toc (make-table-of-contents whole)))
             ;; aehm ...
             (setf (car x) (car toc))
             (setf (cdr x) (cdr toc))
             x))
          ((equal x '(:PRINTINDEX))
           (let ((toc (make-index)))
             ;; double aehm ...
             (setf (car x) (car toc))
             (setf (cdr x) (cdr toc))
             x))
          (t
            (care-for-table-of-contents (node-children x) whole))))
  xs)

(defun make-table-of-contents (whole)
  (let ((res nil))
    (labels ((walk (x)
               (when (and (eq (node-gi x) :SECTION)
                          (not (member (node-attr x :KIND) '(:PARAGRAPH))))
                 (let ((title (node-attr x :TITLE)))
                   ;; note we don't register these links
                   (when (null (node-attr x :ID))
                     (warn "Section ~S has no id?" title))
                   (push `(:HLINK :IDS (,(node-attr x :ID)) ,@title) res)
                   (push `(:BR) res)))
               (mapc #'walk (node-children x)) ))
      (mapc #'walk whole)
      `(:SECTION
        :TITLE ("Table of Contents")
        :NAME (:toc)
        :ID :toc                        ;hmm
        :KIND :TOC
        ,@(reverse res)))))

(defun index-string-greaterp (a b)
  (string> (index-effective-string a)
           (index-effective-string b)))

(defun index-first-char (x)
  (char (index-effective-string x) 0))

(defun index-effective-string (string)
  (let ((p (position #\, string)))
    (when p
      (setf string (subseq string 0 p)))
    (string-downcase
     (cond ((or (and (char= (char string 0) #\+)
                     (char= (char string (1- (length string))) #\+))
                (and (char= (char string 0) #\*)
                     (char= (char string (1- (length string))) #\*)))
            (subseq string 1 (1- (length string))))
           (t
            string)))))

(defun make-index (&aux ids)
  (maphash (lambda (key key-ids)
             (when (and (consp key) (member (car key) '(:SYM :CONCEPT)))
               (dolist (i key-ids) (push i ids))))
           *link-hash*)
  
  (let* ((qu                            ;now a list of (<sort-key> <title> <id>)
          (mapcar (lambda (id)
                    (let* ((title (or (gethash id *id-title-hash*)
                                      (error "Link-end-point has no title?")))
                           (stitle (all-data* title)))
                      (list
                       (cond ((eql 0 (search "(setf " stitle))
                              (subseq stitle (length "(setf ")))
                             ((eql 0 (search "(setf* " stitle))
                              (subseq stitle (length "(setf* ")))
                             ((eql 0 (search ":" stitle))
                              (subseq stitle (length ":")))
                             (t
                              stitle))
                       title
                       id)))
                  ids)))

    ;; sort them
    (setf qu (sort qu #'index-string-greaterp :key #'first))
    (setf *mrindex* qu)
    ;; bucket them
    (let ((buckets (make-array 27 :initial-element nil)))
      (dolist (q qu)
        ;;(print (list (first q) (index-first-char (first q))))
        (let ((k (- (char-code (index-first-char (first q)))
                    (char-code #\a))))
          (unless (<= 0 k 25) (setf k 26))
          (push q (aref buckets k))))
      (sleep 5)
      ;; dump it
      `(:SECTION
        :TITLE ("Index")
        :ID ,(genid)
        :KIND :INDEX
        ,@(loop for k below 27 append
                (let ((q (aref buckets k)))
                  (if (null q)
                      nil
                      (list
                       `(:SECTION
                         :TITLE (,(if (= k 26) "non-alphabetic" (string (code-char (+ (char-code #\a) k)))))
                         :ID ,(genid)
                         :KIND :INDEX-SUB
                         ,@(mapcan (lambda (q)
                                     (destructuring-bind (skey title id) q
                                       (declare (ignore skey))
                                       (list `(:HLINK :IDS (,id) ,@title)
                                             '(:BR))))
                                   q)))))))) ))

;;;; Getting the front matter out of the way.

(defun care-for-frontmatter (xs)
  (mapcan (lambda (x)
            (cond ((not (eql (node-gi x) :DOCUMENT))
                   (warn "Skipping top level cruft: ~S." x))
                  (t
                   (list
                    `(,(node-gi x)
                      ,@(node-attributes x)
                      ,@(let* ((frontmatter)
                               (content (mapcan (lambda (x)
                                                  (cond ((member (node-gi x) '(:TABLEOFCONTENTS :SECTION))
                                                         (list x))
                                                        (t
                                                         (push x frontmatter)
                                                         nil)))
                                                (node-children x))))
                              `(,@(and frontmatter
                                       (list `(:SECTION
                                               :TITLE ("Front matter")
                                               :ID ,(genid)
                                               :NAME (:fm)
                                               :KIND :FM
                                               ,@(reverse frontmatter))))
                                ,@content)))))))
          xs))

;;;; HTML generation

;;; labels/references

;; 1. we attach labels only to some element.
;; 2. the needed A elements are to be generated transparently
;; 3. nameing the labels might be an issue though.


(defun label-href (x)
  (concatenate 'string "#" (label-hrefname x)))

(defun label-hrefname (x)
  (substitute-if-not #\_ (lambda (c)
                           (or (alphanumericp c)
                               (find c "-")))
                     (princ-to-string x)))

(defun link-end-point-href (id)
  (let ((x (gethash id *id-href-hash*)))
    (unless x
      (warn "Link ~S has no URL." id))
    x))

(defun make-verbose-link (id dir &optional other-id)
  `(:A :HREF ,(link-end-point-href id)
    (:SPAN :CLASS ,(ecase dir
                          (:reverse "reverselink")
                          (:forward "forwardlink"))
     "["
     ,@(and other-id
            (gethash other-id *id-title-hash*))
     ,(ecase dir
             (:reverse '(:entity :name "larr"))
             (:forward '(:entity :name "rarr")))
     " "
     ,@(mapcar #'gen-html (gethash id *id-title-hash*))
     "]")))


(defun gen-html (node)
  (cond ((node-annotatable-p node)
         (let ((aid (node-annotation-id node)))
           (cond ((gethash aid *aid-hash*)
                  (warn "~&*** Duplicate annotation id ~S~%*** appears both in ~S~%*** and ~S:~%*** ~S."
                        aid
                        *within-context*
                        (cdr (gethash aid *aid-hash*)) (all-data* node))
                  (gen-html-2 node))
                 (t
                  (setf (gethash aid *aid-hash*) (cons *current-file* *within-context*))
                  (setf node (add-annotation-link node aid))
                  (gen-html-2 node)))))
        (t
         (gen-html-2 node))))

(defun add-annotation-link (node aid)
  (ecase (node-gi node)
    ((:P :LI :DD)
     `(,(node-gi node)
       :AID ,aid                        ;the dumper takes care to introduce the actual A elements
       ,@(node-attributes node)
       ,@(node-children node)))
    ((:DEFUN)
     `(,(node-gi node)
       ,@(node-attributes node)
       ,@(node-children node)
       (:P 
        :AID ,aid)                      ;the dumper takes care to introduce the actual A elements
       ))))

(defun url-query-escape (string)
  (with-output-to-string (bag)
    (loop for c across string do
          (if (or (alphanumericp c) (find c "-,."))
              (princ c bag)
              (format bag "%~2,'0X" (char-code c))))))


(defun gen-html-2 (node)
  (case (node-gi node)
    ((:PCDATA)
     node)
    ;; :RM   
    ((:B :I :EM :TT :SUB :SUP :CODE :CENTER)
     (cons (node-gi node) (mapcar #'gen-html (node-children node))))
    ((:HUGE)
     `(:FONT :SIZE "5" ,@(mapcar #'gen-html (node-children node))))
    
    ((:SF)
     `(:SPAN :STYLE "font-family: sans-serif" ,@(mapcar #'gen-html (node-children node))))
    
    ((:SL)
     `(:I ,@(mapcar #'gen-html (node-children node))))
    ((:CL)
     `(:B :CLASS "cl" ,@(mapcar #'gen-html (node-children node))))
    ((:COLOR)
     `(:FONT :COLOR ,(node-attr node :color) ,@(mapcar #'gen-html (node-children node))))
    ((:RM)
     `(:SPAN ,@(mapcar #'gen-html (node-children node))))
    
    ((:LABEL)
     `(:A :NAME ,(label-hrefname (node-attr node :name))))

    ((:ENTITY)
     node)
    ((:BR)
     node)
    ((:MATH)
     (cons :I (mapcar #'gen-html (node-children node))))

    ((:IMG)
     node)
    
    ((:HR)
     node)
    
    ((:DISPMATH)
     (cons :P (mapcar #'gen-html (node-children node))))
    
    ((:HLINK)
     (when (null (first (node-attr node :ids)))
       (warn "Bogus HLINK: ~s." node))
     ;; ### multilinks!
     `(:A
       ,@(if (node-attr node :id) (list :id (node-attr node :id)))
       :HREF ,(link-end-point-href (first (node-attr node :ids)))
       ,@(mapcar #'gen-html (node-children node))))
    
    ((:TERM)
     `(:SPAN :CLASS "term" ,@(mapcar #'gen-html (node-children node))))
    
    ((:CONCEPT)
     `(:SPAN
       ,@(if (node-attr node :id) (list :id (node-attr node :id)))
       :CLASS "concept" ,@(mapcar #'gen-html (node-children node))))
    
    ((:DEFUN)
     (gen-defun node))
    
    ((:PRINTINDEX)
     (printindex))
    
    ((:DOCUMENT :SECTION)
     (let ((*within-context*
            (if (eql (node-attr node :kind) :INDEX-SUB)
                *within-context*
                (list (let ((title (all-data* (node-attr node :title))))
                        (if (and (alphanumericp (char title 0))
                                 (find (char title 1) "0123456789. "))
                            (subseq title 0 (position #\space title))
                            title))))))
       (let ((*section-level* (+ *section-level* 1)))
         `(:DIV
           ,@(if (node-attr node :id) (list :id (node-attr node :id)))
           (,@(section-kind-to-Hn (node-attr node :kind))
            :style "font-family:sans-serif"
            ,@(mapcar #'gen-html (node-attr node :title)))
           ,@(mapcar #'gen-html (node-children node))))))

    ((:PAREN)
     `(:TABLE :CELLSPACING "0" :BORDER "0" :STYLE "display: inline-table; vertical-align: middle;"
       (:TR
        (:TD :VALIGN :CENTER ,(string (node-attr node :left)))
        (:TD :VALIGN :CENTER ,@(mapcar #'gen-html (node-children node))
        (:TD :VALIGN :CENTER ,(string (node-attr node :right)))))))
    
    ((:TABULAR)
     `(:TABLE :CELLSPACING 0 :CELLPADDING 0 :BORDER 0
       :STYLE "display: inline-table;"
       ,@(mapcar #'gen-html (node-children node))))

    ((:FIGURE)
     `(:DIV :class "figure"
       ,@(mapcar #'gen-html (node-children node))
       (:BR)
       (:DIV :class "caption"
        :style "text-align: center"
        ,@(if *verification-pass-p*
              (list (format nil "Figure ~A: " (node-attr node :number))))
        ,@(mapcar #'gen-html (node-attr node :caption)))))

    ((:TABLE)
     `(:DIV :class "table"
       ,@(mapcar #'gen-html (node-children node))
       (:BR)
       (:DIV :class "caption"
        :style "text-align: center"
        ,@(if *verification-pass-p*
              (list (format nil "Table ~A: " (node-attr node :number))))
        ,@(mapcar #'gen-html (node-attr node :caption)))))
    
    ((:PRE)
     ;; ### we should nuke leading and trailing #\newline
     node)

    ((:CENTER)
     `(:CENTER ,@(mapcar #'gen-html (node-children node))))
    
    ((:TD)
     ;; kludge to avoid empty cells
     (let ((content (mapcar #'gen-html (node-children node))))
       `(,(node-gi node)
         ,@(node-attributes node)
         ,@(or content (list (string +nbsp+))))))

    ((:P)
     (let ((reverse-links (gather-reverse-links node))
           (links))
       (cond ((and reverse-links *reverse-links-p*)
              (do ((q reverse-links (cddr q)))
                  ((null q))
                (dolist (k (cadr q))
                  (push (make-verbose-link k :reverse (car q)) links)))
              `(:DIV
                (,(node-gi node)
                 ,@(node-attributes node)
                 ,@(mapcar #'gen-html (node-children node)))
                (:P
                 :NOANNO :NOANNO
                 ,@(mapcan (lambda (x)
                             (append (list x) (list '(:BR))))
                           links))))
             (t
              `(,(node-gi node)
                ,@(node-attributes node)
                ,@(mapcar #'gen-html (node-children node)))))))

    ((:DL) (gen-DL node))
    ((:DT) (gen-DT node))
    
    ((:UL :OL :DL :LI :TR :TD :TH :P :DD :DT)
     `(,(node-gi node)
       ,@(node-attributes node)
       ,@(mapcar #'gen-html (node-children node))))
    (otherwise
     (error "Unknown GI: ~S." (node-gi node))) ))

(defun gen-DL (node)
  (let ((*within-context* (cons nil *within-context*)))
    `(,(node-gi node)
      ,@(node-attributes node)
      ,@(mapcar #'gen-html (node-children node)))))

(defun gen-DT (node)
  (setf *within-context* (cons (string-trim (list #\space) (all-data node)) (cdr *within-context*)))
  `(,(node-gi node)
    ,@(node-attributes node)
    ,@(mapcar #'gen-html (node-children node))))

(defun gen-defun (node)
  ;; now ...
  (let ((*within-context*
         (cons
          (string-trim (list #\space)
                       (all-data*
                        (node-attr 
                         (find :signature (node-children node) :key #'node-gi)
                         :name)) )
          *within-context*)))
    (let ((revs nil) (forward-links nil))
      (build-defun
       (prog1
           (mapcar (lambda (sig)
                     (let ((id (node-attr sig :ID)))
                       (setf revs (append revs (gethash id *reverse-links*)))
                       (let ((other-ids (lookup-cl-symbol (all-data* (node-attr sig :name)))))
                         (when (> (length other-ids) 1)
                           (let* ((p (position (node-attr sig :ID) other-ids)))
                             (setf forward-links
                                   (append forward-links
                                           (subseq other-ids (+ p 1))
                                           ;; make it so that by always clicking on the next
                                           ;; we can cycle
                                           (subseq other-ids 0 p))))))
                       (list (mapcar #'gen-html (node-attr sig :name))
                             (mapcar #'gen-html (node-attr sig :params))
                             (mapcar #'gen-html (node-attr sig :kind))
                             id)))
                   (remove :SIGNATURE (node-children node) :key #'node-gi :test-not #'eq))
         (unless *reverse-links-p*
           (setf forward-links nil revs nil)))
       (append
        (mapcar #'gen-html (remove :SIGNATURE (node-children node) :key #'node-gi))
        (when forward-links
          (list `(:DIV :CLASS "forwardlinks"
                  ,@(mapcan #'(lambda (x)
                                (list (make-verbose-link x :forward) '(:BR)))
                            forward-links) )))
        (when revs
          ;; hmmm, no entirely the right thing, but ...
          (setf revs (remove-duplicates revs
                                        :key (lambda (x) (gethash x *id-title-hash*))
                                        :test #'equal))
          (list `(:DIV :CLASS "reverselinks"
                  ,@(mapcan #'(lambda (rev)
                                (list (make-verbose-link rev :reverse) '(:BR)))
                            revs) ))))))))

(defun gather-reverse-links (node)
  "Return all reverse links in an node. Result is a plist that maps targets to sources."
  (let (res)
    (labels ((walk (node)
               (let ((id (node-attr node :id)))
                 (when id
                   (dolist (x (gethash id *reverse-links*))
                     (pushnew x (getf res id)))))
               (mapc #'walk (node-children node))))
      (mapc #'walk (node-children node))
      res)))

(defun build-defun (signatures body)
  `(:DIV
    :CLASS "defun"
    ;;(:HR :NOSHADE :NOSHADE :SIZE 1)
    (:DIV :CLASS "defunsignatures"
     ,@(mapcar (lambda (sig)
                 `(:TABLE
                   :ID ,(fourth sig)
                   :WIDTH "100%"
                   ,@(if *verification-pass-p*
                         (list :CELLSPACING 0 :CELLPADDING 0))
                   (:COLGROUP :SPAN 3
                    (:COL :WIDTH "0*")
                    (:COL :WIDTH "1*")
                    (:COL :WIDTH "0*"))
                   (:TR
                    (:TD 
                     :ALIGN :LEFT
                     :VALIGN :BASELINE
                     :NOWRAP :NOWRAP
                     ,@(first sig)
                     ,@(list (string +nbsp+))
                     ,@(list (string +nbsp+))) ;another one to serve as italic correction
                    (:TD 
                     :ALIGN :LEFT
                     :VALIGN :BASELINE
                     :WIDTH "100%"
                     ,@(second sig))
                    (:TD 
                     :ALIGN :RIGHT
                     :VALIGN :BASELINE
                     :NOWRAP :NOWRAP
                     ,@(list (string +nbsp+))
                     ,@(if *verification-pass-p* (list "["))
                     ,@(third sig)
                     ,@(if *verification-pass-p* (list "]"))))))
               signatures))
    (:DIV :CLASS "defunbody"
     (:TABLE
      (:TR
       (:TD ,(make-array 10
                         :element-type (array-element-type "") 
                         :initial-element (code-char #o240)))
       (:TD
        ,@body)))) ))

(defun printindex ()
  (error "DO NOT CALL ME."))

;;;;;

(defun node-annotatable-p (node)
  (and (not (eq (node-attr node :NOANNO) :NOANNO))
       (or
        (member (node-gi node) '(:P :LI :DD))
        (and (member (node-gi node) '(:DEFUN))))))

(defun md5sum (string)
  (format nil "~{~2,'0X~}" (map 'list #'identity  (md5:md5sum-sequence string))))

(defun node-annotation-id (node)
  (concatenate 'string
               (md5sum (remove-if-not (lambda (c)
                                        (or (alphanumericp c)))
                                      (all-data* node)))
               (if *within-context*
                   (format nil "~{/~A~}" *within-context*)
                   "")))


(defun write-lhtml-2 (x sink)
  (let ((id (node-attr x :id)))
    (when id
      (format sink "<A NAME=\"_~A\"></A>" id)))
  (cond ((stringp x) (dump-string x sink))
        ((eq (car x) :entity)
         (princ "&" sink)
         (princ (node-attr x :name) sink)
         (princ ";" sink))
        ((consp x)
         (assert (keywordp (car x)))
         (princ "<" sink)
         (princ (car x) sink)
         (do ((q (cdr x) (cddr q)))
             ((not (keywordp (car q)))
              (terpri sink)
              (princ ">" sink)
              (dolist (k q)
                (write-lhtml k sink))
              
              (let ((aid (node-attr x :aid)))
                (when aid
                  (princ " " sink)
                  (write-lhtml-2 `(:A
                                   :HREF ,(format nil "anno.lml?aid=~A#Z" (url-query-escape aid))
                                   :CLASS "annolink"
                                   "[annotate]")
                                 sink)))

              #+NIL
              (when (and (or (member (car x) '(:LI :DD :P))
                             (and (eq (car x) :DIV) (equal (node-attr x :class) "defun")))
                         (not (node-attr x :NOANNO)))
                (princ " " sink)
                (write-lhtml `(:A
                               :HREF "foo"
                               :CLASS "annolink"
                               "(annotate)")
                             sink))
              (unless (member (car x) *no-close-tag*)
                (format sink "</~A~%>" (car x)) ))
           (unless (member (car q) *nono-attributes*)
             (princ " " sink)
             (princ (car q) sink)
             (princ "=\"" sink)
             (dump-string (princ-to-string (cadr q)) sink)
             (princ "\"" sink)))) ))

(defun write-lhtml (x sink)
  (write-lhtml-2 x sink))

(defun dump-string (string sink)
  (map nil (lambda (c)
             (when (characterp c) (setq c (char-code c)))
             (cond ((= c #.(char-code #\&)) (princ "&amp;" sink))
                   ((= c #.(char-code #\<)) (princ "&lt;" sink))
                   ((= c #.(char-code #\>)) (princ "&gt;" sink))
                   ((= c #.(char-code +nbsp+)) (princ "&nbsp;" sink))
                   ((<= 32 c 126)
                    (write-char (code-char c) sink))
                   (t
                    (format sink "&#~D;" c))))
       string))

;;;; links (again)

;; a. first introduce a simple notation for spots that is instead of
;;    inventing possibly duplicate label names we just gensym them.

;; b. for old fashioned :LABEL and :REF we simply alter the label name
;;    to something unique as above.

;; c. :LABEL nodes itself will go and we tag some other (higher) A
;;    tagged element will know how to render backward links.

;; d. we need to sort out the TeX sources to see where \label nodes
;;    actually occur. More often they are simply in the caption/title
;;    but there seem to be a few stray ones.

;; e. Last but not least we introduce real links, they are multiple
;;    entry as well as multiple exit.

;;    That is a link a reference from some point to other points.

;;    The other point can very well then offer backward linking.

;; f. annotation support is then some mere excersice in introducing
;;    new links.

;; g. stuff like automatic \cl{..} linking and search for definitions
;;    then simply goes against an index of stuff.

;; h. dito with term/concept.

;;; taggable stuff:

;; P, FIGURE, TABLE, SECTION, SIGATURE, what else?

;;

(defun node-set-attribute (node attribute value)
  (let ((atts (node-attributes node)))
    (setf (getf atts attribute) value)
    `(,(node-gi node) ,@atts ,@(node-children node))))

(defun map-node-children (fun node)
  `(,(node-gi node) ,@(node-attributes node)
    ,@(mapcar fun (node-children node))))

(defun apply-to-node-children (node fun)
  `(,(node-gi node) ,@(node-attributes node)
    ,@(funcall fun (node-children node))))

(defun apply-to-node-attribute (node attr fun)
  (node-set-attribute node attr (funcall fun (node-attr node attr))))


(defun learn-tex-label (name node-id title)
  (when (gethash `(:TEX ,name) *link-hash*)
    (warn "Duplicated definition of TeX label ~S." name))
  (push node-id (gethash `(:TEX ,name) *link-hash*))
  (learn-id-title node-id title))

(defun lookup-tex-label (name)
  (or (gethash `(:TEX ,name) *link-hash*)
      (progn
        (warn "TeX label ~S is not defined." name)
        nil)))

(defun learn-id-title (id title)
  (setf (gethash id *id-title-hash*) title))

(defun learn-concept (id blah)
  (learn-id-title id (list blah ", " `(:I "Concept")))
  (push id (gethash `(:CONCEPT ,blah) *link-hash*)))

(defun lookup-concept (blah)
  (gethash `(:CONCEPT ,blah) *link-hash*))

(defun learn-cl-symbol (id symbol title)
  (push id (gethash `(:SYM ,symbol) *link-hash*))
  (learn-id-title id title))

(defun lookup-cl-symbol (symbol)
  (gethash `(:SYM ,symbol) *link-hash*))

(defun end-point-title (id)
  (gethash id *id-title-hash*))

;;;;; Link Introduction Phase

;; We grovel over the whole document and seek out for opportunities to
;; introduce links.

;; Those are:

;;   (:REF ...)   nodes as from \ref{}, links to SECTION, TABLE or FIGURE nodes.
;;   (:CL ..)     possible link to the signature
;;   (:TERM ...)  possible link to the concept node.

;; Links that are introduced yield (:HLINK :IDS <> ..) nodes which
;; later will turn into <A HREF=""> thingies.

;; Further to have backward links we record all links introduced:

;;;; Reverse Links

;; Reverse links are currently handled in the dumping phase which is
;; probably not the right place to do it. It would be more intelligent
;; when these links are introduced right here, so that we would not
;; need any extra magic. Also reverse links to concepts probably a bit
;; hairy.

(defun learn-link (from-id to-ids title)
  "Learn that we have a new link."
  (dolist (to to-ids)
    (push from-id (gethash to *reverse-links*)))
  (setf (gethash from-id *id-title-hash*) title))


(defun introduce-links (xs)
  ;; Bug: Self referencing links in case of SIGNATURE
  (mapcar (lambda (x)
            (cond ((eq (node-gi x) :REF)
                   (with-node-attributes (name) x
                     (let* ((ids (lookup-tex-label name))
                            (title (end-point-title (first ids)))
                            (id (genid)))
                       (learn-link id ids *current-section-title*)
                       `(:HLINK :IDS ,ids
                                :ID ,id
                                ,@title))))
                  ;;
                  ((eq (node-gi x) :CL)
                   (let ((ids (if (member (all-data x) *cl-link-introduction-inhibit*
                                          :test #'equal)
                                  nil
                                  (lookup-cl-symbol (all-data x))))
                         (id (genid)))
                     (cond ((not (null ids))
                            (learn-link id ids *current-section-title*)
                            `(:HLINK :ID ,id :IDS ,ids (:CL ,@(introduce-links (node-children x)))))
                           (t
                            (apply-to-node-children x #'introduce-links)))))
                  ;;
                  ((eq (node-gi x) :TERM)
                   (let ((ids (lookup-concept (all-data x)))
                         (id (genid)))
                     (cond ((not (null ids))
                            (learn-link id ids *current-section-title*)
                            `(:HLINK :ID ,id :IDS ,ids (:TERM ,@(introduce-links (node-children x)))))
                           (t
                            (apply-to-node-children x #'introduce-links)))))
                  ;;
                  ((eq (node-gi x) :DEFUN)
                   ;; Some device to stop function definitions from
                   ;; refering to itself. This is not neccessarily a
                   ;; good thing since this also inhibits finding the
                   ;; other definitions of the same symbol.
                   ;;
                   ;; But this is an interesting situation where
                   ;; points form a cluster where each refers to the
                   ;; others.
                   (let ((*cl-link-introduction-inhibit* nil))
                     (dolist (y (node-children x))
                       (when (eq (node-gi y) :SIGNATURE)
                         (push (all-data* (node-attr y :NAME)) *cl-link-introduction-inhibit*)))
                     (let ((*current-section-title*
                            (append *current-section-title*
                                    (list ", ")
                                    (list
                                     `(:CL ,@(node-attr (first (node-children x)) :name))))))
                       (apply-to-node-children x #'introduce-links))))

                  ((eq (node-gi x) :SECTION)
                   (let ((*current-section-title*
                          (if (eq (node-attr x :kind) :PARAGRAPH)
                              *current-section-title*
                              (node-attr x :TITLE))))
                     (apply-to-node-children x #'introduce-links)))
                  ;;
                  ((stringp x) x)
                  ;;
                  (t
                   (apply-to-node-children x #'introduce-links))))
          xs))


;;;; pagination

;; we want to produce nodes like
;;
;; (:PAGE
;;     :FILENAME <fn>
;;     :NEXT     id
;;     :PREV     id
;;     :UP       id
;;     :TITLE
;;     ...)
;;

(defun section-kind-to-Hn (kind)
  (ecase kind
    ((:DOCUMENT) `(:H1 :align :center))
    ((:PART) `(:h1))
    ((:CHAPTER) '(:h2))
    ((:SECTION) '(:h3))
    ((:SUBSECTION) '(:h4))
    ((:SUBSUBSECTION :PARAGRAPH) '(:h4))
    ((:TOC :INDEX) '(:h2))
    ((:FM) '(:h2))                         ;hmm frontmatter
    ((:INDEX-SUB) '(:h3))))

(defparameter *pagination-level*
  3)

(defun paginate-section-p (section-node)
  (ecase (node-attr section-node :kind)

    ((:DOCUMENT)        (>= *pagination-level* 0))
    ((:PART)            (>= *pagination-level* 1))
    ((:CHAPTER)         (>= *pagination-level* 2))
    ((:SECTION)         (>= *pagination-level* 3))
    ((:SUBSECTION)      (>= *pagination-level* 4))
    ((:SUBSUBSECTION)   (>= *pagination-level* 5))
    ((:PARAGRAPH)       (>= *pagination-level* 6))

;;    ((:DOCUMENT :PART :CHAPTER :SECTION) t)
;;    ((:SUBSECTION :SUBSUBSECTION :PARAGRAPH) nil)

    ((:TOC :INDEX) t)
    ((:FM) t)                         ;hmm frontmatter
    ((:INDEX-SUB) nil)))

#+NIL
(defun paginate-section-p (section-node)
  (case (node-attr section-node :kind)
    ((:DOCUMENT) t)
    (otherwise nil)))

(defun section-link-depth (section-node)
  "How deep should the local toc be?"
  (case (node-attr section-node :kind)
    ((:DOCUMENT) 2)
    ((:PART) 2)
    (otherwise 1)))

(defun section-file-name (section-node)
  (cond ((and (node-attr section-node :section-number)
              (not (member (node-attr section-node :kind)
                           '(:DOCUMENT :FM :TOC :INDEX))))
         (format nil "~{~D~^-~}.html" (node-attr section-node :section-number)))
        (t
         (ecase (node-attr section-node :kind)
           ((:DOCUMENT) "index.html")
           ((:PART)
            (let* ((s (all-data* (node-attr section-node :title)))
                   (p1 (position #\space s))
                   (p2 (position #\space s :start (+ p1 1))))
              (format nil "P-~A.html" (delete #\: (substitute #\- #\. (subseq s (+ p1 1) p2))))))
           ((:CHAPTER :SECTION :SUBSECTION :SUBSUBSECTION)
            (let* ((s (all-data* (node-attr section-node :title)))
                   (p (position #\space s)))
              (print `(,s -> ,(substitute #\- #\. (subseq s 0 p)))
                     *trace-output*)
              (finish-output *trace-output*)
              (format nil "~A.html" (substitute #\- #\. (subseq s 0 p)))))
           ((:FM)  "frontmatter.html")
           ((:TOC) "contents.html")
           ((:INDEX) "theindex.html")))))

(defun paginate-section (node &optional up-page)
  "Given a section node convert it into a :PAGE, leaving a link or return it as it is."
  (cond ((and (member (node-gi node) '(:section :document))
              (paginate-section-p node))
         (let* ((id (genid))
                down-links
                (fn (section-file-name node))
                (this
                 `(:PAGE
                   :ID ,id
                   :FILENAME ,fn
                   :TITLE ,(all-data* (node-attr node :title))
                   :PREV ,(node-attr *prev-page* :id)
                   :NEXT nil
                   :UP ,up-page)))
           (let ((q (member :NEXT *prev-page*)))
             (when q (setf (cadr q) id)))
           (setf *prev-page* this)
           (setf (gethash id *id-title-hash*) (node-attr node :title))
           (setf (gethash id *id-href-hash*) fn)
           (labels ((bar (xs n)
                      (cond ((zerop n) nil)
                            (t
                             (mapcan (lambda (x)
                                       (when (eq (node-gi x) :SECTION)
                                         (when (null (node-attr x :id))
                                           (warn "This has no id: ~s" x))
                                         (let ((further-down (bar (node-children x) (- n 1))))
                                           (list `(:LI :NOANNO :NOANNO
                                                   :STYLE "list-style-type: none"
                                                   (:HLINK :IDS (,(node-attr x :id))
                                                    ,@(node-attr x :title))
                                                   ,@(if further-down
                                                         (list `(:UL ,@further-down))))))))
                                     xs)))))
             (setf down-links (bar (node-children node) (section-link-depth node))))
           ;;
           (let* ((content `(,(node-gi node)
                             ,@(node-attributes node)
                             ,@down-links
                             ,@(mapcar #'(lambda (x) (paginate-section x id)) (node-children node)))))
             (labels ((foo (x)
                        (let ((id (node-attr x :id)))
                          (when id
                            (setf (gethash id *id-href-hash*)
                                  (format nil "~A#_~A" fn id))))
                        (mapc #'foo (node-children x))))
               (foo content))
             
             (setf this (nconc this (list content)))
             (push this *all-pages*)
             ""
             #+NIL
             `(:UL
               (:LI
                (:HLINK :IDS (,id)
                 ,@(node-attr node :title)))))))
        (t
         node)))

(defun dump-all-pages ()
  (dolist (p *all-pages*)
    (dump-page p)))

(defun dump-page (p)
  (format T "~&;; dumping ~S to ~S.~%"
          (node-attr p :title)
          (node-attr p :filename))
  (let ((*current-file* (node-attr p :filename)))
    (let ((page (build-page-html p)))
      (let ((fn (make-pathname :type "raw"
                               :defaults
                               (merge-pathnames (node-attr p :filename)
                                                *data-output-directory*))))
        (ensure-directories-exist fn)
        (with-open-file (output fn :direction :output :if-exists :supersede)
          (let ((*print-pretty* t))
            (print page output))))
      #+NIL
      (with-open-file (output (merge-pathnames (node-attr p :filename) *output-directory*)
                              :direction :output
                              :if-exists :supersede)
        (let ((*current-file* (node-attr p :filename)))
          (write-lhtml page output))))))

(defun make-navbar (p)
  "Construct a navigation bar for page p."
  (if *navbar-p*
      `(:DIV :CLASS "navbar"
        (:TABLE :CELLSPACING 0 :CELLPADDING 0 :BORDER 0 :style "width:100%"
         (:COLGROUP :SPAN 3
          (:COL :WIDTH "0*")
          (:COL :WIDTH "0*")
          (:COL :WIDTH "1*")
          (:COL :WIDTH "0*")
          (:COL :WIDTH "0*"))
         (:TR
          (:TD :ALIGN :LEFT :VALIGN :BASELINE
           ,(if (node-attr p :prev)
                (gen-html `(:HLINK :IDS (,(node-attr p :prev)) "Prev"))
                "")
           (:BR)
           ,(if (node-attr p :next)
                (gen-html `(:HLINK :IDS (,(node-attr p :next)) "Next"))
                ""))
          (:TD ,(make-array 4 :element-type (array-element-type "") :initial-element +nbsp+))
          (:TD :ALIGN :LEFT :VALIGN :BASELINE :NOWRAP :NOWRAP
           (:SPAN :CLASS "upchain"
            ,@(make-up-link-chain p))
           ,(make-array 5 :element-type (array-element-type "") :initial-element +nbsp+))
          (:TD :ALIGN :RIGHT :VALIGN :BASELINE
           (:DIV :CLASS "apropos"
            (:FORM
             :METHOD :GET
             :ACTION "edit/apropos"
             "Apropos " (:BR)
             (:INPUT
              :SIZE 20
              :NAME "q"))))
          (:TD ,(make-array 8 :element-type (array-element-type "") :initial-element +nbsp+))
          )))
      `(:DIV)))

(defun find-page (id)
  (find id *all-pages* :key #'(lambda (x) (node-attr x :id))))

(defun make-up-link-chain (p &optional (herep t))
  "Construct a up link chain for a page p."
  (cond ((null p) nil)
        (t
         (append (make-up-link-chain (find (node-attr p :up) *all-pages*
                                           :key #'(lambda (x) (node-attr x :id)))
                                     nil)
                 (list (if herep '(:BR) " ")
                       (if (node-attr p :up) (list :entity :name "rarr") "")
                       (string +nbsp+)
                       (gen-html`(:HLINK :IDS (,(node-attr p :id))
                                  ,(warp-if herep '(:B *)
                                            (substitute +nbsp+ #\space
                                                        (if (null (node-attr p :up))
                                                            *document-main-title* ;uff hard coded
                                                            (node-attr p :title)) )))))))))

(defun warp-if (cond template stuff)
  (if cond
      (substitute stuff '* template)
      stuff))

;;alternate
;;appendix
;;bookmark
;;contents
;;copyright

;;help
;;home
;;index

;;section
;;subsection
;;chapter

;;glossary
;;start
;;stylesheet
;;next
;;prev


(defun build-page-html (p)
  `(:HTML
    (:HEAD
     (:TITLE ,(node-attr p :title))
     (:LINK :REL "Stylesheet" :TYPE "text/css" :HREF "clim.css")
     ,@(if (node-attr p :prev)
           (list `(:LINK
                   :REL "prev"
                   :TYPE "text/html"
                   :TITLE ,(or (node-attr (find-page (node-attr p :prev)) :title) "")
                   :HREF ,(link-end-point-href (node-attr p :prev))))
           nil)
     ,@(if (node-attr p :next)
           (list `(:LINK
                   :REL "next"
                   :TYPE "text/html"
                   :TITLE ,(or (node-attr (find-page (node-attr p :next)) :title) "")
                   :HREF ,(link-end-point-href (node-attr p :next))))
           nil)
     ,@(if (node-attr p :up)
           (list `(:LINK
                   :REL "up"
                   :TYPE "text/html"
                   :TITLE ,(or (node-attr (find-page (node-attr p :up)) :title) "")
                   :HREF ,(link-end-point-href (node-attr p :up))))
           nil)
     ,(let ((root (first *all-pages*)))
           (assert (null (node-attr root :up)))
           `(:LINK
             :REL "start"
             :TYPE "text/html"
             :TITLE ,(or (node-attr root :title) "")
             :HREF ,(link-end-point-href (node-attr root :id))))
     (:LINK
      ;;###
      :rel "glossary"
      :TYPE "text/html"
      :TITLE "Glossary"
      :HREF "A.html")
     (:LINK
      ;;###
      :rel "index"
      :TYPE "text/html"
      :TITLE "Index"
      :HREF "theindex.html")
     (:LINK
      :REL "contents"
      :TYPE "text/html"
      ;; ###
      :TITLE "Table of Contents"
      :HREF "contents.html")
     )
    (:BODY
     ,(make-navbar p)
     ,@(mapcar #'gen-html (node-children p))
     ,(make-footer p))))

(defun make-footer (p)
  (declare (ignore p))
  `(:DIV :CLASS "footer"
    (:P "Conversion to HTML and annotation support by "
     "Gilbert Baumann"
     " " (:A :HREF "mailto:unk6@rz.uni-karlsruhe.de" "[mail]")
     " " (:A :HREF "http://www.stud.uni-karlsruhe.de/~unk6/" "[home page]") )))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;  Resources
;;;;

(defun find-resource-file (name)
  (let (fn)
    (cond ((probe-file
            (setf fn
                  (merge-pathnames
                   name
                   (merge-pathnames
                    (make-pathname :directory (list :relative (string-downcase *variant*)))
                    *resource-base*))))
           fn)
          ((probe-file
            (setf fn
                  (merge-pathnames
                   name
                   *resource-base*)))
           fn)
          (t
           (error "Resource ~S cannot be found." name)))))

(defparameter *needed-resources*
  ;; resource file; name relative to *output-base-directory*
  '(;("anno.lml"   "edit/clim-spec/")
    ;("news.lml"   "edit/clim-spec/")
    ;("regen.lml"  "edit/clim-spec/")
    ;("submit.lml" "edit/clim-spec/")
    ;("apropos.lml" "edit/clim-spec/")
    ;("serve.lisp"  "edit/clim-spec/")
    ;("index.html" "edit/clim-spec/index.html")
    ("clim.css"   "data/")
    ;(".htaccess"   "edit/clim-spec/")
    ))

#+NIL
(defun install-resources ()
  (dolist (resource *needed-resources*)
    (destructuring-bind (name dir) resource
      (let ((destination (merge-pathnames (merge-pathnames dir *output-base-directory*) name))
            (source      (find-resource-file name)))
        (ensure-directories-exist destination)
        (let ((usource (ext:unix-namestring source :for-input nil))
              (udest (namestring destination)))
          (format T "~&;; creating ~S." udest)
          (ext:run-program "cp" (list "-p" usource udest))))))
  ;; final perm fixup
  (dolist (f (directory (merge-pathnames "**/*" *output-base-directory*)))
    (cond ((pathname-name f)
           ;; file
           (ext:run-program "chmod" (list "a+r" (ext:unix-namestring f))))
          (t
           ;; dir
           (ext:run-program "chmod" (list "a+rx" (ext:unix-namestring f)))))) )


(defun install-resources ()
  (dolist (resource *needed-resources*)
    (destructuring-bind (name dir) resource
      (let ((destination (merge-pathnames (merge-pathnames dir *output-base-directory*) name))
            (source      (find-resource-file name)))
        (ensure-directories-exist destination)
        (format t "~&;; We would need ~S~%" destination)
        #+NIL
        (let ((usource (ext:unix-namestring source :for-input nil))
              (udest (namestring destination)))
          (format T "~&;; creating ~S." udest)
          (ext:run-program "cp" (list "-p" usource udest)))))))

;; /home/gilbert/lisp/mcclim-doc/source/clim.tex

#+NIL
(defun do-clim-spec ()
  (convert-file "input/clim-spec/clim.tex")
  ;; XXX
  #+NIL
  (let ((*needed-resources*
         '(("clim.css" "clim.css")))
        (*output-base-directory* *data-output-directory*))
    (install-resources))
  #+NIL
  ;; XXX .png files
  (dolist (png (directory (merge-pathnames "*.png" *output-directory*)))
    (let ((destination   (merge-pathnames *data-output-directory* png))
          (source      png))
      (ensure-directories-exist destination)
      (let ((usource (ext:unix-namestring source :for-input nil))
            (udest (namestring destination)))
        (format T "~&;; creating ~S." udest)
        (ext:run-program "cp" (list "-p" usource udest))))) )

(defun do-manual ()
  (let ((*defun-tweak-p* t)
        (*pagination-level* 2))
    (convert-file "input/manual/manual.tex")))

(defun do-clxman ()
  (let ((*defun-tweak-p* nil)
        (*pagination-level* 2)
        (*document-main-title* "CLX Manual"))
    (setf *mrindex* nil)                ;???
    (convert-file "input/clxman/manual.tex")))

(defun hemlock ()
  (let ((*backend-numbers-sections-p* t)
        (*document-main-title* "Hemlock Manual"))
    (with-open-file(i"dump0")(setf *boo* (read i))(values))
    (convert-file "foo")))

(defun clm ()
  (let ((*document-main-title* "Common Lisp the Language"))
    (convert-file "input/clm/clm.tex")))

(defun do-fwgzdoc ()
  (setf *mrindex* nil)                  ;???
  (let ((*document-main-title* "FWGZ")
        (*output-base-directory* "output/fwgzdoc/")
        (*data-output-directory* "output/fwgzdoc/data/")
        (*output-directory*"output/fwgzdoc/data/"))
    (convert-file "input/fwgzdoc/fwgzdoc.latex")))

(defun number-sections (boo)
  boo)

(defun format-section-number (number)
  (cond ((= 1 (length number))
         (format nil "Part ~@R: " (car number)))
        (t
         (format nil "~{~D~^.~} " (cdr (reverse (cdr *cur-section-number*)))))))


;;;;;
        
#+NIL
(defun rzstud-regen ()
  (format T "~&;; letting the server regen -- please wait.~%")
  (ext:run-program "w3m" (list
                          "-no-proxy"
                          "-dump"
                          "http://www.stud.uni-karlsruhe.de/~unk6/edit/clim-spec/regen.lml?quux=foobarbeeboo")
                   :error t
                   :output t
                   :input nil))

#+NIL
(defun rzstud-install-scripts ()
  (let ((*variant* :rzstud))
    ;; serve.lisp must be translated.
    (dolist (resource *needed-resources*)
      (destructuring-bind (name dir) resource
        (let ((destination (merge-pathnames dir name))
              (source      (find-resource-file name)))
          (let ((usource (ext:unix-namestring source :for-input nil))
                (udest (format nil "unk6@rzstud1.rz.uni-karlsruhe.de:.public_html/~A"
                               (namestring destination))))
            (format T "~&;; creating ~S." udest)
            (ext:run-program "scp"
                             (list "-p" usource udest)
                             :output t
                             :error t
                             :input nil)))))
    ;; compile serve.lisp
    (ext:run-program
     "ssh"
     (list "-l" "unk6" "rzstud1.rz.uni-karlsruhe.de"
           "./bin/clisp" "-c" "./.public_html/edit/clim-spec/serve.lisp")
     :output t
     :error t
     :input nil)
    ;; construct lml.cgi
    (ext:run-program
     "ssh"
     (list "-l" "unk6" "rzstud1.rz.uni-karlsruhe.de"
           "echo \\#\\! /home/ws/unk6/bin/lisp.run -M/home/ws/unk6/bin/lispinit.mem > ./.public_html/edit/clim-spec/aml.cgi")
     :output t
     :error t
     :input nil)
    (ext:run-program
     "ssh"
     (list "-l" "unk6" "rzstud1.rz.uni-karlsruhe.de"
           "cat ./.public_html/edit/clim-spec/serve.fas >> ./.public_html/edit/clim-spec/aml.cgi")
     :output t
     :error t
     :input nil)
    (ext:run-program
     "ssh"
     (list "-l" "unk6" "rzstud1.rz.uni-karlsruhe.de"
           "chmod a+x ./.public_html/edit/clim-spec/aml.cgi") ;hmm don't like that
     :output t
     :error t
     :input nil)
    (ext:run-program
     "ssh"
     (list "-l" "unk6" "rzstud1.rz.uni-karlsruhe.de"
           "mv ./.public_html/edit/clim-spec/aml.cgi ./.public_html/edit/clim-spec/lml.cgi") ;hmm don't like that
     :output t
     :error t
     :input nil)
    ))
