prepare-topic

(defun find-children-aux
  (par topics acc)
  (cond ((atom topics) acc)
    ((member-eq par
       (cdr (assoc-eq :parents (car topics)))) (find-children-aux par
        (cdr topics)
        (cons (cdr (assoc-eq :name (car topics)))
          acc)))
    (t (find-children-aux par
        (cdr topics)
        acc))))

(defun suborder-indicates-chronological-p
  (suborder)
  (if (consp suborder)
    (cdr (last suborder))
    suborder))

(defun find-children
  (par all-topics suborder)
  (let ((children-names (find-children-aux par all-topics nil)))
    (cond ((suborder-indicates-chronological-p suborder) (remove-duplicates-eq children-names))
      (t (mergesort children-names)))))

(defun make-xml-entity-stuff-items-aux
  (entity-info acc)
  (if (endp entity-info)
    (reverse acc)
    (let* ((entry (car entity-info)) (string (car entry))
        (decimal-code (caddr entry)))
      (make-xml-entity-stuff-items-aux (rest entity-info)
        (if (eq decimal-code :built-in)
          acc
          (cons (cat "  <!ENTITY "
              string
              (implode (repeat (max 1 (- 8 (length string))) #\ ))
              ""&#"
              (nat-to-dec-string decimal-code)
              ";">"
              *newline*)
            acc))))))

(defun make-xml-entity-stuff-items
  (entity-info)
  (string-append-lst (list "<!DOCTYPE xdoc ["
      *newline*
      (string-append-lst (make-xml-entity-stuff-items-aux entity-info
          nil))
      "]>"
      *newline*)))

(defun index-add-topic
  (x topics-fal
    disable-autolinking-p
    index-pkg
    state
    acc)
  (b* ((name (cdr (assoc :name x))) (short (cdr (assoc :short x)))
      (base-pkg (cdr (assoc :base-pkg x)))
      (acc (printtree-rconcat "<index_entry>" acc))
      (acc (cons #\
 acc))
      (acc (printtree-rconcat "<index_head><see topic=""
          acc))
      (acc (file-name-mangle name acc))
      (acc (printtree-rconcat "">" acc))
      (acc (sym-mangle-cap name
          index-pkg
          nil
          acc))
      (acc (printtree-rconcat "</see>" acc))
      (acc (printtree-rconcat "</index_head>" acc))
      (acc (cons #\
 acc))
      (acc (printtree-rconcat "<index_body>" acc))
      (acc (cons #\
 acc))
      ((mv acc state) (preprocess-main short
          name
          topics-fal
          disable-autolinking-p
          base-pkg
          state
          acc))
      (acc (cons #\
 acc))
      (acc (printtree-rconcat "</index_body>" acc))
      (acc (cons #\
 acc))
      (acc (printtree-rconcat "</index_entry>" acc))
      (acc (cons #\
 acc)))
    (mv acc state)))

(defun index-add-topics
  (x topics-fal
    disable-autolinking-p
    index-pkg
    state
    acc)
  (b* (((when (atom x)) (mv acc state)) ((mv acc state) (index-add-topic (car x)
          topics-fal
          disable-autolinking-p
          index-pkg
          state
          acc)))
    (index-add-topics (cdr x)
      topics-fal
      disable-autolinking-p
      index-pkg
      state
      acc)))

(defun index-topics
  (x title
    topics-fal
    disable-autolinking-p
    index-pkg
    state
    acc)
  (b* ((acc (printtree-rconcat "<index title="" acc)) (acc (printtree-rconcat title acc))
      (acc (printtree-rconcat "">" acc))
      (acc (cons #\
 acc))
      ((mv acc state) (index-add-topics x
          topics-fal
          disable-autolinking-p
          index-pkg
          state
          acc))
      (acc (printtree-rconcat "</index>" acc))
      (acc (cons #\
 acc)))
    (mv acc state)))

(defun add-parents
  (parents base-pkg acc)
  (b* (((when (atom parents)) acc) (acc (printtree-rconcat "<parent topic="" acc))
      (acc (file-name-mangle (car parents) acc))
      (acc (printtree-rconcat "">" acc))
      (acc (sym-mangle-cap (car parents)
          base-pkg
          nil
          acc))
      (acc (printtree-rconcat "</parent>" acc))
      (acc (cons #\
 acc)))
    (add-parents (cdr parents)
      base-pkg
      acc)))

(defun gather-topics
  (names topics-fal)
  (b* (((when (atom names)) nil) (look (hons-get (car names) topics-fal))
      ((unless look) (er hard?
          'gather-topics
          "Failed to find topic ~x0."
          (car names))))
    (cons (cdr look)
      (gather-topics (cdr names) topics-fal))))

(defun check-topic-syntax
  (x)
  (b* ((name (cdr (assoc :name x))) (base-pkg (cdr (assoc :base-pkg x)))
      (short (or (cdr (assoc :short x)) ""))
      (long (or (cdr (assoc :long x)) ""))
      (parents (cdr (assoc :parents x)))
      (suborder (cdr (assoc :suborder x)))
      (ctx 'check-topic-syntax)
      ((unless (symbolp name)) (er hard?
          ctx
          "Name is not a symbol: ~x0"
          x))
      ((unless (symbolp base-pkg)) (er hard?
          ctx
          "Base-pkg is not a symbol: ~x0"
          x))
      ((unless (symbol-listp parents)) (er hard?
          ctx
          "Parents are not a symbol-listp: ~x0"
          x))
      ((unless (stringp short)) (er hard?
          ctx
          "Short is not a string or nil: ~x0"
          x))
      ((unless (stringp long)) (er hard?
          ctx
          "Long is not a string or nil: ~x0"
          x))
      ((unless (symbol-listp (fix-true-list suborder))) (er hard?
          ctx
          "Suborder list contains a non-symbol: ~x0"
          x)))
    t))

(defun apply-suborder
  (suborder children-names)
  (cond ((atom suborder) children-names)
    ((member (car suborder) children-names) (cons (car suborder)
        (apply-suborder (cdr suborder)
          (remove (car suborder) children-names))))
    (t (apply-suborder (cdr suborder)
        children-names))))

(defun gentle-subsetp-eq
  (x y)
  (cond ((atom x) t)
    ((member-eq (car x) y) (gentle-subsetp-eq (cdr x) y))
    (t nil)))

(defun preprocess-topic
  (x all-topics
    topics-fal
    disable-autolinking-p
    state)
  (b* ((- (check-topic-syntax x)) (name (cdr (assoc :name x)))
      (base-pkg (cdr (assoc :base-pkg x)))
      (short (or (cdr (assoc :short x)) ""))
      (long (or (cdr (assoc :long x)) ""))
      (parents (cdr (assoc :parents x)))
      (suborder (cdr (assoc :suborder x)))
      (acc nil)
      (acc (printtree-rconcat "<?xml version="1.0" encoding="UTF-8"?>"
          acc))
      (acc (cons #\
 acc))
      (acc (printtree-rconcat "<?xml-stylesheet type="text/xsl" href="xml-topic.xsl"?>"
          acc))
      (acc (cons #\
 acc))
      (acc (printtree-rconcat *xml-entity-stuff* acc))
      (acc (printtree-rconcat "<page>" acc))
      (acc (printtree-rconcat "<topic name="" acc))
      (acc (sym-mangle-cap name
          base-pkg
          nil
          acc))
      (acc (printtree-rconcat "">" acc))
      (acc (cons #\
 acc))
      (acc (add-parents parents base-pkg acc))
      (acc (cons #\
 acc))
      (acc (printtree-rconcat "<short>" acc))
      ((mv short-acc state) (preprocess-main short
          name
          topics-fal
          disable-autolinking-p
          base-pkg
          state
          nil))
      (short-str (printtree->str short-acc))
      ((mv err &) (parse-xml short-str))
      (- (and err
          (xdoc-verbose-p)
          (prog2$ (note-xdoc-error)
            (print-xdoc-error "~|~%; xdoc error: problem with :short in topic ~x0:~%~x1~%~%"
              (list name err)))))
      (acc (b* (((unless err) (printtree-rconcat short-acc acc)) (acc (printtree-rconcat "<b>Markup error in :short: </b><code>"
                acc))
            (acc (simple-html-encode-str err
                0
                (length err)
                acc))
            (acc (printtree-rconcat "</code>" acc)))
          acc))
      (acc (printtree-rconcat "</short>" acc))
      (acc (cons #\
 acc))
      (acc (printtree-rconcat "<long>" acc))
      ((mv long-acc state) (preprocess-main long
          name
          topics-fal
          disable-autolinking-p
          base-pkg
          state
          nil))
      (long-str (printtree->str long-acc))
      ((mv err &) (parse-xml long-str))
      (- (and err
          (xdoc-verbose-p)
          (prog2$ (note-xdoc-error)
            (print-xdoc-error "~|~%; xdoc error: problem with :long in topic ~x0:~%~x1~%~%"
              (list name err)))))
      (acc (b* (((unless err) (printtree-rconcat long-acc acc)) (acc (printtree-rconcat "<h3>Markup error in :long</h3><code>"
                acc))
            (acc (simple-html-encode-str err
                0
                (length err)
                acc))
            (acc (printtree-rconcat "</code>" acc)))
          acc))
      (acc (printtree-rconcat "</long>" acc))
      (acc (cons #\
 acc))
      (children-names (find-children name
          all-topics
          suborder))
      (- (and (xdoc-verbose-p)
          (not (gentle-subsetp-eq suborder
              children-names))
          (cw "~|~%WARNING: in topic ~x0, subtopic order mentions topics that ~
                    are not children: ~&1.~%"
            name
            (set-difference$ (fix-true-list suborder)
              children-names))))
      (children-names (apply-suborder suborder children-names))
      (children-topics (gather-topics children-names topics-fal))
      ((mv acc state) (if (not children-topics)
          (mv acc state)
          (index-topics children-topics
            "Subtopics"
            topics-fal
            disable-autolinking-p
            base-pkg
            state
            acc)))
      (acc (printtree-rconcat "</topic>" acc))
      (acc (cons #\
 acc))
      (acc (printtree-rconcat "</page>" acc))
      (acc (cons #\
 acc)))
    (mv (printtree->str acc) state)))