matrix* Unique(matrix* m, cmpfn_tp criterion) { lie_Index len=m->ncols; register entry** to=m->elm,** from=to,** end=to+m->nrows; if (m->nrows<2) return m; heap_sort_m(m,criterion); while (!eqrow(*++from,*to,len)) if (++to==end-1) return m; while (++from<end) if (!eqrow(*from,*to,len)) swap_rows(++to,from); m->nrows=to+1-m->elm; return m; }
matrix* Weyl_orbit(entry* v, matrix** orbit_graph) { lie_Index i,j,k,r=Lierank(grp),s=Ssrank(grp); matrix* result; entry** m; lie_Index level_start=0, level_end=1, cur=1; { entry* lambda=mkintarray(r); copyrow(v,lambda,r); make_dominant(lambda); result=mkmatrix(bigint2entry(Orbitsize(lambda)),r); copyrow(lambda,result->elm[0],r); freearr(lambda); if (orbit_graph!=NULL) *orbit_graph=mkmatrix(result->nrows,s); } m=result->elm; while (level_start<level_end) { for (k=level_start; k<level_end; ++k) for (i=0; i<s; ++i) if (m[k][i]>0) /* only strictly cross walls, and from dominant side */ { w_refl(m[k],i); for (j=level_end; j<cur; ++j) if (eqrow(m[k],m[j],s)) break; if (orbit_graph!=NULL) { (*orbit_graph)->elm[k][i]=j; (*orbit_graph)->elm[j][i]=k; } if (j==cur) { assert(cur<result->nrows); copyrow(m[k],m[cur++],r); } w_refl(m[k],i); } else if (m[k][i]==0 && orbit_graph!=NULL) (*orbit_graph)->elm[k][i]=k; level_start=level_end; level_end=cur; } return result; }
lie_Index searchterm(poly* p, entry* t) { lie_Index l=0, u, len=p->ncols; entry** expon; cmpfn_tp cmp=set_ordering(cmpfn,len,defaultgrp); if (!issorted(p)) { p=Reduce_pol(p); } u=p->nrows; expon=p->elm; while (u-l>1) { lie_Index m=(u+l)/2; cmp_tp c=(*cmp)(expon[m],t,len); if (c<0) u=m; else if (c>0) l=m+1; else return m; } return l<u && eqrow(expon[l],t,len) ? l : -1; }
local void fundam(matrix* roots, lie_Index first, lie_Index* last) { lie_Index i,j,d; boolean changed; entry* t=mkintarray(s); matrix mm,* m=&mm; mm.elm=&roots->elm[first]; mm.nrows=*last-first; mm.ncols=roots->ncols; for (i=m->nrows-1; i>0; changed ? Unique(m,cmpfn),i=m->nrows-1 : --i) { entry* root_i=m->elm[i]; changed=false; for (j=i-1; j>=0; j--) { entry* root_j=m->elm[j]; entry c=Cart_inprod(root_j,root_i); if (c==2 && eqrow(root_j,root_i,s)) { cycle_block(m,j,m->nrows--,1); root_i=m->elm[--i]; } else if (c>0) { changed=true; { copyrow(root_j,t,s); add_xrow_to(t,-c,root_i,s); if (isposroot(t)) copyrow(t,root_j,s); else { j=i; c=Cart_inprod(root_i,root_j); copyrow(root_i,t,s); add_xrow_to(t,-c,root_j,s); if (isposroot(t)) copyrow(t,root_i,s); else { lie_Index k; entry* ln,* sh; /* the longer and the shorter root */ if (Norm(root_i)>Norm(root_j)) ln=root_i, sh=root_j; else ln=root_j, sh=root_i; switch (Norm(ln)) { case 2: subrow(ln,sh,sh,s); /* |sh=ln-sh| */ add_xrow_to(ln,-2,sh,s); /* |ln=ln-2*sh| */ break; case 3: /* |grp=@t$G_2$@>| now */ for (k=0; sh[k]==0; ++k) {} /* find the place of this $G_2$ component */ sh[k]=1; sh[k+1]=0; ln[k]=0; ln[k+1]=1; /* return standard basis of full system */ break; default: error("problem with norm 1 roots\n"); } } } } } } } cycle_block(roots,first+mm.nrows,roots->nrows,d=*last-first-mm.nrows); *last-=d; roots->nrows-=d; freearr(t); }
poly* Reduce_pol(poly* p) { entry** expon=p->elm; bigint** coef=p->coef; lie_Index t=0,f=0,len=p->ncols; heap_sort_p(p,cmpfn); /* don't exclude cases~$<2$: we must catch $0$-polynomials */ while (++f<p->nrows) if (coef[f]->size==0) clrshared(coef[f]); /* drop term with zero coef */ else if (eqrow(expon[f],expon[t],len)) /* equal exponents: add coef's */ { clrshared(coef[t]); clrshared(coef[f]); coef[t]=add(coef[t],coef[f]); setshared(coef[t]); } else /* now term at f replaces one at t as discriminating term */ { if (coef[t]->size) t++; else clrshared(coef[t]); /* keep if nonzero */ swap_terms(expon,coef,t,f); /* move term, preserve row separateness */ } if (p->nrows!=0) /* |p| mights have no terms at all (e.g. from |alt_dom|). */ if (coef[t]->size) t++; else clrshared(coef[t]); /* handle final term */ else *coef=copybigint(null,NULL); /* safer not to introduce aliasing */ if ((p->nrows=t)==0) /* then must keep last term; coef is cleared */ { lie_Index i; p->nrows=1; setshared(*coef); /* |*coef| was |0| but not shared */ for (i=0; i<len; i++) expon[0][i]=0; /* clear first exponent as well */ } setsorted(p); return p; }
_index find_root(entry* alpha, entry level, simpgrp* g) { _index i,r=g->lierank; matrix* posr=simp_proots(g); for (i=g->level->compon[level-1]; i<g->level->compon[level]; ++i) if (eqrow(alpha,posr->elm[i],r)) return i; return -1; /* not found */ }
matrix* simp_proots(simpgrp* g) { if (g->roots!=NULL) return g->roots; { _index r=g->lierank,l,i,last_root; entry** cartan=simp_Cartan(g)->elm; entry** posr=(g->roots=mkmatrix(simp_numproots(g),r))->elm; entry* level=(g->level=mkvector(simp_exponents(g)[r-1]+1))->compon; entry* norm=(g->root_norm=mkvector(g->roots->nrows))->compon; entry* alpha_wt=mkintarray(r); /* space to convert roots to weight coordinates */ setlonglife(g->roots), setlonglife(g->level), setlonglife(g->root_norm); /* permanent data */ { _index i,j; for (i=0; i<r; ++i) for (j=0; j<r; ++j) posr[i][j] = i==j; level[0]=0; last_root=r; for (i=0; i<r; ++i) norm[i]=1; /* norms are mostly |1| */ switch (g->lietype) /* here are the exceptions */ { case 'B': for (i=0; i<r-1; ++i) norm[i]=2; /* $2,2,\ldots,2,1$ */ break; case 'C': norm[r-1]=2; /* $1,1,\ldots,1,2$ */ break; case 'F': norm[0]=norm[1]=2; /* $2,2,1,1$ */ break; case 'G': norm[1]=3; /* $ 1,3$ */ } } for (l=0; last_root>level[l]; ++l) { level[l+1]=last_root; /* set beginning of a new level */ for (i=level[l]; i<level[l+1]; ++i) { _index j,k; entry* alpha=posr[i]; mulvecmatelm(alpha,cartan,alpha_wt,r,r); /* get values $\<\alpha,\alpha_j>$ */ for (j=0; j<r; ++j) /* try all fundamental roots */ { entry new_norm; { if (alpha_wt[j]<0) /* then $\alpha+\alpha_j$ is a root; find its norm */ if (norm[j]==norm[i]) new_norm=norm[j]; /* |alpha_wt[j]==-1| */ else new_norm=1; /* regardless of |alpha_wt[j]| */ else if (norm[i]>1 || norm[j]>1) continue; /* both roots must be short now */ else if (strchr("ADE",g->lietype)!=NULL) continue; /* but long roots must exist */ else if (alpha_wt[j]>0) if (g->lietype!='G'||alpha_wt[j]!=1) continue; else new_norm=3; /* $[2,1]\to[3,1]$ for $G_2$ */ else if (alpha[j]==0) continue; /* $\alpha-\alpha_j$ should not have a negative entry */ else { { --alpha[j]; for (k=level[l-1]; k<level[l]; ++k) if (eqrow(posr[k],alpha,r)) break; ++alpha[j]; if (k==level[l]) continue; } new_norm=2; } } ++alpha[j]; /* temporarily set $\alpha\K\alpha+\alpha_j$ */ for (k=level[l+1]; k<last_root; ++k) if (eqrow(posr[k],alpha,r)) break; /* if already present, don't add it */ if (k==last_root) { norm[last_root]=new_norm; copyrow(alpha,posr[last_root++],r); } --alpha[j]; /* restore |alpha| */ } } } freearr(alpha_wt); return g->roots; } }