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 nrat4
)
15 (declare-top (special $ratsimpexpons
*exp
*exp2
*radsubst
*loglist $radsubstflag
16 $logsimp
*v
*var radcanp
))
18 (defmvar $radsubstflag nil
19 "`radsubstflag' `t' makes `ratsubs' call `radcan' when it appears useful")
22 (defun pdis (x) ($ratdisrep
(pdis* x
)))
24 (defun pdis* (x) `((mrat simp
,varlist
,genvar
) ,x .
1))
26 (defun rdis (x) ($ratdisrep
(rdis* x
)))
28 (defun rdis* (x) `((mrat simp
,varlist
,genvar
) .
,x
))
30 (defun rform (x) (cdr (ratf x
)))
34 (defmfun $ratcoef
(e x
&optional
(n 1))
35 (ratcoeff e x n
)) ; The spelling "ratcoeff" is nicer.
37 (defun ratcoeff (a b c
)
38 (let* ((formflag ($ratp a
))
39 (taylorform (and formflag
(member 'trunc
(cdar a
) :test
#'eq
))))
40 (cond ((zerop1 b
) (improper-arg-err b
'$ratcoeff
))
41 ((mbagp a
) (cons (car a
)
42 (mapcar #'(lambda (a) (ratcoeff a b c
))
44 ((and taylorform
(mnump c
) (assolike b
(cadddr (cdar a
))))
46 ((and taylorform
(mexptp b
) (mnump c
) (mnump (caddr b
))
47 (assolike (cadr b
) (cadddr (cdar a
))))
48 (pscoeff1 a
(cadr b
) (mul2 c
(caddr b
))))
49 ((and taylorform
(equal c
0)) a
)
50 (t (if taylorform
(setq a
(ratdisrep a
)))
51 (setq a
(let ($ratwtlvl
)
53 (ratcoef (mul2* a b
) b
)
54 (ratcoef a
(if (equal c
1) b
(list '(mexpt) b c
))))))
55 (if (and formflag
(not taylorform
))
59 (defun minimize-varlist (ratfun)
60 (if (not ($ratp ratfun
)) (setq ratfun
(ratf ratfun
)))
61 (minvarlist-mrat (caddr (car ratfun
)) (cadddr (car ratfun
))
64 (defun minvarlist-mrat (vars gens ratform
)
65 (let ((newgens (union* (listovars (car ratform
))
66 (listovars (cdr ratform
)))))
67 (do ((lv vars
(cdr lv
))
72 (cons (list 'mrat
'simp
(nreverse nlv
) (nreverse nlg
))
74 (cond ((member (car lg
) newgens
:test
#'eq
)
76 (push (car lv
) nlv
))))))
78 (defun ratcoef (exp var
)
79 (prog (varlist genvar $ratfac $algebraic $ratwtlvl bas minvar
)
80 (setq var
(ratdisrep var
))
81 (setq bas
(if (and (mexptp var
) (mnump (caddr var
))) (cadr var
) var
))
84 (setq minvar
(car varlist
))
86 (setq exp
(cdr (ratrep* exp
)))
87 (setq var
(cdr (ratrep* var
)))
88 (setq bas
(cadr (ratrep* bas
)))
89 (if (and (onep1 (cdr exp
)) (onep1 (cdr var
)) (pureprod (car var
)))
90 (return (pdis* (prodcoef (car var
) (car exp
)))))
91 (setq exp
(ratquotient exp var
))
92 (if (null minvar
) (return (pdis* (prodcoef (cdr exp
) (car exp
)))))
93 (setq minvar
(caadr (ratrep* minvar
)))
94 loop
(if (or (pcoefp (cdr exp
)) (pointergp minvar
(cadr exp
)))
95 (return (rdis* (cdr (ratdivide exp bas
)))))
96 (setq exp
(ratcoef1 (car exp
) (cdr exp
)))
99 (defun ratcoef1 (num den
)
100 (cond ((pcoefp num
) (rzero))
101 ((eq (car num
) (car den
)) (car (pdivide num den
)))
102 ((pointergp (car den
) (car num
)) (rzero))
103 (t (ratcoef1 (constcoef (cdr num
)) den
))))
107 ((zerop (car p
)) (cadr p
))
108 (t (constcoef (cddr p
)))))
112 (defmfun $ratsubst
(a b c
) ; NEEDS CODE FOR FAC. FORM
113 (prog (varlist newvarlist dontdisrepit $ratfac genvar $keepfloat $float $numer
)
114 ;; hard to maintain user ordering info.
115 (if ($ratp c
) (setq dontdisrepit t
))
116 (if (and $radsubstflag
117 (prog2 (newvar b
) (some #'mexptp varlist
)))
118 (let (($factorflag t
) *exp
*exp2
*radsubst
)
119 (setq a
(fullratsimp a
))
120 (setq b
(fullratsimp b
))
121 (setq c
(fullratsimp c
))
125 (setq *exp
(cdr (ratrep* b
)))
126 (setq *exp2
(cdr (ratrep* c
)))
127 ;; since *radsubst is t, both *exp and *exp2 will be radcan simplified
130 (setq b
(rdis *exp
) c
(rdis *exp2
))
137 (setq a
($ratdisrep a
) b
($ratdisrep b
) c
($ratdisrep c
))
138 (cond ((integerp b
) (setq c
(ratf (maxima-substitute a b c
)))
139 (return (cond (dontdisrepit c
) (t ($ratdisrep c
))))))
148 (mapcar #'(lambda (zz)
149 (cond ((alike1 zz b
) a
)
152 ($ratsubst a b zz
)))))
155 (newvar a
) (newvar b
)
156 (setq newvarlist
(reverse (pairoff (reverse varlist
)
157 (reverse newvarlist
))))
158 (setq a
(cdr (ratrep* a
)))
159 (setq b
(cdr (ratrep* b
)))
160 (setq c
(cdr (ratrep* c
)))
161 (when (pminusp (car b
))
162 (setq b
(ratminus b
))
163 (setq a
(ratminus a
)))
164 (when (and (equal 1 (car b
))
165 (not (equal 1 (cdr b
)))
166 (not (equal 0 (car a
))))
167 (setq a
(ratinvert a
))
168 (setq b
(ratinvert b
)))
169 (cond ((not (equal 1 (cdr b
)))
170 (setq a
(rattimes a
(cons (cdr b
) 1) t
))
171 (setq b
(cons (car b
) 1))))
173 (cond ((member (car b
) '(0 1) :test
#'equal
)
174 (ratf (maxima-substitute (rdis a
) b
(rdis c
))))
175 (t (cons (list 'mrat
'simp varlist genvar
)
176 (if (equal (cdr a
) 1)
177 (ratreduce (everysubst0 (car a
) (car b
) (car c
))
178 (everysubst0 (car a
) (car b
) (cdr c
)))
179 (allsubst00 a b c
))))))
180 (unless (alike newvarlist varlist
)
181 (setq varlist newvarlist
185 (return (cond (dontdisrepit c
) (t ($ratdisrep c
))))))
187 (defun xptimes (x y
) (if $ratwtlvl
(wtptimes x y
0) (ptimes x y
)))
189 (defun allsubst00 (a b c
)
190 (cond ((equal a b
) c
)
191 ((not (equal (cdr b
) 1)) c
)
192 (t (ratquotient (everysubst00 a
(car b
) (car c
))
193 (everysubst00 a
(car b
) (cdr c
))))))
195 (defun everysubst00 (x i z
)
196 (loop with ans
= (rzero)
197 for
(exp coef
) on
(everysubst i z
*alpha
) by
#'cddr
198 do
(setq ans
(ratplus ans
(rattimes (cons coef
1) (ratexpt x exp
) t
)))
199 finally
(return ans
)))
201 (defun everysubst0 (x i z
)
202 (loop with ans
= (pzero)
203 for
(exp coef
) on
(everysubst i z
*alpha
) by
#'cddr
204 do
(setq ans
(pplus ans
(xptimes coef
(pexpt x exp
))))
205 finally
(return ans
)))
207 (defun everysubst1 (a b maxpow
)
208 (loop for
(exp coef
) on
(p-terms b
) by
#'cddr
209 for part
= (everysubst a coef maxpow
)
210 nconc
(if (= 0 exp
) part
211 (everysubst2 part
(make-poly (p-var b
) exp
1)))))
213 (defun everysubst2 (l h
)
214 (do ((ptr l
(cddr ptr
)))
216 (setf (cadr ptr
) (ptimes h
(cadr ptr
)))))
220 (cond ((null m
) l
) (t (cons (car m
) (pairoff (cdr l
) (cdr m
))))))
222 ;;(DEFUN PAIROFF (L M)
223 ;; ;(COND ((NULL M) L) (T (CONS (CAR M) (PAIROFF (CDR L) (CDR M)))))
225 ;; (dolist (x m (nreconc ans l))
226 ;; (push x ans) (setq l (cdr l)))))
228 (defun everysubst (a b maxpow
)
230 (cond ((equal a
1) (list maxpow b
))
233 (do ((b b
(quotient b a
))
235 ((or (> (abs a
) (abs b
))
238 (quotient b
(setq maxpow
(expt a maxpow
)))
241 (t (everysubst1 a b maxpow
))))
242 ((or (pcoefp b
) (pointergp (car a
) (car b
))) (list 0 b
))
243 ((eq (car a
) (car b
))
244 (cond ((null (cdddr a
)) (everypterms b
(caddr a
) (cadr a
) maxpow
))
245 (t (substforsum a b maxpow
))))
246 (t (everysubst1 a b maxpow
))))
248 (defun everypterms (x p n maxpow
)
254 l
(setq q
(min maxpow
(quotient (car x
) n
)))
258 (cons 0 (cons (psimp k x
) ans
)))))
259 (setq part
(everysubst p
(cadr x
) q
))
260 (setq ans
(nconc (everypterms1 part k n
(car x
)) ans
))
267 (defun everypterms1 (l k n j
)
268 (do ((ptr l
(cddr ptr
)))
271 (ptimes (psimp k
(list (- j
(* n
(car ptr
))) 1))
274 (defun substforsum (a b maxpow
)
275 (do ((pow 0 (1+ pow
))
276 (quot) (zl-rem) (ans))
277 ((not (< pow maxpow
)) (list* maxpow b ans
))
278 (desetq (quot zl-rem
) (pdivide b a
))
279 (unless (and (equal (cdr quot
) 1)
280 (not (pzerop (car quot
)))
281 (equal (cdr zl-rem
) 1))
282 (return (cons pow
(cons b ans
))))
283 (unless (pzerop (car zl-rem
))
284 (setq ans
(cons pow
(cons (car zl-rem
) ans
))))
285 (setq b
(car quot
))))
287 (defun prodcoef (a b
)
289 (cond ((pcoefp b
) (quotient b a
)) (t (prodcoef1 a b
))))
291 ((pointergp (car a
) (car b
)) (pzero))
292 ((eq (car a
) (car b
))
293 (cond ((null (cdddr a
))
294 (prodcoef (caddr a
) (ptterm (cdr b
) (cadr a
))))
296 (t (prodcoef1 a b
))))
299 (desetq (a b
) (pdivide b a
))
300 (if (and (equal (cdr a
) 1) (equal (cdr b
) 1))
304 (defun prodcoef1 (a b
)
305 (loop with ans
= (pzero)
306 for
(bexp bcoef
) on
(p-terms b
) by
#'cddr
307 for part
= (prodcoef a bcoef
)
309 do
(setq ans
(pplus ans
(psimp (p-var b
) (list bexp part
))))
310 finally
(return ans
)))
314 (and (not (atom (cdr x
)))
316 (pureprod (caddr x
)))))
318 (defmfun $bothcoef
(r var
)
319 (prog (*var h varlist genvar $ratfac
)
322 ,(setq h
(coeff r var
1.
))
323 ((mplus) ,r
((mtimes) -
1 ,h
,var
)))))
325 (setq h
(and varlist
(car varlist
)))
327 (setq var
(cdr (ratrep* var
)))
328 (setq r
(cdr (ratrep* r
)))
329 (and h
(setq h
(caadr (ratrep* h
))))
330 (cond ((and h
(or (pcoefp (cdr r
)) (pointergp h
(cadr r
)))
332 (setq var
(bothprodcoef (car var
) (car r
)))
333 (return (list '(mlist)
334 (rdis* (ratreduce (car var
) (cdr r
)))
335 (rdis* (ratreduce (cdr var
) (cdr r
))))))
337 ;; CAN'T TELL WHAT BROUGHT US TO THIS POINT, SORRY
338 (merror (intl:gettext
"bothcoef: invalid arguments."))))))
342 (defun bothprodcoef (a b
)
343 (let ((c (prodcoef a b
)))
344 (if (pzerop c
) (cons (pzero) b
) (cons c
(pdifference b
(ptimes c a
))))))
346 (defvar argsfreeofp nil
)
348 (defun argsfreeof (var e
)
349 (let ((argsfreeofp t
)) (freeof var e
)))
351 ;;; This is a version of freeof for a list first argument
352 (defmfun $lfreeof
(l e
) "`freeof' for a list first argument"
354 (merror (intl:gettext
"lfreeof: first argument must be a list; found: ~M") l
))
355 (let ((exp ($totaldisrep e
)))
356 (dolist (var (margs l
) t
)
357 (unless (freeof ($totaldisrep var
) exp
) (return nil
)))))
359 (defmfun $freeof
(&rest args
)
361 (setq l
(mapcar #'$totaldisrep
(nreverse args
))
363 loop
(or (setq l
(cdr l
)) (return t
))
364 (if (freeof (getopr (car l
)) e
) (go loop
))
367 (defun freeof (var e
)
368 (cond ((alike1 var e
) nil
)
370 ((and (not argsfreeofp
)
371 (or (alike1 var
($verbify
(caar e
)))
372 (alike1 var
($nounify
(caar e
)))))
374 ((and (or (member (caar e
) '(%product %sum %laplace
) :test
#'eq
)
375 (and (eq (caar e
) '%integrate
) (cdddr e
))
376 (and (eq (caar e
) '%limit
) (cddr e
)))
377 (alike1 var
(caddr e
)))
378 (freeofl var
(cdddr e
)))
380 (cond ((not (freeofl var
(hand-side (caddr e
) 'r
))) nil
)
381 ((not (freeofl var
(hand-side (caddr e
) 'l
))) t
)
382 (t (freeof var
(cadr e
)))))
383 ((and (eq (caar e
) 'lambda
)
384 (not (member 'array
(cdar e
) :test
#'eq
))
386 ; Check if var appears in the lambda list in any of the
387 ; following ways: var, 'var, [var] or ['var].
390 (alike1 v
`((mquote) ,var
))
391 (alike1 v
`((mlist) ,var
))
392 (alike1 v
`((mlist) ((mquote) ,var
)))))
395 ;; Check for a local variable in a block.
396 ((and (eq (caar e
) 'mprog
)
398 ; Check if var appears in the variable list alone or
406 ;; Check for a loop variable.
407 ((and (member (caar e
) '(mdo mdoin
) :test
#'eq
)
408 (alike1 var
(cadr e
)))
410 (argsfreeofp (freeofl var
(margs e
)))
411 (t (freeofl var
(cdr e
)))))
413 (defun freeofl (var l
) (loop for x in l always
(freeof var x
)))
415 (defun hand-side (e flag
)
416 (setq e
(if (eq (caar e
) 'mequal
) (ncons e
) (cdr e
)))
417 (mapcar #'(lambda (u) (if (eq flag
'l
) (cadr u
) (caddr u
))) e
))
421 (defmfun $radcan
(exp)
422 (cond ((mbagp exp
) (cons (car exp
) (mapcar '$radcan
(cdr exp
))))
423 (t (let (($ratsimpexpons t
))
424 (simplify (let (($expop
0) ($expon
0))
425 (radcan1 (fr1 exp nil
))))))))
427 (defun radcan1 (*exp
)
428 (cond ((atom *exp
) *exp
)
429 (t (let (($factorflag t
) varlist genvar $ratfac $norepeat
430 ($gcd
(or $gcd
(car *gcdl
*)))
433 (setq *exp
(cdr (ratrep* *exp
)))
439 (mapcar 'radcan1
(cdr x
))))))
442 (fr1 (rdis *exp
) nil
)))))
446 (if (allatoms varlist
) (return nil
))
447 (setq varlist
(mapcar #'spc1 varlist
)) ;make list of logs
448 (setq *loglist
(factorlogs *loglist
))
449 (mapc #'spc2
*loglist
) ;subst log factorizations
450 (mapc #'spc3 varlist genvar
) ;expand exponents
451 (mapc #'spc4 varlist
) ;make exponent list
452 (desetq (varlist . genvar
) (spc5 *v varlist genvar
))
453 ;find expon dependencies
454 (setq varlist
(mapcar #'rjfsimp varlist
)) ;restore radicals
455 (mapc #'spc7 varlist
))) ;simplify radicals
458 (loop for x in l always
(atom x
)))
460 (defun rjfsimp (x &aux expon
)
461 (cond ((and *radsubst $radsubstflag
) x
)
462 ((not (m$exp?
(setq x
(let ($logsimp
) (resimplify x
))))) x
)
463 ((mlogp (setq expon
(caddr x
))) (cadr expon
))
464 ((not (and (mtimesp expon
) (or $logsimp
*var
))) x
)
465 (t (do ((rischflag (and *var
(not $logsimp
) (not (freeof *var x
))))
466 (power (cdr expon
) (cdr power
))) ;POWER IS A PRODUCT
468 (cond ((numberp (car power
)))
470 (and rischflag
(cdr power
) (return x
))
472 `((mexpt) ,(cadar power
)
473 ,(muln (remove (car power
) (cdr expon
) :count
1 :test
#'equal
)
475 (rischflag (return x
)))))))
477 (defun dsubsta (x y zl
)
479 (t (cond ((alike1 y
(car zl
)) (rplaca zl x
))
480 ((not (atom (car zl
))) (dsubsta x y
(cdar zl
))))
481 (dsubsta x y
(cdr zl
))
484 (defun radsubst (a b
)
485 (setq *exp
(allsubst00 a b
*exp
))
486 (if *radsubst
(setq *exp2
(allsubst00 a b
*exp2
))))
491 (cond ((mlogp x
) (putonloglist x
))
492 ((and (mexptp x
) (not (eq (cadr x
) '$%e
)))
493 ($exp-form
(list '(mtimes)
495 (putonloglist (list '(%log simp ratsimp
)
499 (defun putonloglist (l)
500 (unless (memalike l
*loglist
) (push l
*loglist
))
504 (radsubst (rform (cdr p
)) (rform (car p
)))
505 (dsubsta (cdr p
) (car p
) varlist
))
507 (defun spc2a (x) ;CONVERTS FACTORED
508 (let ((sum (mapcar #'spc2b x
))) ;RFORM LOGAND TO SUM
509 (if (cdr sum
) ;OF LOGS
514 (let ((log `((%log simp ratsimp irreducible
) ,(pdis (car x
)))))
515 (if (equal 1 (cdr x
)) log
516 (list '(mtimes) (cdr x
) log
))))
518 (defun spc3 (x v
&aux y
)
519 (when (and (m$exp? x
)
520 (not (atom (setq y
(caddr x
))))
521 (mplusp (setq y
(expand1 (if *var
($partfrac y
*var
) y
) 10 10))))
522 (setq y
(cons '(mtimes)
523 (mapcar #'(lambda (z) ($ratsimp
($exp-form z
))) (cdr y
))))
524 (radsubst (rform y
) (rget v
))
525 (dsubsta y x varlist
)))
529 (not (memalike (caddr x
) *v
)))
530 (push (caddr x
) *v
)))
533 (destructuring-let (((c1 p
) (pcontent (car r
)))
534 ((c2 q
) (pcontent (cdr r
))))
535 (if (pminusp p
) (setq p
(pminus p
) c1
(cminus c1
)))
536 (cons (cons c1 c2
) (cons p q
))))
538 ;;The GCDLIST looks like (( GCM1pair occurrencepair11 occurrencepair12 ...) ...
539 ;;(GCMnpair occurrencepairn1 occurrencepairn2 ...))
540 ;;where GCMpairs are lists of ratforms and prefix forms for the greatest common
541 ;;multiple of the occurrencepairs. Each of these pairs is a list of a ratform
542 ;;and a prefix form. The prefix form is a pointer into the varlist.
543 ;;The occurrences are exponents of the base %E.
545 (defun spc5 (vl oldvarlist oldgenvar
&aux gcdlist varlist genvar
)
547 (destructuring-let* ((((c1 . c
) . r
) (rzcontent (rform v
)))
548 (g (assoc r gcdlist
:test
#'equal
)))
549 (cond (g (setf (cadr g
) (plcm c
(cadr g
)))
550 (push (list ($exp-form
(div* v c1
)) c
) (cddr g
)))
551 (t (push (list r c
(list ($exp-form
(div* v c1
)) c
)) gcdlist
)))))
553 (let ((rd (rdis (car g
))))
554 (when (and (mlogp rd
) (memalike (cadr rd
) oldvarlist
))
555 (push (list (cadr rd
) 1) (cddr g
)))
556 (rplaca g
($exp-form
(div rd
(cadr g
))))))
557 (spc5b gcdlist oldvarlist oldgenvar
))
559 ;;(DEFUN SPC5B (V VARLIST GENVAR)
561 ;; (DOLIST (X (CDDR L))
562 ;; (UNLESS (EQUAL (CADR L) (CADR X))
563 ;; (RADSUBST (RATEXPT (RFORM (CAR L))
564 ;; (CAR (QUOTIENT (CADR X) (CADR L))))
565 ;; (RFORM (CAR X))))))
566 ;; (CONS VARLIST GENVAR))
569 (defun spc5b (v varlist genvar
)
572 (unless (equal (cadr l
) (cadr x
))
573 (radsubst (ratexpt (rform (car l
))
574 (quotient (cadr l
) (cadr x
)))
576 (cons varlist genvar
))
579 (if (eq x
'$%i
) (setq x
'((mexpt) -
1 ((rat) 1 2))))
580 (when (and (mexptp x
)
582 (let ((rad (rform x
))
583 (rbase (rform (cadr x
)))
585 (radsubst (ratexpt rbase
(cadr expon
))
586 (ratexpt rad
(caddr expon
))))))
589 (defun goodform (l) ;;bad -> good
590 (loop for
(exp coef
) on l by
#'cddr
591 collect
(cons exp coef
)))
593 (defun factorlogs (l)
594 (prog (negl posl maxpl maxnl maxn
)
598 (ratfact (rform (radcan1 (cadr log
)))
600 (cond ((equal (caadr log
) -
1) (push log negl
))
601 (t (push log posl
))))
602 (setq negl
(flsort negl
) posl
(flsort posl
) l
(append negl posl
))
603 (setq negl
(mapcar #'cdr negl
)
604 posl
(mapcar #'cdr posl
))
605 a
(setq negl
(delete '((-1 .
1)) negl
:test
#'equal
))
607 (return (mapc #'(lambda (x) (rplacd x
(spc2a (cdr x
)))) l
)))
608 (setq maxnl
(flmaxl negl
)
610 b
(setq maxpl
(flmaxl posl
))
611 (cond ((and maxpl
(flgreat (caaar maxpl
) maxn
))
612 (setq posl
(flred posl
(caaar maxpl
)))
615 (not (equal (caaar maxpl
) maxn
)))
617 (cond ((and (flevenp maxpl
) (not (flevenp maxnl
)))
618 (mapc #'(lambda (fp) (rplaca (car fp
) (pminus (caar fp
)))
619 (cond ((oddp (cdar fp
))
620 (setq fp
(delete '(-1 .
1) fp
:test
#'equal
))
621 (setq negl
(delete fp negl
:test
#'equal
))
622 (and (cdr fp
) (push (cdr fp
) posl
)))))
625 (t (setq posl
(flred posl maxn
)
626 negl
(flred negl maxn
))
630 (loop for l in pl never
(oddp (cdar l
))))
633 (mapl #'(lambda (x) (if (equal p
(caaar x
))
634 (rplaca x
(cdar x
))))
636 (delete nil pl
:test
#'equal
))
638 (defun flmaxl (fpl) ;lists of fac. polys
639 (cond ((null fpl
) nil
)
640 (t (do ((maxl (list (car fpl
))
641 (cond ((equal (caaar maxl
) (caaar ll
))
642 (cons (car ll
) maxl
))
643 ((flgreat (caaar maxl
) (caaar ll
)) maxl
)
644 (t (list (car ll
)))))
645 (ll (cdr fpl
) (cdr ll
)))
649 (mapc #'(lambda (x) (rplacd x
(sort (cdr x
) #'flgreat
:key
#'car
)))
654 (if (or any
(cminusp p
)) 1 0))
655 (t (loop for lp on
(p-terms p
) by
#'cddr
656 sum
(nmt (cadr lp
) any
)))))
659 (cond ((equal p -
1) (cons 0 0))
660 (t (cons (nmt p nil
) (nmt p t
)))))
663 (let ((pn (nmterms p
)) (qn (nmterms q
)))
664 (cond ((> (car pn
) (car qn
)) t
)
665 ((< (car pn
) (car qn
)) nil
)
666 ((> (cdr pn
) (cdr qn
)) t
)
667 ((< (cdr pn
) (cdr qn
)) nil
)
668 (t (flgreat1 p q
)))))
670 (defun flgreat1 (p q
)
672 (cond ((numberp q
) (> p q
))
675 ((pointergp (car p
) (car q
)) t
)
676 ((pointergp (car q
) (car p
)) nil
)
677 ((> (cadr p
) (cadr q
)) t
)
678 ((< (cadr p
) (cadr q
)) nil
)
679 (t (flgreat1 (caddr p
) (caddr q
)))))
