Annotation of OpenXM_contrib2/asir2000/builtin/pf.c, Revision 1.1.1.1
1.1 noro 1: /* $OpenXM: OpenXM/src/asir99/builtin/pf.c,v 1.1.1.1 1999/11/10 08:12:26 noro Exp $ */
2: #include "ca.h"
3: #include "math.h"
4: #include "parse.h"
5: #if 0
6: #include <alloca.h>
7: #endif
8:
9: double const_pi(),const_e();
10:
11: void make_ihyp(void);
12: void make_hyp(void);
13: void make_itri(void);
14: void make_tri(void);
15: void make_exp(void);
16: void simplify_pow(PFINS,Obj *);
17:
18: void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval();
19: void Pregister_handler();
20:
21: struct ftab puref_tab[] = {
22: {"functor",Pfunctor,1},
23: {"args",Pargs,1},
24: {"funargs",Pfunargs,1},
25: {"register_handler",Pregister_handler,1},
26: {"call",Pcall,2},
27: {"vtype",Pvtype,1},
28: {"deval",Pdeval,1},
29: {0,0,0},
30: };
31:
32: #if PARI
33: int p_pi(),p_e();
34: int p_log(),p_exp(),p_pow();
35: int p_sin(),p_cos(),p_tan(),p_asin(),p_acos(),p_atan();
36: int p_sinh(),p_cosh(),p_tanh(),p_asinh(),p_acosh(),p_atanh();
37: #else
38: int p_pi,p_e;
39: int p_log,p_exp,p_pow;
40: int p_sin,p_cos,p_tan,p_asin,p_acos,p_atan;
41: int p_sinh,p_cosh,p_tanh,p_asinh,p_acosh,p_atanh;
42: #endif
43:
44: static V *uarg,*darg;
45: static P x,y;
46: static PF pidef,edef;
47: static PF logdef,expdef,powdef;
48: static PF sindef,cosdef,tandef;
49: static PF asindef,acosdef,atandef;
50: static PF sinhdef,coshdef,tanhdef;
51: static PF asinhdef,acoshdef,atanhdef;
52:
53: #define OALLOC(p,n) ((p)=(Obj *)CALLOC((n),sizeof(Obj)))
54:
55: double const_pi() { return 3.14159265358979323846264338327950288; }
56: double const_e() { return 2.718281828459045235360287471352662497; }
57:
58: void pf_init() {
59: uarg = (V *)CALLOC(1,sizeof(V));
60: uarg[0] = &oVAR[26]; MKV(uarg[0],x);
61:
62: darg = (V *)CALLOC(2,sizeof(V));
63: darg[0] = &oVAR[26];
64: darg[1] = &oVAR[27]; MKV(darg[1],y);
65:
66: mkpf("@pi",0,0,0,(int (*)())p_pi,const_pi,0,&pidef);
67: mkpf("@e",0,0,0,(int (*)())p_e,const_e,0,&edef);
68:
69: mkpf("log",0,1,uarg,(int (*)())p_log,log,0,&logdef);
70: mkpf("exp",0,1,uarg,(int (*)())p_exp,exp,0,&expdef);
71: mkpf("pow",0,2,darg,(int (*)())p_pow,pow,(int (*)())simplify_pow,&powdef);
72:
73: mkpf("sin",0,1,uarg,(int (*)())p_sin,sin,0,&sindef);
74: mkpf("cos",0,1,uarg,(int (*)())p_cos,cos,0,&cosdef);
75: mkpf("tan",0,1,uarg,(int (*)())p_tan,tan,0,&tandef);
76: mkpf("asin",0,1,uarg,(int (*)())p_asin,asin,0,&asindef);
77: mkpf("acos",0,1,uarg,(int (*)())p_acos,acos,0,&acosdef);
78: mkpf("atan",0,1,uarg,(int (*)())p_atan,atan,0,&atandef);
79:
80: mkpf("sinh",0,1,uarg,(int (*)())p_sinh,sinh,0,&sinhdef);
81: mkpf("cosh",0,1,uarg,(int (*)())p_cosh,cosh,0,&coshdef);
82: mkpf("tanh",0,1,uarg,(int (*)())p_tanh,tanh,0,&tanhdef);
83: #if !defined(VISUAL)
84: mkpf("asinh",0,1,uarg,(int (*)())p_asinh,asinh,0,&asinhdef);
85: mkpf("acosh",0,1,uarg,(int (*)())p_acosh,acosh,0,&acoshdef);
86: mkpf("atanh",0,1,uarg,(int (*)())p_atanh,atanh,0,&atanhdef);
87: #endif
88: make_exp();
89: make_tri();
90: make_itri();
91: make_hyp();
92: #if !defined(VISUAL)
93: make_ihyp();
94: #endif
95: }
96:
97: void make_exp() {
98: V v;
99: P u,vexp,vlog,vpow;
100: Obj *args;
101:
102: mkpfins(expdef,uarg,&v); MKV(v,vexp);
103: mkpfins(powdef,darg,&v); MKV(v,vpow);
104: mkpfins(logdef,uarg,&v); MKV(v,vlog);
105:
106: /* d/dx(log(x)) = 1/x */
107: OALLOC(logdef->deriv,1); divr(CO,(Obj)ONE,(Obj)x,&logdef->deriv[0]);
108:
109: /* d/dx(exp(x)) = exp(x) */
110: OALLOC(expdef->deriv,1); expdef->deriv[0] = (Obj)vexp;
111:
112: /* d/dy(x^y) = log(x)*x^y */
113: OALLOC(powdef->deriv,2); mulp(CO,vpow,vlog,(P *)&powdef->deriv[1]);
114:
115: /* d/dx(x^y) = y*x^(y-1) */
116: args = (Obj *)ALLOCA(2*sizeof(Obj));
117: args[0] = (Obj)x; subp(CO,y,(P)ONE,(P *)&args[1]);
118: _mkpfins(powdef,args,&v); MKV(v,u);
119: mulr(CO,(Obj)u,(Obj)y,&powdef->deriv[0]);
120: }
121:
122: void make_tri() {
123: V v;
124: P vcos,vsin,vtan,t;
125:
126: mkpfins(cosdef,uarg,&v); MKV(v,vcos);
127: mkpfins(sindef,uarg,&v); MKV(v,vsin);
128: mkpfins(tandef,uarg,&v); MKV(v,vtan);
129:
130: /* d/dx(sin(x)) = cos(x) */
131: OALLOC(sindef->deriv,1); sindef->deriv[0] = (Obj)vcos;
132:
133: /* d/dx(cos(x)) = -sin(x) */
134: OALLOC(cosdef->deriv,1); chsgnp(vsin,(P *)&cosdef->deriv[0]);
135:
136: /* d/dx(tan(x)) = 1+tan(x)^2 */
137: OALLOC(tandef->deriv,1);
138: mulr(CO,(Obj)vtan,(Obj)vtan,(Obj *)&t); addp(CO,(P)ONE,t,(P *)&tandef->deriv[0]);
139: }
140:
141: void make_itri() {
142: P t,xx;
143: Q mtwo;
144: V v;
145: Obj *args;
146:
147: /* d/dx(asin(x)) = (1-x^2)^(-1/2) */
148: OALLOC(asindef->deriv,1);
149: args = (Obj *)ALLOCA(2*sizeof(Obj));
150: mulp(CO,x,x,&xx); subp(CO,(P)ONE,xx,(P *)&args[0]);
151: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
152: _mkpfins(powdef,args,&v); MKV(v,t);
153: asindef->deriv[0] = (Obj)t;
154:
155: /* d/dx(acos(x)) = -(1-x^2)^(-1/2) */
156: OALLOC(acosdef->deriv,1); chsgnp((P)asindef->deriv[0],(P *)&acosdef->deriv[0]);
157:
158: /* d/dx(atan(x)) = 1/(x^2+1) */
159: OALLOC(atandef->deriv,1);
160: addp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atandef->deriv[0]);
161: }
162:
163: void make_hyp() {
164: V v;
165: P vcosh,vsinh,vtanh,t;
166:
167: mkpfins(coshdef,uarg,&v); MKV(v,vcosh);
168: mkpfins(sinhdef,uarg,&v); MKV(v,vsinh);
169: mkpfins(tanhdef,uarg,&v); MKV(v,vtanh);
170:
171: /* d/dx(sinh(x)) = cosh(x) */
172: OALLOC(sinhdef->deriv,1); sinhdef->deriv[0] = (Obj)vcosh;
173:
174: /* d/dx(cosh(x)) = sinh(x) */
175: OALLOC(coshdef->deriv,1); coshdef->deriv[0] = (Obj)vsinh;
176:
177: /* d/dx(tanh(x)) = 1-tanh(x)^2 */
178: OALLOC(tanhdef->deriv,1);
179: mulr(CO,(Obj)vtanh,(Obj)vtanh,(Obj *)&t); subp(CO,(P)ONE,t,(P *)&tanhdef->deriv[0]);
180: }
181:
182: void make_ihyp() {
183: P t,xx;
184: Q mtwo;
185: V v;
186: Obj *args;
187:
188: /* d/dx(asinh(x)) = (1+x^2)^(-1/2) */
189: OALLOC(asinhdef->deriv,1);
190: args = (Obj *)ALLOCA(2*sizeof(Obj));
191: mulp(CO,x,x,&xx); addp(CO,(P)ONE,xx,(P *)&args[0]);
192: STOQ(-2,mtwo); divq(ONE,mtwo,(Q *)&args[1]);
193: _mkpfins(powdef,args,&v); MKV(v,t);
194: asinhdef->deriv[0] = (Obj)t;
195:
196: /* d/dx(acosh(x)) = (x^2-1)^(-1/2) */
197: OALLOC(acoshdef->deriv,1);
198: subp(CO,xx,(P)ONE,(P *)&args[0]);
199: _mkpfins(powdef,args,&v); MKV(v,t);
200: acoshdef->deriv[0] = (Obj)t;
201:
202: /* d/dx(atanh(x)) = 1/(1-x^2) */
203: OALLOC(atanhdef->deriv,1);
204: subp(CO,(P)ONE,xx,&t); divr(CO,(Obj)ONE,(Obj)t,&atanhdef->deriv[0]);
205: }
206:
207: void mkpow(vl,a,e,r)
208: VL vl;
209: Obj a;
210: Obj e;
211: Obj *r;
212: {
213: PFINS ins;
214: PFAD ad;
215:
216: ins = (PFINS)CALLOC(1,sizeof(PF)+2*sizeof(struct oPFAD));
217: ins->pf = powdef; ad = ins->ad;
218: ad[0].d = 0; ad[0].arg = a; ad[1].d = 0; ad[1].arg = e;
219: simplify_ins(ins,r);
220: }
221:
222: void simplify_pow(ins,rp)
223: PFINS ins;
224: Obj *rp;
225: {
226: PF pf;
227: PFAD ad;
228: Obj a0,a1;
229: V v;
230: P t;
231:
232: pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg;
233: if ( !a1 )
234: *rp = (Obj)ONE;
235: else if ( !a0 )
236: *rp = 0;
237: else if ( NUM(a1) && INT(a1) )
238: arf_pwr(CO,a0,a1,rp);
239: else {
240: instov(ins,&v); MKV(v,t); *rp = (Obj)t;
241: }
242: }
243:
244: #define ISPFINS(p)\
245: (p)&&(ID(p) == O_P)&&((int)VR((P)p)->attr!=V_PF)&&\
246: UNIQ(DEG(DC((P)p)))&&UNIQ(COEF(DC((P)p)))
247:
248: void Pfunctor(arg,rp)
249: NODE arg;
250: P *rp;
251: {
252: P p;
253: FUNC t;
254: PF pf;
255: PFINS ins;
256:
257: p = (P)ARG0(arg);
258: if ( !ISPFINS(p) )
259: *rp = 0;
260: else {
261: ins = (PFINS)VR(p)->priv; pf = ins->pf;
262: t = (FUNC)MALLOC(sizeof(struct oFUNC));
263: t->name = pf->name; t->id = A_PURE; t->argc = pf->argc;
264: t->f.puref = pf;
265: makesrvar(t,rp);
266: }
267: }
268:
269: void Pargs(arg,rp)
270: NODE arg;
271: LIST *rp;
272: {
273: P p;
274: PF pf;
275: PFAD ad;
276: PFINS ins;
277: NODE n,n0;
278: int i;
279:
280: p = (P)ARG0(arg);
281: if ( !ISPFINS(p) )
282: *rp = 0;
283: else {
284: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
285: for ( i = 0, n0 = 0; i < pf->argc; i++ ) {
286: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
287: }
288: if ( n0 )
289: NEXT(n) = 0;
290: MKLIST(*rp,n0);
291: }
292: }
293:
294: void Pfunargs(arg,rp)
295: NODE arg;
296: LIST *rp;
297: {
298: P p;
299: P f;
300: FUNC t;
301: PF pf;
302: PFINS ins;
303: PFAD ad;
304: NODE n,n0;
305: int i;
306:
307: p = (P)ARG0(arg);
308: if ( !ISPFINS(p) )
309: *rp = 0;
310: else {
311: ins = (PFINS)VR(p)->priv; ad = ins->ad; pf = ins->pf;
312: t = (FUNC)MALLOC(sizeof(struct oFUNC));
313: t->name = pf->name; t->id = A_PURE; t->argc = pf->argc;
314: t->f.puref = pf;
315: makesrvar(t,&f);
316: n0 = 0; NEXTNODE(n0,n); BDY(n) = (pointer)f;
317: for ( i = 0; i < pf->argc; i++ ) {
318: NEXTNODE(n0,n); BDY(n) = (pointer)ad[i].arg;
319: }
320: NEXT(n) = 0;
321: MKLIST(*rp,n0);
322: }
323: }
324:
325: void Pvtype(arg,rp)
326: NODE arg;
327: Q *rp;
328: {
329: P p;
330:
331: p = (P)ARG0(arg);
332: if ( !p || ID(p) != O_P )
333: *rp = 0;
334: else
335: STOQ((int)VR(p)->attr,*rp);
336: }
337:
338: extern FUNC registered_handler;
339:
340: void Pregister_handler(arg,rp)
341: NODE arg;
342: Q *rp;
343: {
344: P p;
345: V v;
346: FUNC func;
347:
348: p = (P)ARG0(arg);
349: if ( !p )
350: registered_handler = 0;
351: else if ( OID(p) != 2 )
352: error("register_hanlder : invalid argument");
353: v = VR(p);
354: if ( (int)v->attr != V_SR )
355: error("register_hanlder : no such function");
356: else {
357: func = (FUNC)v->priv;
358: if ( func->argc )
359: error("register_hanlder : the function must be with no argument");
360: else {
361: registered_handler = func;
362: *rp = ONE;
363: }
364: }
365: }
366:
367: void Pcall(arg,rp)
368: NODE arg;
369: Obj *rp;
370: {
371: P p;
372: V v;
373:
374: p = (P)ARG0(arg);
375: if ( !p || OID(p) != 2 )
376: error("call : invalid argument");
377: v = VR(p);
378: if ( (int)v->attr != V_SR )
379: error("call : no such function");
380:
381: else
382: *rp = (Obj)bevalf((FUNC)v->priv,BDY((LIST)ARG1(arg)));
383: }
384:
385: void Pdeval(arg,rp)
386: NODE arg;
387: Obj *rp;
388: {
389: asir_assert(ARG0(arg),O_R,"deval");
390: devalr(CO,(Obj)ARG0(arg),rp);
391: }
392:
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