;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Code examples from the presentation:
;;;
;;; Extensions to Lisp to Support the Design of Electronic Circuits and Systems
;;;
;;; International Lisp Conference 2005, Stanford University, June 19-22, 2005
;;;
;;; Martin Mallinson (martin.mallinson@ieee.org)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :sas)
(eval-when (:compile-toplevel :load-toplevel)
(import '(net.html.generator:html-stream net.html.generator:html net.html.generator:*html-stream*)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; HTML
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Some clarifications: there is a daily documentation file. It is an HTML file that
;;; records what you document during the day. This file is used if in reference to
;;; a more explicit file name is given. These daily documentation files are all linked to
;;; in a daily log file. If any explicit document is used, a link to it in the daily documentation
;;; is made. So two basic things: a daily documentation file of which there are many, one for each day
;;; and a daily log file of which there is one.
(defvar *html-output-file* nil)
(defvar *last-html-output-file* nil)
;;; the default directory for all documentation
(defun default-documentation-directory (&optional force-re-specify (probe t))
(let ((new-format-string
(format nil
"You have asked to use the Background Documentation System. ~%~
This is a feature that will keep track of your work in~%~
the background as HTML files throughout the day. But this~%~
machine has not been used for this before and so I dont know~%~
where to put all the HTML files. Is it OK to continue and ask~%~
you to specify the directory to keep all HTML files?"))
(invalid-entry-format-string
(format nil
"The Background Documentation System has an invalid directory.~%~
Do you want to re-specify the directory?")))
(labels ((default-from-registry () (rvalue :html-documents :random))
(ask-user-for-new
(query-text &optional (prompt "Choose a Directory for HTML Documentation Files"))
(let ((p1 (format nil "Create ~a" (default-from-registry))))
(if (default-from-registry)
(ask-user-for-action
((p1 (ensure-directories-exist (merge-pathnames #P"foo.txt" (default-from-registry))))
("Choose another"
(let ((directory (ask-user-for-directory :prompt prompt)))
(when directory
(ensure-directories-exist (merge-pathnames #P"foo.txt" directory))
(setf (rvalue :html-documents :random) (namestring directory)))))
("Cancel" (return-from default-documentation-directory nil)))
:prompt query-text)
(ask-user-for-action
(("Choose Directory"
(let ((directory (ask-user-for-directory :prompt prompt)))
(when directory
(ensure-directories-exist (merge-pathnames #P"foo.txt" directory))
(setf (rvalue :html-documents :random) (namestring directory)))))
("Cancel" (return-from default-documentation-directory nil)))
:prompt query-text)))))
(if force-re-specify (ask-user-for-new new-format-string)
(let ((registry-value (default-from-registry)))
(if (null registry-value) (ask-user-for-new new-format-string)
(if (null probe) registry-value
(if (directory (merge-pathnames #P"*.*" registry-value)) registry-value
(let ((test-pathname (merge-pathnames #P"empty.txt" registry-value)))
(ignore-errors
(with-open-file (str test-pathname :direction :output)
(write-string "Ignore this empty file" str))
(delete-file test-pathname)
(return-from default-documentation-directory registry-value))
(ask-user-for-new
invalid-entry-format-string
(format nil "Replace ~a as doc. directory" registry-value)))))))))))
;;; This is the log file...
(defun html-daily-index-file ()
(let ((directory (default-documentation-directory)))
(when directory (make-pathname :name "Daily Log" :type "html" :defaults directory))))
;;; The default file for documents this is the daily documentation file - note it is
;;; down in a directory named by the day..
(defun default-documentation-file ()
(flet ((doc-file-error
(cond)
(ask-user-for-action
(("Cancel" (throw :document-error nil))
("Re-specify File"
(default-documentation-directory t)
(return-from default-documentation-file (default-documentation-file)))
("Process as a Bug" nil))
:prompt (format nil "This error was found:~%=>~A~%~
The documentation system was in the process of verifying the~%~
existence of the documentation directory. Perhaps that directory~%~
is no longer mounted or perhaps no longer exists? If this is the~%~
case you should choose to re-specify the file. The filename will~%~
be saved for next time.~2%What would you like to do?~2%~
Cancel just ignores the error and continues with no documentation~%~
Re-specify file will ask you for another file to use for documentation~%~
Process as Bug will call up the bug reporting system~%~
[You may have to choose Cancel more than one time but the program~%~
should safely recover if you choose to cancel the request]" cond)
:title "Error During Documentation Request")))
(multiple-value-bind (sec min hour date month year) (decode-universal-time (get-universal-time))
(declare (ignore hour min sec))
(let ((directory (default-documentation-directory))
(name (format nil "doc-~d-~d-~d" year month date)))
(when directory
(let ((result (make-pathname :name name
:type "html"
:directory (append (pathname-directory directory)
(list (format nil "~d-~d-~d" month date year)))
:defaults directory)))
(handler-bind ((file-error #'doc-file-error))
(ensure-directories-exist result))
result))))))
'(defun edit-html (&optional (file (html-daily-index-file)))
(multiple-value-bind (command num-arg) (format-string-from-registry-command-string "http")
(when command
(case num-arg
(0 (excl::run-shell-command (format nil "~a ~a" command (format nil "file:///~a" file)) :wait nil))
(1 (excl::run-shell-command (format nil command (format nil "file:///~a" file)) :wait nil))))))
(defun edit-html (&optional (file (html-daily-index-file)))
(invoke-html-browser file))
#-runtime-system
(def-sas-menu-function (com-edit-html :name "Edit ~HTML") (edit-html))
(defun current-html-file () (or *html-output-file* (default-documentation-file)))
(defun html-ref-pathname (pathname &optional (html-file (current-html-file)))
;; For now if its not the same directory just write the long pathname...
(if (excl::pathname-equalp (excl::path-pathname pathname) (excl::path-pathname html-file))
(format nil "~a.~a" (pathname-name pathname) (pathname-type pathname))
(format nil "file:///~a" (substitute #\| #\: (substitute #\/ #\\ (namestring pathname))))))
(defun add-file-to-daily-log (html-file &optional title)
(with-open-file (str (html-daily-index-file) :direction :output :if-exists :append :if-does-not-exist :create)
(html-stream
str
(:html
(:head (:title "Documentation Stream Log"))
(:body
((:a :href (html-ref-pathname html-file (html-daily-index-file)))
(:princ (or title (format nil "~/sas::fdate/ ~:*~/sas::ftime/" (get-universal-time)))))
:br)))))
;;; This macro works as follows: if you call me with no arguments I will use the stream *html-stream* if
;;; there is one, and just output to that. If there isnt one I will append to todays documentation stream.
;;; If you call me with a title I'll use it, (but if I am appending, you may not see it on the viewer title).
;;; If you give me a file I assume you want to use that so I will replace *html-stream* with a stream to that
;;; file for the context of the call. Finally, if you give me a file I will link to that file in the daily log.
;;; Here is the "problem" with this: in effect a call to document-html with no file spec means put it in the
;;; daily log. The clear and obvisous way to do this would be to bind *html-stream* and *html-output-file*
;;; to the daily log. No problem, then exiting from an inner context of a call to document-html with a filename
;;; we would find ourselves back in the dialiy log context. We cant do that for two reasons. 1: the daily log
;;; would be open for all the lisp session, which goes on for more than one day and 2: I want to be able to
;;; open and inspect the daily log at all times. Fortunatly, if we keep opening and closing the daily log appending
;;; new HTML in the top level html context, at least Netscape and Microsoft show all the file. Thats what I do:
;;; each call to document-html in the "null" (ie top level context) opens the daily documenation file and appends.
(defmacro document-html ((&optional title &key file link show) &body body)
`(let ((%file-spec% ,file)
(%new-day-file% nil)
(%title% ,title)
(%link% ,link)
(%file% nil))
(labels ((%do-documentation% () (terpri *html-stream*) (html ,@body))
(%do-documentation-in-context%
(file)
;; Bind the the the two specials - one in the let the other conveniently in the open-file call and do it..
(let ((*html-output-file* file))
(with-open-file (*html-stream* *html-output-file* :direction :output :if-exists :append :if-does-not-exist :create)
(html
(:html
(:head (:title (:princ-safe (or %title% (format nil "Documentation Stream ~a" (pathname-name *html-output-file*))))))
(:body (%do-documentation%))))))))
(cond
((and *html-stream* (null %file-spec%))
;; this is the easy bit - there is no new file and the stream is open - just do it...
(%do-documentation%))
(%file-spec%
;; There is a new file to open but there is no stream. This means we just encounted a call to document something
;; we create the context and do the documentation: but then we log the file in the daily documenation:
(setq %file% (merge-pathnames (pathname %file-spec%) (default-documentation-file)))
(%do-documentation-in-context% %file%)
;; Now at this point a stream was not open: but we leave a link in the daily doc by calling the
;; generic documentation function on that file:
(unless %link% (document "~&
Documented "))
(document-html-file %file% %link%)
(unless %link% (document " at ~/ide.editor::ftime/" (get-universal-time))))
(t
;; here we are now with no HTML stream and no file. This means that a call to document-html is to record the
;; results in the daily document file: make the context for that and call it..
(setq %file% (default-documentation-file))
;; see if it is new - if it is, we want to link to it in the daily log file..
(setq %new-day-file% (not (probe-file %file%)))
(%do-documentation-in-context% %file%)
;; if it was new, link to it in the log file:
(when %new-day-file% (add-file-to-daily-log %file% (or %title% ,link)))))
;; at this point if we made file we can show t if asked to do so:
(when (and %file% ,show) (edit-html %file%))
%file%)))
#-runtime-system
(setf (text-edit-indentation 'document-html) '(4 2))
;;;-------------------------------------------------------
;;; How things document themselves
;;;
;;; To simple functions: the first is #'document meaning document the thing in
;;; the current documentation stream. The second is #'document-href which will return a file
;;; that is to be the object itself: the presumption is that clicking on this file links brings
;;; up the object in the appropriate tool. For example, if a dataplot object is asked to document
;;; itself it will make an image in the current documentation stream as a result of the call
;;; to #'document then #'document-href will be called and, if it should return a file
;;; if there is a file type that can recreate th object. The file will presumably be of
;;; type *.dpz that can be opened with data plot...
;;;
#||
;;; Bottom level catchers
(defmethod document ((obj t) &rest format-args) obj)
(defmethod document-href ((obj t) in-html-file &rest format-args) (declare (ignore in-html-file)) ())
;;; Around the base line documentation function we try to put the
;;; document object onto the arg list. I presume that document calls
;;; document on a more appropriate object if it itself cannot handle it.
;;; (example: documenting a data plot creates a bit map and documents that)
(defmethod document :around ((obj t) &rest format-args)
;; Sadly, a string cant handle this generically because the
;; format-arg to a string is not parsable as a plist..
(catch :document-error
(unless (or (typep obj 'string) (getf format-args :href))
(setf (getf format-args :href)
(apply #'document-href obj (current-html-file) format-args))
(when (getf format-args :br)
(document-html () (:br) (:princ #\newline))
(setf (getf format-args :br) nil)))
(apply #'call-next-method obj format-args)))
;; Ask the user for a note to place in the document stream
(defun document-note (&optional (doc-prompt "Documentation Note:") format-string &rest format-args)
(if format-string
(document (apply #'format nil format-string format-args))
(multiple-value-bind (string1 string2 button-text)
(ask-user-for-string doc-prompt "" "OK" "Cancel" nil nil "Documentation Note")
(declare (ignore string2))
(unless (string-equal button-text "Cancel")
(when (> (string-length string1) 1)
(document string1)
string1)))))
;;; A string is simple, just output it.
(defmethod document ((obj string) &rest format-args)
(document-html () (:princ (apply #'format nil obj format-args)))
obj)
(defmethod document ((obj pixmap) &rest format-args)
(let ((name (getf format-args :name))
(quality (getf format-args :quality))
(href (getf format-args :href))
(scratch-path (make-pathname :name "pixtemp" :type "bmp" :defaults (sys::temporary-directory))))
(when (probe-file scratch-path) (delete-file scratch-path))
(save-pixmap obj scratch-path)
(document-bmp-file scratch-path :name name :quality quality :href href))
obj)
||#
;;; This is a third-party converter that I need to convert to JPEG:
;;; Aug 2003 now use newer open-source conveter "PVW32Con.exe"
(defun find-cjpeg-file ()
(let* ((registry-clue (rvalue :cjpeg-source :random))
(found (and registry-clue
(probe-file
(make-pathname :name "PVW32Con" :type "exe"
:defaults (pathname registry-clue))))))
(or found
(and (report-text "Searching for PVW32Con")
(let ((subfind (ignore-errors (directory "\\**\\PVW32Con.exe"))))
(when subfind
(setf (rvalue :cjpeg-source :random) (namestring (excl::path-pathname (car subfind))))
(car subfind))))
(let ((user (ask-user-for-existing-pathname "Please Locate the file PVW32Con.exe"
:allowed-types '(("Executables" . "*.exe")))))
(when user
(setf (rvalue :cjpeg-source :random) (namestring (excl::path-pathname user)))
user))
(error "Sorry, cant locate the PVW32Con.EXE file to make jpegs"))))
(defvar *cjpeg-failed* nil)
(defun document-bmp-file (bmp-file &key name quality href)
(let ((type (if *cjpeg-failed* "bmp" "jpg")))
(unless (pathnamep name)
(setq name (make-pathname :type type
:name (or name (pathname-name bmp-file))
:defaults (current-html-file))))
(unless (numberp quality) (setq quality 75))
(setq quality (round quality))
(let ((executable (find-cjpeg-file))
(temp-jpg (make-pathname :type "jpg" :defaults bmp-file)))
(when executable
(when (probe-file temp-jpg) (delete-file temp-jpg))
(if *cjpeg-failed*
(sys::copy-file bmp-file temp-jpg)
(with-current-directory (executable)
(excl:run-shell-command
(format nil "PVW32Con.exe ~a -j --o ~a --jq~d" (namestring bmp-file) (namestring temp-jpg) quality)
:wait t :show-window :minimized)))
(unless (or (probe-file temp-jpg)
(sleep 0.25)
(probe-file temp-jpg)
(sleep 1.0)
(probe-file temp-jpg))
(when *cjpeg-failed*
(error "No output file. Even BMP link failed~%Tried to find ~s" temp-jpg))
(cerror "Link to the BMP file? (should work on IE)"
"No JPG File ~s expected. ~%(PVW32Con.exe may have failed)~%~s" temp-jpg
(format nil "PVW32Con.exe ~a -j --o ~a --jq~d"
(namestring bmp-file) (namestring temp-jpg) quality))
(setq *cjpeg-failed* t)
(return-from document-bmp-file
(document-bmp-file bmp-file :name name :quality quality :href href)))
(when (probe-file name) (delete-file name))
(sys::copy-file temp-jpg name)
(if href
(document-html ()
((:a :href (princ-to-string (html-ref-pathname href)))
((:img :src (format nil "~a.~a" (pathname-name name) type) :border 0))))
(document-html ()
((:img :src (format nil "~a.~a" (pathname-name name) type)))))))))
(defun document-html-file (html-file &optional (link-text (pathname-name html-file)))
(unless link-text (setq link-text (pathname-name html-file)))
(document-html ()
((:a :href (html-ref-pathname html-file)) (:princ link-text))))
;;;-------------------------------------------------------
;;; Some simple help for tables and so forth:
(defun table-stats-row (name list &key printer units)
(html
(:tr
(:td (:princ name))
(cond
((stringp printer)
(html
(:td (format *html-stream* printer (if list (reduce #'min list) "*")))
(:td (format *html-stream* printer (if list (mean list) "*")))
(:td (format *html-stream* printer (if list (reduce #'max list) "*")))))
(printer
(html
(:td (funcall printer (if list (reduce #'min list) "*") *html-stream*))
(:td (funcall printer (if list (mean list) "*") *html-stream*))
(:td (funcall printer (if list (reduce #'max list) "*") *html-stream*))))
(t
(html
(:td (:princ (if list (reduce #'min list) "*")))
(:td (:princ (if list (mean list) "*")))
(:td (:princ (if list (reduce #'max list) "*"))))))
(when units (html (:td (:princ units)))))))
;;;-------------------------------------------------------
;;;
#||
(defun test ()
;;; These next two forms go into the daily document stream...
(document "fred")
(let ((bmp (ask-user-for-existing-pathname "BMP" :allowed-types '(("BMP" . "*.bmp")))))
(document-bmp-file bmp :href bmp))
(document-html ("My Amplifier stuff" :file "amp" :link "
fred the man")
(document "Right now my amplifier sucks")
(document-html ("How bad?" :file "amp2")
(document "not at all really - just a test"))))
(test)
(edit-html)
||#
;;;-------------------------------------------------------
;;; Provide
(provide :html-doc)