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;(defmfun $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))))) 164