src/macdes.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 (in-package :maxima)
  10
  11 (defvar $manual_demo "manual.demo")
  12
  13 (defmvar $browser "firefox '~a'"
  14   "Browser to use for displaying the documentation.  This may be
  15   initialized on startup to an OS-specific value.  It must contain
  16   exactly one ~a which will be replaced by the url.")
  17
  18 (defmvar $url_base "localhost:8080"
  19   "Base URL where the HTML doc may be found.  This can be a file path
  20   like \"file:///<path>\" or a web server like \"localhost:8080\" or
  21   some other web server.
  22
  23   This may be initialized on startup to a file path where the html
  24   files can be found.")
  25
  26 (defmvar $output_format_for_help '$text
  27   "The output format for help.  It should be one of the values '$text,
  28   '$html, '$frontend.  The default is '$text which causes the help to
  29   be sent to the terminal as plain text.  '$html opens a browser to
  30   the page for the help.  '$frontend assumes that some frontend will
  31   provide the necessary function to display help appropriately for the
  32   frontend.")
  33
  34 ;; When $output_format_for_help is set, set-output-format-for-help is
  35 ;; called to validate the value.
  36 (putprop '$output_format_for_help
  37          'set-output-format-for-help
  38          'assign)
  39
  40 (defvar *help-display-function*
  41   'display-text-topics
  42   "A symbol naming the function used to display help, as determined
  43   from $output_format_for_help.")
  44
  45 (defvar *debug-display-html-help* nil
  46   "Set to non-NIL to get some debugging messages from hdescribe.")
  47
  48 (defmspec $example (l)
  49   (declare (special *need-prompt*))
  50   (let ((example (second l)))
  51     (when (symbolp example)
  52       ;; Coerce a symbol to be a string.
  53       ;; Remove the first character if it is a dollar sign.
  54       (setq example (coerce (exploden (stripdollar example)) 'string)))
  55     (unless (stringp example)
  56       (merror
  57         (intl:gettext "example: argument must be a symbol or a string; found: ~M") example))
  58     ;; Downcase the string. $example is not case sensitive.
  59     (setq example (string-downcase example))
  60     (with-open-file (st ($file_search1 $manual_demo '((mlist) $file_search_demo)))
  61       (prog (tem all c-tag d-tag)
  62        again
  63        (setq tem (read-char st nil))
  64        (unless tem (go notfound))
  65        (unless (eql tem #\&) (go again))
  66        (setq tem (read-char st nil))
  67        (unless (eql tem #\&) (go again))
  68        ;; so we are just after having read &&
  69
  70        (setq tem (read st nil nil))
  71        (unless tem (go notfound))
  72        ;; Coerce the topic in tem to be a string.
  73        (setq tem (coerce (exploden tem) 'string))
  74        (cond ((string= tem example)
  75               (go doit))
  76              (t (push tem all)
  77                 (go again)))
  78        ;; at this stage we read maxima forms and print and eval
  79        ;; until a peek sees '&' as the first character of next expression,
  80        ;; but at first skip over whitespaces.
  81        doit
  82        (when (member (setq tem (peek-char nil st nil))
  83                      '(#\tab #\space #\newline #\linefeed #\return #\page))
  84          ;; Found whitespace. Read char and look for next char.
  85          ;; The && label can be positioned anywhere before the next topic.
  86          (setq tem (read-char st nil))
  87          (go doit))
  88        (cond ((or (null tem) (eql tem #\&))
  89               (setf *need-prompt* t)
  90               (return '$done)))
  91        (setq tem (dbm-read st nil nil))
  92        (incf $linenum)
  93        (setq c-tag (makelabel $inchar))
  94        (unless $nolabels (setf (symbol-value c-tag) (nth 2 tem)))
  95        (let ($display2d)
  96          (displa `((mlabel) ,c-tag ,(nth 2 tem))))
  97        (setq $% (meval* (nth 2 tem)))
  98        (setq d-tag (makelabel $outchar))
  99        (unless $nolabels (setf (symbol-value d-tag) $%))
 100        (when (eq (caar tem) 'displayinput)
 101          (displa `((mlabel) ,d-tag ,$%)))
 102        (go doit)
 103
 104        notfound
 105        (setf *need-prompt* t)
 106        (if (= (length l) 1)
 107          (return `((mlist) ,@(nreverse all)))
 108          (progn
 109            (mtell (intl:gettext "example: ~M not found. 'example();' returns the list of known examples.~%") example)
 110            (return '$done)))))))
 111
 112 (defun mread-noprompt (&rest read-args)
 113   (let ((*mread-prompt* "") (*prompt-on-read-hang*))
 114     (declare (special *mread-prompt* *prompt-on-read-hang*))
 115     (unless read-args (setq read-args (list #+(or sbcl cmu) *standard-input*
 116                                             #-(or sbcl cmu) *query-io*)))
 117     (caddr (apply #'mread read-args))))
 118
 119 ;; Some list creation utilities.
 120
 121 (defmspec $create_list (l)
 122   (cons '(mlist) (apply #'create-list1 (cadr l) (cddr l))))
 123
 124 (defun create-list1 (form &rest l &aux lis var1 top)
 125   (cond ((null l) (list (meval* form)))
 126         (t
 127          (setq var1 (first l)
 128                lis (second l)
 129                l (cddr l))
 130          (unless (symbolp var1) (merror (intl:gettext "create_list: expected a symbol; found: ~A") var1))
 131          (setq lis (meval* lis))
 132          (mbinding ((list var1))
 133            (cond ((and (numberp lis)
 134                        (progn
 135                          (setq top (car l) l (cdr l))
 136                          (setq top (meval* top))
 137                          (numberp top)))
 138                   (loop for i from lis to top
 139                      do (mset var1 i)
 140                      append
 141                      (apply #'create-list1 form l)))
 142                  (($listp lis)
 143                   (loop for v in (cdr lis)
 144                      do (mset var1 v)
 145                      append
 146                      (apply #'create-list1 form l)))
 147                  (t (merror (intl:gettext "create_list: unexpected arguments."))))))))
 148
 149 ;; The documentation is now in INFO format and can be printed using
 150 ;; tex, or viewed using info or gnu emacs or using a web browser.  All
 151 ;; versions of maxima have a builtin info retrieval mechanism.
 152
 153 (defmspec $describe (x)
 154   (let ((topic ($sconcat (cadr x)))
 155         (exact-p (or (null (caddr x)) (eq (caddr x) '$exact))))
 156     (if exact-p
 157         (cl-info::info-exact topic)
 158         (cl-info::info-inexact topic))))
 159
 160 (defmspec $apropos (s)
 161   (setq s (car (margs s)))
 162   (cond ((or (stringp s)
 163              (and (symbolp s) (setq s (string (stripdollar s)))))
 164          ;; A list of all Maxima names which contain the string S.
 165          (let ((acc (apropos-list s :maxima)))
 166            ;; Filter the names which are Maxima User symbols starting
 167            ;; with % or $ and remove duplicates.
 168            (remove-duplicates
 169             (cons '(mlist)
 170                    (delete-if-not
 171                     #'(lambda (x)
 172                         (cond ((eq x '||) nil)
 173                               ((char= (get-first-char x) #\$) x)
 174                               ;; Change to a verb, when present.
 175                               ((char= (get-first-char x) #\%) (or (get x 'noun) x))
 176                               (t nil)))
 177                     acc)) :test #'eq)))
 178         (t
 179          (merror
 180           (intl:gettext "apropos: argument must be a string or symbol; found: ~M") s))))
 181
 182 \f
 183 ;;; Display help in browser instead of the terminal
 184 (defun display-html-help (x)
 185   ;; The pattern is basically " <nnn>" where "nnn" is any number of
 186   ;; digits.
 187   (let ((fixup-regexp (pregexp:pregexp " <\([[:digit:]]\)>")))
 188     (flet ((fixup-topic (topic)
 189              ;; When using ?? adapt_depth, the list of topics is
 190              ;; "adapt_depth" and "adapt_depth <1>".  The HTML id of
 191              ;; "adapt_depth <1>" is "adapt-depth-1", so massage any
 192              ;; topic of the form "foo <n>" to "foo-n" so we can find
 193              ;; the HTML doc for it.  For simplicity, we'll use
 194              ;; pregexp to replace " <n>" with "-n".
 195              (pregexp:pregexp-replace fixup-regexp topic "-\\1")))
 196       (let* ((topic (fixup-topic ($sconcat x)))
 197              (found-it (gethash topic cl-info::*html-index*)))
 198         (when *debug-display-html-help*
 199           (format *debug-io* "topic = ~S~%" topic)
 200           (format *debug-io* "found-it = ~S~%" found-it))
 201         (when found-it
 202           (destructuring-bind (base-name . id)
 203               found-it
 204             (let ((url (concatenate 'string
 205                                     $url_base
 206                                     "/"
 207                                     (namestring base-name)
 208                                     "#index-"
 209                                     id))
 210                   command)
 211               (when *debug-display-html-help*
 212                 (format *debug-io* "URL: ~S~%" url))
 213               (setf command (ignore-errors (format nil $browser url)))
 214               (cond (command
 215                      (when *debug-display-html-help*
 216                        (format *debug-io* "Command: ~S~%" command))
 217                      ($system command))
 218                     (t
 219                      (merror "Browser command must contain exactly one ~~A:  ~S" $browser))))))
 220         topic))))
 221
 222 (defun display-html-topics (wanted)
 223   (when maxima::*debug-display-html-help*
 224     (format *debug-io* "wanted = ~S~%" wanted))
 225   (loop for (dir entry) in wanted
 226         do (display-html-help (car entry))))
 227
 228 (defun display-text-topics (wanted)
 229   (loop for item in wanted
 230         do (let ((doc (cl-info::read-info-text (first item) (second item))))
 231              (if doc
 232                  (format t "~A~%~%" doc)
 233                  (format t "Unable to find documentation for `~A'.~%~
 234                                 Possible bug maxima-index.lisp or build_index.pl?~%"
 235                          (first (second item)))))))
 236
 237 ;; Escape the characters that are special to XML. This mechanism excludes
 238 ;; the possibility that any keyword might coincide with the any xml tag
 239 ;; start or tag end marker.
 240 #+(or)
 241 (defun xml-fix-string (x)
 242   (when (stringp x)
 243     (let* ((tmp-x (wxxml-string-substitute "&amp;" #\& x))
 244            (tmp-x (wxxml-string-substitute "&lt;" #\< tmp-x))
 245            (tmp-x (wxxml-string-substitute "&gt;" #\> tmp-x))
 246            (tmp-x (wxxml-string-substitute "&#13;" #\Return tmp-x))
 247            (tmp-x (wxxml-string-substitute "&#13;" #\Linefeed tmp-x))
 248            (tmp-x (wxxml-string-substitute "&#13;" #\Newline tmp-x))
 249            (tmp-x (wxxml-string-substitute "&quot;" #\" tmp-x)))
 250       tmp-x)
 251     x))
 252
 253
 254 #+(or)
 255 (defun display-wxmaxima-topics (wanted)
 256   (loop for (dir entry) in wanted
 257         do
 258            ;; Tell wxMaxima to jump to the manual entry for "keyword"
 259            (format t "<html-manual-keyword>~a</html-manual-keyword>~%"
 260                    (xml-fix-string (car entry)))
 261            ;; Tell the lisp to make sure that this string is actually output
 262            ;; as soon as possible
 263            (finish-output)))
 264
 265 ;; When a frontend is running, this function should be redefined to
 266 ;; display the help in whatever way the frontend wants to.
 267 (defun display-frontend-topics (wanted)
 268   (declare (ignore wanted))
 269   (merror (intl:gettext "output_format_for_help: frontend not implemented.")))
 270
 271 (defun set-output-format-for-help (assign-var val)
 272   "When $output_format_for_help is set, this function validates the
 273   value and sets *help-display-function* to the function to display
 274   the help item in the specified format."
 275   ;; Don't need assign-var here.  It should be $output_format_for_help
 276   ;; since this function is only called when $output_format_for_help
 277   ;; is assigned.
 278   (declare (ignore assign-var))
 279   (case val
 280     ($text
 281      (setf *help-display-function* 'display-text-topics))
 282     ($html
 283      (setf *help-display-function* 'display-html-topics))
 284     ($frontend
 285      (if $maxima_frontend
 286          (setf *help-display-function* 'display-frontend-topics)
 287          (merror (intl:gettext "output_format_for_help set to frontend, but no frontend is running."))))
 288     (otherwise
 289      (merror (intl:gettext "output_format_for_help should be one of text, html, or frontend: ~M")
 290              val))))