When autoloading a Maxima script, avoid clobbering global state.
[maxima.git] / src / mstuff.lisp
blob75b119a55bf3696501c202adc4555eb390d0f1df
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 ;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package :maxima)
13 (macsyma-module mstuff)
15 (defmfun $sort (l &optional (f 'lessthan))
16 (let ((llist l) comparfun bfun ($prederror t))
17 (unless ($listp llist)
18 (merror (intl:gettext "sort: first argument must be a list; found: ~M") llist))
19 (setq llist (copy-list (cdr llist))
20 comparfun
21 (mfunction1 (setq bfun (getopr f))))
22 (when (member bfun '(lessthan great) :test #'eq)
23 (setq llist (mapcar #'ratdisrep llist)))
24 (cons '(mlist) (stable-sort llist comparfun))))
26 ;; cmulisp does not like the closure version. Clisp insists on the
27 ;; closure version. Gcl likes either... For the moment we will
28 ;; leave a conditional here.
29 (defun mfunction1 (fun)
30 (if (functionp fun)
31 (lambda (x y) (mevalp (funcall fun x y)))
32 #+(or cmu scl)
33 (lambda (x y) (mevalp `((,fun) ((mquote) ,x) ((mquote) ,y))))
34 #-(or cmu scl)
35 #'(lambda (x y) (mevalp `((,fun) ((mquote) ,x) ((mquote) ,y))))))
37 (defun lessthan (a b)
38 (great b a))
40 (defmspec $makelist (x)
41 (setq x (cdr x))
42 (prog (n form arg a b c d lv)
43 (setq n (length x))
44 (cond
45 ((= n 0) (return '((mlist))))
46 ((= n 1)
47 (setq form (first x))
48 (return
49 `((mlist) ,(meval `(($ev) ,@(list (list '(mquote) form)))))))
50 ((= n 2)
51 (setq form (first x))
52 (setq b ($float (meval (second x))))
53 (if (numberp b)
54 (return
55 (do
56 ((m 1 (1+ m)) (ans))
57 ((> m b) (cons '(mlist) (nreverse ans)))
58 (push (meval `(($ev) ,@(list (list '(mquote) form))))
59 ans)))
60 (merror (intl:gettext "makelist: second argument must evaluate to a number; found: ~M") b)))
61 ((= n 3)
62 (setq form (first x))
63 (setq arg (second x))
64 (setq b (meval (third x)))
65 (if ($listp b)
66 (setq lv (mapcar #'(lambda (u) (list '(mquote) u)) (cdr b)))
67 (progn
68 (setq b ($float (meval b)))
69 (if ($numberp b)
70 (return
71 (do
72 ((m 1 (1+ m)) (ans))
73 ((> m b) (cons '(mlist) (nreverse ans)))
74 (push
75 (meval
76 `(($ev) ,@(list (list '(mquote) form)
77 (list '(mequal) arg m)))) ans)))
78 (merror (intl:gettext "makelist: third argument must be a number or a list; found: ~M") b)))))
79 ((= n 4)
80 (setq form (first x))
81 (setq arg (second x))
82 (setq a (meval (third x)))
83 (setq b (meval (fourth x)))
84 (setq d ($float (meval `((mplus) ,b ((mtimes) ,a -1)))))
85 (if (numberp d)
86 (setq lv (interval2 a 1 d))
87 (merror (intl:gettext "makelist: the fourth argument minus the third one must evaluate to a number; found: ~M") d)))
88 ((= n 5)
89 (setq form (first x))
90 (setq arg (second x))
91 (setq a (meval (third x)))
92 (setq b (meval (fourth x)))
93 (setq c (meval (fifth x)))
94 (setq d ($float
95 (meval
96 `((mtimes) ((mplus) ,b ((mtimes) ,a -1)) ((mexpt) ,c -1)))))
97 (if (numberp d)
98 (setq lv (interval2 a c d))
99 (merror (intl:gettext "makelist: the fourth argument minus the third one, divided by the fifth one must evaluate to a number; found: ~M") d)))
100 (t (merror (intl:gettext "makelist: maximum 5 arguments allowed; found: ~M.~%To create a list with sublists, use nested makelist commands.") n)))
101 (return
102 (do ((lv lv (cdr lv))
103 (ans))
104 ((null lv) (cons '(mlist) (nreverse ans)))
105 (push (meval `(($ev)
106 ,@(list (list '(mquote) form)
107 (list '(mequal) arg (car lv)))))
108 ans)))))
110 (defun interval2 (i s d)
111 (do ((nn i (meval `((mplus) ,s ,nn)))
112 (m 0 (1+ m))
113 (ans))
114 ((> m d) (nreverse ans))
115 (push nn ans)))
117 (defun interval (i j)
118 (do ((nn i (add2 1 nn))
119 (m 0 (1+ m))
120 (k (sub* j i))
121 (ans))
122 ((> m k) (nreverse ans))
123 (push nn ans)))
125 (defmfun $sublist (a f)
126 (unless ($listp a)
127 (merror (intl:gettext "sublist: first argument must be a list; found: ~M") a) )
128 (do ((a (cdr a) (cdr a))
129 (x))
130 ((null a) (cons '(mlist) (nreverse x)))
131 (if (definitely-so (mfuncall f (car a)))
132 (push (car a) x))))