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