version 1.99, 2016/12/02 02:12:00 |
version 1.103, 2017/03/27 09:05:46 |
|
|
* 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/dp.c,v 1.98 2016/03/31 08:43:25 noro Exp $ |
* $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.102 2017/02/28 07:06:28 noro Exp $ |
*/ |
*/ |
#include "ca.h" |
#include "ca.h" |
#include "base.h" |
#include "base.h" |
Line 174 struct ftab dp_tab[] = { |
|
Line 174 struct ftab dp_tab[] = { |
|
{"dp_gr_mod_main",Pdp_gr_mod_main,5}, |
{"dp_gr_mod_main",Pdp_gr_mod_main,5}, |
{"dp_gr_f_main",Pdp_gr_f_main,4}, |
{"dp_gr_f_main",Pdp_gr_f_main,4}, |
{"dp_gr_checklist",Pdp_gr_checklist,2}, |
{"dp_gr_checklist",Pdp_gr_checklist,2}, |
{"nd_f4",Pnd_f4,4}, |
{"nd_f4",Pnd_f4,-4}, |
{"nd_gr",Pnd_gr,4}, |
{"nd_gr",Pnd_gr,-4}, |
{"nd_gr_trace",Pnd_gr_trace,5}, |
{"nd_gr_trace",Pnd_gr_trace,-5}, |
{"nd_f4_trace",Pnd_f4_trace,5}, |
{"nd_f4_trace",Pnd_f4_trace,-5}, |
{"nd_gr_postproc",Pnd_gr_postproc,5}, |
{"nd_gr_postproc",Pnd_gr_postproc,5}, |
{"nd_gr_recompute_trace",Pnd_gr_recompute_trace,5}, |
{"nd_gr_recompute_trace",Pnd_gr_recompute_trace,5}, |
{"nd_btog",Pnd_btog,-6}, |
{"nd_btog",Pnd_btog,-6}, |
{"nd_weyl_gr_postproc",Pnd_weyl_gr_postproc,5}, |
{"nd_weyl_gr_postproc",Pnd_weyl_gr_postproc,5}, |
{"nd_weyl_gr",Pnd_weyl_gr,4}, |
{"nd_weyl_gr",Pnd_weyl_gr,-4}, |
{"nd_weyl_gr_trace",Pnd_weyl_gr_trace,5}, |
{"nd_weyl_gr_trace",Pnd_weyl_gr_trace,-5}, |
{"nd_nf",Pnd_nf,5}, |
{"nd_nf",Pnd_nf,5}, |
{"nd_weyl_nf",Pnd_weyl_nf,5}, |
{"nd_weyl_nf",Pnd_weyl_nf,5}, |
|
|
Line 2101 void Pdp_gr_mod_main(NODE arg,LIST *rp) |
|
Line 2101 void Pdp_gr_mod_main(NODE arg,LIST *rp) |
|
void Pnd_f4(NODE arg,LIST *rp) |
void Pnd_f4(NODE arg,LIST *rp) |
{ |
{ |
LIST f,v; |
LIST f,v; |
int m,homo,retdp; |
int m,homo,retdp,ac; |
Obj val; |
Obj val; |
|
Q mq; |
|
Num nhomo; |
|
NODE node; |
struct order_spec *ord; |
struct order_spec *ord; |
|
|
do_weyl = 0; |
do_weyl = 0; |
nd_rref2 = 0; |
nd_rref2 = 0; |
asir_assert(ARG0(arg),O_LIST,"nd_f4"); |
retdp = 0; |
asir_assert(ARG1(arg),O_LIST,"nd_f4"); |
if ( (ac = argc(arg)) == 4 ) { |
asir_assert(ARG2(arg),O_N,"nd_f4"); |
asir_assert(ARG0(arg),O_LIST,"nd_f4"); |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
asir_assert(ARG1(arg),O_LIST,"nd_f4"); |
f = remove_zero_from_list(f); |
asir_assert(ARG2(arg),O_N,"nd_f4"); |
if ( !BDY(f) ) { |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
*rp = f; return; |
f = remove_zero_from_list(f); |
} |
if ( !BDY(f) ) { |
m = QTOS((Q)ARG2(arg)); |
*rp = f; return; |
create_order_spec(0,ARG3(arg),&ord); |
} |
homo = retdp = 0; |
mq = (Q)ARG2(arg); |
if ( get_opt("homo",&val) && val ) homo = 1; |
if ( mq && (PL(NM(mq)) > 1 || BD(NM(mq))[0] >= (1<<30)) ) { |
if ( get_opt("dp",&val) && val ) retdp = 1; |
node = mknode(1,mq); |
if ( get_opt("rref2",&val) && val ) nd_rref2 = 1; |
Psetmod_ff(node,&val); |
|
m = -2; |
|
} else |
|
m = QTOS(mq); |
|
create_order_spec(0,ARG3(arg),&ord); |
|
homo = 0; |
|
if ( get_opt("homo",&val) && val ) homo = 1; |
|
if ( get_opt("dp",&val) && val ) retdp = 1; |
|
if ( get_opt("rref2",&val) && val ) nd_rref2 = 1; |
|
} else if ( ac == 1 ) { |
|
f = (LIST)ARG0(arg); |
|
parse_gr_option(f,current_option,&v,&nhomo,&m,&ord); |
|
homo = QTOS((Q)nhomo); |
|
if ( get_opt("dp",&val) && val ) retdp = 1; |
|
if ( get_opt("rref2",&val) && val ) nd_rref2 = 1; |
|
} else |
|
error("nd_f4 : invalid argument"); |
nd_gr(f,v,m,homo,retdp,1,ord,rp); |
nd_gr(f,v,m,homo,retdp,1,ord,rp); |
} |
} |
|
|
void Pnd_gr(NODE arg,LIST *rp) |
void Pnd_gr(NODE arg,LIST *rp) |
{ |
{ |
LIST f,v; |
LIST f,v; |
int m,homo,retdp; |
int m,homo,retdp,ac; |
Obj val; |
Obj val; |
|
Q mq; |
|
Num nhomo; |
|
NODE node; |
struct order_spec *ord; |
struct order_spec *ord; |
|
|
do_weyl = 0; |
do_weyl = 0; |
asir_assert(ARG0(arg),O_LIST,"nd_gr"); |
retdp = 0; |
asir_assert(ARG1(arg),O_LIST,"nd_gr"); |
if ( (ac=argc(arg)) == 4 ) { |
asir_assert(ARG2(arg),O_N,"nd_gr"); |
asir_assert(ARG0(arg),O_LIST,"nd_gr"); |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
asir_assert(ARG1(arg),O_LIST,"nd_gr"); |
f = remove_zero_from_list(f); |
asir_assert(ARG2(arg),O_N,"nd_gr"); |
if ( !BDY(f) ) { |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
*rp = f; return; |
f = remove_zero_from_list(f); |
} |
if ( !BDY(f) ) { |
m = QTOS((Q)ARG2(arg)); |
*rp = f; return; |
create_order_spec(0,ARG3(arg),&ord); |
} |
homo = retdp = 0; |
mq = (Q)ARG2(arg); |
if ( get_opt("homo",&val) && val ) homo = 1; |
if ( mq && (PL(NM(mq)) > 1 || BD(NM(mq))[0] >= (1<<30)) ) { |
if ( get_opt("dp",&val) && val ) retdp = 1; |
node = mknode(1,mq); |
|
Psetmod_ff(node,&val); |
|
m = -2; |
|
} else |
|
m = QTOS(mq); |
|
create_order_spec(0,ARG3(arg),&ord); |
|
homo = 0; |
|
if ( get_opt("homo",&val) && val ) homo = 1; |
|
if ( get_opt("dp",&val) && val ) retdp = 1; |
|
} else if ( ac == 1 ) { |
|
f = (LIST)ARG0(arg); |
|
parse_gr_option(f,current_option,&v,&nhomo,&m,&ord); |
|
homo = QTOS((Q)nhomo); |
|
if ( get_opt("dp",&val) && val ) retdp = 1; |
|
} else |
|
error("nd_gr : invalid argument"); |
nd_gr(f,v,m,homo,retdp,0,ord,rp); |
nd_gr(f,v,m,homo,retdp,0,ord,rp); |
} |
} |
|
|
Line 2152 void Pnd_gr_postproc(NODE arg,LIST *rp) |
|
Line 2189 void Pnd_gr_postproc(NODE arg,LIST *rp) |
|
{ |
{ |
LIST f,v; |
LIST f,v; |
int m,do_check; |
int m,do_check; |
|
Q mq; |
|
Obj val; |
|
NODE node; |
struct order_spec *ord; |
struct order_spec *ord; |
|
|
do_weyl = 0; |
do_weyl = 0; |
Line 2163 void Pnd_gr_postproc(NODE arg,LIST *rp) |
|
Line 2203 void Pnd_gr_postproc(NODE arg,LIST *rp) |
|
if ( !BDY(f) ) { |
if ( !BDY(f) ) { |
*rp = f; return; |
*rp = f; return; |
} |
} |
m = QTOS((Q)ARG2(arg)); |
mq = (Q)ARG2(arg); |
|
if ( mq && (PL(NM(mq)) > 1 || BD(NM(mq))[0] >= (1<<30)) ) { |
|
node = mknode(1,mq); |
|
Psetmod_ff(node,&val); |
|
m = -2; |
|
} else |
|
m = QTOS(mq); |
create_order_spec(0,ARG3(arg),&ord); |
create_order_spec(0,ARG3(arg),&ord); |
do_check = ARG4(arg) ? 1 : 0; |
do_check = ARG4(arg) ? 1 : 0; |
nd_gr_postproc(f,v,m,ord,do_check,rp); |
nd_gr_postproc(f,v,m,ord,do_check,rp); |
Line 2238 void Pnd_weyl_gr_postproc(NODE arg,LIST *rp) |
|
Line 2284 void Pnd_weyl_gr_postproc(NODE arg,LIST *rp) |
|
void Pnd_gr_trace(NODE arg,LIST *rp) |
void Pnd_gr_trace(NODE arg,LIST *rp) |
{ |
{ |
LIST f,v; |
LIST f,v; |
int m,homo; |
int m,homo,ac; |
|
Num nhomo; |
struct order_spec *ord; |
struct order_spec *ord; |
|
|
do_weyl = 0; |
do_weyl = 0; |
asir_assert(ARG0(arg),O_LIST,"nd_gr_trace"); |
if ( (ac = argc(arg)) == 5 ) { |
asir_assert(ARG1(arg),O_LIST,"nd_gr_trace"); |
asir_assert(ARG0(arg),O_LIST,"nd_gr_trace"); |
asir_assert(ARG2(arg),O_N,"nd_gr_trace"); |
asir_assert(ARG1(arg),O_LIST,"nd_gr_trace"); |
asir_assert(ARG3(arg),O_N,"nd_gr_trace"); |
asir_assert(ARG2(arg),O_N,"nd_gr_trace"); |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
asir_assert(ARG3(arg),O_N,"nd_gr_trace"); |
f = remove_zero_from_list(f); |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
if ( !BDY(f) ) { |
f = remove_zero_from_list(f); |
*rp = f; return; |
if ( !BDY(f) ) { |
} |
*rp = f; return; |
homo = QTOS((Q)ARG2(arg)); |
} |
m = QTOS((Q)ARG3(arg)); |
homo = QTOS((Q)ARG2(arg)); |
create_order_spec(0,ARG4(arg),&ord); |
m = QTOS((Q)ARG3(arg)); |
|
create_order_spec(0,ARG4(arg),&ord); |
|
} else if ( ac == 1 ) { |
|
f = (LIST)ARG0(arg); |
|
parse_gr_option(f,current_option,&v,&nhomo,&m,&ord); |
|
homo = QTOS((Q)nhomo); |
|
} else |
|
error("nd_gr_trace : invalid argument"); |
nd_gr_trace(f,v,m,homo,0,ord,rp); |
nd_gr_trace(f,v,m,homo,0,ord,rp); |
} |
} |
|
|
void Pnd_f4_trace(NODE arg,LIST *rp) |
void Pnd_f4_trace(NODE arg,LIST *rp) |
{ |
{ |
LIST f,v; |
LIST f,v; |
int m,homo; |
int m,homo,ac; |
|
Num nhomo; |
struct order_spec *ord; |
struct order_spec *ord; |
|
|
do_weyl = 0; |
do_weyl = 0; |
asir_assert(ARG0(arg),O_LIST,"nd_gr_trace"); |
if ( (ac = argc(arg))==5 ) { |
asir_assert(ARG1(arg),O_LIST,"nd_gr_trace"); |
asir_assert(ARG0(arg),O_LIST,"nd_f4_trace"); |
asir_assert(ARG2(arg),O_N,"nd_gr_trace"); |
asir_assert(ARG1(arg),O_LIST,"nd_f4_trace"); |
asir_assert(ARG3(arg),O_N,"nd_gr_trace"); |
asir_assert(ARG2(arg),O_N,"nd_f4_trace"); |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
asir_assert(ARG3(arg),O_N,"nd_f4_trace"); |
f = remove_zero_from_list(f); |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
if ( !BDY(f) ) { |
f = remove_zero_from_list(f); |
*rp = f; return; |
if ( !BDY(f) ) { |
} |
*rp = f; return; |
homo = QTOS((Q)ARG2(arg)); |
} |
m = QTOS((Q)ARG3(arg)); |
homo = QTOS((Q)ARG2(arg)); |
create_order_spec(0,ARG4(arg),&ord); |
m = QTOS((Q)ARG3(arg)); |
|
create_order_spec(0,ARG4(arg),&ord); |
|
} else if ( ac == 1 ) { |
|
f = (LIST)ARG0(arg); |
|
parse_gr_option(f,current_option,&v,&nhomo,&m,&ord); |
|
homo = QTOS((Q)nhomo); |
|
} else |
|
error("nd_gr_trace : invalid argument"); |
nd_gr_trace(f,v,m,homo,1,ord,rp); |
nd_gr_trace(f,v,m,homo,1,ord,rp); |
} |
} |
|
|
void Pnd_weyl_gr(NODE arg,LIST *rp) |
void Pnd_weyl_gr(NODE arg,LIST *rp) |
{ |
{ |
LIST f,v; |
LIST f,v; |
int m,homo,retdp; |
int m,homo,retdp,ac; |
Obj val; |
Obj val; |
|
Num nhomo; |
struct order_spec *ord; |
struct order_spec *ord; |
|
|
do_weyl = 1; |
do_weyl = 1; |
asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr"); |
retdp = 0; |
asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr"); |
if ( (ac = argc(arg)) == 4 ) { |
asir_assert(ARG2(arg),O_N,"nd_weyl_gr"); |
asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr"); |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr"); |
f = remove_zero_from_list(f); |
asir_assert(ARG2(arg),O_N,"nd_weyl_gr"); |
if ( !BDY(f) ) { |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
*rp = f; do_weyl = 0; return; |
f = remove_zero_from_list(f); |
} |
if ( !BDY(f) ) { |
m = QTOS((Q)ARG2(arg)); |
*rp = f; do_weyl = 0; return; |
create_order_spec(0,ARG3(arg),&ord); |
} |
homo = retdp = 0; |
m = QTOS((Q)ARG2(arg)); |
if ( get_opt("homo",&val) && val ) homo = 1; |
create_order_spec(0,ARG3(arg),&ord); |
if ( get_opt("dp",&val) && val ) retdp = 1; |
homo = 0; |
|
if ( get_opt("homo",&val) && val ) homo = 1; |
|
if ( get_opt("dp",&val) && val ) retdp = 1; |
|
} else if ( ac == 1 ) { |
|
f = (LIST)ARG0(arg); |
|
parse_gr_option(f,current_option,&v,&nhomo,&m,&ord); |
|
homo = QTOS((Q)nhomo); |
|
if ( get_opt("dp",&val) && val ) retdp = 1; |
|
} else |
|
error("nd_weyl_gr : invalid argument"); |
nd_gr(f,v,m,homo,retdp,0,ord,rp); |
nd_gr(f,v,m,homo,retdp,0,ord,rp); |
do_weyl = 0; |
do_weyl = 0; |
} |
} |
Line 2307 void Pnd_weyl_gr(NODE arg,LIST *rp) |
|
Line 2379 void Pnd_weyl_gr(NODE arg,LIST *rp) |
|
void Pnd_weyl_gr_trace(NODE arg,LIST *rp) |
void Pnd_weyl_gr_trace(NODE arg,LIST *rp) |
{ |
{ |
LIST f,v; |
LIST f,v; |
int m,homo; |
int m,homo,ac; |
|
Num nhomo; |
struct order_spec *ord; |
struct order_spec *ord; |
|
|
do_weyl = 1; |
do_weyl = 1; |
asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace"); |
if ( (ac = argc(arg)) == 5 ) { |
asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace"); |
asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace"); |
asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace"); |
asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace"); |
asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace"); |
asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace"); |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace"); |
f = remove_zero_from_list(f); |
f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); |
if ( !BDY(f) ) { |
f = remove_zero_from_list(f); |
*rp = f; do_weyl = 0; return; |
if ( !BDY(f) ) { |
} |
*rp = f; do_weyl = 0; return; |
homo = QTOS((Q)ARG2(arg)); |
} |
m = QTOS((Q)ARG3(arg)); |
homo = QTOS((Q)ARG2(arg)); |
create_order_spec(0,ARG4(arg),&ord); |
m = QTOS((Q)ARG3(arg)); |
|
create_order_spec(0,ARG4(arg),&ord); |
|
} else if ( ac == 1 ) { |
|
f = (LIST)ARG0(arg); |
|
parse_gr_option(f,current_option,&v,&nhomo,&m,&ord); |
|
homo = QTOS((Q)nhomo); |
|
} else |
|
error("nd_weyl_gr_trace : invalid argument"); |
nd_gr_trace(f,v,m,homo,0,ord,rp); |
nd_gr_trace(f,v,m,homo,0,ord,rp); |
do_weyl = 0; |
do_weyl = 0; |
} |
} |