1 ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancments. ;;;;;
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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
))
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)
31 (lambda (x y
) (mevalp (funcall fun x y
)))
33 (lambda (x y
) (mevalp `((,fun
) ((mquote) ,x
) ((mquote) ,y
))))
35 #'(lambda (x y
) (mevalp `((,fun
) ((mquote) ,x
) ((mquote) ,y
))))))
40 (defmspec $makelist
(x)
42 (prog (n form arg a b c d lv
)
45 ((= n
0) (return '((mlist))))
49 `((mlist) ,(meval `(($ev
) ,@(list (list '(mquote) form
)))))))
52 (setq b
($float
(meval (second x
))))
57 ((> m b
) (cons '(mlist) (nreverse ans
)))
58 (push (meval `(($ev
) ,@(list (list '(mquote) form
))))
60 (merror (intl:gettext
"makelist: second argument must evaluate to a number; found: ~M") b
)))
64 (setq b
(meval (third x
)))
66 (setq lv
(mapcar #'(lambda (u) (list '(mquote) u
)) (cdr b
)))
68 (setq b
($float
(meval b
)))
73 ((> m b
) (cons '(mlist) (nreverse ans
)))
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
)))))
82 (setq a
(meval (third x
)))
83 (setq b
(meval (fourth x
)))
84 (setq d
($float
(meval `((mplus) ,b
((mtimes) ,a -
1)))))
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
)))
91 (setq a
(meval (third x
)))
92 (setq b
(meval (fourth x
)))
93 (setq c
(meval (fifth x
)))
96 `((mtimes) ((mplus) ,b
((mtimes) ,a -
1)) ((mexpt) ,c -
1)))))
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
)))
102 (do ((lv lv
(cdr lv
))
104 ((null lv
) (cons '(mlist) (nreverse ans
)))
106 ,@(list (list '(mquote) form
)
107 (list '(mequal) arg
(car lv
)))))
110 (defun interval2 (i s d
)
111 (do ((nn i
(meval `((mplus) ,s
,nn
)))
114 ((> m d
) (nreverse ans
))
117 (defun interval (i j
)
118 (do ((nn i
(add2 1 nn
))
122 ((> m k
) (nreverse ans
))
125 (defmfun $sublist
(a f
)
127 (merror (intl:gettext
"sublist: first argument must be a list; found: ~M") a
) )
128 (do ((a (cdr a
) (cdr a
))
130 ((null a
) (cons '(mlist) (nreverse x
)))
131 (if (definitely-so (mfuncall f
(car a
)))