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 1982 Massachusetts Institute of Technology ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13 (macsyma-module matrun
)
15 ;;; TRANSLATION properties for the FSUBRs in this file
16 ;;; can be found in MAXSRC;TRANS5 >. Be sure to check on those
17 ;;; if any semantic changes are made.
19 (declare-top (special $rules $maxapplyheight $maxapplydepth
))
21 ;; $MAXAPPLYDEPTH is the maximum depth within an expression to which
22 ;; APPLYi will delve. If $MAXAPPLYDEPTH is 0, it is applied only to
24 (defmvar $maxapplydepth
10000.
)
26 ;; If $MAXAPPLYHEIGHT is 0, only atoms are affected by $APPLYB1 and
28 (defmvar $maxapplyheight
10000.
)
30 (defmvar matchreverse nil
)
32 (defmspec $disprule
(l) (setq l
(cdr l
))
33 (if (and (eq (car l
) '$all
) (null (cdr l
)))
34 (disprule1 (cdr $rules
))
38 `((mlist simp
) ,@(loop for r in l collect
(cadr ($ldisp
(consrule r
))))))
41 (let ((rule (mget x
'$rule
)))
42 (if rule
(list '(msetq simp
) x
(cons '(marrow simp
) (cdr rule
)))
43 (merror (intl:gettext
"disprule: ~:M is not a user rule.") x
))))
45 (defmfun $remrule
(op rule
)
48 (cond ((not (eq rule
'$all
))
49 (removerule op rule
) (return (getop op
)))
50 ((null (setq rules
(mget op
'oldrules
)))
51 (merror (intl:gettext
"remrule: no rules known for operator ~:@M") op
)))
52 next
(cond ((or (null rules
) (null (cdr rules
)))
53 (mputprop op
1 'rulenum
) (return (getop op
)))
54 (t (removerule op
(car rules
))
55 (setq rules
(cdr rules
)) (go next
)))))
57 (defun removerule (op rule
)
58 (cond ((member rule
*builtin-$rules
* :test
#'eq
)
62 (oldrules old othrulename othrule
)
63 (setq oldrules
(mget op
'oldrules
))
64 (cond ((or (null rule
) (null (setq oldrules
(member rule oldrules
:test
#'equal
))))
65 (merror (intl:gettext
"remrule: no such rule: ~:M") rule
))
66 ((null (car (setq oldrules
(cdr oldrules
))))
67 (setq oldrules
(cdr oldrules
))
68 (setq othrulename
'simpargs1
)
69 (setq othrule
#'(lambda (a bb c
) (declare (ignore bb
)) (simpargs a c
))))
70 (t (setq othrulename
(car oldrules
))
71 (setq othrule
(cadr (getl (car oldrules
) '(expr subr
))))))
72 (putprop rule othrule
'expr
)
73 (setq old
(cdr (member rule
(reverse (mget op
'oldrules
)) :test
#'equal
)))
74 (if old
(putprop (car old
)
75 (subst othrulename rule
(get (car old
) 'expr
))
77 (if (boundp rule
) (makunbound rule
))
78 (mremprop rule
'$rule
)
79 (mremprop rule
'$ruletype
)
80 (mremprop rule
'ruleof
)
82 (setq $rules
(delete rule $rules
:count
1 :test
#'eq
))
83 (putprop rule othrulename
'expr
)
84 (if (eq (get op
'operators
) rule
)
85 (putprop op othrulename
'operators
))
86 (return (mputprop op
(delete rule
(mget op
'oldrules
) :test
#'eq
) 'oldrules
))))))
89 (cond ((equal e
1) '(1 .
0))
90 ((equal e
0) '(0 .
1))
92 ((eq (caar e
) 'mexpt
) (cons (cadr e
) (caddr e
)))
95 (defmfun findfun
(e p c
)
97 (cond ((and (null (atom e
)) (eq (caar e
) p
)) (return e
))
98 ((or (atom e
) (not (eq (caar e
) c
))) (matcherr))
99 ((and (null matchreverse
) (member c
'(mplus mtimes
) :test
#'eq
))
100 (setq e
(reverse (cdr e
))) (go b
)))
102 b
(cond ((null e
) (matcherr))
103 ((and (not (atom (car e
))) (eq (caaar e
) p
)) (return (car e
))))
106 (defmfun findexpon
(e1 base
* c
)
109 (cond ((and (mexptp e
) (alike1 base
* (cadr e
)))
111 ((or (atom e
) (not (eq (caar e
) c
))) (go c
))
112 ((and (null matchreverse
) (member c
'(mplus mtimes
) :test
#'eq
))
113 (setq e
(reverse (cdr e
))) (go b
)))
115 b
(cond ((null e
) (go c
))
116 ((and (mexptp (car e
)) (alike1 base
* (cadar e
)))
117 (return (caddar e
))))
119 c
(cond ((or (and (not (atom e1
)) (member c
'(mplus mtimes
) :test
#'eq
)
120 (eq c
(caar e1
)) (memalike base
* e1
))
122 (and (not (atom base
*)) (eq c
(caar base
*))))
124 ((eq c
'mexpt
) (matcherr))
127 (defmfun findbase
(e expon c
)
129 (cond ((equal expon
0)
130 (if (and (eq c
'mexpt
) (not (equal 1 e
))) (matcherr))
132 ((equal expon
1) (return e
))
133 ((and (numberp expon
) (> expon
0) (equal e
0))
135 ((and (mexptp e
) (alike1 expon
(caddr e
)))
137 ((or (atom e
) (not (eq (caar e
) c
))) (matcherr))
138 ((and (null matchreverse
) (member c
'(mplus mtimes
) :test
#'eq
))
139 (setq e
(reverse (cdr e
))) (go b
)))
142 (return (if (and (realp expon
) (minusp expon
)) 1 0)))
143 ((and (mexptp (car e
)) (alike1 expon
(caddar e
)))
147 (defmfun part
+ (e p preds
)
148 (prog (flag saved val
)
149 (if (not (mplusp e
)) (matcherr))
150 (cond ((> (length p
) (length preds
))
152 (setq p
(nthkdr p
(- (length p
) (length preds
))))
153 (setq p
(nreverse p
))))
154 (setq e
(copy-tree e
)) ; PREVIOUSLY: (setq e ($ratexpand e))
156 a
(cond ((null p
) (cond ((null e
) (return t
)) (t (matcherr))))
157 ((and (cdr preds
) (member (car (caddar preds
)) '(msetq setq
) :test
#'eq
))
158 (cond (flag (merror (intl:gettext
"PART+: two or more pattern variables match anything.")))
159 (t (setq flag t p
(reverse p
) preds
(reverse preds
))
161 ((not (atom (car p
)))
164 loop
(cond ((null mye
) (matcherr)))
165 (setq val
(catch 'match
(mcall (car preds
) (car mye
))))
167 (setq mye
(cdr mye
)) (go loop
))
168 (t (return (setq e
(delete (car mye
) e
:count
1 :test
#'equal
))))))
170 (t (mset (car p
) 0)))
174 (cond ((null (setq val
(catch 'match
(mcall (car preds
) z
)))) nil
)
175 (t (setq saved
(add2* saved val
))
176 (setq e
(delete z e
:count
1 :test
#'equal
)))))
178 (cond ((and (equal saved
0)
179 (null (setq val
(catch 'match
(mcall (car preds
) 0)))))
182 b
(setq preds
(cdr preds
) p
(cdr p
))
185 (defmfun part
* (e p preds
)
186 (prog (flag saved val
)
187 (if (not (mtimesp e
)) (matcherr))
188 (cond ((> (length p
) (length preds
))
190 (setq p
(nthkdr p
(- (length p
) (length preds
))))
191 (setq p
(nreverse p
))))
192 (setq e
(copy-tree e
)) ; PREVIOUSLY: (setq e ($factor e))
194 a
(cond ((null p
) (cond ((null e
) (return t
)) (t (matcherr))))
195 ((and (cdr preds
) (member (car (caddar preds
)) '(msetq setq
) :test
#'eq
))
196 (cond (flag (merror (intl:gettext
"PART*: two or more pattern variables match anything.")))
197 (t (setq flag t p
(reverse p
) preds
(reverse preds
))
199 ((not (atom (car p
)))
202 loop
(cond ((null mye
) (matcherr)))
203 (setq val
(catch 'match
(mcall (car preds
) (car mye
))))
205 (setq mye
(cdr mye
)) (go loop
))
206 (t (return (setq e
(delete (car mye
) e
:count
1 :test
#'equal
))))))
208 (t (mset (car p
) 1)))
211 #'(lambda (z) (setq val
(catch 'match
(mcall (car preds
) z
)))
212 (cond ((null val
) nil
)
213 (t (setq saved
(mul2* saved val
))
214 (setq e
(delete z e
:count
1 :test
#'equal
)))))
216 (cond ((and (equal saved
1)
217 (null (setq val
(catch 'match
(mcall (car preds
) 1)))))
220 b
(setq preds
(cdr preds
) p
(cdr p
))
223 ;;; TRANSLATE property in MAXSRC;TRANS5 >
225 (defmspec $apply1
(l) (setq l
(cdr l
))
226 (let ((expr (meval (car l
))))
227 (mapc #'(lambda (z) (setq expr
(apply1 expr z
0))) (cdr l
))
230 (defmfun apply1
(expr *rule depth
)
232 ((> depth $maxapplydepth
) expr
)
236 (setq expr
(rule-apply *rule expr
))
238 ((or (atom expr
) (mnump expr
)) (return expr
))
239 ((eq (caar expr
) 'mrat
)
240 (setq expr
(ratdisrep expr
)) (go b
))
246 (mapcar #'(lambda (z) (apply1 z
*rule
(1+ depth
)))
250 (defmspec $applyb1
(l) (setq l
(cdr l
))
251 (let ((expr (meval (car l
))))
252 (mapc #'(lambda (z) (setq expr
(car (apply1hack expr z
)))) (cdr l
))
255 (defmfun apply1hack
(expr *rule
)
260 ((atom expr
) (return (cons (multiple-value-bind (ans rule-hit
) (mcall *rule expr
) (if rule-hit ans expr
)) 0)))
261 ((specrepp expr
) (setq expr
(specdisrep expr
)) (go b
)))
262 (setq pairs
(mapcar #'(lambda (z) (apply1hack z
*rule
))
265 (mapc #'(lambda (l) (setq max
(max max
(cdr l
)))) pairs
)
266 (setq expr
(simplifya (cons (delsimp (car expr
))
267 (mapcar #'car pairs
))
269 (cond ((= max $maxapplyheight
) (return (cons expr max
))))
270 (setq expr
(rule-apply *rule expr
))
271 (return (cons expr
(1+ max
)))))
273 (defun *rulechk
(*rule
)
274 (if (and (symbolp *rule
) (not (fboundp *rule
)) (not (mfboundp *rule
)))
275 (merror (intl:gettext
"apply1: no such rule: ~:M") *rule
)))
277 (defun rule-apply (*rule expr
)
279 loop
(multiple-value-setq (ans rule-hit
) (mcall *rule expr
))
280 (cond ((and rule-hit
(not (alike1 ans expr
)))
281 (setq expr ans
) (go loop
)))
284 (defmspec $apply2
(l) (setq l
(cdr l
))
285 (let ((rulelist (cdr l
))) (apply2 rulelist
(meval (car l
)) 0)))
287 (defmfun apply2
(rulelist expr depth
)
289 ((> depth $maxapplydepth
) expr
)
291 (prog (ans ruleptr rule-hit
)
292 a
(setq ruleptr rulelist
)
296 ((atom expr
) (return expr
))
297 ((eq (caar expr
) 'mrat
)
298 (setq expr
(ratdisrep expr
)) (go b
))
304 (mapcar #'(lambda (z) (apply2 rulelist z
(1+ depth
)))
307 (cond ((progn (multiple-value-setq (ans rule-hit
) (mcall (car ruleptr
) expr
)) rule-hit
)
310 (t (setq ruleptr
(cdr ruleptr
)) (go b
)))))))
312 (defmspec $applyb2
(l) (setq l
(cdr l
))
313 (let ((rulelist (cdr l
))) (car (apply2hack rulelist
(meval (car l
))))))
315 (defmfun apply2hack
(rulelist e
)
318 (cond ((atom e
) (return (cons (apply2 rulelist e -
1) 0)))
319 ((specrepp e
) (return (apply2hack rulelist
(specdisrep e
)))))
320 (setq pairs
(mapcar #'(lambda (x) (apply2hack rulelist x
)) (cdr e
)))
322 (mapc #'(lambda (l) (setq max
(max max
(cdr l
)))) pairs
)
323 (setq e
(simplifya (cons (delsimp (car e
)) (mapcar #'car pairs
)) t
))
324 (cond ((= max $maxapplyheight
) (return (cons e max
)))
325 (t (return (cons (apply2 rulelist e -
1) (1+ max
)))))))