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