1 ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancements. ;;;;;
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 nisimp
)
15 ;;;programs for the LET LETSIMP LETRULES and REMLET commands
16 ;;;these programs use the names LETSIMPTREE and LETRULES on the
17 ;;;property list of atoms
18 ;;;except for the top level programs all program names have the prefix NIS
20 (declare-top (special nistree nisrules nisflag
))
22 (defmvar $letvarsimp nil
)
26 :properties
((evflag t
)))
28 (defmvar $default_let_rule_package
'$default_let_rule_package
29 "The name of the default rule package used by `let' and `letsimp'")
31 (putprop '$default_let_rule_package
'let-rule-setter
'assign
)
33 (defmvar $current_let_rule_package
'$default_let_rule_package
34 "The name of the current rule package used by `let' and `letsimp'")
36 (putprop '$current_let_rule_package
'let-rule-setter
'assign
)
38 (defmvar $let_rule_packages
'((mlist) $default_let_rule_package
)
39 "The names of the various let rule simplification packages")
41 (putprop '$let_rule_packages
'let-rule-setter
'assign
)
43 (setq nisrules nil nistree nil
)
45 (defun let-rule-setter (var val
)
46 (cond ((eq var
'$default_let_rule_package
)
47 (merror (intl:gettext
"assignment: cannot assign to default_let_rule_package.")))
48 ((and (eq var
'$current_let_rule_package
)
49 (not (memalike val
(cdr $let_rule_packages
))))
50 (merror (intl:gettext
"assignment: ~M is not a rule package.") val
))
51 ((eq var
'$let_rule_packages
)
52 (merror (intl:gettext
"assignment: cannot assign to let_rule_packages.~%assignment: call 'let' to create let rule packages.")))))
54 (defmspec $let
(l) (setq l
(cdr l
))
55 (if (null (cdr l
)) (wna-err '$let
))
56 ;;LET([PATTERN,REPL,PRED,ARG1,...,ARGN],NAME)
57 (prog (pattern pat replacement treename text $ratfac
)
58 ;;LET(PATTERN,REPL,PRED,ARG1,...,ARGN)
60 (setq treename $current_let_rule_package
))
61 ((eq 'mlist
(caaar l
))
62 (setq treename
(cadr l
))
63 (if (not (symbolp treename
))
64 (improper-arg-err treename
'$let
))
66 (t (setq treename $current_let_rule_package
)))
67 (let ((nistree (mget treename
'letsimptree
))
68 (nisrules (mget treename
'letrules
)))
69 (setq pat
(strip-lineinfo (meval (car l
))))
70 (setq replacement
(cdr l
))
71 (setq pattern
(cond ((atom pat
) (list pat
))
72 ((eq (caar pat
) 'mtimes
)
75 (setq nistree
(nislet nistree pattern replacement
))
76 (cond (treename (mputprop treename
79 (add2lnc treename $let_rule_packages
)))
80 (nonsymchk (caddr l
) '$let
)
82 (append (list '(mtext) pat
'| --
> |
)
85 '#.
(intern (format nil
" ~A " 'where
))
86 (cons (list (caddr l
))
89 (setq nisrules
(append (list text
) nisrules
))
90 (cond (treename (mputprop treename
95 (defun nislet (tree list function
)
97 (setq permlist
(nispermutations list
))
98 step
(cond ((eq nil permlist
) (return tree
)))
99 (setq tree
(nistreebuilder tree
(car permlist
) function
))
100 (setq permlist
(cdr permlist
))
103 (defun nispermutations (llist)
105 ((null (cdr llist
)) (list llist
))
110 (nisaddon (car llist
)
111 (nispermutations (append a
(cdr llist
))))
113 (if (null (cdr llist
)) (return permlist
))
115 (setq llist
(cdr llist
))
118 (defun nisaddon (x llist
)
119 (if llist
(cons (cons x
(car llist
)) (nisaddon x
(cdr llist
)))))
121 (defun nistreebuilder (tree perm function
)
122 (cond ((null perm
) (cons (list function
) tree
))
124 (list (cons (car perm
)
125 (nistreebuilder nil
(cdr perm
) function
))))
126 ((equal (car perm
) (caar tree
))
129 (nistreebuilder (cdar tree
)
133 (nistreebuilder (cdr tree
)
137 (defun nisswcar (x y
)
140 (defun nisswcdr (x y
)
143 (defmspec $remlet
(x)
145 ;; REMLET(PROD,NAME) REMLET(PROD) REMLET() REMLET(FALSE,NAME)
146 (prog (pattern text treename
)
147 (cond ((cddr x
) (wna-err '$remlet
))
148 ((null (cdr x
)) (setq treename $current_let_rule_package
))
149 (t (setq treename
(cadr x
))
150 (if (not (symbolp treename
))
151 (improper-arg-err treename
'$remlet
))))
152 (setq pattern
(strip-lineinfo (meval (car x
))))
153 (when (or (not pattern
) (eq '$all pattern
))
154 (setq nisrules nil nistree nil
)
155 (unless (eq treename
'$default_let_rule_package
)
156 (setq $let_rule_packages
(delete treename $let_rule_packages
:count
1 :test
#'eq
)))
158 (setq nistree
(mget treename
'letsimptree
))
159 (if (setq text
(nisremlet pattern
)) (return text
))
162 (nistreelister (mget treename
'letrules
) pattern
))
164 a
(mputprop treename nistree
'letsimptree
)
165 (mputprop treename nisrules
'letrules
)
168 (defun nistreelister (llist pattern
)
170 a
(if (alike1 pattern
(cadar llist
)) (return (append x
(cdr llist
))))
171 (setq x
(append x
(list (car llist
))) llist
(cdr llist
))
174 (defun nisremlet (pat)
175 (prog (llist permlist x
)
176 (setq llist
(if (mtimesp pat
) (cdr pat
) (ncons pat
)))
177 (setq nisflag t x nistree
)
178 (setq permlist
(nispermutations llist
))
179 step
(when (null permlist
) (setq nistree x
) (return nil
))
180 (setq x
(nistreetrimmer (car permlist
) x
))
181 (if (null nisflag
) (merror (intl:gettext
"remlet: no rule found: ~M") pat
))
182 (setq permlist
(cdr permlist
))
185 (defun nistreetrimmer (perm tree
)
187 (cond ((null tree
) (setq nisflag nil
))
189 (setq nisflag
(caar tree
)) (cdr tree
))
190 (t (nisswcdr tree
(nistreetrimmer nil
(cdr tree
))))))
191 ((null tree
) (setq nisflag nil
))
192 ((equal (car perm
) (caar tree
))
194 (setq x
(nistreetrimmer (cdr perm
) (cdar tree
)))
195 (if (null x
) (return (cdr tree
)))
196 (return (nisswcar tree
(nisswcdr (car tree
) x
)))))
197 (t (nisswcdr tree
(nistreetrimmer perm
(cdr tree
))))))
199 (defmspec $letrules
(name)
200 (setq name
(cdr name
)) ;LETRULES(NAME)
201 (let ((treename (if name
(car name
) $current_let_rule_package
)))
202 (if (not (symbolp treename
)) (improper-arg-err treename
'$letrules
))
203 (setq nistree
(mget treename
'letsimptree
)
204 nisrules
(mget treename
'letrules
))
205 (apply #'$disp nisrules
)))
207 (defmspec $letsimp
(form) ;letsimp(expr,tree1,...,treen)
208 (setq form
(cdr form
))
209 (let* ((expr (strip-lineinfo (meval (pop form
))))
212 (progv (unless sw
'(varlist genvar
))
213 (unless sw
(list varlist genvar
))
214 (when (and sw
(member 'trunc
(cdar expr
) :test
#'eq
))
215 (setq expr
($taytorat expr
)))
216 (dolist (rulepackage (or form
(list $current_let_rule_package
))
217 (if sw
(ratf expr
) expr
))
218 (unless (symbolp rulepackage
)
219 (improper-arg-err rulepackage
'$letsimp
))
220 (when (setq nistree
(mget rulepackage
'letsimptree
))
221 ;; Whereas nisletsimp returns an expression in general
222 ;; representation, the original expr might be in CRE form.
223 ;; Regardless, we use ratf to make sure varlist and genvar
224 ;; know of expr's kernels.
225 (setq expr
(nisletsimp (if (atom expr
)
229 (defun nisletsimp (e)
232 ((or (and (atom e
) (setq x
(ncons e
)))
233 (and (eq (caar e
) 'mtimes
) (setq x
(cdr e
))))
234 (setq x
(nisnewlist x
))
235 (if x
(nisletsimp ($ratexpand
(cons '(mtimes) x
))) e
))
236 ((member (caar e
) '(mplus mequal mlist $matrix
) :test
#'eq
)
237 (cons (if (eq (caar e
) 'mplus
) '(mplus) (car e
))
238 (mapcar #'nisletsimp
(cdr e
))))
239 ((or (eq (caar e
) 'mrat
)
240 (and (eq (caar e
) 'mquotient
) (setq e
(ratf e
))))
242 (t ;; A kernel (= product of 1 element)
243 (setq x
(nisnewlist (ncons e
)))
244 (if x
(nisletsimp ($ratexpand
(cons '(mtimes) x
))) e
)))))
246 (defun nisletsimprat (e)
247 (let ((num (cadr e
)) (denom (cddr e
)) $ratexpand
)
248 (if $letvarsimp
(setq varlist
(mapcar #'nisletsimp varlist
)))
249 (let (($ratexpand t
))
250 ; Construct new CREs based on the numerator and denominator
251 ; of E and disrep them in the VARLIST and GENVAR context from
254 ; NISLETSIMP can change VARLIST and GENVAR, so the order of
255 ; the PDIS and NISLETSIMP forms matter here. PDISing and
256 ; NISLETSIMPing the numerator before moving on to the
257 ; denominator is not correct.
258 (let ((varlist (mrat-varlist e
))
259 (genvar (mrat-genvar e
)))
262 (setq num
(nisletsimp num
)
263 denom
(nisletsimp denom
)))
264 (setq e
(list '(mquotient) num denom
))
265 (if $letrat
(nisletsimp ($ratexpand e
)) e
)))
267 (defun nisnewlist (llist)
268 (let ((x (nissearch llist nistree nil
))) (if x
(nisreplace llist x
))))
270 (defun nissearch (x y z
)
272 ((nisinnernull y
) (nisfix (nisinnernull y
) z
))
274 (t (prog (xx yy path bind
)
277 b
(cond ((and (setq bind
(nismatch (car xx
)
284 (return (cons (car bind
) path
))))
288 (cond ((null yy
) (return nil
)))
291 (defun nisinnernull (x)
293 ((null (cdar x
)) (caar x
))
294 (t (nisinnernull (cdr x
)))))
296 (defun nisfix (funperd argasslist
)
297 (prog (function args bindings perd flag
)
298 (if (not argasslist
) (return (car funperd
)))
299 (setq argasslist
(nisnumberpicker argasslist
))
300 (setq args
(maplist 'caar argasslist
))
301 (setq bindings
(maplist 'cdar argasslist
))
302 (mbinding (args bindings
)
303 (setq function
(car funperd
))
304 (if (setq perd
(cdr funperd
))
305 (if (not (meval perd
)) (setq flag t
)))
306 (if (null flag
) (setq function
(meval function
))))
307 (return (if flag nil
(list function
)))))
309 (defun nisnumberpicker (x)
311 ((or (not (symbolp (caar x
)))
312 (kindp (caar x
) '$constant
))
313 ;; Skip over numbers and constants
314 (nisnumberpicker (cdr x
)))
315 (t (nisswcdr x
(nisnumberpicker (cdr x
))))))
317 (defun nismatch (a b c
)
319 (setq x
(nisextract a
))
320 (setq y
(nisextract b
))
323 (cond ((and (listp (cadr x
))
324 (equal (car x
) (car y
))
325 (setq c
(cons (cons (car x
) (car y
)) c
))
326 (setq c
(nisargschecker (cadr x
)
329 (setq newexpt
(nisexpocheck (cddr x
)
332 (cond ((equal '(rat) (car newexpt
))
333 (return (cons (cons a
(nisbuild x newexpt
))
335 (t (return (cons (cons a
'(dummy 0 (0 0)))
338 (cond ((and (setq c
(nisargmatch (niskernel a
) (car y
) c
))
339 (setq newexpt
(nisexpocheck (cddr x
)
342 (cond ((equal '(rat) (car newexpt
))
343 (return (cons (cons a
(nisbuild x newexpt
))
345 (t (return (cons (cons a
'(dummy 0 (0 0)))
350 (if (mexptp a
) (cadr a
) a
))
352 (defun nisextract (x)
353 (cond ((or (atom x
) (eq (caar x
) 'rat
))
355 ((eq 'mexpt
(caar x
))
356 (cond ((atom (cadr x
))
357 (cons (cadr x
) (cons t
(caddr x
))))
358 (t (cons (if (member 'array
(cdaadr x
) :test
#'eq
)
359 (list (caaadr x
) 'array
)
361 (cons (cdadr x
) (caddr x
))))))
362 (t (cons (if (member 'array
(cdar x
) :test
#'eq
)
363 (list (caar x
) 'array
)
367 (defun nisargschecker (listargs treeargs argasslist
)
369 (cond ((and listargs treeargs
) (go check
))
370 ((or listargs treeargs
) (return nil
))
371 (t (return argasslist
)))
372 check
(setq c
(nisargmatch (car listargs
)
375 (cond (c (return (nisargschecker (cdr listargs
)
380 (defun nisexpocheck (listpower treepower argasslist
)
381 (prog (p q r s a b xx
)
382 (cond ((atom treepower
)
383 (cond ((numberp treepower
)
384 (prog2 (setq r treepower s
1) (go math
)))
385 (t (return (nisargmatch listpower
388 (setq r
(cadr treepower
) s
(caddr treepower
))
389 (if (not (numberp s
)) (return nil
))
390 math
(cond ((numberp listpower
) (setq p listpower q
1))
391 ((atom listpower
) (return nil
))
392 ((eq 'rat
(caar listpower
))
393 (setq p
(cadr listpower
) q
(caddr listpower
)))
395 (setq xx
(* (* q s
) (- (* p s
) (* q r
))))
396 (setq a
(< (* r s
) 0))
398 (cond ((or (not (or a b
)) (and a
(or b
(equal 0 xx
))))
399 (return (list '(rat) xx
(* q s
)))))
402 (defun nisargmatch (x y c
)
405 up
(if (null w
) (go down
))
406 (cond ((eq (caar w
) y
)
407 (cond ((alike1 (cdar w
) x
) (return c
))
411 down
(setq w
(mget y
'matchdeclare
))
412 (cond ((null w
) (if (equal x y
) (go out
) (return nil
)))
413 ((member (car w
) '($true t
) :test
#'eq
) (go out
))
415 (meval (cons (ncons (car w
))
416 (append (cdr w
) (list x
)))))
418 ((and (not (atom (car w
)))
419 (not (atom (caar w
)))
421 ; If we arrive here, (CAR W) is a Maxima expression like ((FOO) ...)
422 ; If (CAR W) is a Maxima lambda expression, evaluate it via MFUNCALL.
423 ; Otherwise, append X and call MEVAL.
424 ; Note that "otherwise" includes Maxima lambda expressions with missing arguments;
425 ; in that case the expression is ((MQAPPLY) ((LAMBDA) ...)) and MEVAL is the way to go.
426 (if (eq (caaar w
) 'lambda
)
428 (meval (append (car w
) (list x
)))))
431 out
(return (cons (cons y x
) c
))))
433 (defun nisbuild (x newexpt
)
436 (cons (if (symbolp (car x
)) (ncons (car x
)) (car x
))
441 (defun nisreplace (llist asslist
)
442 (cond ((eq (cdr asslist
) nil
) (cons (car asslist
) llist
))
443 ((equal (car llist
) (caar asslist
))
444 (cond ((equal 0 (cadar (cdddar asslist
)))
445 (nisreplace (cdr llist
) (cdr asslist
)))
446 (t (cons (cdar asslist
)
447 (nisreplace (cdr llist
) (cdr asslist
))))))
448 (t (cons (car llist
) (nisreplace (cdr llist
) asslist
)))))