Annotation of OpenXM_contrib2/asir2000/builtin/pf.c, Revision 1.8
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.8 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.7 2004/06/22 09:17:21 noro Exp $
1.2 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "math.h"
52: #include "parse.h"
53: #if 0
54: #include <alloca.h>
55: #endif
56:
57: double const_pi(),const_e();
58:
59: void make_ihyp(void);
60: void make_hyp(void);
61: void make_itri(void);
62: void make_tri(void);
63: void make_exp(void);
64: void simplify_pow(PFINS,Obj *);
65:
66: void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval();
67: void Pregister_handler();
1.4 noro 68: void Peval_quote();
1.7 noro 69: void Pmapat();
1.1 noro 70:
71: struct ftab puref_tab[] = {
1.7 noro 72: {"mapat",Pmapat,-99999999},
1.1 noro 73: {"functor",Pfunctor,1},
74: {"args",Pargs,1},
75: {"funargs",Pfunargs,1},
76: {"register_handler",Pregister_handler,1},
77: {"call",Pcall,2},
78: {"vtype",Pvtype,1},
79: {"deval",Pdeval,1},
1.4 noro 80: {"eval_quote",Peval_quote,1},
1.1 noro 81: {0,0,0},
82: };
83:
1.6 ohara 84: #if defined(PARI)
1.1 noro 85: int p_pi(),p_e();
86: int p_log(),p_exp(),p_pow();
87: int p_sin(),p_cos(),p_tan(),p_asin(),p_acos(),p_atan();
88: int p_sinh(),p_cosh(),p_tanh(),p_asinh(),p_acosh(),p_atanh();
89: #else
90: int p_pi,p_e;
91: int p_log,p_exp,p_pow;
92: int p_sin,p_cos,p_tan,p_asin,p_acos,p_atan;
93: int p_sinh,p_cosh,p_tanh,p_asinh,p_acosh,p_atanh;
94: #endif
95:
96: static V *uarg,*darg;
97: static P x,y;
98: static PF pidef,edef;
99: static PF logdef,expdef,powdef;
100: static PF sindef,cosdef,tandef;
101: static PF asindef,acosdef,atandef;
102: static PF sinhdef,coshdef,tanhdef;
103: static PF asinhdef,acoshdef,atanhdef;
104:
105: #define OALLOC(p,n) ((p)=(Obj *)CALLOC((n),sizeof(Obj)))
106:
107: double const_pi() { return 3.14159265358979323846264338327950288; }
108: double const_e() { return 2.718281828459045235360287471352662497; }
109:
110: void pf_init() {
111: uarg = (V *)CALLOC(1,sizeof(V));
112: uarg[0] = &oVAR[26]; MKV(uarg[0],x);
113:
114: darg = (V *)CALLOC(2,sizeof(V));
115: darg[0] = &oVAR[26];
116: darg[1] = &oVAR[27]; MKV(darg[1],y);
117:
118: mkpf("@pi",0,0,0,(int (*)())p_pi,const_pi,0,&pidef);
119: mkpf("@e",0,0,0,(int (*)())p_e,const_e,0,&edef);
120:
121: mkpf("log",0,1,uarg,(int (*)())p_log,log,0,&logdef);
122: mkpf("exp",0,1,uarg,(int (*)())p_exp,exp,0,&expdef);
123: mkpf("pow",0,2,darg,(int (*)())p_pow,pow,(int (*)())simplify_pow,&powdef);
124:
125: mkpf("sin",0,1,uarg,(int (*)())p_sin,sin,0,&sindef);
126: mkpf("cos",0,1,uarg,(int (*)())p_cos,cos,0,&cosdef);
127: mkpf("tan",0,1,uarg,(int (*)())p_tan,tan,0,&tandef);
128: mkpf("asin",0,1,uarg,(int (*)())p_asin,asin,0,&asindef);
129: mkpf("acos",0,1,uarg,(int (*)())p_acos,acos,0,&acosdef);
130: mkpf("atan",0,1,uarg,(int (*)())p_atan,atan,0,&atandef);
131:
132: mkpf("sinh",0,1,uarg,(int (*)())p_sinh,sinh,0,&sinhdef);
133: mkpf("cosh",0,1,uarg,(int (*)())p_cosh,cosh,0,&coshdef);
134: mkpf("tanh",0,1,uarg,(int (*)())p_tanh,tanh,0,&tanhdef);
135: #if !defined(VISUAL)
136: mkpf("asinh",0,1,uarg,(int (*)())p_asinh,asinh,0,&asinhdef);
137: mkpf("acosh",0,1,uarg,(int (*)())p_acosh,acosh,0,&acoshdef);
138: mkpf("atanh",0,1,uarg,(int (*)())p_atanh,atanh,0,&atanhdef);
139: #endif
140: make_exp();
141: make_tri();
142: make_itri();
143: make_hyp();
144: #if !defined(VISUAL)
145: make_ihyp();
146: #endif
147: }
148:
149: void make_exp() {
150: V v;
151: P u,vexp,vlog,vpow;
152: Obj *args;
153:
154: mkpfins(expdef,uarg,&v); MKV(v,vexp);
155: mkpfins(powdef,darg,&v); MKV(v,vpow);
156: mkpfins(logdef,uarg,&v); MKV(v,vlog);
157:
158: /* d/dx(log(x)) = 1/x */
159: OALLOC(logdef->deriv,1); divr(CO,(Obj)ONE,(Obj)x,&logdef->deriv[0]);
160:
161: /* d/dx(exp(x)) = exp(x) */
162: OALLOC(expdef->deriv,1); expdef->deriv[0] = (Obj)vexp;
163:
164: /* d/dy(x^y) = log(x)*x^y */
165: OALLOC(powdef->deriv,2); mulp(CO,vpow,vlog,(P *)&powdef->deriv[1]);
166:
167: /* d/dx(x^y) = y*x^(y-1) */
168: args = (Obj *)ALLOCA(2*sizeof(Obj));
169: args[0] = (Obj)x; subp(CO,y,(P)ONE,(P *)&args[1]);
170: _mkpfins(powdef,args,&v); MKV(v,u);
171: mulr(CO,(Obj)u,(Obj)y,&powdef->deriv[0]);
172: }
173:
174: void make_tri() {
175: V v;
176: P vcos,vsin,vtan,t;
177:
178: mkpfins(cosdef,uarg,&v); MKV(v,vcos);
179: mkpfins(sindef,uarg,&v); MKV(v,vsin);
180: mkpfins(tandef,uarg,&v); MKV(v,vtan);
181:
182: /* d/dx(sin(x)) = cos(x) */
183: OALLOC(sindef->deriv,1); sindef->deriv[0] = (Obj)vcos;
184:
185: /* d/dx(cos(x)) = -sin(x) */
186: OALLOC(cosdef->deriv,1); chsgnp(vsin,(P *)&cosdef->deriv[0]);
187:
188: /* d/dx(tan(x)) = 1+tan(x)^2 */
189: OALLOC(tandef->deriv,1);
190: mulr(CO,(Obj)vtan,(Obj)vtan,(Obj *)&t); addp(CO,(P)ONE,t,(P *)&tandef->deriv[0]);
191: }
192:
193: void make_itri() {
194: P t,xx;
195: Q mtwo;
196: V v;
197: Obj *args;
198:
199: /* d/dx(asin(x)) = (1-x^2)^(-1/2) */
200: OALLOC(asindef->deriv,1);
201: args = (Obj *)ALLOCA(2*sizeof(Obj));
202: mulp(CO,x,x,&xx); subp(CO,(P)ONE,xx,(P *)&args[0]);
203: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
204: _mkpfins(powdef,args,&v); MKV(v,t);
205: asindef->deriv[0] = (Obj)t;
206:
207: /* d/dx(acos(x)) = -(1-x^2)^(-1/2) */
208: OALLOC(acosdef->deriv,1); chsgnp((P)asindef->deriv[0],(P *)&acosdef->deriv[0]);
209:
210: /* d/dx(atan(x)) = 1/(x^2+1) */
211: OALLOC(atandef->deriv,1);
212: addp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atandef->deriv[0]);
213: }
214:
215: void make_hyp() {
216: V v;
217: P vcosh,vsinh,vtanh,t;
218:
219: mkpfins(coshdef,uarg,&v); MKV(v,vcosh);
220: mkpfins(sinhdef,uarg,&v); MKV(v,vsinh);
221: mkpfins(tanhdef,uarg,&v); MKV(v,vtanh);
222:
223: /* d/dx(sinh(x)) = cosh(x) */
224: OALLOC(sinhdef->deriv,1); sinhdef->deriv[0] = (Obj)vcosh;
225:
226: /* d/dx(cosh(x)) = sinh(x) */
227: OALLOC(coshdef->deriv,1); coshdef->deriv[0] = (Obj)vsinh;
228:
229: /* d/dx(tanh(x)) = 1-tanh(x)^2 */
230: OALLOC(tanhdef->deriv,1);
231: mulr(CO,(Obj)vtanh,(Obj)vtanh,(Obj *)&t); subp(CO,(P)ONE,t,(P *)&tanhdef->deriv[0]);
232: }
233:
234: void make_ihyp() {
235: P t,xx;
236: Q mtwo;
237: V v;
238: Obj *args;
239:
240: /* d/dx(asinh(x)) = (1+x^2)^(-1/2) */
241: OALLOC(asinhdef->deriv,1);
242: args = (Obj *)ALLOCA(2*sizeof(Obj));
243: mulp(CO,x,x,&xx); addp(CO,(P)ONE,xx,(P *)&args[0]);
244: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
245: _mkpfins(powdef,args,&v); MKV(v,t);
246: asinhdef->deriv[0] = (Obj)t;
247:
248: /* d/dx(acosh(x)) = (x^2-1)^(-1/2) */
249: OALLOC(acoshdef->deriv,1);
250: subp(CO,xx,(P)ONE,(P *)&args[0]);
251: _mkpfins(powdef,args,&v); MKV(v,t);
252: acoshdef->deriv[0] = (Obj)t;
253:
254: /* d/dx(atanh(x)) = 1/(1-x^2) */
255: OALLOC(atanhdef->deriv,1);
256: subp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atanhdef->deriv[0]);
257: }
258:
259: void mkpow(vl,a,e,r)
260: VL vl;
261: Obj a;
262: Obj e;
263: Obj *r;
264: {
265: PFINS ins;
266: PFAD ad;
267:
268: ins = (PFINS)CALLOC(1,sizeof(PF)+2*sizeof(struct oPFAD));
269: ins->pf = powdef; ad = ins->ad;
270: ad[0].d = 0; ad[0].arg = a; ad[1].d = 0; ad[1].arg = e;
271: simplify_ins(ins,r);
272: }
273:
274: void simplify_pow(ins,rp)
275: PFINS ins;
276: Obj *rp;
277: {
278: PF pf;
279: PFAD ad;
280: Obj a0,a1;
281: V v;
282: P t;
283:
284: pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg;
285: if ( !a1 )
286: *rp = (Obj)ONE;
1.8 ! noro 287: else if ( !a0 ) {
! 288: if ( RATN(a1) && SGN((Q)a1)>0 )
! 289: *rp = 0;
! 290: else if ( RATN(a1) && SGN((Q)a1) < 0 )
! 291: error("simplify_pow : division by 0");
! 292: else {
! 293: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
! 294: }
! 295: } else if ( NUM(a1) && INT(a1) )
1.1 noro 296: arf_pwr(CO,a0,a1,rp);
297: else {
298: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
299: }
300: }
301:
302: #define ISPFINS(p)\
303: (p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr!=V_PF)&&\
304: UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p)))
305:
306: void Pfunctor(arg,rp)
307: NODE arg;
308: P *rp;
309: {
310: P p;
311: FUNC t;
312: PF pf;
313: PFINS ins;
314:
315: p = (P)ARG0(arg);
316: if ( !ISPFINS(p) )
317: *rp = 0;
318: else {
319: ins = (PFINS)VR(p)->priv; pf = ins->pf;
320: t = (FUNC)MALLOC(sizeof(struct oFUNC));
1.7 noro 321: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
1.1 noro 322: t->f.puref = pf;
323: makesrvar(t,rp);
324: }
325: }
326:
327: void Pargs(arg,rp)
328: NODE arg;
329: LIST *rp;
330: {
331: P p;
332: PF pf;
333: PFAD ad;
334: PFINS ins;
335: NODE n,n0;
336: int i;
337:
338: p = (P)ARG0(arg);
339: if ( !ISPFINS(p) )
340: *rp = 0;
341: else {
342: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
343: for ( i = 0, n0 = 0; i < pf->argc; i++ ) {
344: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
345: }
346: if ( n0 )
347: NEXT(n) = 0;
348: MKLIST(*rp,n0);
349: }
350: }
351:
352: void Pfunargs(arg,rp)
353: NODE arg;
354: LIST *rp;
355: {
356: P p;
357: P f;
358: FUNC t;
359: PF pf;
360: PFINS ins;
361: PFAD ad;
362: NODE n,n0;
363: int i;
364:
365: p = (P)ARG0(arg);
366: if ( !ISPFINS(p) )
367: *rp = 0;
368: else {
369: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
370: t = (FUNC)MALLOC(sizeof(struct oFUNC));
1.7 noro 371: t->name = t->fullname = pf->name; t->id = A_PURE; t->argc = pf->argc;
1.1 noro 372: t->f.puref = pf;
373: makesrvar(t,&f);
1.5 noro 374: n = n0 = 0; NEXTNODE(n0,n); BDY(n) = (pointer)f;
1.1 noro 375: for ( i = 0; i < pf->argc; i++ ) {
376: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
377: }
378: NEXT(n) = 0;
379: MKLIST(*rp,n0);
380: }
381: }
382:
383: void Pvtype(arg,rp)
384: NODE arg;
385: Q *rp;
386: {
387: P p;
388:
389: p = (P)ARG0(arg);
390: if ( !p || ID(p) != O_P )
391: *rp = 0;
392: else
393: STOQ((int)VR(p)->attr,*rp);
394: }
395:
396: extern FUNC registered_handler;
397:
398: void Pregister_handler(arg,rp)
399: NODE arg;
400: Q *rp;
401: {
402: P p;
403: V v;
404: FUNC func;
405:
406: p = (P)ARG0(arg);
407: if ( !p )
408: registered_handler = 0;
409: else if ( OID(p) != 2 )
410: error("register_hanlder : invalid argument");
411: v = VR(p);
412: if ( (int)v->attr != V_SR )
413: error("register_hanlder : no such function");
414: else {
415: func = (FUNC)v->priv;
416: if ( func->argc )
417: error("register_hanlder : the function must be with no argument");
418: else {
419: registered_handler = func;
420: *rp = ONE;
421: }
422: }
423: }
424:
1.7 noro 425: void Pcall(NODE arg,Obj *rp)
1.1 noro 426: {
427: P p;
428: V v;
429:
430: p = (P)ARG0(arg);
431: if ( !p || OID(p) != 2 )
432: error("call : invalid argument");
433: v = VR(p);
434: if ( (int)v->attr != V_SR )
435: error("call : no such function");
436:
437: else
438: *rp = (Obj)bevalf((FUNC)v->priv,BDY((LIST)ARG1(arg)));
1.7 noro 439: }
440:
441: /* at=position of arg to be used for iteration */
442:
443: void Pmapat(NODE arg,Obj *rp)
444: {
445: LIST args;
446: NODE node,rest,t0,t,n,r,r0;
447: P fpoly;
448: V fvar;
449: FUNC f;
450: VECT v,rv;
451: MAT m,rm;
452: LIST rl;
453: int len,row,col,i,j,pos;
454: Obj iter;
455: pointer val;
456:
457: if ( argc(arg) < 3 )
458: error("mapat : too few arguments");
459:
460: fpoly = (P)ARG0(arg);
461: if ( !fpoly || OID(fpoly) != O_P )
462: error("mapat : invalid function specification");
463: fvar = VR(fpoly);
464: if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )
465: error("mapat : invalid function specification");
466: if ( !INT(ARG1(arg)) )
467: error("mapat : invalid position");
468: pos = QTOS((Q)ARG1(arg));
469: node = NEXT(NEXT(arg));
470: len = length(node);
471: if ( pos >= len )
472: error("evalmapatf : invalid position");
473: r0 = 0;
474: for ( i = 0, t = node; i < pos; i++, t = NEXT(t) ) {
475: NEXTNODE(r0,r);
476: BDY(r) = BDY(t);
477: }
478: NEXTNODE(r0,r);
479: iter = BDY(t); rest = NEXT(t);
480: if ( !iter ) {
481: *rp = bevalf(f,node);
482: return;
483: }
484: switch ( OID(iter) ) {
485: case O_VECT:
486: v = (VECT)iter; len = v->len; MKVECT(rv,len);
487: for ( i = 0; i < len; i++ ) {
488: BDY(r) = BDY(v)[i]; NEXT(r) = rest;
489: BDY(rv)[i] = bevalf(f,r0);
490: }
491: *rp = (Obj)rv;
492: break;
493: case O_MAT:
494: m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);
495: for ( i = 0; i < row; i++ )
496: for ( j = 0; j < col; j++ ) {
497: BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;
498: BDY(rm)[i][j] = bevalf(f,r0);
499: }
500: *rp = (Obj)rm;
501: break;
502: case O_LIST:
503: n = BDY((LIST)iter);
504: for ( t0 = t = 0; n; n = NEXT(n) ) {
505: BDY(r) = BDY(n); NEXT(r) = rest;
506: NEXTNODE(t0,t); BDY(t) = bevalf(f,r0);
507: }
508: if ( t0 )
509: NEXT(t) = 0;
510: MKLIST(rl,t0);
511: *rp = (Obj)rl;
512: break;
513: default:
514: *rp = bevalf(f,node);
515: break;
516: }
1.1 noro 517: }
518:
519: void Pdeval(arg,rp)
520: NODE arg;
521: Obj *rp;
522: {
523: asir_assert(ARG0(arg),O_R,"deval");
524: devalr(CO,(Obj)ARG0(arg),rp);
525: }
526:
1.4 noro 527: void Peval_quote(arg,rp)
528: NODE arg;
529: Obj *rp;
530: {
531: asir_assert(ARG0(arg),O_QUOTE,"eval_quote");
532: *rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));
533: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to pf.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin