Annotation of OpenXM_contrib2/asir2000/builtin/pdiv.c, Revision 1.6
1.3 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.4 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.3 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.6 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/pdiv.c,v 1.5 2001/02/21 07:10:17 noro Exp $
1.3 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "parse.h"
52:
53: void Psdiv(), Psrem(), Ptdiv(), Psqr(), Pinva_mod();
54: void Psdiv_gf2n(), Psrem_gf2n();
55: void Psdivm(), Psremm(), Psqrm();
56: void Psrem_mod();
57: void Pugcd();
58: void Purem();
59: void Pudiv();
60:
61: struct ftab pdiv_tab[] = {
62: {"sdiv",Psdiv,-3},
63: {"srem",Psrem,-3},
64: {"sdiv_gf2n",Psdiv_gf2n,2},
65: {"srem_gf2n",Psrem_gf2n,2},
66: {"sqr",Psqr,-3},
1.5 noro 67: {"tdiv",Ptdiv,-3},
1.1 noro 68: {"udiv",Pudiv,2},
69: {"sdivm",Psdivm,-4},
70: {"sremm",Psremm,-4},
71: {"sqrm",Psqrm,-4},
72: {"inva_mod",Pinva_mod,3},
73: {"srem_mod",Psrem_mod,3},
74: {"ugcd",Pugcd,2},
75: {"urem",Purem,2},
76: {0,0,0},
77: };
78:
79: void Psdiv(arg,rp)
80: NODE arg;
81: Obj *rp;
82: {
83: P q,r,dnd,dnd1,dvr,dvr1;
84: V v;
85: VL vl;
86:
87: asir_assert(ARG0(arg),O_P,"sdiv");
88: asir_assert(ARG1(arg),O_P,"sdiv");
89: dnd = (P)ARG0(arg); dvr = (P)ARG1(arg);
90: if ( argc(arg) == 3 ) {
91: v = VR((P)ARG2(arg));
92: change_mvar(CO,dnd,v,&dnd1); change_mvar(CO,dvr,v,&dvr1);
93: reordvar(CO,v,&vl);
94: divsrp(vl,dnd1,dvr1,&q,&r);
95: restore_mvar(CO,q,v,(P *)rp);
96: } else
97: divsrp(CO,dnd,dvr,(P *)rp,&r);
98: }
99:
100: void Psrem(arg,rp)
101: NODE arg;
102: Obj *rp;
103: {
104: P q,r,dnd,dnd1,dvr,dvr1;
105: V v;
106: VL vl;
107:
108: asir_assert(ARG0(arg),O_P,"srem");
109: asir_assert(ARG1(arg),O_P,"srem");
110: dnd = (P)ARG0(arg); dvr = (P)ARG1(arg);
111: if ( argc(arg) == 3 ) {
112: v = VR((P)ARG2(arg));
113: change_mvar(CO,dnd,v,&dnd1); change_mvar(CO,dvr,v,&dvr1);
114: reordvar(CO,v,&vl);
115: divsrp(vl,dnd1,dvr1,&q,&r);
116: restore_mvar(CO,r,v,(P *)rp);
117: } else
118: divsrp(CO,dnd,dvr,&q,(P *)rp);
119: }
120:
121: void Psqr(arg,rp)
122: NODE arg;
123: LIST *rp;
124: {
125: P q,q1,r,r1,dnd,dnd1,dvr,dvr1;
126: NODE n,tn;
127: V v;
128: VL vl;
129:
130: asir_assert(ARG0(arg),O_P,"sqr");
131: asir_assert(ARG1(arg),O_P,"sqr");
132: dnd = (P)ARG0(arg); dvr = (P)ARG1(arg);
133: if ( argc(arg) == 3 ) {
134: v = VR((P)ARG2(arg));
135: change_mvar(CO,dnd,v,&dnd1); change_mvar(CO,dvr,v,&dvr1);
136: reordvar(CO,v,&vl);
137: divsrp(vl,dnd1,dvr1,&q1,&r1);
138: restore_mvar(CO,q1,v,&q); restore_mvar(CO,r1,v,&r);
139: } else
140: divsrp(CO,dnd,dvr,&q,&r);
141: MKNODE(tn,r,0); MKNODE(n,q,tn); MKLIST(*rp,n);
142: }
143:
144: void Psdiv_gf2n(arg,rp)
145: NODE arg;
146: GF2N *rp;
147: {
148: GF2N dnd,dvr;
149: UP2 q,r;
150:
151: dnd = (GF2N)ARG0(arg); dvr = (GF2N)ARG1(arg);
152: if ( !dvr )
153: error("sdiv_gf2n : division by 0");
154: else if ( !dnd )
155: *rp = 0;
156: else {
157: qrup2(dnd->body,dvr->body,&q,&r);
158: MKGF2N(q,*rp);
159: }
160: }
161:
162: void Psrem_gf2n(arg,rp)
163: NODE arg;
164: GF2N *rp;
165: {
166: GF2N dnd,dvr;
167: UP2 q,r;
168:
169: dnd = (GF2N)ARG0(arg); dvr = (GF2N)ARG1(arg);
170: if ( !dvr )
171: error("srem_gf2n : division by 0");
172: else if ( !dnd )
173: *rp = 0;
174: else {
175: qrup2(dnd->body,dvr->body,&q,&r);
176: MKGF2N(r,*rp);
177: }
178: }
179:
180: void Ptdiv(arg,rp)
181: NODE arg;
182: P *rp;
183: {
184: P p1,p2,q1,q2,q,c1,c2,c;
1.5 noro 185: int m;
1.1 noro 186:
187: p1 = (P)ARG0(arg); p2 = (P)ARG1(arg);
188: asir_assert(p1,O_P,"tdiv");
189: asir_assert(p2,O_P,"tdiv");
190: if ( !p1 || !p2 )
191: *rp = 0;
192: else if ( (OID(p1) > O_P) || (OID(p2) > O_P ) )
193: *rp = 0;
1.5 noro 194: else if ( argc(arg) == 3 ) {
195: m = QTOS((Q)ARG2(arg));
196: ptomp(m,p1,&q1); ptomp(m,p2,&q2);
197: if ( divtmp(CO,m,q1,q2,&q) )
198: mptop(q,rp);
199: else
200: *rp = 0;
1.6 ! noro 201: } else if ( qpcheck((Obj)p1) && qpcheck((Obj)p2) ) {
1.1 noro 202: ptozp(p1,1,(Q *)&c1,&q1); ptozp(p2,1,(Q *)&c2,&q2);
203: if ( divtpz(CO,q1,q2,&q) ) {
204: divq((Q)c1,(Q)c2,(Q *)&c); mulp(CO,q,c,rp);
205: } else
1.6 ! noro 206: *rp = 0;
! 207: } else {
! 208: if ( !divtp(CO,p1,p2,rp) )
1.1 noro 209: *rp = 0;
210: }
211: }
212:
213: void Pudiv(arg,rp)
214: NODE arg;
215: LIST *rp;
216: {
217: P q,r,dnd,dvr;
218: NODE n,tn;
219:
220: asir_assert(ARG0(arg),O_P,"udiv");
221: asir_assert(ARG1(arg),O_P,"udiv");
222: dnd = (P)ARG0(arg); dvr = (P)ARG1(arg);
223: udivpz(dnd,dvr,&q,&r);
224: MKNODE(tn,r,0); MKNODE(n,q,tn); MKLIST(*rp,n);
225: }
226:
227: void Psdivm(arg,rp)
228: NODE arg;
229: Obj *rp;
230: {
231: P q,r,dnd,dnd1,dndm,dvr,dvr1,dvrm,t;
232: V v;
233: VL vl;
234: int m;
235:
236: asir_assert(ARG0(arg),O_P,"sdivm");
237: asir_assert(ARG1(arg),O_P,"sdivm");
238: asir_assert(ARG2(arg),O_N,"sdivm");
239: dnd = (P)ARG0(arg); dvr = (P)ARG1(arg); m = QTOS((Q)ARG2(arg));
240: if ( argc(arg) == 4 ) {
241: v = VR((P)ARG3(arg));
242: change_mvar(CO,dnd,v,&dnd1); change_mvar(CO,dvr,v,&dvr1);
243: reordvar(CO,v,&vl);
244: ptomp(m,dnd1,&dndm); ptomp(m,dvr1,&dvrm);
245: divsrmp(vl,m,dndm,dvrm,&t,&r); mptop(t,&q);
246: restore_mvar(CO,q,v,(P *)rp);
247: } else {
248: ptomp(m,dnd,&dndm); ptomp(m,dvr,&dvrm);
249: divsrmp(CO,m,dndm,dvrm,&t,&r); mptop(t,(P *)rp);
250: }
251: }
252:
253: void Psremm(arg,rp)
254: NODE arg;
255: Obj *rp;
256: {
257: P q,r,dnd,dnd1,dndm,dvr,dvr1,dvrm,t;
258: V v;
259: VL vl;
260: int m;
261:
262: asir_assert(ARG0(arg),O_P,"sremm");
263: asir_assert(ARG1(arg),O_P,"sremm");
264: asir_assert(ARG2(arg),O_N,"sremm");
265: dnd = (P)ARG0(arg); dvr = (P)ARG1(arg); m = QTOS((Q)ARG2(arg));
266: if ( argc(arg) == 4 ) {
267: v = VR((P)ARG3(arg));
268: change_mvar(CO,dnd,v,&dnd1); change_mvar(CO,dvr,v,&dvr1);
269: reordvar(CO,v,&vl);
270: ptomp(m,dnd1,&dndm); ptomp(m,dvr1,&dvrm);
271: divsrmp(vl,m,dndm,dvrm,&q,&t); mptop(t,&r);
272: restore_mvar(CO,r,v,(P *)rp);
273: } else {
274: ptomp(m,dnd,&dndm); ptomp(m,dvr,&dvrm);
275: divsrmp(CO,m,dndm,dvrm,&q,&t); mptop(t,(P *)rp);
276: }
277: }
278:
279: void Psqrm(arg,rp)
280: NODE arg;
281: LIST *rp;
282: {
283: P q,q1,r,r1,dnd,dnd1,dndm,dvr,dvr1,dvrm;
284: NODE n,tn;
285: V v;
286: VL vl;
287: int m;
288:
289: asir_assert(ARG0(arg),O_P,"sqrm");
290: asir_assert(ARG1(arg),O_P,"sqrm");
291: asir_assert(ARG2(arg),O_N,"sqrm");
292: dnd = (P)ARG0(arg); dvr = (P)ARG1(arg); m = QTOS((Q)ARG2(arg));
293: if ( argc(arg) == 4 ) {
294: v = VR((P)ARG3(arg));
295: change_mvar(CO,dnd,v,&dnd1); change_mvar(CO,dvr,v,&dvr1);
296: reordvar(CO,v,&vl);
297: ptomp(m,dnd1,&dndm); ptomp(m,dvr1,&dvrm);
1.2 noro 298: divsrmp(vl,m,dndm,dvrm,&q,&r); mptop(q,&q1); mptop(r,&r1);
1.1 noro 299: restore_mvar(CO,q1,v,&q); restore_mvar(CO,r1,v,&r);
300: } else {
301: ptomp(m,dnd,&dndm); ptomp(m,dvr,&dvrm);
1.2 noro 302: divsrmp(CO,m,dndm,dvrm,&q1,&r1); mptop(q1,&q); mptop(r1,&r);
1.1 noro 303: }
304: MKNODE(tn,r,0); MKNODE(n,q,tn); MKLIST(*rp,n);
305: }
306:
307: void Pinva_mod(arg,rp)
308: NODE arg;
309: P *rp;
310: {
311: P dp,f;
312: Q q;
313: int n,i;
314: int mod;
315: V v;
316: UM wf,wdp,winv;
317:
318: asir_assert(ARG0(arg),O_P,"gcda_mod");
319: asir_assert(ARG1(arg),O_N,"gcda_mod");
320: asir_assert(ARG2(arg),O_P,"gcda_mod");
321: dp = (P)ARG0(arg);
322: mod = QTOS((Q)ARG1(arg));
323: f = (P)ARG2(arg);
324: if ( NUM(f) ) {
325: i = invm(rem(NM((Q)f),mod),mod);
326: STOQ(i,q); *rp = (P)q;
327: } else {
328: v = VR(dp);
329: n = MAX(UDEG(dp),UDEG(f));
330: wf = W_UMALLOC(n); wdp = W_UMALLOC(n);
331: winv = W_UMALLOC(n);
332: ptoum(mod,f,wf); ptoum(mod,dp,wdp);
333: invum(mod,wdp,wf,winv);
334: if ( DEG(winv) < 0 )
335: *rp = 0;
336: else {
337: umtop(v,winv,rp);
338: }
339: }
340: }
341:
342: void Psrem_mod(arg,rp)
343: NODE arg;
344: P *rp;
345: {
346: P p1,p2;
347: int n,dr;
348: int mod;
349: V v;
350: UM wp1,wp2,q;
351:
352: asir_assert(ARG0(arg),O_P,"srem_mod");
353: asir_assert(ARG1(arg),O_P,"srem_mod");
354: asir_assert(ARG2(arg),O_N,"srem_mod");
355: p1 = (P)ARG0(arg); p2 = (P)ARG1(arg); mod = QTOS((Q)ARG2(arg));
356: if ( !p1 || NUM(p1) )
357: *rp = p1;
358: else {
359: v = VR(p1);
360: n = MAX(UDEG(p1),UDEG(p2));
361: wp1 = W_UMALLOC(n); wp2 = W_UMALLOC(n); q = W_UMALLOC(n);
362: ptoum(mod,p1,wp1); ptoum(mod,p2,wp2);
363: dr = divum(mod,wp1,wp2,q);
364: if ( ( DEG(wp1) = dr ) == -1 )
365: *rp = 0;
366: else
367: umtop(v,wp1,rp);
368: }
369: }
370:
371: void Purem(arg,rp)
372: NODE arg;
373: P *rp;
374: {
375: asir_assert(ARG0(arg),O_P,"urem");
376: asir_assert(ARG1(arg),O_P,"urem");
377: uremp((P)ARG0(arg),(P)ARG1(arg),rp);
378: }
379:
380: void Pugcd(arg,rp)
381: NODE arg;
382: P *rp;
383: {
384: asir_assert(ARG0(arg),O_P,"ugcd");
385: asir_assert(ARG1(arg),O_P,"ugcd");
386: ugcdp((P)ARG0(arg),(P)ARG1(arg),rp);
387: }
388:
389: void invum(mod,dp,f,inv)
390: int mod;
391: UM dp,f,inv;
392: {
393: UM g1,g2,a1,a2,a3,wm,q,tum;
394: int d,dr;
395:
396: d = DEG(dp)+DEG(f)+10;
397: g1 = W_UMALLOC(d); g2 = W_UMALLOC(d); a1 = W_UMALLOC(d);
398: a2 = W_UMALLOC(d); a3 = W_UMALLOC(d); wm = W_UMALLOC(d);
399: q = W_UMALLOC(d);
400: DEG(a1) = 0; COEF(a1)[0] = 1; DEG(a2) = -1;
401: cpyum(f,g1); cpyum(dp,g2);
402: while ( 1 ) {
403: dr = divum(mod,g1,g2,q); tum = g1; g1 = g2; g2 = tum;
404: if ( ( DEG(g2) = dr ) == -1 )
405: break;
406: mulum(mod,a2,q,wm); subum(mod,a1,wm,a3); dr = divum(mod,a3,dp,q);
407: tum = a1; a1 = a2; a2 = a3; a3 = tum; DEG(a3) = dr;
408: }
409: if ( DEG(g1) != 0 )
410: DEG(inv) = -1;
411: else if ( COEF(g1)[0] != 1 )
412: mulsum(mod,a2,invm(COEF(g1)[0],mod),inv);
413: else
414: cpyum(a2,inv);
415: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to pdiv.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin