1;;; -*- mode: lisp; package: cl-maxima; syntax: common-lisp -*- 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;;; ;;;;; 4;;; Copyright (c) 1984 by William Schelter,University of Texas ;;;;; 5;;; All rights reserved ;;;;; 6;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 8(in-package :maxima) 9 10(declare-top (unspecial p y)) 11 12;; These functions can be used to keep an alphabetical masterlist in 13;;*genvar* and *varlist* and use them. I think *genpairs* is now 14;;redundant second genpairs is much smaller than *genpairs* would be and 15;;just keeps the pairs needed for the current form. *varlist* and 16;;*genvar* are still the global ones. 17 18 19;;(ratsetup varlist genvar) does ratsetup1 and ratsetup2. Which map the 20;;above over varlist but also do things all the way down the list. 21;;could do (ratsetup *varlist* *genvar*) if you want to fix them up. to 22;;get latest tellrat info and ratweight level info etc. 23 24;;if new-newvar has been called on x and varlist is *varlist* then 25;;new-prep1 should have all the variables it wants in genpairs and so we 26;;could use the old prep1. In fact new-newvar must be called first 27;;because the newvarmexpt function which handles exponentiation does not 28;;have a new- analogue and so will call (newsym) not (add-newvar) 29 30;; IDEAS NOT YET IMPLEMENTED: Change the gensym so that instead 31;;of allocating a symbol one uses a number (between 1 and 2^16 say). 32;;Instead of using the value cell to record the ordering, this is done 33;;in an array : so the function for POINTERGP would look like (> (aref 34;;genvar x) (aref genvar y)) the functions VALGET and VALPUT would just 35;;need changing to (aref genvar x) etc. 36 37;; Another idea would be to change PTIMES and PPLUS etc. so that their 38;;internal calls to themselves would involve another function say 39;;NPTIMES which would take as its arguments and values a reusable type 40;;of polynomial like a an array etc. Then one would only need the 41;;functions to change would be the functions which change the 42;;NPOLYNOMIALS back to the polynomials and vice versa. 43 44;;the following are faster than the previous ones in the ratmac 45 46(defun safe-putprop ( sym value indicator) 47 (putprop sym value indicator)) 48 49;;(defun POINTERGP (A B) (> (VALGET A) (VALGET B))) 50;;as a subst it is faster any problems 'wfs 51 52(defun new-prep1 (x &aux temp) 53 (cond ((floatp x) 54 (cond ($keepfloat (cons x 1.0)) ((prepfloat x)))) 55 ((integerp x) (cons (cmod x) 1)) 56 ((typep x 'rational) 57 (cond ((null modulus)(cons 58 (numerator x) (denominator x))) 59 (t (cquotient (numerator x) (denominator x))))) 60 61 ((atom x)(cond ((assolike x genpairs)) 62 (t(format t "***In new-prep1**") 63 (add-newvar-to-genpairs x )))) 64 ((and $ratfac (assolike x genpairs))) 65 ((eq (caar x) 'mplus) 66 (cond ($ratfac 67 (setq x (mapcar #'new-prep1 (cdr x))) 68 (cond ((every #'frpoly? x) 69 (cons (mfacpplus (mapl #'(lambda (x) 70 (rplaca x (caar x))) 71 x)) 72 1)) 73 (t (do ((a (car x) (facrplus a (car l))) 74 (l (cdr x) (cdr l))) 75 ((null l) a))))) 76 (t (do ((a (new-prep1 (cadr x)) (ratplus a (new-prep1 (car l)))) 77 (l (cddr x) (cdr l))) 78 ((null l) a))))) 79 ((eq (caar x) 'mtimes) 80 (do ((a (savefactors (new-prep1 (cadr x))) 81 (rattimes a (savefactors (new-prep1 (car l))) sw)) 82 (l (cddr x) (cdr l)) 83 (sw (not (and $norepeat (member 'ratsimp (cdar x) :test #'eq))))) 84 ((null l) a))) 85 ((eq (caar x) 'mexpt) 86 (newvarmexpt x (caddr x) t)) 87 ((eq (caar x) 'mquotient) 88 (ratquotient (savefactors (new-prep1 (cadr x))) 89 (savefactors (new-prep1 (caddr x))))) 90 ((eq (caar x) 'mminus) 91 (ratminus (new-prep1 (cadr x)))) 92 ((eq (caar x) 'rat) 93 (cond (modulus (cons (cquotient (cmod (cadr x)) (cmod (caddr x))) 1)) 94 (t (cons (cadr x) (caddr x))))) 95 ((eq (caar x) 'bigfloat)(bigfloat2rat x)) 96 ((eq (caar x) 'mrat) 97 (cond ((and *withinratf* (member 'trunc (car x) :test #'eq)) 98 (throw 'ratf nil)) 99 ((catch 'compatvl 100 (progn (setq temp (compatvarl (caddar x) 101 varlist 102 (cadddr (car x)) 103 genvar)) 104 t)) 105 (cond ((member 'trunc (car x) :test #'eq) 106 (cdr ($taytorat x))) 107 ((and (not $keepfloat) 108 (or (pfloatp (cadr x)) (pfloatp (cddr x)))) 109 (cdr (ratrep* ($ratdisrep x)))) 110 ((sublis temp (cdr x))))) 111 (t (cdr (ratrep* ($ratdisrep x)))))) 112 ((assolike x genpairs)) 113 (t (setq x (littlefr1 x)) 114 (cond ((assolike x genpairs)) 115 (t (format t "%%in new-prep1") 116 (add-newvar-to-genpairs x)))))) 117 118;;because symbolics will assign a common lisp print name only when the symbol is referred to 119(defun safe-string (symb) 120 (let () 121 (string symb))) 122 123(defun new-ratf (l &aux genpairs) 124 (prog (u *withinratf*) 125 (setq *withinratf* t) 126 (when (eq '%% (catch 'ratf (new-newvar l))) ;;get the new variables onto *varlist* 127 (setq *withinratf* nil) (return (srf l))) ;new-prep1 should not have to add any. 128 (let ((varlist *varlist*)(genvar *genvar*)) 129 130 (setq u (catch 'ratf (new-ratrep* l))) ; for truncation routines 131 (return (or u (prog2 (setq *withinratf* nil) (srf l))))))) 132 133 134 135(defun new-newvar (l ) 136; (let (( vlist varlist)) 137 (my-newvar1 l)) 138; (setq varlist (sortgreat vlist)) 139 ; vlist)) 140 ; (setq varlist (nconc (sortgreat vlist) varlist))) 141 142 143(defun new-ratrep* (x) 144 ;;the ratsetup is done in my-newvar1 145 (xcons (new-prep1 x) 146 (list* 'mrat 'simp *varlist* *genvar* 147 (if (and (not (atom x)) (member 'irreducible (cdar x) :test #'eq)) 148 '(irreducible))))) 149 150(defun new-rat (x &aux genpairs) 151 (cond 152 ((affine-polynomialp x) (cons x 1)) 153 ((rational-functionp x) x) 154 ((and (listp x) (eq (caar x) 'mrat)) 155 (cond ((member (car (num (cdr x))) *genvar* :test #'eq) 156 (cdr x)) 157 (t (format t "~%disrepping")(new-rat ($totaldisrep x))))) 158 (t 159 160 (prog (u *withinratf*) 161 (setq *withinratf* t) 162 (cond ((mbagp x)(return (cons (car x) (mapcar 'new-rat (cdr x))))) 163 (t 164 (when (eq '%% (catch 'ratf (new-newvar x))) 165 (setq *withinratf* nil)(return (srf x))) 166 (let ((varlist *varlist*)(genvar *genvar*)) 167 (setq u (catch 'ratf (new-prep1 x))) ;;truncations 168 (return (or u (prog2 (setq *withinratf* nil) (srf x))))))))))) 169 170 171(defun my-newvar1 (x) 172 (cond ((numberp x) nil) 173 ((assolike x genpairs) nil) 174 ;;; ((memalike x varlist))we 're using *varlist* 175; ; ((memalike x vlist) nil) 176 ((atom x) (add-newvar-to-genpairs x )nil) 177 ((member (caar x) 178 '(mplus mtimes rat mdifference 179 mquotient mminus bigfloat) :test #'eq) 180 (mapc #'my-newvar1 (cdr x))) 181 182 ((eq (caar x) 'mexpt) 183 (my-newvar1 (second x) )) 184 ;; ;(newvarmexpt x (caddr x) nil)) 185 ((eq (caar x) 'mrat) (merror " how did you get here Bill?") 186 (and *withinratf* (member 'trunc (cdddar x) :test #'eq) (throw 'ratf '%%)) 187 (cond ($ratfac (mapc 'newvar3 (caddar x))) 188 (t (mapc #'my-newvar1 (reverse (caddar x)))))) 189 ((eq (caar x) 'mnctimes)(add-newvar-to-genpairs x )) 190 (t (merror "What is x like ? ~A" x)))) 191 192;;need this? 193; (cond (*fnewvarsw (setq x (littlefr1 x)) 194; (mapc (function newvar1) 195; (cdr x)) 196; (or (memalike x vlist) 197; (memalike x varlist) 198;; (putonvlist x))) 199;; (t (putonvlist x)))))) 200 201(defun add-newvar-to-genpairs (va &aux the-gensym) 202 (cond ((assolike va nil) genpairs) 203 (t (setq the-gensym (add-newvar va)) 204 (push (cons va (rget the-gensym)) genpairs) 205 (rat-setup1 va the-gensym)(rat-setup2 va the-gensym))) 206 nil) 207 208 209;;might be worthwhile to keep a resource or list of gensyms so that when 210;;you reset-vgp then you don't just discard them you reuse them via the gensym call 211 212(defvar *genvar-resemble* t) 213 214(defun add-newvar ( va &optional (use-*genpairs* t)&aux the-gensym) 215 "If va is not in varlist ADD-NEWVAR splices va into the varlist and a new gensym 216into genvar ordering and adds to genpairs" 217 (declare (special $order_function)) 218 use-*genpairs* ;;don't use it 219 (cond ((and (symbolp va) (not (eql (aref (safe-string va) 0) #\$))) (merror "doesn't begin with $"))) 220 (let () 221 (multiple-value-bind (after there) 222 (find-in-ordered-list va *varlist* $order_function) 223 (cond ((not there) 224 (setq the-gensym (gensym-readable va)) 225; (cond ((and (symbolp va) *genvar-resemble*) 226; (setq the-gensym (make-symbol (string-trim "$" (safe-string va))))) 227; (t 228; (setq the-gensym (gensym)))) 229 230 (safe-putprop the-gensym va 'disrep) 231; (cond (use-*genpairs* (push (cons va (rget the-gensym)) *genpairs*))) 232; (rat-setup1 va the-gensym)(rat-setup2 va the-gensym) 233 (setq *genvar* (nsplice-in after the-gensym *genvar*)) 234 (setq *varlist* (nsplice-in after va *varlist*)) 235 (when *check-order* 236; (check-repeats *varlist*) 237 (check-order *varlist*)) 238 (loop for v in (nthcdr (max 0 after) *genvar*) 239 for i from (1+ after) 240 do (setf (symbol-value v) i))) 241 (there 242 (setq the-gensym (nth after *genvar*)) 243 (cond ((not (nc-equal (get the-gensym 'disrep) va)) 244 (fsignal "bad-correspondence" ))))) 245 (values the-gensym (not there))))) 246 247(defun rat-setup1 (v g) 248 (and $ratwtlvl 249 (setq v (assolike v *ratweights)) 250 (if v (safe-putprop g v '$ratweight) (remprop g '$ratweight)))) 251 252 253 254(defun rat-setup2 (v g) 255 (when $algebraic 256 (cond ((setq v (algpget v)) 257 (let () 258 (safe-putprop g v 'tellrat))) 259 (t (remprop g 'tellrat))))) 260 261 262 263(defun te (f g) 264 (let* ((genvar (nreverse (sort (union1 (listovars f) (listovars g)) #'pointergp))) 265 (varlist (loop for v in genvar collecting (get v 'disrep)))) 266 (break t) 267 (ratreduce f g))) 268 269;; 270 271(defun new-pfactor (poly) 272 "returns an alternating list: factor1 expt1 factor2 expt2 ..." 273 (let ((genvar (nreverse (sort (listovars poly) #'pointergp)))) 274 (pfactor poly))) 275 276(defun multiply-factors-with-multiplicity (a-list &aux ( answer 1)) 277 (loop for v in a-list by #'cddr 278 for w in (cdr a-list) by #'cddr 279 do (loop while (> w 0) 280 do (setq answer (n* answer v)) 281 (setq w (1- w)))) 282 answer) 283 284(defun copy-vgp () 285 (setq *varlist* (copy-list *varlist*)) 286 (setq *genvar* (copy-list *genvar*)) nil) 287 288 289(defun q-var (f)(cond ((atom f) nil) 290 (t (aref f 0)))) 291 292(defun ar-last (aray) 293 (aref aray (1- (length (the cl:array aray))))) 294(defun ar-second-last (aray) 295 (aref aray (- (length (the cl:array aray)) 2))) 296 297(defun set-fill-pointer (aray n)(setf (fill-pointer aray ) n) aray) 298(defun constant-term-in-main-variable (f) 299 (cond ((czerop (ar-second-last f)) 300 (ar-last f)) 301 (t 0))) 302 303#+debug 304(progn 305 (defmfun pplus (x y) 306 (cond ((pcoefp x) (pcplus x y)) 307 ((pcoefp y) (pcplus y x)) 308 ((eq (p-var x) (p-var y)) 309 (psimp (p-var x) (ptptplus (p-terms y) (p-terms x)))) 310 ((pointergp (p-var x) (p-var y)) 311 (psimp (p-var x) (ptcplus y (p-terms x)))) 312 (t (psimp (p-var y) (ptcplus x (p-terms y)))))) 313 314 (defmfun ptimes (x y) 315 (cond ((pcoefp x) (if (pzerop x) 0 (pctimes x y))) 316 ((pcoefp y) (if (pzerop y) 0 (pctimes y x))) 317 ((eq (p-var x) (p-var y)) 318 (palgsimp (p-var x) (ptimes1 (p-terms x) (p-terms y)) (alg x))) 319 ((pointergp (p-var x) (p-var y)) 320 (psimp (p-var x) (pctimes1 y (p-terms x)))) 321 (t (psimp (p-var y) (pctimes1 x (p-terms y)))))) 322 (defun ptimes (x y) 323 (cond ((atom x) 324 (cond ((and (numberp x) 325 (zerop x)) 326 0) 327 (t (pctimes x y)))) 328 ((atom y) 329 (cond ((and (numberp y) 330 (zerop y)) 331 0) 332 (t (pctimes y x)))) 333 ((eq (car x) (car y)) 334 (palgsimp (car x) (ptimes1 (cdr x) (cdr y)) (alg x))) 335 ((> (symbol-value (car x)) (symbol-value (car y))) 336 (psimp (car x) (pctimes1 y (cdr x)))) 337 (t (psimp (car y) (pctimes1 x (cdr y)))))) 338 339 (defmfun pdifference (x y) 340 (cond ((pcoefp x) (pcdiffer x y)) 341 ((pcoefp y) (pcplus (cminus y) x)) 342 ((eq (p-var x) (p-var y)) 343 (psimp (p-var x) (ptptdiffer (p-terms x) (p-terms y)))) 344 ((pointergp (p-var x) (p-var y)) 345 (psimp (p-var x) (ptcdiffer-minus (p-terms x) y))) 346 (t (psimp (p-var y) (ptcdiffer x (p-terms y)))))) 347 348 349 (defun pfactor (p &aux ($algebraic algfac*)) 350 (cond ((pcoefp p) (cfactor p)) 351 ($ratfac (pfacprod p)) 352 (t (setq p (factorout p)) 353 (cond ((equal (cadr p) 1) (car p)) 354 ((numberp (cadr p)) (append (cfactor (cadr p)) (car p))) 355 (t ((lambda (cont) 356 (nconc 357 (cond ((equal (car cont) 1) nil) 358 (algfac* 359 (cond (modulus (list (car cont) 1)) 360 ((equal (car cont) '(1 . 1)) nil) 361 ((equal (cdar cont) 1) 362 (list (caar cont) 1)) 363 (t (list (caar cont) 1 (cdar cont) -1)))) 364 (t (cfactor (car cont)))) 365 (pfactor11 (psqfr (cadr cont))) 366 (car p))) 367 (cond (modulus (list (leadalgcoef (cadr p)) 368 (monize (cadr p)))) 369 (algfac* (algcontent (cadr p))) 370 371 (t (pcontent (cadr p)))))))))) 372 373 374 (defun fullratsimp (l) 375 (let (($expop 0) ($expon 0) (inratsimp t) $ratsimpexpons) 376 (setq l ($totaldisrep l)) (fr1 l varlist)))) 377 378 379;;the following works but is slow see projective 380(defmfun $gcdlist (&rest fns) 381 (cond ((and (eql (length fns) 1) 382 ($listp (car fns)) 383 (setq fns (cdr (car fns)))))) 384 (let (varlist gcd-denom gcd-num rat-fns ) 385 (cond ((eql (length fns) 1) (car fns)) 386 (t 387 (loop for v in fns 388 do (newvar v)) 389 (setq rat-fns (loop for v in fns collecting (cdr (ratrep* v)))) 390 (setq gcd-num (num (car rat-fns))) 391 (loop for w in (cdr rat-fns) 392 do 393 (setq gcd-num (pgcd gcd-num (num w)))) 394 (setq gcd-denom (denom (car rat-fns))) 395 (loop for w in (cdr rat-fns) 396 do (setq gcd-denom (pgcd gcd-denom (denom w)))) 397 (ratdisrep (cons (list 'mrat 'simp varlist genvar) 398 (cons gcd-num gcd-denom))))))) 399 400;;;;the following works but seems slower than factoring 401;(defun $projective ( vector) 402; (check-arg vector '$listp nil) 403; (let ( VARLIST (fns (cdr vector)) 404; answer gcd-num factor lcm-denom rat-fns ) 405; (loop for v in fns 406; do (newvar v)) 407; (setq rat-fns (loop for v in fns 408; collecting (cdr (ratrep* v)))) 409; (setq gcd-num (num (car rat-fns))) 410; (loop for w in (cdr rat-fns) 411; do 412; (setq gcd-num (pgcd gcd-num (num w)))) 413; (setq lcm-denom (denom (car rat-fns))) 414; (loop for w in (cdr rat-fns) 415; do (setq lcm-denom (plcm lcm-denom (denom w)))) 416; (setq factor (cons lcm-denom gcd-num)) 417; (setq answer (loop for v in rat-fns 418; collecting (rattimes v factor t))) 419; (setq header (list 'mrat 'simp varlist genvar)) 420; (loop for v in answer 421; collecting (ratdisrep (cons header v)) into tem 422; finally (return (cons '(mlist) tem))))) 423 424(defun factoredp (poly) 425 (cond ((atom poly) t) 426 (t (member 'factored (car poly) :test #'eq)))) 427 428(defun exponent (expr prod) 429 (cond ((atom prod) 0) 430 ((eq (caar prod) 'mexpt)(cond ((eq (second prod) expr)(third prod)) 431 (t 0))) 432 (t(check-arg prod '$productp nil) 433 (loop for v in (cdr prod) do 434 (cond 435 ((equal expr v) (return 1)) 436 ((numberp v)) 437 ((atom v)) 438 ((and (equal (caar v) 'mexpt) 439 (equal (second v) expr)) 440 (return (third v)))) 441 finally (return 0))))) 442 443(defun $projective (vector &aux factors first-one factored-vector expon lcm-denom tem fac where proj) 444 (setq factored-vector (loop for v in (cdr vector) 445 when (factoredp v) collecting v 446 else collecting ($factor v))) 447 (loop for v in factored-vector 448 for i from 0 449 when (not ($zerop v)) 450 do (setq first-one v)(setq where i) (return 'done)) 451 (cond ((null where) 'image_not_in_projective_space) 452 (t 453 (setq factored-vector (delete first-one factored-vector :count 1 :test #'equal)) 454 (setq proj (loop for w in factored-vector collecting (div* w first-one))) 455 (loop for term in proj 456 when (not (numberp term) ) 457 do 458 (cond ((atom term)(setq fac term)) 459 (t 460 (loop for v in (cdr term) do 461 (cond ((atom v) (setq fac v)) 462 ((eq (caar v) 'mexpt) (setq fac (second v))) 463 ((eq (caar v) 'mplus) (setq fac v))) 464 (cond ((not (member fac factors :test #'equal)) (push fac factors))))))) 465 (loop for w in factors 466 do (setq expon 0) 467 (setq expon (loop for v in proj 468 when (< (setq tem (exponent w v)) 0) 469 minimize tem)) 470 (cond ((not (eql expon 0)) 471 (push `((mexpt simp) ,w ,expon) lcm-denom)))) 472 (cond (lcm-denom (push '(mtimes simp) lcm-denom)) 473 (t (setq lcm-denom 1))) 474 (loop for v in proj 475 collecting (div* v lcm-denom) into tem 476 finally (return 477 (cons '(mlist) (nsplice-in (1- where) 478 (div* 1 lcm-denom) tem))))))) 479(defun $zeta3_ratsimp (expr &aux answer) 480 (setq answer (new-rat expr)) 481 (setq answer (rationalize-denom-zeta3 answer)) 482 (new-disrep answer)) 483 484(defun rationalize-denom-zeta3 (expr &aux the-denom the-num the-gen) 485 (setq the-gen (add-newvar '$%zeta3)) 486 (cond ((affine-polynomialp expr) expr) 487 ((variable-in-polyp (denom expr) the-gen) 488 (setq the-denom (denom expr)) 489 (setq the-num (num expr)) 490 (setq the-denom (conj-zeta3 the-denom the-gen)) 491 (ratreduce (ptimes the-num the-denom) (ptimes the-denom (denom expr)))) 492 (t expr))) 493 494(defun conj-zeta3 (expr the-gen &aux answer) 495 (cond ((atom expr) expr) 496 ((eq (car expr) the-gen) 497 (setq expr (copy-list expr)) 498 (setf (second expr) 2) 499 (palgsimp the-gen (cdr expr) (alg expr))) 500 (t (setq answer (copy-list expr)) 501 (do ((r (cddr answer) (cddr r))) 502 ((not (consp r)) answer) 503 (rplaca r (conj-zeta3 (car r) the-gen)))))) 504 505(defun variable-in-polyp (poly gen) 506 (catch 'its-in 507 (variable-in-polyp1 poly gen))) 508(defun variable-in-polyp1 (poly gen) 509 (cond ((atom poly) nil) 510 ((eq (car poly) gen) (throw 'its-in t)) 511 (t 512 (do ((r (cddr poly) (cddr r))) 513 ((not (consp r)) nil) 514 (variable-in-polyp1 (car r) gen))))) 515 516(defun $zeta3_factor (poly) 517 ($factor poly `((mplus) ((mexpt) $%zeta3 2) $%zeta3 1))) ; %zeta3^2+%zeta3+1 518 519(defun new-newvarmexpt (x e flag) 520 (declare (special radlist expsumsplit vlist)) 521 ;; when flag is t, call returns ratform 522 (prog (topexp) 523 (cond ((and (fixnump e) (not flag)) 524 (return (newvar1 (cadr x))))) 525 (setq topexp 1) 526 top (cond 527 528 ;; x=b^n for n a number 529 ((fixnump e) 530 (setq topexp (* topexp e)) 531 (setq x (cadr x))) 532 ((atom e) nil) 533 534 ;; x=b^(p/q) for p and q integers 535 ((eq (caar e) 'rat) 536 (cond ((or (minusp (cadr e)) (greaterp (cadr e) 1)) 537 (setq topexp (* topexp (cadr e))) 538 (setq x (list '(mexpt) 539 (cadr x) 540 (list '(rat) 1 (caddr e)))))) 541 (cond ((or flag (numberp (cadr x)) )) 542 (*ratsimp* 543 (cond ((memalike x radlist) (return nil)) 544 (t (setq radlist (cons x radlist)) 545 (return (newvar1 (cadr x))))) ) 546 ($algebraic (newvar1 (cadr x))))) 547 ;; x=b^(a*c) 548 ((eq (caar e) 'mtimes) 549 (cond 550 ((or 551 552 ;; x=b^(n *c) 553 (and (atom (cadr e)) 554 (fixnump (cadr e)) 555 (setq topexp (* topexp (cadr e))) 556 (setq e (cddr e))) 557 558 ;; x=b^(p/q *c) 559 (and (not (atom (cadr e))) 560 (eq (caaadr e) 'rat) 561 (not (equal 1 (cadadr e))) 562 (setq topexp (* topexp (cadadr e))) 563 (setq e (cons (list '(rat) 564 1 565 (caddr (cadr e))) 566 (cddr e))))) 567 (setq x 568 (list '(mexpt) 569 (cadr x) 570 (setq e (simplify (cons '(mtimes) 571 e))))) 572 (go top)))) 573 574 ;; x=b^(a+c) 575 ((and (eq (caar e) 'mplus) expsumsplit) ;switch controls 576 (setq ;splitting exponent 577 x ;sums 578 (cons 579 '(mtimes) 580 (mapcar 581 #'(lambda (ll) 582 (list '(mexpt) 583 (cadr x) 584 (simplify (list '(mtimes) 585 topexp 586 ll)))) 587 (cdr e)))) 588 (cond (flag (return (new-prep1 x))) 589 (t (return (newvar1 x)))))) 590 (cond (flag nil) 591 ((equal 1 topexp) 592 (cond ((or (atom x) 593 (not (eq (caar x) 'mexpt))) 594 (newvar1 x)) 595 ((or (memalike x varlist) (memalike x vlist)) 596 nil) 597 (t (cond ((or (atom x) (null *fnewvarsw)) 598 (putonvlist x)) 599 (t (setq x (littlefr1 x)) 600 (mapc #'newvar1 (cdr x)) 601 (or (memalike x vlist) 602 (memalike x varlist) 603 (putonvlist x))))))) 604 (t (newvar1 x))) 605 (return 606 (cond 607 ((null flag) nil) 608 ((equal 1 topexp) 609 (cond 610 ((and (not (atom x)) (eq (caar x) 'mexpt)) 611 (cond ((assolike x genpairs)) 612; *** should only get here if called from fr1. *fnewvarsw=nil 613 (t (setq x (littlefr1 x)) 614 (cond ((assolike x genpairs)) 615 (t (new-newsym x)))))) 616 (t (new-prep1 x)))) 617 (t (ratexpt (new-prep1 x) topexp)))))) 618 619 620(defun new-newsym (e) 621 (prog (g p) 622 (cond ((setq g (assolike e genpairs)) 623 (return g))) 624 (setq g (gensym)) 625 (putprop g e 'disrep) 626 (add-newvar e) 627; (push e varlist) 628; (push (cons e (rget g)) genpairs) 629; (valput g (if genvar (1- (valget (car genvar))) 1)) 630; (push g genvar) 631 (cond ((setq p (and $algebraic (algpget e))) 632; (algordset p genvar) 633 (putprop g p 'tellrat))) 634 (return (rget g)))) 635 636 637 638;; the tellrat must be compatible with *genvar* 639 640(defun tellrat1 (x &aux varlist genvar $algebraic $ratfac algvar) 641 (setq x ($totaldisrep x)) 642 (and (not (atom x)) (eq (caar x) 'mequal) 643 (newvar (cadr x))) 644 (newvar (setq x (meqhk x))) 645 (or varlist (merror "Improper polynomial")) 646 (setq x (primpart (cadr ($new_rat x)))) 647 (setq algvar (if (symbolp (car x)) (get (car x) 'disrep))) 648 (setq x (p-terms x)) 649 (if (not (equal (pt-lc x) 1)) (merror "Minimal polynomial must be monic")) 650 (do ((p (pt-red x) (pt-red p))) ((ptzerop p)) (setf (pt-lc p) (pdis (pt-lc p)))) 651 (setq algvar (cons algvar x)) 652 (if (setq x (assol (car algvar) tellratlist)) 653 (setq tellratlist (remove x tellratlist :test #'equal))) 654 (push algvar tellratlist)) 655