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;
}
}
