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 (defmfun 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 (defmfun 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
)
114 ;; hard to maintain user ordering info.
115 (if ($ratp c
) (setq dontdisrepit t
))
116 (when (and $radsubstflag
117 (prog2 (newvar b
) (some #'mexptp varlist
)))
118 (let (($factorflag t
) *exp
*exp2
*radsubst
)
119 (setq b
(fullratsimp b
))
120 (setq c
(fullratsimp c
))
124 (setq *exp
(cdr (ratrep* b
)))
125 (setq *exp2
(cdr (ratrep* c
)))
126 ;; since *radsubst is t, both *exp and *exp2 will be radcan simplified
129 (setq b
(rdis *exp
) c
(rdis *exp2
))
131 (setq a
($ratdisrep a
) b
($ratdisrep b
) c
($ratdisrep c
))
132 (cond ((integerp b
) (setq c
(ratf (maxima-substitute a b c
)))
133 (return (cond (dontdisrepit c
) (t ($ratdisrep c
))))))
142 (mapcar #'(lambda (zz)
143 (cond ((alike1 zz b
) a
)
146 ($ratsubst a b zz
)))))
149 (newvar a
) (newvar b
)
150 (setq newvarlist
(reverse (pairoff (reverse varlist
)
151 (reverse newvarlist
))))
152 (setq a
(cdr (ratrep* a
)))
153 (setq b
(cdr (ratrep* b
)))
154 (setq c
(cdr (ratrep* c
)))
155 (when (pminusp (car b
))
156 (setq b
(ratminus b
))
157 (setq a
(ratminus a
)))
158 (when (and (equal 1 (car b
))
159 (not (equal 1 (cdr b
)))
160 (not (equal 0 (car a
))))
161 (setq a
(ratinvert a
))
162 (setq b
(ratinvert b
)))
163 (cond ((not (equal 1 (cdr b
)))
164 (setq a
(rattimes a
(cons (cdr b
) 1) t
))
165 (setq b
(cons (car b
) 1))))
167 (cond ((member (car b
) '(0 1) :test
#'equal
)
168 (ratf (maxima-substitute (rdis a
) b
(rdis c
))))
169 (t (cons (list 'mrat
'simp varlist genvar
)
170 (if (equal (cdr a
) 1)
171 (ratreduce (everysubst0 (car a
) (car b
) (car c
))
172 (everysubst0 (car a
) (car b
) (cdr c
)))
173 (allsubst00 a b c
))))))
174 (unless (alike newvarlist varlist
)
175 (setq varlist newvarlist
179 (return (cond (dontdisrepit c
) (t ($ratdisrep c
))))))
181 (defun xptimes (x y
) (if $ratwtlvl
(wtptimes x y
0) (ptimes x y
)))
183 (defun allsubst00 (a b c
)
184 (cond ((equal a b
) c
)
185 (t (ratquotient (everysubst00 a
(car b
) (car c
))
186 (everysubst00 a
(car b
) (cdr c
))))))
188 (defun everysubst00 (x i z
)
189 (loop with ans
= (rzero)
190 for
(exp coef
) on
(everysubst i z
*alpha
) by
#'cddr
191 do
(setq ans
(ratplus ans
(rattimes (cons coef
1) (ratexpt x exp
) t
)))
192 finally
(return ans
)))
194 (defun everysubst0 (x i z
)
195 (loop with ans
= (pzero)
196 for
(exp coef
) on
(everysubst i z
*alpha
) by
#'cddr
197 do
(setq ans
(pplus ans
(xptimes coef
(pexpt x exp
))))
198 finally
(return ans
)))
200 (defun everysubst1 (a b maxpow
)
201 (loop for
(exp coef
) on
(p-terms b
) by
#'cddr
202 for part
= (everysubst a coef maxpow
)
203 nconc
(if (= 0 exp
) part
204 (everysubst2 part
(make-poly (p-var b
) exp
1)))))
206 (defun everysubst2 (l h
)
207 (do ((ptr l
(cddr ptr
)))
209 (setf (cadr ptr
) (ptimes h
(cadr ptr
)))))
213 (cond ((null m
) l
) (t (cons (car m
) (pairoff (cdr l
) (cdr m
))))))
215 ;;(DEFUN PAIROFF (L M)
216 ;; ;(COND ((NULL M) L) (T (CONS (CAR M) (PAIROFF (CDR L) (CDR M)))))
218 ;; (dolist (x m (nreconc ans l))
219 ;; (push x ans) (setq l (cdr l)))))
221 (defun everysubst (a b maxpow
)
223 (cond ((equal a
1) (list maxpow b
))
226 (do ((b b
(quotient b a
))
228 ((or (> (abs a
) (abs b
))
231 (quotient b
(setq maxpow
(expt a maxpow
)))
234 (t (everysubst1 a b maxpow
))))
235 ((or (pcoefp b
) (pointergp (car a
) (car b
))) (list 0 b
))
236 ((eq (car a
) (car b
))
237 (cond ((null (cdddr a
)) (everypterms b
(caddr a
) (cadr a
) maxpow
))
238 (t (substforsum a b maxpow
))))
239 (t (everysubst1 a b maxpow
))))
241 (defun everypterms (x p n maxpow
)
247 l
(setq q
(min maxpow
(quotient (car x
) n
)))
251 (cons 0 (cons (psimp k x
) ans
)))))
252 (setq part
(everysubst p
(cadr x
) q
))
253 (setq ans
(nconc (everypterms1 part k n
(car x
)) ans
))
260 (defun everypterms1 (l k n j
)
261 (do ((ptr l
(cddr ptr
)))
264 (ptimes (psimp k
(list (- j
(* n
(car ptr
))) 1))
267 (defun substforsum (a b maxpow
)
268 (do ((pow 0 (1+ pow
))
269 (quot) (zl-rem) (ans))
270 ((not (< pow maxpow
)) (list* maxpow b ans
))
271 (desetq (quot zl-rem
) (pdivide b a
))
272 (unless (and (equal (cdr quot
) 1)
273 (not (pzerop (car quot
)))
274 (equal (cdr zl-rem
) 1))
275 (return (cons pow
(cons b ans
))))
276 (unless (pzerop (car zl-rem
))
277 (setq ans
(cons pow
(cons (car zl-rem
) ans
))))
278 (setq b
(car quot
))))
280 (defun prodcoef (a b
)
282 (cond ((pcoefp b
) (quotient b a
)) (t (prodcoef1 a b
))))
284 ((pointergp (car a
) (car b
)) (pzero))
285 ((eq (car a
) (car b
))
286 (cond ((null (cdddr a
))
287 (prodcoef (caddr a
) (ptterm (cdr b
) (cadr a
))))
289 (t (prodcoef1 a b
))))
292 (desetq (a b
) (pdivide b a
))
293 (if (and (equal (cdr a
) 1) (equal (cdr b
) 1))
297 (defun prodcoef1 (a b
)
298 (loop with ans
= (pzero)
299 for
(bexp bcoef
) on
(p-terms b
) by
#'cddr
300 for part
= (prodcoef a bcoef
)
302 do
(setq ans
(pplus ans
(psimp (p-var b
) (list bexp part
))))
303 finally
(return ans
)))
307 (and (not (atom (cdr x
)))
309 (pureprod (caddr x
)))))
311 (defmfun $bothcoef
(r var
)
312 (prog (*var h varlist genvar $ratfac
)
315 ,(setq h
(coeff r var
1.
))
316 ((mplus) ,r
((mtimes) -
1 ,h
,var
)))))
318 (setq h
(and varlist
(car varlist
)))
320 (setq var
(cdr (ratrep* var
)))
321 (setq r
(cdr (ratrep* r
)))
322 (and h
(setq h
(caadr (ratrep* h
))))
323 (cond ((and h
(or (pcoefp (cdr r
)) (pointergp h
(cadr r
)))
325 (setq var
(bothprodcoef (car var
) (car r
)))
326 (return (list '(mlist)
327 (rdis* (ratreduce (car var
) (cdr r
)))
328 (rdis* (ratreduce (cdr var
) (cdr r
))))))
330 ;; CAN'T TELL WHAT BROUGHT US TO THIS POINT, SORRY
331 (merror (intl:gettext
"bothcoef: invalid arguments."))))))
335 (defun bothprodcoef (a b
)
336 (let ((c (prodcoef a b
)))
337 (if (pzerop c
) (cons (pzero) b
) (cons c
(pdifference b
(ptimes c a
))))))
339 (defvar argsfreeofp nil
)
341 (defmfun argsfreeof
(var e
)
342 (let ((argsfreeofp t
)) (freeof var e
)))
344 ;;; This is a version of freeof for a list first argument
345 (defmfun $lfreeof
(l e
) "`freeof' for a list first argument"
347 (merror (intl:gettext
"lfreeof: first argument must be a list; found: ~M") l
))
348 (let ((exp ($totaldisrep e
)))
349 (dolist (var (margs l
) t
)
350 (unless (freeof ($totaldisrep var
) exp
) (return nil
)))))
352 (defmfun $freeof
(&rest args
)
354 (setq l
(mapcar #'$totaldisrep
(nreverse args
))
356 loop
(or (setq l
(cdr l
)) (return t
))
357 (if (freeof (getopr (car l
)) e
) (go loop
))
360 (defun freeof (var e
)
361 (cond ((alike1 var e
) nil
)
363 ((and (not argsfreeofp
)
364 (or (alike1 var
($verbify
(caar e
)))
365 (alike1 var
($nounify
(caar e
)))))
367 ((and (or (member (caar e
) '(%product %sum %laplace
) :test
#'eq
)
368 (and (eq (caar e
) '%integrate
) (cdddr e
))
369 (and (eq (caar e
) '%limit
) (cddr e
)))
370 (alike1 var
(caddr e
)))
371 (freeofl var
(cdddr e
)))
373 (cond ((not (freeofl var
(hand-side (caddr e
) 'r
))) nil
)
374 ((not (freeofl var
(hand-side (caddr e
) 'l
))) t
)
375 (t (freeof var
(cadr e
)))))
376 ((and (eq (caar e
) 'lambda
) (not (member 'array
(cdar e
) :test
#'eq
)) (member var
(cdadr e
) :test
#'eq
)) t
)
377 ;; Check for a local variable in a block.
378 ((and (eq (caar e
) 'mprog
) (member var
(cdadr e
) :test
#'eq
)) t
)
379 ;; Check for a loop variable.
380 ((and (eq (caar e
) 'mdo
) (alike1 var
(cadr e
))) t
)
381 (argsfreeofp (freeofl var
(margs e
)))
382 (t (freeofl var
(cdr e
)))))
384 (defun freeofl (var l
) (loop for x in l always
(freeof var x
)))
386 (defmfun hand-side
(e flag
)
387 (setq e
(if (eq (caar e
) 'mequal
) (ncons e
) (cdr e
)))
388 (mapcar #'(lambda (u) (if (eq flag
'l
) (cadr u
) (caddr u
))) e
))
392 (defmfun $radcan
(exp)
393 (cond ((mbagp exp
) (cons (car exp
) (mapcar '$radcan
(cdr exp
))))
394 (t (let (($ratsimpexpons t
))
395 (simplify (let (($expop
0) ($expon
0))
396 (radcan1 (fr1 exp nil
))))))))
398 (defun radcan1 (*exp
)
399 (cond ((atom *exp
) *exp
)
400 (t (let (($factorflag t
) varlist genvar $ratfac $norepeat
401 ($gcd
(or $gcd
(car *gcdl
*)))
404 (setq *exp
(cdr (ratrep* *exp
)))
410 (mapcar 'radcan1
(cdr x
))))))
413 (fr1 (rdis *exp
) nil
)))))
417 (if (allatoms varlist
) (return nil
))
418 (setq varlist
(mapcar #'spc1 varlist
)) ;make list of logs
419 (setq *loglist
(factorlogs *loglist
))
420 (mapc #'spc2
*loglist
) ;subst log factorizations
421 (mapc #'spc3 varlist genvar
) ;expand exponents
422 (mapc #'spc4 varlist
) ;make exponent list
423 (desetq (varlist . genvar
) (spc5 *v varlist genvar
))
424 ;find expon dependencies
425 (setq varlist
(mapcar #'rjfsimp varlist
)) ;restore radicals
426 (mapc #'spc7 varlist
))) ;simplify radicals
429 (loop for x in l always
(atom x
)))
431 (defun rjfsimp (x &aux expon
)
432 (cond ((and *radsubst $radsubstflag
) x
)
433 ((not (m$exp?
(setq x
(let ($logsimp
) (resimplify x
))))) x
)
434 ((mlogp (setq expon
(caddr x
))) (cadr expon
))
435 ((not (and (mtimesp expon
) (or $logsimp
*var
))) x
)
436 (t (do ((rischflag (and *var
(not $logsimp
) (not (freeof *var x
))))
437 (power (cdr expon
) (cdr power
))) ;POWER IS A PRODUCT
439 (cond ((numberp (car power
)))
441 (and rischflag
(cdr power
) (return x
))
443 `((mexpt) ,(cadar power
)
444 ,(muln (remove (car power
) (cdr expon
) :count
1 :test
#'equal
)
446 (rischflag (return x
)))))))
448 (defun dsubsta (x y zl
)
450 (t (cond ((alike1 y
(car zl
)) (rplaca zl x
))
451 ((not (atom (car zl
))) (dsubsta x y
(cdar zl
))))
452 (dsubsta x y
(cdr zl
))
455 (defun radsubst (a b
)
456 (setq *exp
(allsubst00 a b
*exp
))
457 (if *radsubst
(setq *exp2
(allsubst00 a b
*exp2
))))
462 (cond ((mlogp x
) (putonloglist x
))
463 ((and (mexptp x
) (not (eq (cadr x
) '$%e
)))
464 ($exp-form
(list '(mtimes)
466 (putonloglist (list '(%log simp ratsimp
)
470 (defun putonloglist (l)
471 (unless (memalike l
*loglist
) (push l
*loglist
))
475 (radsubst (rform (cdr p
)) (rform (car p
)))
476 (dsubsta (cdr p
) (car p
) varlist
))
478 (defun spc2a (x) ;CONVERTS FACTORED
479 (let ((sum (mapcar #'spc2b x
))) ;RFORM LOGAND TO SUM
480 (if (cdr sum
) ;OF LOGS
485 (let ((log `((%log simp ratsimp irreducible
) ,(pdis (car x
)))))
486 (if (equal 1 (cdr x
)) log
487 (list '(mtimes) (cdr x
) log
))))
489 (defun spc3 (x v
&aux y
)
490 (when (and (m$exp? x
)
491 (not (atom (setq y
(caddr x
))))
492 (mplusp (setq y
(expand1 (if *var
($partfrac y
*var
) y
) 10 10))))
493 (setq y
(cons '(mtimes)
494 (mapcar #'(lambda (z) ($ratsimp
($exp-form z
))) (cdr y
))))
495 (radsubst (rform y
) (rget v
))
496 (dsubsta y x varlist
)))
500 (not (memalike (caddr x
) *v
)))
501 (push (caddr x
) *v
)))
504 (destructuring-let (((c1 p
) (pcontent (car r
)))
505 ((c2 q
) (pcontent (cdr r
))))
506 (if (pminusp p
) (setq p
(pminus p
) c1
(cminus c1
)))
507 (cons (cons c1 c2
) (cons p q
))))
509 ;;The GCDLIST looks like (( GCM1pair occurrencepair11 occurrencepair12 ...) ...
510 ;;(GCMnpair occurrencepairn1 occurrencepairn2 ...))
511 ;;where GCMpairs are lists of ratforms and prefix forms for the greatest common
512 ;;multiple of the occurrencepairs. Each of these pairs is a list of a ratform
513 ;;and a prefix form. The prefix form is a pointer into the varlist.
514 ;;The occurrences are exponents of the base %E.
516 (defun spc5 (vl oldvarlist oldgenvar
&aux gcdlist varlist genvar
)
518 (destructuring-let* ((((c1 . c
) . r
) (rzcontent (rform v
)))
519 (g (assoc r gcdlist
:test
#'equal
)))
520 (cond (g (setf (cadr g
) (plcm c
(cadr g
)))
521 (push (list ($exp-form
(div* v c1
)) c
) (cddr g
)))
522 (t (push (list r c
(list ($exp-form
(div* v c1
)) c
)) gcdlist
)))))
524 (let ((rd (rdis (car g
))))
525 (when (and (mlogp rd
) (memalike (cadr rd
) oldvarlist
))
526 (push (list (cadr rd
) 1) (cddr g
)))
527 (rplaca g
($exp-form
(div rd
(cadr g
))))))
528 (spc5b gcdlist oldvarlist oldgenvar
))
530 ;;(DEFUN SPC5B (V VARLIST GENVAR)
532 ;; (DOLIST (X (CDDR L))
533 ;; (UNLESS (EQUAL (CADR L) (CADR X))
534 ;; (RADSUBST (RATEXPT (RFORM (CAR L))
535 ;; (CAR (QUOTIENT (CADR X) (CADR L))))
536 ;; (RFORM (CAR X))))))
537 ;; (CONS VARLIST GENVAR))
540 (defun spc5b (v varlist genvar
)
543 (unless (equal (cadr l
) (cadr x
))
544 (radsubst (ratexpt (rform (car l
))
545 (quotient (cadr l
) (cadr x
)))
547 (cons varlist genvar
))
550 (if (eq x
'$%i
) (setq x
'((mexpt) -
1 ((rat) 1 2))))
551 (when (and (mexptp x
)
553 (let ((rad (rform x
))
554 (rbase (rform (cadr x
)))
556 (radsubst (ratexpt rbase
(cadr expon
))
557 (ratexpt rad
(caddr expon
))))))
560 (defun goodform (l) ;;bad -> good
561 (loop for
(exp coef
) on l by
#'cddr
562 collect
(cons exp coef
)))
564 (defun factorlogs (l)
565 (prog (negl posl maxpl maxnl maxn
)
569 (ratfact (rform (radcan1 (cadr log
)))
571 (cond ((equal (caadr log
) -
1) (push log negl
))
572 (t (push log posl
))))
573 (setq negl
(flsort negl
) posl
(flsort posl
) l
(append negl posl
))
574 (setq negl
(mapcar #'cdr negl
)
575 posl
(mapcar #'cdr posl
))
576 a
(setq negl
(delete '((-1 .
1)) negl
:test
#'equal
))
578 (return (mapc #'(lambda (x) (rplacd x
(spc2a (cdr x
)))) l
)))
579 (setq maxnl
(flmaxl negl
)
581 b
(setq maxpl
(flmaxl posl
))
582 (cond ((and maxpl
(flgreat (caaar maxpl
) maxn
))
583 (setq posl
(flred posl
(caaar maxpl
)))
586 (not (equal (caaar maxpl
) maxn
)))
588 (cond ((and (flevenp maxpl
) (not (flevenp maxnl
)))
589 (mapc #'(lambda (fp) (rplaca (car fp
) (pminus (caar fp
)))
590 (cond ((oddp (cdar fp
))
591 (setq fp
(delete '(-1 .
1) fp
:test
#'equal
))
592 (setq negl
(delete fp negl
:test
#'equal
))
593 (and (cdr fp
) (push (cdr fp
) posl
)))))
596 (t (setq posl
(flred posl maxn
)
597 negl
(flred negl maxn
))
601 (loop for l in pl never
(oddp (cdar l
))))
604 (mapl #'(lambda (x) (if (equal p
(caaar x
))
605 (rplaca x
(cdar x
))))
607 (delete nil pl
:test
#'equal
))
609 (defun flmaxl (fpl) ;lists of fac. polys
610 (cond ((null fpl
) nil
)
611 (t (do ((maxl (list (car fpl
))
612 (cond ((equal (caaar maxl
) (caaar ll
))
613 (cons (car ll
) maxl
))
614 ((flgreat (caaar maxl
) (caaar ll
)) maxl
)
615 (t (list (car ll
)))))
616 (ll (cdr fpl
) (cdr ll
)))
620 (mapc #'(lambda (x) (rplacd x
(sort (cdr x
) #'flgreat
:key
#'car
)))
625 (if (or any
(cminusp p
)) 1 0))
626 (t (loop for lp on
(p-terms p
) by
#'cddr
627 sum
(nmt (cadr lp
) any
)))))
630 (cond ((equal p -
1) (cons 0 0))
631 (t (cons (nmt p nil
) (nmt p t
)))))
634 (let ((pn (nmterms p
)) (qn (nmterms q
)))
635 (cond ((> (car pn
) (car qn
)) t
)
636 ((< (car pn
) (car qn
)) nil
)
637 ((> (cdr pn
) (cdr qn
)) t
)
638 ((< (cdr pn
) (cdr qn
)) nil
)
639 (t (flgreat1 p q
)))))
641 (defun flgreat1 (p q
)
643 (cond ((numberp q
) (> p q
))
646 ((pointergp (car p
) (car q
)) t
)
647 ((pointergp (car q
) (car p
)) nil
)
648 ((> (cadr p
) (cadr q
)) t
)
649 ((< (cadr p
) (cadr q
)) nil
)
650 (t (flgreat1 (caddr p
) (caddr q
)))))
