OpenXM_contrib2/asir2000/builtin/pf.c - diff

Return to pf.c CVS log

Up to [local] / OpenXM_contrib2 / asir2000 / builtin

Diff for /OpenXM_contrib2/asir2000/builtin/pf.c between version 1.10 and 1.24

version 1.10, 2005/09/08 08:37:02

version 1.24, 2018/03/28 05:27:22

Line 45

* DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,

* PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.

* $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.9 2004/12/17 03:09:08 noro Exp $

* $OpenXM: OpenXM_contrib2/asir2000/builtin/pf.c,v 1.23 2018/03/27 06:29:19 noro Exp $

#include "ca.h"

#include "math.h"

Line 54

#include <alloca.h>

#endif

double const_pi(),const_e();

double const_pi(),const_e(), double_factorial();

void make_ihyp(void);

void make_hyp(void);

Line 62 void make_itri(void);

void make_tri(void);

void make_exp(void);

void simplify_pow(PFINS,Obj *);

FNODE partial_eval(FNODE f);

void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(),Pfunargs_ext();

void Pregister_handler();

void Peval_quote();

void Pmapat();

void Pmapat(), Pmap();

void Padd_handler();

void Plist_handler();

void Pclear_handler();

struct ftab puref_tab[] = {

{"mapat",Pmapat,-99999999},

{"map",Pmap,-99999999},

{"functor",Pfunctor,1},

{"args",Pargs,1},

{"funargs",Pfunargs,1},

Line 84 struct ftab puref_tab[] = {

Line 86 struct ftab puref_tab[] = {

{"call",Pcall,2},

{"vtype",Pvtype,1},

{"deval",Pdeval,1},

{"eval_quote",Peval_quote,1},

{"eval_quote",Peval_quote,-2},

{0,0,0},

};

#if defined(PARI)

int mp_pi(),mp_e();

int p_pi(),p_e();

int mp_exp(), mp_log(), mp_pow();

int p_log(),p_exp(),p_pow();

int mp_sin(),mp_cos(),mp_tan(),mp_asin(),mp_acos(),mp_atan();

int p_sin(),p_cos(),p_tan(),p_asin(),p_acos(),p_atan();

int mp_sinh(),mp_cosh(),mp_tanh(),mp_asinh(),mp_acosh(),mp_atanh();

int p_sinh(),p_cosh(),p_tanh(),p_asinh(),p_acosh(),p_atanh();

int mp_factorial(),mp_abs();

#else

int p_pi,p_e;

int p_log,p_exp,p_pow;

int p_sin,p_cos,p_tan,p_asin,p_acos,p_atan;

int p_sinh,p_cosh,p_tanh,p_asinh,p_acosh,p_atanh;

#endif

static V *uarg,*darg;

static P x,y;

Line 108 static PF sindef,cosdef,tandef;

Line 104 static PF sindef,cosdef,tandef;

static PF asindef,acosdef,atandef;

static PF sinhdef,coshdef,tanhdef;

static PF asinhdef,acoshdef,atanhdef;

static PF factorialdef,absdef;

#define OALLOC(p,n) ((p)=(Obj *)CALLOC((n),sizeof(Obj)))

double const_pi() { return 3.14159265358979323846264338327950288; }

double const_e() { return 2.718281828459045235360287471352662497; }

double double_factorial(double x)

{

return tgamma(x+1);

}

int simplify_elemfunc_ins();

int simplify_factorial_ins();

int simplify_abs_ins();

void pf_init() {

uarg = (V *)CALLOC(1,sizeof(V));

uarg[0] = &oVAR[26]; MKV(uarg[0],x);

Line 122 void pf_init() {

Line 128 void pf_init() {

darg[0] = &oVAR[26];

darg[1] = &oVAR[27]; MKV(darg[1],y);

mkpf("@pi",0,0,0,(int (*)())p_pi,const_pi,0,&pidef);

mkpf("@pi",0,0,0,(int (*)())mp_pi,const_pi,simplify_elemfunc_ins,&pidef);

mkpf("@e",0,0,0,(int (*)())p_e,const_e,0,&edef);

mkpf("@e",0,0,0,(int (*)())mp_e,const_e,simplify_elemfunc_ins,&edef);

mkpf("log",0,1,uarg,(int (*)())p_log,log,0,&logdef);

mkpf("factorial",0,1,uarg,(int (*)())mp_factorial,double_factorial,simplify_factorial_ins,&factorialdef);

mkpf("exp",0,1,uarg,(int (*)())p_exp,exp,0,&expdef);

mkpf("abs",0,1,uarg,(int (*)())mp_abs,fabs,simplify_abs_ins,&absdef);

mkpf("pow",0,2,darg,(int (*)())p_pow,pow,(int (*)())simplify_pow,&powdef);

mkpf("sin",0,1,uarg,(int (*)())p_sin,sin,0,&sindef);

mkpf("log",0,1,uarg,(int (*)())mp_log,log,simplify_elemfunc_ins,&logdef);

mkpf("cos",0,1,uarg,(int (*)())p_cos,cos,0,&cosdef);

mkpf("exp",0,1,uarg,(int (*)())mp_exp,exp,simplify_elemfunc_ins,&expdef);

mkpf("tan",0,1,uarg,(int (*)())p_tan,tan,0,&tandef);

mkpf("pow",0,2,darg,(int (*)())mp_pow,pow,(int (*)())simplify_pow,&powdef);

mkpf("asin",0,1,uarg,(int (*)())p_asin,asin,0,&asindef);

mkpf("acos",0,1,uarg,(int (*)())p_acos,acos,0,&acosdef);

mkpf("atan",0,1,uarg,(int (*)())p_atan,atan,0,&atandef);

mkpf("sinh",0,1,uarg,(int (*)())p_sinh,sinh,0,&sinhdef);

mkpf("sin",0,1,uarg,(int (*)())mp_sin,sin,simplify_elemfunc_ins,&sindef);

mkpf("cosh",0,1,uarg,(int (*)())p_cosh,cosh,0,&coshdef);

mkpf("cos",0,1,uarg,(int (*)())mp_cos,cos,simplify_elemfunc_ins,&cosdef);

mkpf("tanh",0,1,uarg,(int (*)())p_tanh,tanh,0,&tanhdef);

mkpf("tan",0,1,uarg,(int (*)())mp_tan,tan,simplify_elemfunc_ins,&tandef);

#if !defined(VISUAL)

mkpf("asin",0,1,uarg,(int (*)())mp_asin,asin,simplify_elemfunc_ins,&asindef);

mkpf("asinh",0,1,uarg,(int (*)())p_asinh,asinh,0,&asinhdef);

mkpf("acos",0,1,uarg,(int (*)())mp_acos,acos,simplify_elemfunc_ins,&acosdef);

mkpf("acosh",0,1,uarg,(int (*)())p_acosh,acosh,0,&acoshdef);

mkpf("atan",0,1,uarg,(int (*)())mp_atan,atan,simplify_elemfunc_ins,&atandef);

mkpf("atanh",0,1,uarg,(int (*)())p_atanh,atanh,0,&atanhdef);

mkpf("sinh",0,1,uarg,(int (*)())mp_sinh,sinh,simplify_elemfunc_ins,&sinhdef);

mkpf("cosh",0,1,uarg,(int (*)())mp_cosh,cosh,simplify_elemfunc_ins,&coshdef);

mkpf("tanh",0,1,uarg,(int (*)())mp_tanh,tanh,simplify_elemfunc_ins,&tanhdef);

#if !defined(VISUAL) && !defined(__MINGW32__)

mkpf("asinh",0,1,uarg,(int (*)())mp_asinh,asinh,simplify_elemfunc_ins,&asinhdef);

mkpf("acosh",0,1,uarg,(int (*)())mp_acosh,acosh,simplify_elemfunc_ins,&acoshdef);

mkpf("atanh",0,1,uarg,(int (*)())mp_atanh,atanh,simplify_elemfunc_ins,&atanhdef);

#endif

make_exp();

make_tri();

make_itri();

make_hyp();

#if !defined(VISUAL)

#if !defined(VISUAL) && !defined(__MINGW32__)

make_ihyp();

#endif

}

Line 278 Obj *r;

Line 287 Obj *r;

simplify_ins(ins,r);

}

extern int evalef;

void simplify_pow(ins,rp)

PFINS ins;

Obj *rp;

Line 288 Obj *rp;

Line 299 Obj *rp;

V v;

P t;

if ( evalef ) {

simplify_elemfunc_ins(ins,rp);

return;

}

pf = ins->pf; ad = ins->ad; a0 = ad[0].arg; a1 = ad[1].arg;

if ( !a1 )

*rp = (Obj)ONE;

Line 297 Obj *rp;

Line 312 Obj *rp;

else if ( RATN(a1) && SGN((Q)a1) < 0 )

error("simplify_pow : division by 0");

else {

instov(ins,&v); MKV(v,t); *rp = (Obj)t;

instoobj(ins,rp);

}

} else if ( NUM(a1) && INT(a1) )

arf_pwr(CO,a0,a1,rp);

else {

instov(ins,&v); MKV(v,t); *rp = (Obj)t;

instoobj(ins,rp);

}

Line 563 void Pcall(NODE arg,Obj *rp)

Line 578 void Pcall(NODE arg,Obj *rp)

{

P p;

V v;

NODE n,n1;

LIST list;

VECT vect;

pointer *a;

int len,i;

p = (P)ARG0(arg);

if ( !p || OID(p) != 2 )

Line 570 void Pcall(NODE arg,Obj *rp)

Line 590 void Pcall(NODE arg,Obj *rp)

v = VR(p);

if ( (int)v->attr != V_SR )

error("call : no such function");

else {

else

list = (LIST) ARG1(arg);

*rp = (Obj)bevalf((FUNC)v->priv,BDY((LIST)ARG1(arg)));

if ( list ) {

switch (OID(list)) {

case O_VECT:

vect = (VECT)list; len = vect->len; a = BDY(vect);

for ( i = len - 1, n = 0; i >= 0; i-- ) {

MKNODE(n1,a[i],n); n = n1;

}

MKLIST(list,n);

/* falling next case */

case O_LIST:

*rp = (Obj)bevalf_with_opts((FUNC)v->priv,BDY(list),current_option);

return;

default:

break;

}

error("call : invalid argument");

}

/* at=position of arg to be used for iteration */

Line 590 void Pmapat(NODE arg,Obj *rp)

Line 627 void Pmapat(NODE arg,Obj *rp)

int len,row,col,i,j,pos;

Obj iter;

pointer val;

NODE option;

option = current_option;

if ( argc(arg) < 3 )

error("mapat : too few arguments");

Line 615 void Pmapat(NODE arg,Obj *rp)

Line 655 void Pmapat(NODE arg,Obj *rp)

NEXTNODE(r0,r);

iter = BDY(t); rest = NEXT(t);

if ( !iter ) {

*rp = bevalf(f,node);

*rp = bevalf_with_opts(f,node,option);

return;

}

switch ( OID(iter) ) {

Line 623 void Pmapat(NODE arg,Obj *rp)

Line 663 void Pmapat(NODE arg,Obj *rp)

v = (VECT)iter; len = v->len; MKVECT(rv,len);

for ( i = 0; i < len; i++ ) {

BDY(r) = BDY(v)[i]; NEXT(r) = rest;

BDY(rv)[i] = bevalf(f,r0);

BDY(rv)[i] = bevalf_with_opts(f,r0,option);

}

*rp = (Obj)rv;

break;

Line 632 void Pmapat(NODE arg,Obj *rp)

Line 672 void Pmapat(NODE arg,Obj *rp)

for ( i = 0; i < row; i++ )

for ( j = 0; j < col; j++ ) {

BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;

BDY(rm)[i][j] = bevalf(f,r0);

BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);

}

*rp = (Obj)rm;

break;

Line 640 void Pmapat(NODE arg,Obj *rp)

Line 680 void Pmapat(NODE arg,Obj *rp)

n = BDY((LIST)iter);

for ( t0 = t = 0; n; n = NEXT(n) ) {

BDY(r) = BDY(n); NEXT(r) = rest;

NEXTNODE(t0,t); BDY(t) = bevalf(f,r0);

NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);

}

if ( t0 )

NEXT(t) = 0;

Line 648 void Pmapat(NODE arg,Obj *rp)

Line 688 void Pmapat(NODE arg,Obj *rp)

*rp = (Obj)rl;

break;

default:

*rp = bevalf(f,node);

*rp = bevalf_with_opts(f,node,option);

break;

}

/* An implementation of 'map' as builtin function. */

void Pmap(NODE arg,Obj *rp)

{

LIST args;

NODE node,rest,t0,t,n,r,r0;

P fpoly;

V fvar;

FUNC f;

VECT v,rv;

MAT m,rm;

LIST rl;

int len,row,col,i,j;

Obj iter;

pointer val;

NODE option;

option = current_option;

if ( argc(arg) < 2 )

error("mapat : too few arguments");

fpoly = (P)ARG0(arg);

if ( !fpoly || OID(fpoly) != O_P )

error("map : invalid function specification");

fvar = VR(fpoly);

if ( fvar->attr != (pointer)V_SR || !(f=(FUNC)fvar->priv) )

error("map : invalid function specification");

node = NEXT(arg);

len = length(node);

if ( 0 >= len )

error("evalmapf : invalid position");

r0 = 0;

NEXTNODE(r0,r);

iter = BDY(node); rest = NEXT(node);

if ( !iter ) {

*rp = bevalf_with_opts(f,node,option);

return;

}

switch ( OID(iter) ) {

case O_VECT:

v = (VECT)iter; len = v->len; MKVECT(rv,len);

for ( i = 0; i < len; i++ ) {

BDY(r) = BDY(v)[i]; NEXT(r) = rest;

BDY(rv)[i] = bevalf_with_opts(f,r0,option);

}

*rp = (Obj)rv;

break;

case O_MAT:

m = (MAT)iter; row = m->row; col = m->col; MKMAT(rm,row,col);

for ( i = 0; i < row; i++ )

for ( j = 0; j < col; j++ ) {

BDY(r) = BDY(m)[i][j]; NEXT(r) = rest;

BDY(rm)[i][j] = bevalf_with_opts(f,r0,option);

}

*rp = (Obj)rm;

break;

case O_LIST:

n = BDY((LIST)iter);

for ( t0 = t = 0; n; n = NEXT(n) ) {

BDY(r) = BDY(n); NEXT(r) = rest;

NEXTNODE(t0,t); BDY(t) = bevalf_with_opts(f,r0,option);

}

if ( t0 )

NEXT(t) = 0;

MKLIST(rl,t0);

*rp = (Obj)rl;

break;

default:

*rp = bevalf_with_opts(f,node,option);

break;

}

void Pdeval(arg,rp)

NODE arg;

Obj *rp;

Line 665 void Peval_quote(arg,rp)

Line 779 void Peval_quote(arg,rp)

NODE arg;

Obj *rp;

{

asir_assert(ARG0(arg),O_QUOTE,"eval_quote");

FNODE a;

*rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));

QUOTE q;

Obj f;

f = (Obj)ARG0(arg);

if ( !f || OID(f) != O_QUOTE ) {

*rp = f;

return;

}

if ( argc(arg) == 2 && ARG1(arg) ) {

a = partial_eval((FNODE)BDY((QUOTE)ARG0(arg)));

MKQUOTE(q,a);

*rp = (Obj)q;

} else

*rp = eval((FNODE)BDY((QUOTE)ARG0(arg)));

}

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>