;;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10 -*-
;;;; --------------------------------------------------------------------------
;;;; File name: static-kb-browser.lsp
;;;; System: FIRE
;;;; Version:
;;;; Author: Jesse Alama
;;;; Created: January 8, 2002
;;;; Purpose: Generation of static HTML pages containing simple
;;;; documentation for colections
;;;; --------------------------------------------------------------------------
;;;; Modified: Sunday, January 4, 2004 at 21:06:10 by Kenneth Forbus
(in-package :fire)
;; The static KB browser depends upon the AllegroServe system; it is essential
;; that you load the AllegroServe system if you want to compile or load the
;; static KB browser
(defun document-html-for-collections (top-level-cols path kb)
(when (probe-file path)
(let ((all-cols (union top-level-cols
(union-all (mapcar #'(lambda (col)
(all-specs col :kb kb))
top-level-cols)))))
(generate-toc top-level-cols path kb)
(dolist (col (remove-if-not #'symbolp all-cols))
(when (symbolp col)
(generate-html-for-collection col path kb all-cols)))
:done)))
(defun union-all (lists &key (test #'eq) (key #'identity))
(reduce #'(lambda (lst1 lst2)
(union lst1 lst2 :test test :key key))
lists))
;; internals
;; Helpful macros for HTML generation
(defmacro with-html-stream ((stream) &body body)
`(net.html.generator:html-stream ,stream ,@body))
(defmacro with-html-file ((title header sub-header footer path fname)
&body body)
"Construct an HTML page with string TITLE as title, string HEADER for
a header, HTML form SUB-HEADER as a sub-header, string PATH as the
directory in which to store the HTML file called by the string FNAME"
(let ((html-file (gensym)))
`(with-open-file (,html-file (qrg::make-qrg-file-name ,path ,fname)
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(with-html-stream (,html-file)
(:html
(:head (:title (:princ ,title)))
(:body (print-html (make-heading ,header :align "center" :size 2))
(when ,sub-header
(print-html
(make-heading ,sub-header :align "center" :size 4)))
(:hr)
(progn ,@body)
(when ,footer
(print-html :hr)
(print-html
(make-heading ,footer :align "center" :size 4)))))))))
;; HTML generation
(defun generate-toc (cols path kb)
"Generate a table of contets page for top-level collections COLS
to be stored as \"toc.html\" under the path PATH. A table of contents
page provides links to the given top-level collections, declares that
knowledge base KB was used, and displays the time when the TOC was
created."
(multiple-value-bind (second minute hour date month year)
(get-decoded-time)
(declare (ignore second))
(let* ((time-string (format nil
"TOC generated on ~S/~S/~S at ~S:~S with KB ~S"
month date year hour minute (name kb)))
(header "Table of Contents")
(footer (make-heading time-string :align "center" :size 5))
(sub-header nil)) ;; don't use a sub-header for the TOC
(with-html-file
("Table of Contents" header sub-header footer path "toc.html")
(print-html
(make-ul
(link-known-collections cols (remove-if-not #'symbolp cols)))))))
:done)
(defun generate-html-for-collection (col path kb all-cols)
"Write a simple HTML file describing the collection COL. The file
will have have the name of COL as its title, and it will contain
a heading with the collection name and a pointer to the table of
contents. A comment for or description of the collection is provided
(if one is available), followed by several sections containing
\"definitional information\" for the collection, such as
the collections of which COL is an instance, its specializations, and
its generalizations. (If any of thse collections of collections is
empty, then that section is omitted.) A list of all formulas
mentioning COL is also included. All of the information concerning
COL is gathered from the knowledge base KB"
(let ((specs (sort (remove-duplicates
(remove-if-not #'symbolp (all-specs col :kb kb)))
#'string< :key #'princ-to-string))
(genls (sort
(remove-duplicates
(remove-if-not #'symbolp (all-genls col :kb kb)))
#'string< :key #'princ-to-string))
(isas (sort (remove-duplicates
(remove-if-not #'symbolp (retrieve-isas col :kb kb)))
#'string< :key #'princ-to-string))
(mentions (retrieve-references col :kb kb))
(comment (get-documentation col kb))
(col-name (format nil "~A" col))
(col-fname (format nil "~A.html" col)))
;; define document structure elements
(let* ((toc-link '((:a href "toc.html")
"[return to table of contents]"))
(header col-name)
(sub-header toc-link)
(footer toc-link))
(with-html-file (col-name header sub-header footer path col-fname)
;; ensure that a comment is written, even if one is unavailable
(if comment
(write-section "Comment" (make-princ comment))
(write-section "Comment" (make-princ "[no comment available]")))
;; the comment section is the only one not UL'ed; for
;; consistency, add an extra newline that comes for
;; free with UL on the other sections
(print-html '(:br))
(when isas
(write-col-section "Instance Of" isas all-cols
:list-type :comma-separated-list))
(when genls
(write-col-section "Generalizations" genls all-cols
:list-type :comma-separated-list))
(when specs
(write-col-section "Specializations" specs all-cols
:list-type :unordered-list))
(mark-and-write-mentions-of-col col mentions all-cols))))
:done)
(defun write-col-section (label cols known-cols &key list-type)
"Construct a new section having string LABEL as its label, mark up
collections in COLS that are also in KNOWN-COLS, and construct
an HTML unordered list whose elements are the marked-up collections"
(if (eq list-type :comma-separated-list)
(write-section label
(make-comma-separated-list
(link-known-collections cols known-cols)))
(write-section label
(make-ul
(link-known-collections cols known-cols)))))
(defun link-known-collections (cols known-cols)
"Generate a list of HTML forms for printing out elements of the list COLS
so that elements of COLS that are symbols and members of KNOWN cols are
hyperlinked and the remaing elements simply printed"
(let ((linked '()))
(dolist (col cols)
(if (and (symbolp col) (member col known-cols))
(push (make-collection-link col) linked)
(push (make-princ col) linked)))
linked))
;; Pretty-printing (and linking) formulas used in generating the
;; "Mentions" section
(defun mark-and-write-mentions-of-col (col formulas all-cols)
"Given a collection COL and a list FORMULAS of formulas, write an
HTML unordered list whose elements are the full-marked counterparts
of elements of FORMULAS (see REPLACE-COLS-WITH-LINKS)."
(net.html.generator:html (:b "Formulas mentioning ") (:b (:princ col)))
(net.html.generator:html
(:ul (dolist (formula formulas)
(print-html (format nil "~A"
(mark-formula formula all-cols))))))
:done)
;; Note: the functions MARK-FORMULA and REPLACE-COLS-WITH-LINKS
;; may not be portable; I take advantage of the fact that the
;; print result of interning complex symbols in Allegro has vertical bars
(defun mark-formula (formula all-cols)
"Replace a pretty string that comes from FORMULA by replacing all names
of collections in FORMULA with their HTML A tagged counterparts
(see REPLACE-COLS-WITH-LINKS)."
(let* ((pretty (with-output-to-string (pretty)
(pprint (replace-cols-with-links formula
all-cols) pretty)))
(new-html (format nil "~A~%
" pretty)))
(remove #\| new-html :test #'char=)))
(defun replace-cols-with-links (formula all-cols)
"Replace each collection mentioned in FORMULA that is a member of ALL-COLS
with a new symbol whose symbol name is an HTML A tag pointing to a page
for the original collection the A symbol replaced."
(let ((subst '()))
(dolist (symbol (flatten formula))
(when (member symbol all-cols)
(let ((ahref (format nil "~A" symbol symbol)))
(push (cons symbol (intern ahref)) subst))))
(sublis subst formula)))
(defun flatten (formula)
(cond ((null formula) formula)
((not (consp formula)) (list formula))
(t (append (flatten (car formula))
(flatten (cdr formula))))))
;; General purpose HTML generation utilities
;; Part 1: Construction of HTML forms
(defun make-ul (list-elements)
(cons :ul (mapcar #'make-li list-elements)))
(defun make-comma-separated-list (list-elements)
(when list-elements
(let* ((reversed (reverse list-elements))
(last (car reversed))
(initial (reverse (cdr reversed)))
(result nil))
(dolist (elem initial)
(push elem result)
(push '(:princ ", ") result))
(setq result (append (list last) result))
(cons :p (reverse result)))))
(defun make-li (form) `(:li ,form))
(defun make-princ (obj) `(:princ ,obj))
(defun make-collection-link (collection)
"Given a collection name COLLECTION, construct an HTML A tag whose
whose anchor name is COLLECTION and whose HREF argument is
the result of appending \".html\" to the string representation of
COLLECTION."
(let ((file-name (format nil "~A.html" collection)))
`((:a href ,file-name) (:princ ,collection))))
(defun make-heading (form &key (align "left") size)
(case size
(6 `((:h6 align ,align) ,form))
(5 `((:h5 align ,align) ,form))
(4 `((:h4 align ,align) ,form))
(3 `((:h3 align ,align) ,form))
(2 `((:h2 align ,align) ,form))
(t `((:h1 align ,align) ,form))))
;; Part 2: Writing HTML streams
(defun print-html (lhtml)
(net.html.generator:html-print lhtml net.html.generator:*html-stream*))
(defun write-section (label contents)
"A section consists of a label (a string) and an HTML form that it its
contents. Write a new section whose label is LABEL (but bold), and
whose content is the HTML form CONTENTS."
(print-html `(:b ,label)) (print-html " ") (print-html contents)
(print-html `(:br)))