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 (defmspec $example (l)
  14   (declare (special *need-prompt*))
  15   (let ((example (second l)))
  16     (when (symbolp example)
  17       ;; Coerce a symbol to be a string.
  18       ;; Remove the first character if it is a dollar sign.
  19       (setq example (coerce (exploden (stripdollar example)) 'string)))
  20     (unless (stringp example)
  21       (merror
  22         (intl:gettext "example: argument must be a symbol or a string; found: ~M") example))
  23     ;; Downcase the string. $example is not case sensitive.
  24     (setq example (string-downcase example))
  25     (with-open-file (st ($file_search1 $manual_demo '((mlist) $file_search_demo)))
  26       (prog (tem all c-tag d-tag)
  27        again
  28        (setq tem (read-char st nil))
  29        (unless tem (go notfound))
  30        (unless (eql tem #\&) (go again))
  31        (setq tem (read-char st nil))
  32        (unless (eql tem #\&) (go again))
  33        ;; so we are just after having read &&
  34
  35        (setq tem (read st nil nil))
  36        (unless tem (go notfound))
  37        ;; Coerce the topic in tem to be a string.
  38        (setq tem (coerce (exploden tem) 'string))
  39        (cond ((string= tem example)
  40               (go doit))
  41              (t (push tem all)
  42                 (go again)))
  43        ;; at this stage we read maxima forms and print and eval
  44        ;; until a peek sees '&' as the first character of next expression,
  45        ;; but at first skip over whitespaces.
  46        doit
  47        (when (member (setq tem (peek-char nil st nil))
  48                      '(#\tab #\space #\newline #\linefeed #\return #\page))
  49          ;; Found whitespace. Read char and look for next char.
  50          ;; The && label can be positioned anywhere before the next topic.
  51          (setq tem (read-char st nil))
  52          (go doit))
  53        (cond ((or (null tem) (eql tem #\&))
  54               (setf *need-prompt* t)
  55               (return '$done)))
  56        (setq tem (dbm-read st nil nil))
  57        (incf $linenum)
  58        (setq c-tag (makelabel $inchar))
  59        (unless $nolabels (setf (symbol-value c-tag) (nth 2 tem)))
  60        (let ($display2d)
  61          (displa `((mlabel) ,c-tag ,(nth 2 tem))))
  62        (setq $% (meval* (nth 2 tem)))
  63        (setq d-tag (makelabel $outchar))
  64        (unless $nolabels (setf (symbol-value d-tag) $%))
  65        (when (eq (caar tem) 'displayinput)
  66          (displa `((mlabel) ,d-tag ,$%)))
  67        (go doit)
  68
  69        notfound
  70        (setf *need-prompt* t)
  71        (if (= (length l) 1)
  72          (return `((mlist) ,@(nreverse all)))
  73          (progn
  74            (mtell (intl:gettext "example: ~M not found. 'example();' returns the list of known examples.~%") example)
  75            (return '$done)))))))
  76
  77 (defun mread-noprompt (&rest read-args)
  78   (let ((*mread-prompt* "") (*prompt-on-read-hang*))
  79     (declare (special *mread-prompt* *prompt-on-read-hang*))
  80     (unless read-args (setq read-args (list #+(or sbcl cmu) *standard-input*
  81                                             #-(or sbcl cmu) *query-io*)))
  82     (caddr (apply #'mread read-args))))
  83
  84 ;; Some list creation utilities.
  85
  86 (defmspec $create_list (l)
  87   (cons '(mlist) (apply #'create-list1 (cadr l) (cddr l))))
  88
  89 (defun create-list1 (form &rest l &aux lis var1 top)
  90   (cond ((null l) (list (meval* form)))
  91         (t
  92          (setq var1 (first l)
  93                lis (second l)
  94                l (cddr l))
  95          (unless (symbolp var1) (merror (intl:gettext "create_list: expected a symbol; found: ~A") var1))
  96          (setq lis (meval* lis))
  97          (mbinding ((list var1))
  98            (cond ((and (numberp lis)
  99                        (progn
 100                          (setq top (car l) l (cdr l))
 101                          (setq top (meval* top))
 102                          (numberp top)))
 103                   (loop for i from lis to top
 104                      do (mset var1 i)
 105                      append
 106                      (apply #'create-list1 form l)))
 107                  (($listp lis)
 108                   (loop for v in (cdr lis)
 109                      do (mset var1 v)
 110                      append
 111                      (apply #'create-list1 form l)))
 112                  (t (merror (intl:gettext "create_list: unexpected arguments."))))))))
 113
 114 ;; The documentation is now in INFO format and can be printed using
 115 ;; tex, or viewed using info or gnu emacs or using a web browser.  All
 116 ;; versions of maxima have a builtin info retrieval mechanism.
 117
 118 (defmspec $describe (x)
 119   (let ((topic ($sconcat (cadr x)))
 120         (exact-p (or (null (caddr x)) (eq (caddr x) '$exact))))
 121     (if exact-p
 122         (cl-info::info-exact topic)
 123         (cl-info::info-inexact topic))))
 124
 125 ; The old implementation
 126 ;(defun $apropos (s)
 127 ;  (cons '(mlist) (apropos-list s :maxima)))
 128
 129 ;;; Utility function for apropos to filter a list LST with a function FN
 130 ;;; it is semiliar to remove-if-not, but take the return value of the function
 131 ;;; and build up a new list with this values.
 132 ;;; e.g. (filter #'(lambda(x) (if (oddp x) (inc x)) '(1 2 3 4 5)) --> (2 4 6)
 133
 134 (defun filter (fn lst)
 135   (let ((acc nil))
 136     (dolist (x lst)
 137       (let ((val (funcall fn x)))
 138         (if val (push val acc))))
 139     (nreverse acc)))
 140
 141 (defmspec $apropos (s)
 142   (let (acc y)
 143     (setq s (car (margs s)))
 144     (cond ((stringp s)
 145            ;; A list of all Maxima names which contain the string S.
 146            (setq acc (append acc (apropos-list (stripdollar s) :maxima)))
 147            ;; Filter the names which are Maxima User symbols starting
 148            ;; with % or $ and remove duplicates.
 149            ($listify
 150              ($setify
 151                (cons '(mlist)
 152                       (filter #'(lambda (x)
 153                                   (cond ((char= (get-first-char x) #\$) x)
 154                                         ((char= (get-first-char x) #\%)
 155                                          ;; Change to a verb, when present.
 156                                          (if (setq y (get x 'noun))
 157                                              y
 158                                              x))
 159                                         (t nil)))
 160                               acc)))))
 161           (t
 162            (merror
 163              (intl:gettext "apropos: argument must be a string; found: ~M") s)))))