![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to algnum.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin|
Return to algnum.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / builtin |
1.2 noro 1: /*
2: * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED
3: * All rights reserved.
4: *
5: * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,
6: * non-exclusive and royalty-free license to use, copy, modify and
7: * redistribute, solely for non-commercial and non-profit purposes, the
8: * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and
9: * conditions of this Agreement. For the avoidance of doubt, you acquire
10: * only a limited right to use the SOFTWARE hereunder, and FLL or any
11: * third party developer retains all rights, including but not limited to
12: * copyrights, in and to the SOFTWARE.
13: *
14: * (1) FLL does not grant you a license in any way for commercial
15: * purposes. You may use the SOFTWARE only for non-commercial and
16: * non-profit purposes only, such as academic, research and internal
17: * business use.
18: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
19: * international copyright treaties. If you make copies of the SOFTWARE,
20: * with or without modification, as permitted hereunder, you shall affix
21: * to all such copies of the SOFTWARE the above copyright notice.
22: * (3) An explicit reference to this SOFTWARE and its copyright owner
23: * shall be made on your publication or presentation in any form of the
24: * results obtained by use of the SOFTWARE.
25: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.3 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.2 noro 27: * for such modification or the source code of the modified part of the
28: * SOFTWARE.
29: *
30: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
31: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
32: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
33: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
34: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
35: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
36: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
37: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
38: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
39: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
40: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
41: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
42: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
43: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
44: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
45: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
46: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
47: *
1.9 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/algnum.c,v 1.8 2004/12/06 01:15:18 noro Exp $
1.2 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "parse.h"
52:
53: void Pdefpoly(), Pnewalg(), Pmainalg(), Palgtorat(), Prattoalg(), Pgetalg();
54: void Palg(), Palgv(), Pgetalgtree();
1.6 noro 55: void Pinvalg_le();
1.7 noro 56: void Pset_field(),Palgtodalg(),Pdalgtoalg();
1.1 noro 57:
58: void mkalg(P,Alg *);
59: int cmpalgp(P,P);
60: void algptop(P,P *);
61: void algtorat(Num,Obj *);
62: void rattoalg(Obj,Alg *);
63: void ptoalgp(P,P *);
1.4 noro 64: void clctalg(P,VL *);
1.8 noro 65: void get_algtree(Obj f,VL *r);
1.1 noro 66:
67: struct ftab alg_tab[] = {
1.7 noro 68: {"set_field",Pset_field,1},
69: {"algtodalg",Palgtodalg,1},
70: {"dalgtoalg",Pdalgtoalg,1},
1.6 noro 71: {"invalg_le",Pinvalg_le,1},
1.1 noro 72: {"defpoly",Pdefpoly,1},
73: {"newalg",Pnewalg,1},
74: {"mainalg",Pmainalg,1},
75: {"algtorat",Palgtorat,1},
76: {"rattoalg",Prattoalg,1},
77: {"getalg",Pgetalg,1},
78: {"getalgtree",Pgetalgtree,1},
79: {"alg",Palg,1},
80: {"algv",Palgv,1},
81: {0,0,0},
82: };
83:
84: static int UCN,ACNT;
1.7 noro 85:
86: void Pset_field(NODE arg,Q *rp)
87: {
88: setfield_dalg(BDY((LIST)ARG0(arg)));
89: *rp = 0;
90: }
91:
92: void Palgtodalg(NODE arg,DAlg *rp)
93: {
94: algtodalg((Alg)ARG0(arg),rp);
95: }
96:
97: void Pdalgtoalg(NODE arg,Alg *rp)
98: {
99: dalgtoalg((DAlg)ARG0(arg),rp);
100: }
1.1 noro 101:
102: void Pnewalg(arg,rp)
103: NODE arg;
104: Alg *rp;
105: {
106: P p;
107: VL vl;
108: P c;
109:
110: p = (P)ARG0(arg);
111: if ( !p || OID(p) != O_P )
112: error("newalg : invalid argument");
113: clctv(CO,p,&vl);
114: if ( NEXT(vl) )
115: error("newalg : invalid argument");
116: c = COEF(DC(p));
117: if ( !NUM(c) || !RATN(c) )
118: error("newalg : invalid argument");
119: mkalg(p,rp);
120: }
121:
122: void mkalg(p,r)
123: P p;
124: Alg *r;
125: {
126: VL vl,mvl,nvl;
127: V a,tv;
128: char buf[BUFSIZ];
129: char *name;
130: P x,t,s;
131: Num c;
132: DCP dc,dcr,dcr0;
133:
134: for ( vl = ALG; vl; vl = NEXT(vl) )
135: if ( !cmpalgp(p,(P)vl->v->attr) ) {
136: a = vl->v; break;
137: }
138: if ( !vl ) {
139: NEWVL(vl); NEXT(vl) = ALG; ALG = vl;
140: NEWV(a); vl->v = a;
141: sprintf(buf,"#%d",ACNT++);
142: name = (char *)MALLOC(strlen(buf)+1);
143: strcpy(name,buf); NAME(a) = name;
144:
145: for ( dc = DC(p), dcr0 = 0; dc; dc = NEXT(dc) ) {
146: NEXTDC(dcr0,dcr); DEG(dcr) = DEG(dc); c = (Num)COEF(dc);
147: if ( NID(c) != N_A )
148: COEF(dcr) = (P)c;
149: else
150: COEF(dcr) = (P)BDY(((Alg)c));
151: }
152: NEXT(dcr) = 0; MKP(a,dcr0,t); a->attr = (pointer)t;
153:
154: sprintf(buf,"t%s",name); makevar(buf,&s);
155:
156: if ( NEXT(ALG) ) {
157: tv = (V)NEXT(ALG)->v->priv;
158: for ( vl = CO; NEXT(NEXT(vl)); vl = NEXT(vl) );
159: nvl = NEXT(vl); NEXT(vl) = 0;
160: for ( vl = CO; NEXT(vl) && (NEXT(vl)->v != tv); vl = NEXT(vl) );
161: mvl = NEXT(vl); NEXT(vl) = nvl; NEXT(nvl) = mvl;
162: }
163:
164: a->priv = (pointer)VR(s); VR(s)->priv = (pointer)a;
165: }
166: MKV(a,x); MKAlg(x,*r);
167: }
168:
169: int cmpalgp(p,defp)
170: P p,defp;
171: {
172: DCP dc,dcd;
173: P t;
174:
175: for ( dc = DC(p), dcd = DC(defp); dc && dcd;
176: dc = NEXT(dc), dcd = NEXT(dcd) ) {
177: if ( cmpq(DEG(dc),DEG(dcd)) )
178: break;
179: t = NID((Num)COEF(dc)) == N_A ? (P)BDY((Alg)COEF(dc)) : COEF(dc);
180: if ( compp(ALG,t,COEF(dcd)) )
181: break;
182: }
183: if ( dc || dcd )
184: return 1;
185: else
186: return 0;
187: }
188:
189: void Pdefpoly(arg,rp)
190: NODE arg;
191: P *rp;
192: {
193: asir_assert(ARG0(arg),O_N,"defpoly");
194: algptop((P)VR((P)BDY((Alg)ARG0(arg)))->attr,rp);
195: }
196:
197: void Pmainalg(arg,r)
198: NODE arg;
199: Alg *r;
200: {
201: Num c;
202: V v;
203: P b;
204:
205: c = (Num)(ARG0(arg));
206: if ( NID(c) <= N_R )
207: *r = 0;
208: else {
209: v = VR((P)BDY((Alg)c)); MKV(v,b); MKAlg(b,*r);
210: }
211: }
212:
213: void Palgtorat(arg,rp)
214: NODE arg;
215: Obj *rp;
216: {
217: asir_assert(ARG0(arg),O_N,"algtorat");
218: algtorat((Num)ARG0(arg),rp);
219: }
220:
221: void Prattoalg(arg,rp)
222: NODE arg;
223: Alg *rp;
224: {
225: asir_assert(ARG0(arg),O_R,"rattoalg");
226: rattoalg((Obj)ARG0(arg),rp);
227: }
228:
229: void Pgetalg(arg,rp)
230: NODE arg;
231: LIST *rp;
232: {
233: Obj t;
234: P p;
235: VL vl;
236: Num a;
237: Alg b;
238: NODE n0,n;
239:
240: if ( !(a = (Num)ARG0(arg)) || NID(a) <= N_R )
241: vl = 0;
242: else {
243: t = BDY((Alg)a);
244: switch ( OID(t) ) {
245: case O_P: case O_R:
246: clctvr(ALG,t,&vl); break;
247: default:
248: vl = 0; break;
249: }
250: }
251: for ( n0 = 0; vl; vl = NEXT(vl) ) {
252: NEXTNODE(n0,n); MKV(vl->v,p); MKAlg(p,b); BDY(n) = (pointer)b;
253: }
254: if ( n0 )
255: NEXT(n) = 0;
256: MKLIST(*rp,n0);
257: }
258:
259: void Pgetalgtree(arg,rp)
260: NODE arg;
261: LIST *rp;
262: {
263: Obj t;
264: P p;
265: VL vl,vl1,vl2;
266: Num a;
267: Alg b;
268: NODE n0,n;
269:
1.8 noro 270: #if 0
1.1 noro 271: if ( !(a = (Num)ARG0(arg)) || NID(a) <= N_R )
272: vl = 0;
273: else {
274: t = BDY((Alg)a);
275: switch ( OID(t) ) {
276: case O_P:
1.5 noro 277: clctalg((P)t,&vl); break;
1.1 noro 278: case O_R:
279: clctalg(NM((R)t),&vl1);
280: clctalg(DN((R)t),&vl2);
281: mergev(ALG,vl1,vl2,&vl); break;
282: default:
283: vl = 0; break;
284: }
285: }
1.8 noro 286: #else
287: get_algtree((Obj)ARG0(arg),&vl);
288: #endif
1.1 noro 289: for ( n0 = 0; vl; vl = NEXT(vl) ) {
290: NEXTNODE(n0,n); MKV(vl->v,p); MKAlg(p,b); BDY(n) = (pointer)b;
291: }
292: if ( n0 )
293: NEXT(n) = 0;
294: MKLIST(*rp,n0);
295: }
296:
297: void clctalg(p,vl)
298: P p;
299: VL *vl;
300: {
301: int n,i;
302: VL tvl;
303: VN vn,vn1;
304: P d;
305: DCP dc;
306:
307: for ( n = 0, tvl = ALG; tvl; tvl = NEXT(tvl), n++ );
308: vn = (VN) ALLOCA((n+1)*sizeof(struct oVN));
309: for ( i = n-1, tvl = ALG; tvl; tvl = NEXT(tvl), i-- ) {
310: vn[i].v = tvl->v;
311: vn[i].n = 0;
312: }
313: markv(vn,n,p);
314: for ( i = n-1; i >= 0; i-- ) {
315: if ( !vn[i].n )
316: continue;
317: d = (P)vn[i].v->attr;
318: for ( dc = DC(d); dc; dc = NEXT(dc) )
319: markv(vn,i,COEF(dc));
320: }
321: vn1 = (VN) ALLOCA((n+1)*sizeof(struct oVN));
322: for ( i = 0; i < n; i++ ) {
323: vn1[i].v = vn[n-1-i].v; vn1[i].n = vn[n-1-i].n;
324: }
325: vntovl(vn1,n,vl);
326: }
327:
328: void Palg(arg,rp)
329: NODE arg;
330: Alg *rp;
331: {
332: Q a;
333: VL vl;
334: P x;
335: int n;
336:
337: a = (Q)ARG0(arg);
338: if ( a && (OID(a) != O_N || NID(a) != N_Q || !INT(a)) )
339: *rp = 0;
340: else {
341: n = ACNT-QTOS(a)-1;
342: for ( vl = ALG; vl && n; vl = NEXT(vl), n-- );
343: if ( vl ) {
344: MKV(vl->v,x); MKAlg(x,*rp);
345: } else
346: *rp = 0;
347: }
348: }
349:
350: void Palgv(arg,rp)
351: NODE arg;
352: Obj *rp;
353: {
354: Q a;
355: VL vl;
356: P x;
357: int n;
358: Alg b;
359:
360: a = (Q)ARG0(arg);
361: if ( a && (OID(a) != O_N || NID(a) != N_Q || !INT(a)) )
362: *rp = 0;
363: else {
364: n = ACNT-QTOS(a)-1;
365: for ( vl = ALG; vl && n; vl = NEXT(vl), n-- );
366: if ( vl ) {
367: MKV(vl->v,x); MKAlg(x,b); algtorat((Num)b,rp);
368: } else
369: *rp = 0;
370: }
371: }
372:
373: void algptop(p,r)
374: P p,*r;
375: {
376: DCP dc,dcr,dcr0;
377:
378: if ( NUM(p) )
379: *r = (P)p;
380: else {
381: for ( dc = DC(p), dcr0 = 0; dc; dc = NEXT(dc) ) {
382: NEXTDC(dcr0,dcr); DEG(dcr) = DEG(dc);
383: algptop(COEF(dc),&COEF(dcr));
384: }
385: NEXT(dcr) = 0; MKP((V)(VR(p)->priv),dcr0,*r);
386: }
387: }
388:
389: void algtorat(n,r)
390: Num n;
391: Obj *r;
392: {
393: Obj obj;
394: P nm,dn;
395:
396: if ( !n || NID(n) <= N_R )
397: *r = (Obj)n;
398: else {
399: obj = BDY((Alg)n);
400: if ( ID(obj) <= O_P )
401: algptop((P)obj,(P *)r);
402: else {
403: algptop(NM((R)obj),&nm); algptop(DN((R)obj),&dn);
404: divr(CO,(Obj)nm,(Obj)dn,r);
405: }
406: }
407: }
408:
409: void rattoalg(obj,n)
410: Obj obj;
411: Alg *n;
412: {
413: P nm,dn;
414: Obj t;
415:
416: if ( !obj || ID(obj) == O_N )
417: *n = (Alg)obj;
418: else if ( ID(obj) == O_P ) {
419: ptoalgp((P)obj,(P *)&t); MKAlg(t,*n);
420: } else {
421: ptoalgp(NM((R)obj),&nm); ptoalgp(DN((R)obj),&dn);
422: divr(ALG,(Obj)nm,(Obj)dn,&t); MKAlg(t,*n);
423: }
424: }
425:
426: void ptoalgp(p,r)
427: P p,*r;
428: {
429: DCP dc,dcr,dcr0;
430:
431: if ( NUM(p) )
432: *r = (P)p;
433: else {
434: for ( dc = DC(p), dcr0 = 0; dc; dc = NEXT(dc) ) {
435: NEXTDC(dcr0,dcr); DEG(dcr) = DEG(dc);
436: ptoalgp(COEF(dc),&COEF(dcr));
437: }
438: NEXT(dcr) = 0; MKP((V)(VR(p)->priv),dcr0,*r);
439: }
1.6 noro 440: }
441:
442: void invalg_le(Alg a,LIST *r);
443:
444: void Pinvalg_le(NODE arg,LIST *r)
445: {
446: invalg_le((Alg)ARG0(arg),r);
447: }
448:
449: typedef struct oMono_nf {
450: DP mono;
451: DP nf;
452: Q dn;
453: } *Mono_nf;
454:
455: void invalg_le(Alg a,LIST *r)
456: {
457: Alg inv;
458: MAT mobj,sol;
459: int *rinfo,*cinfo;
460: P p,dn,dn1,ap;
461: VL vl,tvl;
462: Q c1,c2,c3,cont,c,two,iq,dn0,mul,dnsol;
463: int i,j,n,len,k;
464: MP mp,mp0;
465: DP dp,nm,nm1,m,d,u,u1;
466: NODE b,b1,hlist,mblist,t,s,rev0,rev,hist;
467: DP *ps;
468: struct order_spec *spec;
469: Mono_nf h,h1;
470: N nq,nr,nl,ng;
471: Q **mat,**solmat;
472: Q *w;
473: int *wi;
474:
475: ap = (P)BDY(a);
476: asir_assert(ap,O_P,"invalg_le");
477:
478: /* collecting algebraic numbers */
479: clctalg(ap,&vl);
480:
481: /* setup */
482: ptozp(ap,1,&c,&p);
483: STOQ(2,two); create_order_spec(0,(Obj)two,&spec); initd(spec);
484: for ( n = 0, tvl = vl; tvl; tvl = NEXT(tvl), n++ );
485: ps = (DP *)ALLOCA(n*sizeof(DP));
486:
487: /* conversion to DP */
488: for ( i = 0, tvl = vl; i < n; i++, tvl = NEXT(tvl) ) {
489: ptod(ALG,vl,tvl->v->attr,&ps[i]);
490: }
491: ptod(ALG,vl,p,&dp);
492: /* index list */
493: for ( b = 0, i = 0; i < n; i++ ) {
494: STOQ(i,iq); MKNODE(b1,(pointer)iq,b); b = b1;
495: }
496: /* simplification */
497: dp_true_nf(b,dp,ps,1,&nm,&dn);
498:
499: /* construction of NF table */
500:
501: /* stdmono: <<0,...,0>> < ... < max */
502: for ( hlist = 0, i = 0; i < n; i++ ) {
503: MKNODE(b1,(pointer)ps[i],hlist); hlist = b1;
504: }
505: dp_mbase(hlist,&rev0);
506: for ( mblist = 0, rev = rev0; rev; rev = NEXT(rev) ) {
507: MKNODE(b1,BDY(rev),mblist); mblist = b1;
508: }
509: dn0 = ONE;
510: for ( hist = 0, t = mblist; t; t = NEXT(t) ) {
511: /* searching a predecessor */
512: for ( m = (DP)BDY(t), s = hist; s; s = NEXT(s) ) {
513: h = (Mono_nf)BDY(s);
514: if ( dp_redble(m,h->mono) )
515: break;
516: }
517: h1 = (Mono_nf)ALLOCA(sizeof(struct oMono_nf));
518: if ( s ) {
519: dp_subd(m,h->mono,&d);
520: muld(CO,d,h->nf,&u);
521: dp_true_nf(b,u,ps,1,&nm1,&dn1);
522: mulq(h->dn,(Q)dn1,&h1->dn);
523: } else {
524: muld(CO,m,nm,&u);
525: dp_true_nf(b,u,ps,1,&nm1,&dn1);
526: h1->dn = (Q)dn1;
527: }
528: h1->mono = m;
529: h1->nf = nm1;
530: MKNODE(b1,(pointer)h1,hist); hist = b1;
531:
532: /* dn0 = LCM(dn0,h1->dn) */
533: gcdn(NM(dn0),NM(h1->dn),&ng); divn(NM(dn0),ng,&nq,&nr);
534: muln(nq,NM(h1->dn),&nl); NTOQ(nl,1,dn0);
535: }
536: /* create a matrix */
537: len = length(mblist);
538: MKMAT(mobj,len,len+1);
539: mat = (Q **)BDY(mobj);
540: mat[len-1][len] = dn0;
541: for ( j = 0, t = hist; j < len; j++, t = NEXT(t) ) {
542: h = (Mono_nf)BDY(t);
543: nm1 = h->nf;
544: divq((Q)dn0,h->dn,&mul);
545: for ( i = 0, rev = rev0, mp = BDY(nm1); mp && i < len; i++, rev = NEXT(rev) )
546: if ( dl_equal(n,BDY((DP)BDY(rev))->dl,mp->dl) ) {
547: mulq(mul,(Q)mp->c,&mat[i][j]);
548: mp = NEXT(mp);
549: }
550: }
551: #if 0
552: w = (Q *)ALLOCA((len+1)*sizeof(Q));
553: wi = (int *)ALLOCA((len+1)*sizeof(int));
554: for ( i = 0; i < len; i++ ) {
555: for ( j = 0, k = 0; j <= len; j++ )
556: if ( mat[i][j] ) {
557: w[k] = mat[i][j];
558: wi[k] = j;
559: k++;
560: }
561: removecont_array(w,k);
562: for ( j = 0; j < k; j++ )
563: mat[i][wi[j]] = w[j];
564: }
565: #endif
566: generic_gauss_elim_hensel(mobj,&sol,&dnsol,&rinfo,&cinfo);
567: solmat = (Q **)BDY(sol);
568: for ( i = 0, t = rev0, mp0 = 0; i < len; i++, t = NEXT(t) )
569: if ( solmat[i][0] ) {
570: NEXTMP(mp0,mp);
571: mp->c = (P)solmat[i][0];
572: mp->dl = BDY((DP)BDY(t))->dl;
573: }
574: NEXT(mp) = 0; MKDP(n,mp0,u);
575: dp_ptozp(u,&u1);
576: divq((Q)BDY(u)->c,(Q)BDY(u1)->c,&cont);
577: dtop(ALG,vl,u1,&ap);
578: MKAlg(ap,inv);
579: mulq(dnsol,(Q)dn,&c1);
580: mulq(c1,c,&c2);
581: divq(c2,cont,&c3);
582: b = mknode(2,inv,c3);
583: MKLIST(*r,b);
1.8 noro 584: }
585:
586: void get_algtree(Obj f,VL *r)
587: {
588: VL vl1,vl2,vl3;
589: Obj t;
590: DCP dc;
591: NODE b;
592: pointer *a;
593: pointer **m;
594: int len,row,col,i,j,l;
595:
596: if ( !f ) *r = 0;
597: else
598: switch ( OID(f) ) {
599: case O_N:
600: if ( NID((Num)f) != N_A ) *r = 0;
601: else {
602: t = BDY((Alg)f);
603: switch ( OID(t) ) {
604: case O_P:
605: clctalg((P)t,r); break;
606: case O_R:
607: clctalg(NM((R)t),&vl1);
608: clctalg(DN((R)t),&vl2);
609: mergev(ALG,vl1,vl2,r); break;
610: default:
611: *r = 0; break;
612: }
613: }
614: break;
615: case O_P:
616: vl1 = 0;
617: for ( dc = DC((P)f); dc; dc = NEXT(dc) ) {
618: get_algtree((Obj)COEF(dc),&vl2);
619: mergev(ALG,vl1,vl2,&vl3);
620: vl1 = vl3;
621: }
622: *r = vl1;
623: break;
624: case O_R:
625: get_algtree((Obj)NM((R)f),&vl1);
626: get_algtree((Obj)DN((R)f),&vl2);
627: mergev(ALG,vl1,vl2,r);
628: break;
629: case O_LIST:
630: vl1 = 0;
631: for ( b = BDY((LIST)f); b; b = NEXT(b) ) {
632: get_algtree((Obj)BDY(b),&vl2);
633: mergev(ALG,vl1,vl2,&vl3);
634: vl1 = vl3;
635: }
636: *r = vl1;
637: break;
638: case O_VECT:
639: vl1 = 0;
640: l = ((VECT)f)->len;
641: a = BDY((VECT)f);
642: for ( i = 0; i < l; i++ ) {
643: get_algtree((Obj)a[i],&vl2);
644: mergev(ALG,vl1,vl2,&vl3);
645: vl1 = vl3;
646: }
647: *r = vl1;
648: break;
649: case O_MAT:
650: vl1 = 0;
651: row = ((MAT)f)->row; col = ((MAT)f)->col;
652: m = BDY((MAT)f);
653: for ( i = 0; i < row; i++ )
654: for ( j = 0; j < col; j++ ) {
655: get_algtree((Obj)m[i][j],&vl2);
656: mergev(ALG,vl1,vl2,&vl3);
657: vl1 = vl3;
658: }
659: *r = vl1;
660: break;
661: default:
662: *r = 0;
1.9 ! noro 663: break;
! 664: }
! 665: }
! 666:
! 667: void algobjtorat(Obj f,Obj *r)
! 668: {
! 669: Obj t;
! 670: DCP dc,dcr,dcr0;
! 671: P p,nm,dn;
! 672: R rat;
! 673: NODE b,s,s0;
! 674: VECT v;
! 675: MAT mat;
! 676: LIST list;
! 677: pointer *a;
! 678: pointer **m;
! 679: int len,row,col,i,j,l;
! 680:
! 681: if ( !f ) *r = 0;
! 682: else
! 683: switch ( OID(f) ) {
! 684: case O_N:
! 685: algtorat((Num)f,r);
! 686: break;
! 687: case O_P:
! 688: dcr0 = 0;
! 689: for ( dc = DC((P)f); dc; dc = NEXT(dc) ) {
! 690: NEXTDC(dcr0,dcr);
! 691: algobjtorat((Obj)COEF(dc),&t);
! 692: COEF(dcr) = (P)t;
! 693: DEG(dcr) = DEG(dc);
! 694: }
! 695: NEXT(dcr) = 0; MKP(VR((P)f),dcr0,p); *r = (Obj)p;
! 696: break;
! 697: case O_R:
! 698: algobjtorat((Obj)NM((R)f),&t); nm = (P)t;
! 699: algobjtorat((Obj)DN((R)f),&t); dn = (P)t;
! 700: MKRAT(nm,dn,0,rat); *r = (Obj)rat;
! 701: break;
! 702: case O_LIST:
! 703: s0 = 0;
! 704: for ( b = BDY((LIST)f); b; b = NEXT(b) ) {
! 705: NEXTNODE(s0,s);
! 706: algobjtorat((Obj)BDY(b),&t);
! 707: BDY(s) = (pointer)t;
! 708: }
! 709: NEXT(s) = 0;
! 710: MKLIST(list,s0);
! 711: *r = (Obj)list;
! 712: break;
! 713: case O_VECT:
! 714: l = ((VECT)f)->len;
! 715: a = BDY((VECT)f);
! 716: MKVECT(v,l);
! 717: for ( i = 0; i < l; i++ ) {
! 718: algobjtorat((Obj)a[i],&t);
! 719: BDY(v)[i] = (pointer)t;
! 720: }
! 721: *r = (Obj)v;
! 722: break;
! 723: case O_MAT:
! 724: row = ((MAT)f)->row; col = ((MAT)f)->col;
! 725: m = BDY((MAT)f);
! 726: MKMAT(mat,row,col);
! 727: for ( i = 0; i < row; i++ )
! 728: for ( j = 0; j < col; j++ ) {
! 729: algobjtorat((Obj)m[i][j],&t);
! 730: BDY(mat)[i][j] = (pointer)t;
! 731: }
! 732: *r = (Obj)mat;
! 733: break;
! 734: default:
! 735: *r = f;
1.8 noro 736: break;
737: }
1.1 noro 738: }