![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to algnum_ff.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_ff.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / builtin |
1.1 noro 1: /* $OpenXM: OpenXM/src/asir99/builtin/algnum_ff.c,v 1.1.1.1 1999/11/10 08:12:26 noro Exp $ */
2: #include "ca.h"
3: #include "parse.h"
4:
5: void Pdefpoly(), Pnewalg(), Pmainalg(), Palgtorat(), Prattoalg(), Pgetalg();
6: void Palg(), Palgv(), Pgetalgtree();
7:
8: #if defined(THINK_C)
9: void mkalg(P,Alg *);
10: int cmpalgp(P,P);
11: void algptop(P,P *);
12: void algtorat(Num,Obj *);
13: void rattoalg(Obj,Alg *);
14: void ptoalgp(P,P *);
15: #else
16: void mkalg();
17: int cmpalgp();
18: void algptop();
19: void algtorat();
20: void rattoalg();
21: void ptoalgp();
22: void clctalg();
23: #endif
24:
25: struct ftab alg_tab[] = {
26: {"defpoly",Pdefpoly,1},
27: {"newalg",Pnewalg,1},
28: {"mainalg",Pmainalg,1},
29: {"algtorat",Palgtorat,1},
30: {"rattoalg",Prattoalg,1},
31: {"getalg",Pgetalg,1},
32: {"getalgtree",Pgetalgtree,1},
33: {"alg",Palg,1},
34: {"algv",Palgv,1},
35: {0,0,0},
36: };
37:
38: static int UCN,ACNT;
39:
40: void Pnewalg(arg,rp)
41: NODE arg;
42: Alg *rp;
43: {
44: P p;
45: VL vl;
46: P c;
47:
48: p = (P)ARG0(arg);
49: if ( !p || OID(p) != O_P )
50: error("newalg : invalid argument");
51: clctv(CO,p,&vl);
52: if ( NEXT(vl) )
53: error("newalg : invalid argument");
54: c = COEF(DC(p));
55: if ( !NUM(c) || !RATN(c) )
56: error("newalg : invalid argument");
57: mkalg(p,rp);
58: }
59:
60: void mkalg(p,r)
61: P p;
62: Alg *r;
63: {
64: VL vl,mvl,nvl;
65: V a,tv;
66: char buf[BUFSIZ];
67: char *name;
68: P x,t,s;
69: Num c;
70: DCP dc,dcr,dcr0;
71:
72: for ( vl = ALG; vl; vl = NEXT(vl) )
73: if ( !cmpalgp(p,(P)vl->v->attr) ) {
74: a = vl->v; break;
75: }
76: if ( !vl ) {
77: NEWVL(vl); NEXT(vl) = ALG; ALG = vl;
78: NEWV(a); vl->v = a;
79: sprintf(buf,"#%d",ACNT++);
80: name = (char *)MALLOC(strlen(buf)+1);
81: strcpy(name,buf); NAME(a) = name;
82:
83: for ( dc = DC(p), dcr0 = 0; dc; dc = NEXT(dc) ) {
84: NEXTDC(dcr0,dcr); DEG(dcr) = DEG(dc); c = (Num)COEF(dc);
85: if ( NID(c) != N_A )
86: COEF(dcr) = (P)c;
87: else
88: COEF(dcr) = (P)BDY(((Alg)c));
89: }
90: NEXT(dcr) = 0; MKP(a,dcr0,t); a->attr = (pointer)t;
91:
92: sprintf(buf,"t%s",name); makevar(buf,&s);
93:
94: if ( NEXT(ALG) ) {
95: tv = (V)NEXT(ALG)->v->priv;
96: for ( vl = CO; NEXT(NEXT(vl)); vl = NEXT(vl) );
97: nvl = NEXT(vl); NEXT(vl) = 0;
98: for ( vl = CO; NEXT(vl) && (NEXT(vl)->v != tv); vl = NEXT(vl) );
99: mvl = NEXT(vl); NEXT(vl) = nvl; NEXT(nvl) = mvl;
100: }
101:
102: a->priv = (pointer)VR(s); VR(s)->priv = (pointer)a;
103: }
104: MKV(a,x); MKAlg(x,*r);
105: }
106:
107: int cmpalgp(p,defp)
108: P p,defp;
109: {
110: DCP dc,dcd;
111: P t;
112:
113: for ( dc = DC(p), dcd = DC(defp); dc && dcd;
114: dc = NEXT(dc), dcd = NEXT(dcd) ) {
115: if ( cmpq(DEG(dc),DEG(dcd)) )
116: break;
117: t = NID((Num)COEF(dc)) == N_A ? (P)BDY((Alg)COEF(dc)) : COEF(dc);
118: if ( compp(ALG,t,COEF(dcd)) )
119: break;
120: }
121: if ( dc || dcd )
122: return 1;
123: else
124: return 0;
125: }
126:
127: void Pdefpoly(arg,rp)
128: NODE arg;
129: P *rp;
130: {
131: asir_assert(ARG0(arg),O_N,"defpoly");
132: algptop((P)VR((P)BDY((Alg)ARG0(arg)))->attr,rp);
133: }
134:
135: void Pmainalg(arg,r)
136: NODE arg;
137: Alg *r;
138: {
139: Num c;
140: V v;
141: P b;
142:
143: c = (Num)(ARG0(arg));
144: if ( NID(c) <= N_R )
145: *r = 0;
146: else {
147: v = VR((P)BDY((Alg)c)); MKV(v,b); MKAlg(b,*r);
148: }
149: }
150:
151: void Palgtorat(arg,rp)
152: NODE arg;
153: Obj *rp;
154: {
155: asir_assert(ARG0(arg),O_N,"algtorat");
156: algtorat((Num)ARG0(arg),rp);
157: }
158:
159: void Prattoalg(arg,rp)
160: NODE arg;
161: Alg *rp;
162: {
163: asir_assert(ARG0(arg),O_R,"rattoalg");
164: rattoalg((Obj)ARG0(arg),rp);
165: }
166:
167: void Pgetalg(arg,rp)
168: NODE arg;
169: LIST *rp;
170: {
171: Obj t;
172: P p;
173: VL vl;
174: Num a;
175: Alg b;
176: NODE n0,n;
177:
178: if ( !(a = (Num)ARG0(arg)) || NID(a) <= N_R )
179: vl = 0;
180: else {
181: t = BDY((Alg)a);
182: switch ( OID(t) ) {
183: case O_P: case O_R:
184: clctvr(ALG,t,&vl); break;
185: default:
186: vl = 0; break;
187: }
188: }
189: for ( n0 = 0; vl; vl = NEXT(vl) ) {
190: NEXTNODE(n0,n); MKV(vl->v,p); MKAlg(p,b); BDY(n) = (pointer)b;
191: }
192: if ( n0 )
193: NEXT(n) = 0;
194: MKLIST(*rp,n0);
195: }
196:
197: void Pgetalgtree(arg,rp)
198: NODE arg;
199: LIST *rp;
200: {
201: Obj t;
202: P p;
203: VL vl,vl1,vl2;
204: Num a;
205: Alg b;
206: NODE n0,n;
207:
208: if ( !(a = (Num)ARG0(arg)) || NID(a) <= N_R )
209: vl = 0;
210: else {
211: t = BDY((Alg)a);
212: switch ( OID(t) ) {
213: case O_P:
214: clctalg(t,&vl); break;
215: case O_R:
216: clctalg(NM((R)t),&vl1);
217: clctalg(DN((R)t),&vl2);
218: mergev(ALG,vl1,vl2,&vl); break;
219: default:
220: vl = 0; break;
221: }
222: }
223: for ( n0 = 0; vl; vl = NEXT(vl) ) {
224: NEXTNODE(n0,n); MKV(vl->v,p); MKAlg(p,b); BDY(n) = (pointer)b;
225: }
226: if ( n0 )
227: NEXT(n) = 0;
228: MKLIST(*rp,n0);
229: }
230:
231: void clctalg(p,vl)
232: P p;
233: VL *vl;
234: {
235: int n,i;
236: VL tvl;
237: VN vn,vn1;
238: P d;
239: DCP dc;
240:
241: for ( n = 0, tvl = ALG; tvl; tvl = NEXT(tvl), n++ );
242: vn = (VN) ALLOCA((n+1)*sizeof(struct oVN));
243: for ( i = n-1, tvl = ALG; tvl; tvl = NEXT(tvl), i-- ) {
244: vn[i].v = tvl->v;
245: vn[i].n = 0;
246: }
247: markv(vn,n,p);
248: for ( i = n-1; i >= 0; i-- ) {
249: if ( !vn[i].n )
250: continue;
251: d = (P)vn[i].v->attr;
252: for ( dc = DC(d); dc; dc = NEXT(dc) )
253: markv(vn,i,COEF(dc));
254: }
255: vn1 = (VN) ALLOCA((n+1)*sizeof(struct oVN));
256: for ( i = 0; i < n; i++ ) {
257: vn1[i].v = vn[n-1-i].v; vn1[i].n = vn[n-1-i].n;
258: }
259: vntovl(vn1,n,vl);
260: }
261:
262: void Palg(arg,rp)
263: NODE arg;
264: Alg *rp;
265: {
266: Q a;
267: VL vl;
268: P x;
269: int n;
270:
271: a = (Q)ARG0(arg);
272: if ( a && (OID(a) != O_N || NID(a) != N_Q || !INT(a)) )
273: *rp = 0;
274: else {
275: n = ACNT-QTOS(a)-1;
276: for ( vl = ALG; vl && n; vl = NEXT(vl), n-- );
277: if ( vl ) {
278: MKV(vl->v,x); MKAlg(x,*rp);
279: } else
280: *rp = 0;
281: }
282: }
283:
284: void Palgv(arg,rp)
285: NODE arg;
286: Obj *rp;
287: {
288: Q a;
289: VL vl;
290: P x;
291: int n;
292: Alg b;
293:
294: a = (Q)ARG0(arg);
295: if ( a && (OID(a) != O_N || NID(a) != N_Q || !INT(a)) )
296: *rp = 0;
297: else {
298: n = ACNT-QTOS(a)-1;
299: for ( vl = ALG; vl && n; vl = NEXT(vl), n-- );
300: if ( vl ) {
301: MKV(vl->v,x); MKAlg(x,b); algtorat((Num)b,rp);
302: } else
303: *rp = 0;
304: }
305: }
306:
307: void algptop(p,r)
308: P p,*r;
309: {
310: DCP dc,dcr,dcr0;
311:
312: if ( NUM(p) )
313: *r = (P)p;
314: else {
315: for ( dc = DC(p), dcr0 = 0; dc; dc = NEXT(dc) ) {
316: NEXTDC(dcr0,dcr); DEG(dcr) = DEG(dc);
317: algptop(COEF(dc),&COEF(dcr));
318: }
319: NEXT(dcr) = 0; MKP((V)(VR(p)->priv),dcr0,*r);
320: }
321: }
322:
323: void algtorat(n,r)
324: Num n;
325: Obj *r;
326: {
327: Obj obj;
328: P nm,dn;
329:
330: if ( !n || NID(n) <= N_R )
331: *r = (Obj)n;
332: else {
333: obj = BDY((Alg)n);
334: if ( ID(obj) <= O_P )
335: algptop((P)obj,(P *)r);
336: else {
337: algptop(NM((R)obj),&nm); algptop(DN((R)obj),&dn);
338: divr(CO,(Obj)nm,(Obj)dn,r);
339: }
340: }
341: }
342:
343: void rattoalg(obj,n)
344: Obj obj;
345: Alg *n;
346: {
347: P nm,dn;
348: Obj t;
349:
350: if ( !obj || ID(obj) == O_N )
351: *n = (Alg)obj;
352: else if ( ID(obj) == O_P ) {
353: ptoalgp((P)obj,(P *)&t); MKAlg(t,*n);
354: } else {
355: ptoalgp(NM((R)obj),&nm); ptoalgp(DN((R)obj),&dn);
356: divr(ALG,(Obj)nm,(Obj)dn,&t); MKAlg(t,*n);
357: }
358: }
359:
360: void ptoalgp(p,r)
361: P p,*r;
362: {
363: DCP dc,dcr,dcr0;
364:
365: if ( NUM(p) )
366: *r = (P)p;
367: else {
368: for ( dc = DC(p), dcr0 = 0; dc; dc = NEXT(dc) ) {
369: NEXTDC(dcr0,dcr); DEG(dcr) = DEG(dc);
370: ptoalgp(COEF(dc),&COEF(dcr));
371: }
372: NEXT(dcr) = 0; MKP((V)(VR(p)->priv),dcr0,*r);
373: }
374: }