version 1.10, 2005/09/08 08:37:02 |
version 1.20, 2015/08/04 06:20:44 |
|
|
* DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, |
* DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, |
* PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. |
* 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.19 2014/09/19 01:25:59 noro Exp $ |
*/ |
*/ |
#include "ca.h" |
#include "ca.h" |
#include "math.h" |
#include "math.h" |
Line 62 void make_itri(void); |
|
Line 62 void make_itri(void); |
|
void make_tri(void); |
void make_tri(void); |
void make_exp(void); |
void make_exp(void); |
void simplify_pow(PFINS,Obj *); |
void simplify_pow(PFINS,Obj *); |
|
FNODE partial_eval(FNODE f); |
|
|
void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(),Pfunargs_ext(); |
void Pfunctor(),Pargs(),Pfunargs(),Pvtype(),Pcall(),Pdeval(),Pfunargs_ext(); |
void Pregister_handler(); |
void Pregister_handler(); |
void Peval_quote(); |
void Peval_quote(); |
void Pmapat(); |
void Pmapat(), Pmap(); |
void Padd_handler(); |
void Padd_handler(); |
void Plist_handler(); |
void Plist_handler(); |
void Pclear_handler(); |
void Pclear_handler(); |
|
|
struct ftab puref_tab[] = { |
struct ftab puref_tab[] = { |
{"mapat",Pmapat,-99999999}, |
{"mapat",Pmapat,-99999999}, |
|
{"map",Pmap,-99999999}, |
{"functor",Pfunctor,1}, |
{"functor",Pfunctor,1}, |
{"args",Pargs,1}, |
{"args",Pargs,1}, |
{"funargs",Pfunargs,1}, |
{"funargs",Pfunargs,1}, |
Line 84 struct ftab puref_tab[] = { |
|
Line 86 struct ftab puref_tab[] = { |
|
{"call",Pcall,2}, |
{"call",Pcall,2}, |
{"vtype",Pvtype,1}, |
{"vtype",Pvtype,1}, |
{"deval",Pdeval,1}, |
{"deval",Pdeval,1}, |
{"eval_quote",Peval_quote,1}, |
{"eval_quote",Peval_quote,-2}, |
{0,0,0}, |
{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(); |
|
#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 V *uarg,*darg; |
static P x,y; |
static P x,y; |
static PF pidef,edef; |
static PF pidef,edef; |
Line 114 static PF asinhdef,acoshdef,atanhdef; |
|
Line 110 static PF asinhdef,acoshdef,atanhdef; |
|
double const_pi() { return 3.14159265358979323846264338327950288; } |
double const_pi() { return 3.14159265358979323846264338327950288; } |
double const_e() { return 2.718281828459045235360287471352662497; } |
double const_e() { return 2.718281828459045235360287471352662497; } |
|
|
|
int simplify_elemfunc_ins(); |
|
|
void pf_init() { |
void pf_init() { |
uarg = (V *)CALLOC(1,sizeof(V)); |
uarg = (V *)CALLOC(1,sizeof(V)); |
uarg[0] = &oVAR[26]; MKV(uarg[0],x); |
uarg[0] = &oVAR[26]; MKV(uarg[0],x); |
Line 122 void pf_init() { |
|
Line 120 void pf_init() { |
|
darg[0] = &oVAR[26]; |
darg[0] = &oVAR[26]; |
darg[1] = &oVAR[27]; MKV(darg[1],y); |
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,0,&pidef); |
mkpf("@e",0,0,0,(int (*)())p_e,const_e,0,&edef); |
mkpf("@e",0,0,0,(int (*)())mp_e,const_e,0,&edef); |
|
|
mkpf("log",0,1,uarg,(int (*)())p_log,log,0,&logdef); |
mkpf("log",0,1,uarg,(int (*)())mp_log,log,simplify_elemfunc_ins,&logdef); |
mkpf("exp",0,1,uarg,(int (*)())p_exp,exp,0,&expdef); |
mkpf("exp",0,1,uarg,(int (*)())mp_exp,exp,simplify_elemfunc_ins,&expdef); |
mkpf("pow",0,2,darg,(int (*)())p_pow,pow,(int (*)())simplify_pow,&powdef); |
mkpf("pow",0,2,darg,(int (*)())mp_pow,pow,(int (*)())simplify_pow,&powdef); |
|
|
mkpf("sin",0,1,uarg,(int (*)())p_sin,sin,0,&sindef); |
mkpf("sin",0,1,uarg,(int (*)())mp_sin,sin,simplify_elemfunc_ins,&sindef); |
mkpf("cos",0,1,uarg,(int (*)())p_cos,cos,0,&cosdef); |
mkpf("cos",0,1,uarg,(int (*)())mp_cos,cos,simplify_elemfunc_ins,&cosdef); |
mkpf("tan",0,1,uarg,(int (*)())p_tan,tan,0,&tandef); |
mkpf("tan",0,1,uarg,(int (*)())mp_tan,tan,simplify_elemfunc_ins,&tandef); |
mkpf("asin",0,1,uarg,(int (*)())p_asin,asin,0,&asindef); |
mkpf("asin",0,1,uarg,(int (*)())mp_asin,asin,simplify_elemfunc_ins,&asindef); |
mkpf("acos",0,1,uarg,(int (*)())p_acos,acos,0,&acosdef); |
mkpf("acos",0,1,uarg,(int (*)())mp_acos,acos,simplify_elemfunc_ins,&acosdef); |
mkpf("atan",0,1,uarg,(int (*)())p_atan,atan,0,&atandef); |
mkpf("atan",0,1,uarg,(int (*)())mp_atan,atan,simplify_elemfunc_ins,&atandef); |
|
|
mkpf("sinh",0,1,uarg,(int (*)())p_sinh,sinh,0,&sinhdef); |
mkpf("sinh",0,1,uarg,(int (*)())mp_sinh,sinh,simplify_elemfunc_ins,&sinhdef); |
mkpf("cosh",0,1,uarg,(int (*)())p_cosh,cosh,0,&coshdef); |
mkpf("cosh",0,1,uarg,(int (*)())mp_cosh,cosh,simplify_elemfunc_ins,&coshdef); |
mkpf("tanh",0,1,uarg,(int (*)())p_tanh,tanh,0,&tanhdef); |
mkpf("tanh",0,1,uarg,(int (*)())mp_tanh,tanh,simplify_elemfunc_ins,&tanhdef); |
#if !defined(VISUAL) |
#if !defined(VISUAL) |
mkpf("asinh",0,1,uarg,(int (*)())p_asinh,asinh,0,&asinhdef); |
mkpf("asinh",0,1,uarg,(int (*)())mp_asinh,asinh,simplify_elemfunc_ins,&asinhdef); |
mkpf("acosh",0,1,uarg,(int (*)())p_acosh,acosh,0,&acoshdef); |
mkpf("acosh",0,1,uarg,(int (*)())mp_acosh,acosh,simplify_elemfunc_ins,&acoshdef); |
mkpf("atanh",0,1,uarg,(int (*)())p_atanh,atanh,0,&atanhdef); |
mkpf("atanh",0,1,uarg,(int (*)())mp_atanh,atanh,simplify_elemfunc_ins,&atanhdef); |
#endif |
#endif |
make_exp(); |
make_exp(); |
make_tri(); |
make_tri(); |
Line 563 void Pcall(NODE arg,Obj *rp) |
|
Line 561 void Pcall(NODE arg,Obj *rp) |
|
{ |
{ |
P p; |
P p; |
V v; |
V v; |
|
NODE n,n1; |
|
LIST list; |
|
VECT vect; |
|
pointer *a; |
|
int len,i; |
|
|
p = (P)ARG0(arg); |
p = (P)ARG0(arg); |
if ( !p || OID(p) != 2 ) |
if ( !p || OID(p) != 2 ) |
Line 570 void Pcall(NODE arg,Obj *rp) |
|
Line 573 void Pcall(NODE arg,Obj *rp) |
|
v = VR(p); |
v = VR(p); |
if ( (int)v->attr != V_SR ) |
if ( (int)v->attr != V_SR ) |
error("call : no such function"); |
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 */ |
/* at=position of arg to be used for iteration */ |
Line 590 void Pmapat(NODE arg,Obj *rp) |
|
Line 610 void Pmapat(NODE arg,Obj *rp) |
|
int len,row,col,i,j,pos; |
int len,row,col,i,j,pos; |
Obj iter; |
Obj iter; |
pointer val; |
pointer val; |
|
NODE option; |
|
|
|
option = current_option; |
|
|
if ( argc(arg) < 3 ) |
if ( argc(arg) < 3 ) |
error("mapat : too few arguments"); |
error("mapat : too few arguments"); |
|
|
Line 615 void Pmapat(NODE arg,Obj *rp) |
|
Line 638 void Pmapat(NODE arg,Obj *rp) |
|
NEXTNODE(r0,r); |
NEXTNODE(r0,r); |
iter = BDY(t); rest = NEXT(t); |
iter = BDY(t); rest = NEXT(t); |
if ( !iter ) { |
if ( !iter ) { |
*rp = bevalf(f,node); |
*rp = bevalf_with_opts(f,node,option); |
return; |
return; |
} |
} |
switch ( OID(iter) ) { |
switch ( OID(iter) ) { |
Line 623 void Pmapat(NODE arg,Obj *rp) |
|
Line 646 void Pmapat(NODE arg,Obj *rp) |
|
v = (VECT)iter; len = v->len; MKVECT(rv,len); |
v = (VECT)iter; len = v->len; MKVECT(rv,len); |
for ( i = 0; i < len; i++ ) { |
for ( i = 0; i < len; i++ ) { |
BDY(r) = BDY(v)[i]; NEXT(r) = rest; |
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; |
*rp = (Obj)rv; |
break; |
break; |
Line 632 void Pmapat(NODE arg,Obj *rp) |
|
Line 655 void Pmapat(NODE arg,Obj *rp) |
|
for ( i = 0; i < row; i++ ) |
for ( i = 0; i < row; i++ ) |
for ( j = 0; j < col; j++ ) { |
for ( j = 0; j < col; j++ ) { |
BDY(r) = BDY(m)[i][j]; NEXT(r) = rest; |
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; |
*rp = (Obj)rm; |
break; |
break; |
Line 640 void Pmapat(NODE arg,Obj *rp) |
|
Line 663 void Pmapat(NODE arg,Obj *rp) |
|
n = BDY((LIST)iter); |
n = BDY((LIST)iter); |
for ( t0 = t = 0; n; n = NEXT(n) ) { |
for ( t0 = t = 0; n; n = NEXT(n) ) { |
BDY(r) = BDY(n); NEXT(r) = rest; |
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 ) |
if ( t0 ) |
NEXT(t) = 0; |
NEXT(t) = 0; |
Line 648 void Pmapat(NODE arg,Obj *rp) |
|
Line 671 void Pmapat(NODE arg,Obj *rp) |
|
*rp = (Obj)rl; |
*rp = (Obj)rl; |
break; |
break; |
default: |
default: |
*rp = bevalf(f,node); |
*rp = bevalf_with_opts(f,node,option); |
break; |
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) |
void Pdeval(arg,rp) |
NODE arg; |
NODE arg; |
Obj *rp; |
Obj *rp; |
Line 665 void Peval_quote(arg,rp) |
|
Line 762 void Peval_quote(arg,rp) |
|
NODE arg; |
NODE arg; |
Obj *rp; |
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))); |
} |
} |