Annotation of OpenXM_contrib2/asir2000/builtin/fctr.c, Revision 1.2
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
! 26: * e-mail at risa-admin@flab.fujitsu.co.jp of the detailed specification
! 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: *
! 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/fctr.c,v 1.1.1.1 1999/12/03 07:39:07 noro Exp $
! 49: */
1.1 noro 50: #include "ca.h"
51: #include "parse.h"
52:
53: void Pfctr(), Pgcd(), Pgcdz(), Plcm(), Psqfr(), Pufctrhint();
54: void Pptozp(), Pcont();
55: void Pafctr(), Pagcd();
56: void Pmodsqfr(),Pmodfctr(),Pddd(),Pnewddd(),Pddd_tab();
57: void Pirred_check(), Pnfctr_mod();
58:
59: struct ftab fctr_tab[] = {
60: {"fctr",Pfctr,1},
61: {"gcd",Pgcd,-3},
62: {"gcdz",Pgcdz,2},
63: {"lcm",Plcm,2},
64: {"sqfr",Psqfr,1},
65: {"ufctrhint",Pufctrhint,2},
66: {"ptozp",Pptozp,1},
67: {"cont",Pcont,-2},
68: {"afctr",Pafctr,2},
69: {"agcd",Pagcd,3},
70: {"modsqfr",Pmodsqfr,2},
71: {"modfctr",Pmodfctr,2},
72: #if 0
73: {"ddd",Pddd,2},
74: {"newddd",Pnewddd,2},
75: #endif
76: {"ddd_tab",Pddd_tab,2},
77: {"irred_check",Pirred_check,2},
78: {"nfctr_mod",Pnfctr_mod,2},
79: {0,0,0},
80: };
81:
82: void Pfctr(arg,rp)
83: NODE arg;
84: LIST *rp;
85: {
86: DCP dc;
87:
88: asir_assert(ARG0(arg),O_P,"fctr");
89: fctrp(CO,(P)ARG0(arg),&dc);
90: dcptolist(dc,rp);
91: }
92:
93: void Pgcd(arg,rp)
94: NODE arg;
95: P *rp;
96: {
97: P p1,p2,g1,g2,g;
98: Num m;
99: int mod;
100:
101: p1 = (P)ARG0(arg); p2 = (P)ARG1(arg);
102: asir_assert(p1,O_P,"gcd");
103: asir_assert(p2,O_P,"gcd");
104: if ( !p1 )
105: *rp = p2;
106: else if ( !p2 )
107: *rp = p1;
108: else if ( !qpcheck((Obj)p1) || !qpcheck((Obj)p2) )
109: error("gcd : invalid argument");
110: else if ( argc(arg) == 2 )
111: ezgcdp(CO,p1,p2,rp);
112: else {
113: m = (Num)ARG2(arg);
114: asir_assert(m,O_P,"gcd");
115: mod = QTOS((Q)m);
116: ptomp(mod,p1,&g1); ptomp(mod,p2,&g2);
117: gcdprsmp(CO,mod,g1,g2,&g);
118: mptop(g,rp);
119: }
120: }
121:
122: void Pgcdz(arg,rp)
123: NODE arg;
124: P *rp;
125: {
126: P p1,p2,t;
127: Q c1,c2;
128: N n;
129:
130: p1 = (P)ARG0(arg); p2 = (P)ARG1(arg);
131: asir_assert(p1,O_P,"gcdz");
132: asir_assert(p2,O_P,"gcdz");
133: if ( !p1 )
134: *rp = p2;
135: else if ( !p2 )
136: *rp = p1;
137: else if ( !qpcheck((Obj)p1) || !qpcheck((Obj)p2) )
138: error("gcdz : invalid argument");
139: else if ( NUM(p1) || NUM(p2) ) {
140: if ( NUM(p1) )
141: c1 = (Q)p1;
142: else
143: ptozp(p1,1,&c1,&t);
144: if ( NUM(p2) )
145: c2 = (Q)p2;
146: else
147: ptozp(p2,1,&c2,&t);
148: gcdn(NM(c1),NM(c2),&n); NTOQ(n,1,c1); *rp = (P)c1;
149: } else {
150: #if 0
151: w[0] = p1; w[1] = p2; nezgcdnpz(CO,w,2,rp);
152: #endif
153: ezgcdpz(CO,p1,p2,rp);
154: }
155: }
156:
157: void Plcm(arg,rp)
158: NODE arg;
159: P *rp;
160: {
161: P t1,t2,p1,p2,g,q;
162: Q c;
163:
164: p1 = (P)ARG0(arg); p2 = (P)ARG1(arg);
165: asir_assert(p1,O_P,"lcm");
166: asir_assert(p2,O_P,"lcm");
167: if ( !p1 || !p2 )
168: *rp = 0;
169: else if ( !qpcheck((Obj)p1) || !qpcheck((Obj)p2) )
170: error("lcm : invalid argument");
171: else {
172: ptozp(p1,1,&c,&t1); ptozp(p2,1,&c,&t2);
173: ezgcdp(CO,t1,t2,&g); divsp(CO,t1,g,&q); mulp(CO,q,t2,rp);
174: }
175: }
176:
177: void Psqfr(arg,rp)
178: NODE arg;
179: LIST *rp;
180: {
181: DCP dc;
182:
183: asir_assert(ARG0(arg),O_P,"sqfr");
184: sqfrp(CO,(P)ARG0(arg),&dc);
185: dcptolist(dc,rp);
186: }
187:
188: void Pufctrhint(arg,rp)
189: NODE arg;
190: LIST *rp;
191: {
192: DCP dc;
193:
194: asir_assert(ARG0(arg),O_P,"ufctrhint");
195: asir_assert(ARG1(arg),O_N,"ufctrhint");
196: ufctr((P)ARG0(arg),QTOS((Q)ARG1(arg)),&dc);
197: dcptolist(dc,rp);
198: }
199:
200: #if 0
201: Pmgcd(arg,rp)
202: NODE arg;
203: Obj *rp;
204: {
205: NODE node,tn;
206: int i,m;
207: P *l;
208:
209: node = BDY((LIST)ARG0(arg));
210: for ( i = 0, tn = node; tn; tn = NEXT(tn), i++ );
211: m = i; l = (P *)ALLOCA(m*sizeof(P));
212: for ( i = 0, tn = node; i < m; tn = NEXT(tn), i++ )
213: l[i] = (P)BDY(tn);
214: nezgcdnpz(CO,l,m,rp);
215: }
216: #endif
217:
218: void Pcont(arg,rp)
219: NODE arg;
220: P *rp;
221: {
222: DCP dc;
223: int m;
224: P p,p1;
225: P *l;
226: V v;
227:
228: asir_assert(ARG0(arg),O_P,"cont");
229: p = (P)ARG0(arg);
230: if ( NUM(p) )
231: *rp = p;
232: else {
233: if ( argc(arg) == 2 ) {
234: v = VR((P)ARG1(arg));
235: change_mvar(CO,p,v,&p1);
236: if ( VR(p1) != v ) {
237: *rp = p1; return;
238: } else
239: p = p1;
240: }
241: for ( m = 0, dc = DC(p); dc; dc = NEXT(dc), m++ );
242: l = (P *)ALLOCA(m*sizeof(P));
243: for ( m = 0, dc = DC(p); dc; dc = NEXT(dc), m++ )
244: l[m] = COEF(dc);
245: nezgcdnpz(CO,l,m,rp);
246: }
247: }
248:
249: void Pptozp(arg,rp)
250: NODE arg;
251: P *rp;
252: {
253: Q t;
254:
255: asir_assert(ARG0(arg),O_P,"ptozp");
256: ptozp((P)ARG0(arg),1,&t,rp);
257: }
258:
259: void Pafctr(arg,rp)
260: NODE arg;
261: LIST *rp;
262: {
263: DCP dc;
264:
265: asir_assert(ARG0(arg),O_P,"afctr");
266: asir_assert(ARG1(arg),O_P,"afctr");
267: afctr(CO,(P)ARG0(arg),(P)ARG1(arg),&dc);
268: dcptolist(dc,rp);
269: }
270:
271: void Pagcd(arg,rp)
272: NODE arg;
273: P *rp;
274: {
275: asir_assert(ARG0(arg),O_P,"agcd");
276: asir_assert(ARG1(arg),O_P,"agcd");
277: asir_assert(ARG2(arg),O_P,"agcd");
278: gcda(CO,(P)ARG0(arg),(P)ARG1(arg),(P)ARG2(arg),rp);
279: }
280:
281: #if 1
282: #define Mulum mulum
283: #define Divum divum
284: #define Mulsum mulsum
285: #define Gcdum gcdum
286: #endif
287:
288: void Mulum(), Mulsum(), Gcdum();
289: int Divum();
290:
291: #define FCTR 0 /* berlekamp */
292: #define SQFR 1
293: #define DDD 2 /* Cantor-Zassenhauss */
294: #define NEWDDD 3 /* berlekamp + root-finding by Cantor-Zassenhauss */
295:
296: UM *resberle();
297:
298: void Pmodfctr(arg,rp)
299: NODE arg;
300: LIST *rp;
301: {
302: DCP dc;
303: int mod;
304:
305: mod = QTOS((Q)ARG1(arg));
306: if ( mod < 0 )
307: error("modfctr : invalid modulus");
308: modfctrp(ARG0(arg),mod,NEWDDD,&dc);
309: if ( !dc ) {
310: NEWDC(dc); COEF(dc) = 0; DEG(dc) = ONE; NEXT(dc) = 0;
311: }
312: dcptolist(dc,rp);
313: }
314:
315: void Pmodsqfr(arg,rp)
316: NODE arg;
317: LIST *rp;
318: {
319: DCP dc;
320:
321: if ( !dc ) {
322: NEWDC(dc); COEF(dc) = 0; DEG(dc) = ONE; NEXT(dc) = 0;
323: }
324: modfctrp(ARG0(arg),QTOS((Q)ARG1(arg)),SQFR,&dc);
325: dcptolist(dc,rp);
326: }
327:
328: void Pddd(arg,rp)
329: NODE arg;
330: LIST *rp;
331: {
332: DCP dc;
333:
334: if ( !dc ) {
335: NEWDC(dc); COEF(dc) = 0; DEG(dc) = ONE; NEXT(dc) = 0;
336: }
337: modfctrp(ARG0(arg),QTOS((Q)ARG1(arg)),DDD,&dc);
338: dcptolist(dc,rp);
339: }
340:
341: void Pnewddd(arg,rp)
342: NODE arg;
343: LIST *rp;
344: {
345: DCP dc;
346:
347: if ( !dc ) {
348: NEWDC(dc); COEF(dc) = 0; DEG(dc) = ONE; NEXT(dc) = 0;
349: }
350: modfctrp(ARG0(arg),QTOS((Q)ARG1(arg)),NEWDDD,&dc);
351: dcptolist(dc,rp);
352: }
353:
354: void Pirred_check(arg,rp)
355: NODE arg;
356: Q *rp;
357: {
358: P p;
359: UM mp;
360: int r,mod;
361:
362: p = (P)ARG0(arg);
363: if ( !p ) {
364: *rp = 0; return;
365: }
366: mp = W_UMALLOC(UDEG(p));
367: mod = QTOS((Q)ARG1(arg));
368: ptoum(mod,p,mp);
369: r = irred_check(mp,mod);
370: if ( r )
371: *rp = ONE;
372: else
373: *rp = 0;
374: }
375:
376: void Pnfctr_mod(arg,rp)
377: NODE arg;
378: Q *rp;
379: {
380: P p;
381: UM mp;
382: int r,mod;
383:
384: p = (P)ARG0(arg);
385: if ( !p ) {
386: *rp = 0; return;
387: }
388: mp = W_UMALLOC(UDEG(p));
389: mod = QTOS((Q)ARG1(arg));
390: ptoum(mod,p,mp);
391: r = nfctr_mod(mp,mod);
392: STOQ(r,*rp);
393: }
394:
395: void Pddd_tab(arg,rp)
396: NODE arg;
397: VECT *rp;
398: {
399: P p;
400: UM mp,t,q,r1,w,w1;
401: UM *r,*s;
402: int dr,mod,n,i;
403: VECT result;
404: V v;
405:
406: p = (P)ARG0(arg); mod = QTOS((Q)ARG1(arg));
407: v = VR(p);
408: n = UDEG(p); mp = W_UMALLOC(n);
409: ptoum(mod,p,mp);
410: r = (UM *)W_ALLOC(n); s = (UM *)W_ALLOC(n);
411: r[0] = UMALLOC(0); DEG(r[0]) = 0; COEF(r[0])[0] = 1;
412: t = W_UMALLOC(mod); bzero(COEF(t),sizeof(int)*(mod+1));
413: DEG(t) = mod; COEF(t)[mod] = 1;
414: q = W_UMALLOC(mod);
415: dr = divum(mod,t,mp,q);
416: DEG(t) = dr; r[1] = r1 = UMALLOC(dr); cpyum(t,r1);
417: s[0] = W_UMALLOC(dr); cpyum(t,s[0]);
418: w = W_UMALLOC(n); bzero(COEF(w),sizeof(int)*(n+1));
419: w1 = W_UMALLOC(2*n); bzero(COEF(w1),sizeof(int)*(2*n+1));
420: for ( i = 1; i < n; i++ ) {
421: DEG(w) = i; COEF(w)[i-1] = 0; COEF(w)[i] = 1;
422: mulum(mod,r1,w,w1);
423: dr = divum(mod,w1,mp,q); DEG(w1) = dr;
424: s[i] = W_UMALLOC(dr); cpyum(w1,s[i]);
425: }
426: for ( i = 2; i < n; i++ ) {
427: mult_mod_tab(r[i-1],mod,s,w,n);
428: r[i] = UMALLOC(DEG(w)); cpyum(w,r[i]);
429: }
430: MKVECT(result,n);
431: for ( i = 0; i < n; i++ )
432: umtop(v,r[i],(P *)&BDY(result)[i]);
433: *rp = result;
434: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to fctr.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin