| version 1.65, 2006/10/12 08:20:37 | version 1.68, 2007/09/06 02:23:40 | 
|  |  | 
| * non-exclusive and royalty-free license to use, copy, modify and | * non-exclusive and royalty-free license to use, copy, modify and | 
| * redistribute, solely for non-commercial and non-profit purposes, the | * redistribute, solely for non-commercial and non-profit purposes, the | 
| * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and | * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and | 
| * conditions of this Agreement. For the avoidance of doubt, you acquire | * conditions of this Agreement. For the avoidance of doubt, you acquire * only a limited right to use the SOFTWARE hereunder, and FLL or any | 
| * only a limited right to use the SOFTWARE hereunder, and FLL or any |  | 
| * third party developer retains all rights, including but not limited to | * third party developer retains all rights, including but not limited to | 
| * copyrights, in and to the SOFTWARE. | * copyrights, in and to the SOFTWARE. | 
| * | * | 
|  |  | 
| * 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.64 2006/06/13 04:13:26 noro Exp $ | * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.67 2007/08/21 23:53:00 noro Exp $ | 
| */ | */ | 
| #include "ca.h" | #include "ca.h" | 
| #include "base.h" | #include "base.h" | 
| 
| Line 68  void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest( |  | 
| Line 67  void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest( |  | 
| void Pdp_set_sugar(); | void Pdp_set_sugar(); | 
| void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv(); | void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv(); | 
| void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat(); | void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat(); | 
| void Pdp_nf(),Pdp_true_nf(); | void Pdp_nf(),Pdp_true_nf(),Pdp_true_nf_marked(); | 
| void Pdp_nf_mod(),Pdp_true_nf_mod(); | void Pdp_nf_mod(),Pdp_true_nf_mod(); | 
| void Pdp_criB(),Pdp_nelim(); | void Pdp_criB(),Pdp_nelim(); | 
| void Pdp_minp(),Pdp_sp_mod(); | void Pdp_minp(),Pdp_sp_mod(); | 
| 
| Line 100  void Pnd_weyl_gr(),Pnd_weyl_gr_trace(); |  | 
| Line 99  void Pnd_weyl_gr(),Pnd_weyl_gr_trace(); |  | 
| void Pnd_nf(); | void Pnd_nf(); | 
| void Pdp_initial_term(); | void Pdp_initial_term(); | 
| void Pdp_order(); | void Pdp_order(); | 
|  | void Pdp_inv_or_split(); | 
|  | void Pdp_compute_last_w(); | 
|  |  | 
| LIST dp_initial_term(); | LIST dp_initial_term(); | 
| LIST dp_order(); | LIST dp_order(); | 
| 
| Line 133  struct ftab dp_tab[] = { |  | 
| Line 134  struct ftab dp_tab[] = { |  | 
| {"dp_nf",Pdp_nf,4}, | {"dp_nf",Pdp_nf,4}, | 
| {"dp_nf_f",Pdp_nf_f,4}, | {"dp_nf_f",Pdp_nf_f,4}, | 
| {"dp_true_nf",Pdp_true_nf,4}, | {"dp_true_nf",Pdp_true_nf,4}, | 
|  | {"dp_true_nf_marked",Pdp_true_nf_marked,4}, | 
| {"dp_nf_mod",Pdp_nf_mod,5}, | {"dp_nf_mod",Pdp_nf_mod,5}, | 
| {"dp_true_nf_mod",Pdp_true_nf_mod,5}, | {"dp_true_nf_mod",Pdp_true_nf_mod,5}, | 
| {"dp_lnf_mod",Pdp_lnf_mod,3}, | {"dp_lnf_mod",Pdp_lnf_mod,3}, | 
| 
| Line 185  struct ftab dp_tab[] = { |  | 
| Line 187  struct ftab dp_tab[] = { |  | 
| {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4}, | {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4}, | 
|  |  | 
| /* misc */ | /* misc */ | 
|  | {"dp_inv_or_split",Pdp_inv_or_split,3}, | 
| {"dp_set_weight",Pdp_set_weight,-1}, | {"dp_set_weight",Pdp_set_weight,-1}, | 
| {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1}, | {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1}, | 
| {0,0,0}, | {0,0,0}, | 
| 
| Line 245  struct ftab dp_supp_tab[] = { |  | 
| Line 248  struct ftab dp_supp_tab[] = { |  | 
| {"dp_idiv",Pdp_idiv,2}, | {"dp_idiv",Pdp_idiv,2}, | 
| {"dp_tdiv",Pdp_tdiv,2}, | {"dp_tdiv",Pdp_tdiv,2}, | 
| {"dp_minp",Pdp_minp,2}, | {"dp_minp",Pdp_minp,2}, | 
|  | {"dp_compute_last_w",Pdp_compute_last_w,5}, | 
|  |  | 
| {0,0,0} | {0,0,0} | 
| }; | }; | 
|  |  | 
|  | NODE compute_last_w(NODE g,NODE gh,int n,int **v,int row1,int **m1,int row2,int **m2); | 
|  |  | 
|  | void Pdp_compute_last_w(NODE arg,LIST *rp) | 
|  | { | 
|  | NODE g,gh,r; | 
|  | VECT w,rv; | 
|  | LIST l; | 
|  | MAT w1,w2; | 
|  | int row1,row2,i,j,n; | 
|  | int *v; | 
|  | int **m1,**m2; | 
|  | Q q; | 
|  |  | 
|  | g = (NODE)BDY((LIST)ARG0(arg)); | 
|  | gh = (NODE)BDY((LIST)ARG1(arg)); | 
|  | w = (VECT)ARG2(arg); | 
|  | w1 = (MAT)ARG3(arg); | 
|  | w2 = (MAT)ARG4(arg); | 
|  | n = w1->col; | 
|  | row1 = w1->row; | 
|  | row2 = w2->row; | 
|  | if ( w ) { | 
|  | v = W_ALLOC(n); | 
|  | for ( i = 0; i < n; i++ ) v[i] = QTOS((Q)w->body[i]); | 
|  | } else v = 0; | 
|  | m1 = almat(row1,n); | 
|  | for ( i = 0; i < row1; i++ ) | 
|  | for ( j = 0; j < n; j++ ) m1[i][j] = QTOS((Q)w1->body[i][j]); | 
|  | m2 = almat(row2,n); | 
|  | for ( i = 0; i < row2; i++ ) | 
|  | for ( j = 0; j < n; j++ ) m2[i][j] = QTOS((Q)w2->body[i][j]); | 
|  | r = compute_last_w(g,gh,n,&v,row1,m1,row2,m2); | 
|  | if ( !r ) *rp = 0; | 
|  | else { | 
|  | MKVECT(rv,n); | 
|  | for ( i = 0; i < n; i++ ) { | 
|  | STOQ(v[i],q); rv->body[i] = (pointer)q; | 
|  | } | 
|  | MKLIST(l,r); | 
|  | r = mknode(2,rv,l); | 
|  | MKLIST(*rp,r); | 
|  | } | 
|  | } | 
|  |  | 
|  | void Pdp_inv_or_split(arg,rp) | 
|  | NODE arg; | 
|  | Obj *rp; | 
|  | { | 
|  | NODE gb,newgb; | 
|  | DP f,inv; | 
|  | struct order_spec *spec; | 
|  | LIST list; | 
|  |  | 
|  | do_weyl = 0; dp_fcoeffs = 0; | 
|  | asir_assert(ARG0(arg),O_LIST,"dp_inv_or_split"); | 
|  | asir_assert(ARG1(arg),O_DP,"dp_inv_or_split"); | 
|  | if ( !create_order_spec(0,(Obj)ARG2(arg),&spec) ) | 
|  | error("dp_inv_or_split : invalid order specification"); | 
|  | gb = BDY((LIST)ARG0(arg)); | 
|  | f = (DP)ARG1(arg); | 
|  | newgb = (NODE)dp_inv_or_split(gb,f,spec,&inv); | 
|  | if ( !newgb ) { | 
|  | /* invertible */ | 
|  | *rp = (Obj)inv; | 
|  | } else { | 
|  | MKLIST(list,newgb); | 
|  | *rp = (Obj)list; | 
|  | } | 
|  | } | 
|  |  | 
| void Pdp_sort(arg,rp) | void Pdp_sort(arg,rp) | 
| NODE arg; | NODE arg; | 
| DP *rp; | DP *rp; | 
|  |  | 
| b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg)); | b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg)); | 
| full = (Q)ARG3(arg) ? 1 : 0; | full = (Q)ARG3(arg) ? 1 : 0; | 
| dp_true_nf(b,g,ps,full,&nm,&dn); | dp_true_nf(b,g,ps,full,&nm,&dn); | 
|  | } | 
|  | NEWNODE(n); BDY(n) = (pointer)nm; | 
|  | NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn; | 
|  | NEXT(NEXT(n)) = 0; MKLIST(*rp,n); | 
|  | } | 
|  |  | 
|  | void Pdp_true_nf_marked(arg,rp) | 
|  | NODE arg; | 
|  | LIST *rp; | 
|  | { | 
|  | NODE b,n; | 
|  | DP *ps,*hps; | 
|  | DP g; | 
|  | DP nm; | 
|  | P dn; | 
|  | int full; | 
|  |  | 
|  | do_weyl = 0; dp_fcoeffs = 0; | 
|  | asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked"); | 
|  | asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked"); | 
|  | asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked"); | 
|  | asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked"); | 
|  | if ( !(g = (DP)ARG1(arg)) ) { | 
|  | nm = 0; dn = (P)ONE; | 
|  | } else { | 
|  | b = BDY((LIST)ARG0(arg)); | 
|  | ps = (DP *)BDY((VECT)ARG2(arg)); | 
|  | hps = (DP *)BDY((VECT)ARG3(arg)); | 
|  | dp_true_nf_marked(b,g,ps,hps,&nm,&dn); | 
| } | } | 
| NEWNODE(n); BDY(n) = (pointer)nm; | NEWNODE(n); BDY(n) = (pointer)nm; | 
| NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn; | NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn; |