matrix* Weyl_root_orbit(entry* v)
{ lie_Index i,j,r=Lierank(grp),s=Ssrank(grp);
entry* x=mkintarray(r); matrix* orbit, *result; entry** m;
lie_Index dc=Detcartan();
mulvecmatelm(v,Cartan()->elm,x,s,r);
orbit=Weyl_orbit(x,NULL);
result=mkmatrix(orbit->nrows,s); m=result->elm;
mulmatmatelm(orbit->elm,Icartan()->elm,m,orbit->nrows,s,s);
freemem(orbit);
for (i=0; i<result->nrows; ++i)
for (j=0; j<s; ++j) m[i][j]/=dc;
return result;
}
static void set_simp_adjoint(entry* dst,simpgrp* g)
{ _index r=g->lierank; vector* high=Highroot(g);
mulvecmatelm(high->compon,g->cartan->elm,dst,r,r); freemem(high);
}
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;
}
}