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;
}
entry Schur_char_val(entry* lambda, entry* mu, lie_Index l, lie_Index m)
{ lie_Index i; entry sum=0;
while (l>0 && lambda[l-1]==0) --l; /* get reduced form of~|lambda| */
if (l<=1) return 1; /* trivial character */
if (l>lambda[0]) /* then better work with the transpose partition */
{ vector* tr=Trans_part(lambda,l);
entry ch=Schur_char_val(tr->compon,mu,lambda[0],m); freemem(tr);
return Sign_part(mu,m)*ch;
}
{ entry* lambda_prime=mkintarray(4*l)
,* sigma=lambda_prime+l,* pos=sigma+l,* nu=pos+l;
/* 4 length-|l| arrays */
boolean sg=true; /* positive sign */
copyrow(lambda,lambda_prime,l);
/* |lambda| might be alias of |mu|, but |lambda_prime| is not */
for (i=0; i<l; ++i) pos[i]=sigma[i]=i;
/* |sigma| is the permutation; |pos| records its swap sequence */
do
{ copyrow(lambda_prime,nu,l);
{ lie_Index i; for (i=1; i<l; ++i) if (nu[i]>nu[i-1]) /* skip most cases */
{ entry nui=nu[i]; lie_Index j=i;
do nu[j]=nu[j-1]; while (--j>0 && nui>nu[j-1]); nu[j]=nui;
}
}
sum+= sg ? Young_char_val(nu,mu,l,m) : -Young_char_val(nu,mu,l,m);
{ lie_Index i=0,j;
do
{
{ lambda_prime[i]-=sigma[i];
if ((j=pos[i])<i) { swap(&sigma[i],&sigma[j]); sg=!sg;}
}
do
if(--j<0) break; /* tried all positions for this |i| */
while (lambda_prime[i]+sigma[j]<0);
} while (j<0 && ++i<l);
if (i==l) break;
do /* now |j>=0| and |sigma[j]| can move validly to |sigma[i]| */
{
{ if ((pos[i]=j)<i) { swap(&sigma[i],&sigma[j]); sg=!sg;}
lambda_prime[i]+=sigma[i]; /* this becomes non-negative */
}
if (--i<0) break;
for (j=i; lambda_prime[i]+sigma[j]<0; --j) {} /* this leaves |j>=0| */
} while (true);
}
} while (true);
freearr(lambda_prime);
}
return sum;
}
matrix *mat_append_mat_mat(matrix *a, matrix *b) {
matrix *result;
_index i,n1=a->nrows,n2=b->nrows,m;
if (a->ncols != b->ncols)
error("Unequal number of columns. (%ld <-> %ld) \n",
(long)a->ncols, (long)b->ncols);
m=a->ncols;
result = mkmatrix(n1+n2,m);
for (i=0;i<n1;++i) copyrow(a->elm[i],result->elm[i],m);
for (i=0;i<n2;++i) copyrow(b->elm[i],result->elm[n1+i],m);
return result;
}
matrix* Permutations(entry* v,lie_Index n)
{ lie_Index N=1; entry* w=mkintarray(n); copyrow(v,w,n); sortrow(w,n);
{ lie_Index i=0,j=n-1; while (i<j) swap(&w[i++],&w[j--]); }
/* increasing order */
{ lie_Index i=0, mult=1;
while (++i<n) { N*=i+1; if (w[i]>w[i-1]) mult=1; else N /= ++mult; }
}
{ matrix* result=mkmatrix(N,n); lie_Index i=0;
do copyrow(w,result->elm[i++],n); while (Nextperm(w,n));
freearr(w); return result;
}
}
void wt_ins(entry* wt, bigint* c, boolean neg)
{ if (c->size==0) {
freemem(c);
return;
}
{ lie_Index i=searchterm(sorted,wt);
if (i>=0)
{ clrshared(sorted->coef[i]);
sorted->coef[i]= (neg ? sub : add)(sorted->coef[i],c);
setshared(sorted->coef[i]);
}
else
{ poly** acc= neg ? &neg_acc : &pos_acc;
lie_Index i=(*acc)->nrows;
if (i==(*acc)->rowsize)
{ sorted=Add_pol_pol(sorted,*acc,neg);
*acc=mkpoly(Max(sorted->nrows,ACCMIN),sorted->ncols);
i=0;
}
copyrow(wt,(*acc)->elm[i],sorted->ncols);
(*acc)->coef[i++]=c;
setshared(c);
(*acc)->nrows=i;
}
}
}
matrix* Schur_char(entry* lambda, lie_Index l)
{ lie_Index i,n=check_part(lambda,l); entry np=n_parts(n);
matrix* result=mkmatrix(np,n+1); entry** res=result->elm;
res[0][0]=n; for (i=1; i<n; ++i) res[0][i]=0; i=0;
while (res[i][n]=Schur_char_val(lambda,res[i],l,n),++i<np)
{ copyrow(res[i-1],res[i],n); Nextpart(res[i],n); }
return result;
}
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);
}
bigint* Orbitsize(entry* w)
{ lie_Index i,d,s=Ssrank(grp); entry* x=mkintarray(s),* y=x; bigint* result=one;
copyrow(w,x,s); make_dominant(x);
if (type_of(grp)==SIMPGRP) return simp_worbitsize(x,&grp->s);
for (i=0; i<grp->g.ncomp; ++i,y+=d)
{ simpgrp* g=Liecomp(grp,i); d=g->lierank;
result=mult(result,simp_worbitsize(y,g));
}
freearr(x); return result;
}
matrix* Partitions(lie_Index n)
{ matrix* result=mkmatrix(n_parts(n),n);
if (n>0)
{ entry* lambda=mkintarray(n),** res=result->elm; lie_Index i=0,j;
lambda[0]=n;
for(j=1;j<n;j++) lambda[j]=0; /* initialise |lambda| to $[n,0,0,\ldots]$ */
do copyrow(lambda,res[i++],n); while(Nextpart(lambda,n));
freearr(lambda);
}
return result;
}
vector* Simproot_norms(object grp)
{ if (type_of(grp)==SIMPGRP)
{ simp_proots(&grp->s); return grp->s.root_norm; }
{ _index i; for (i=0; i<grp->g.ncomp; ++i) simp_proots(Liecomp(grp,i)); }
if (grp->g.ncomp==1) return Liecomp(grp,0)->root_norm;
{ _index i,t=0; vector* result=mkvector(Ssrank(grp));
for (i=0; i<grp->g.ncomp; ++i)
{ simpgrp* g=Liecomp(grp,i); _index r=g->lierank;
copyrow(g->root_norm->compon,&result->compon[t],r); t+=r;
}
return result;
}
}
matrix* Tableaux(entry* lambda, lie_Index l)
{ bigint* nt=n_tableaux(lambda,l); lie_Index n=check_part(lambda,l);
matrix* result=mkmatrix(bigint2entry(nt),n);
entry** res=result->elm,* t=mkintarray(n);
freemem(nt);
{ lie_Index i=0,j,k;
for (j=1; j<=l; ++j) for (k=lambda[j-1]; k>0; --k) t[i++]=j;
}
{ lie_Index i=0; do copyrow(t,res[i++],n); while(Nexttableau(t,n)); }
freearr(t); return result;
}
matrix* Cartan(void)
{ if (type_of(grp)==SIMPGRP) return simp_Cartan(&grp->s);
if (simpgroup(grp)) return simp_Cartan(Liecomp(grp,0));
{ _index i,j, t=0;
matrix* cartan=mat_null(Ssrank(grp),Lierank(grp));
for (i=0; i<grp->g.ncomp; ++i)
{ _index r=Liecomp(grp,i)->lierank;
entry** c=simp_Cartan(Liecomp(grp,i))->elm;
for (j=0; j<r; ++j) copyrow(c[j],&cartan->elm[t+j][t],r);
t+=r;
}
return cartan;
}
}
local entry* simp_exponents (simpgrp* g)
{ if (g->exponents!=NULL) return g->exponents->compon;
{ static entry
exp_E[3][7] = {{4,5,7,8,11},{5,7,9,11,13,17},{7,11,13,17,19,23,29}}
, exp_F4[3] = {5,7,11};
_index i,r=g->lierank; entry* e=(g->exponents=mkvector(r))->compon;
setlonglife(g->exponents); e[0]=1;
switch (g->lietype)
{ case 'A': /* $1,2,3,\ldots,r$ */
for (i=1; i<r; ++i) e[i]=i+1;
break; case 'B': case 'C': /* $1,3,5,\ldots,2r-1$ */
for (i=1; i<r; ++i) e[i]=2*i+1;
break; case 'D': /* $1,3,5,\ldots,r-2,r-1,r,\ldots,2r-3$
or $1,3,5,\ldots,r-1,r-1,\ldots,2r-3$ */
for (i=0; 2*i+1<r; ++i) { e[i]=2*i+1; e[r-i-1]=2*(r-i)-3; }
if (2*i+1==r) e[i]=r-1;
break; case 'E': copyrow(exp_E[r-6],&e[1],r-1);
break; case 'F': copyrow(exp_F4,&e[1],3);
break; case 'G': e[1]=5;
}
return e;
}
}
matrix* Posroots(object grp)
{ if (type_of(grp)==SIMPGRP) return simp_proots(&grp->s);
if (simpgroup(grp)) return simp_proots(Liecomp(grp,0));
{ _index i,j,t1=0,t2=0;
matrix* result=mat_null(Numproots(grp),Ssrank(grp));
entry** m=result->elm;
for (i=0; i<grp->g.ncomp; ++i)
{ matrix* posr=simp_proots(Liecomp(grp,i));
_index r=Liecomp(grp,i)->lierank;
for (j=0; j<posr->nrows; ++j) copyrow(posr->elm[j],&m[t1+j][t2],r);
t1+=posr->nrows; t2+=r;
}
return result;
}
}
vector* Exponents(object grp)
{ if (type_of(grp)==SIMPGRP)
{ simp_exponents(&grp->s); return grp->s.exponents; }
if (simpgroup(grp))
{ simp_exponents(Liecomp(grp,0)); return Liecomp(grp,0)->exponents; }
{ _index i,t=0; vector* v=mkvector(Lierank(grp)); entry* e=v->compon;
{ for (i=0; i<grp->g.ncomp; ++i)
{ simpgrp* g=Liecomp(grp,i); _index r=g->lierank;
copyrow(simp_exponents(g),&e[t],r); t+=r;
}
for (i=0; i<grp->g.toraldim; ++i) e[t+i]=0;
}
return v;
}
}
local void long_close(matrix* m, lie_Index first, lie_Index last)
{ lie_Index i,j; entry* root_i,* root_j,* t=mkintarray(s);
for (i=first; i<last; ++i)
{ root_i=m->elm[i]; if (Norm(root_i)>1) continue;
for (j=i+1; j<last; ++j)
{ root_j=m->elm[j]; if (Norm(root_j)>1) continue;
subrow(root_i,root_j,t,s);
if (isroot(t))
if (isposroot(t))
{ copyrow(t,root_i,s); break; } /* need not consider more |j|'s */
else add_xrow_to(root_j,-1,root_i,s);
}
}
freearr(t);
}
poly* LR_tensor_irr(entry* lambda,entry * mu, _index n)
{ _index i,j;
entry* nu; entry** T;
if (n==0) return poly_one(0);
{ nu=&mkintarray(n+1)[1]; copyrow(lambda,nu,n); nu[-1]=lambda[0]+mu[0];
T=alloc_array(entry*,n+1);
for (i=0;i<=n;++i) /* allocate row |T[i]| and place sentinel before it */
{ T[i]= &mkintarray(mu[i==0?0:i-1]+1)[1]; T[i][-1]=n-1-i; }
for (i=0,j=mu[0]-1; j>=0; --j)
{ while (i<n && mu[i]>j) ++i; /* find first |i| with |mu[i]<=j| */
T[i][j]=-1; /* place sentinel at bottom of column |j| */
}
}
wt_init(n); /* prepare to collect terms with exponents of size~|n| */
{ j=-1; for (i=n-1; i>0 && mu[i]==0; --i) {} /* move to initial position */
recurse: /* recursive starting point; */
if (++j>=mu[i] &&(j=0,--i<0)) /* move to next empty position, if any */
wt_ins(nu,one,false); /* if not, |T| is full; contribute |nu| once */
else
{ _index k= T[i+1][j]; entry prev= nu[k];
do
{ while (nu[++k]==prev) {} /* find next |k| with |nu[k]<nu[@t$k'$@>]| */
++nu[T[i][j]=k]; goto recurse;
/* insert |k| into |T| and extend partition |nu|; recurse */
resume: prev= --nu[k=T[i][j]];
/* restore |k| and |nu|; set |prev=nu[k]| */
} while (prev>nu[T[i][j-1]]);
/* if so, there are still corners of |nu| to try */
}
if (j==0) j= ++i<n?mu[i]:0; /* return to end of row below if necessary */
if (--j>=0) goto resume; /* do return jump unless empty row is reached */
}
{ --nu; freearr(nu);
for (i=0;i<=n;i++) { entry* t=&T[i][-1]; freearr(t); }
freearr(T);
}
return wt_collect(); /* return sum of all contributed terms */
}
poly* Worbit_p(poly* p)
{ lie_Index i,k=0,l=0,r=p->ncols; poly* result; entry** res;
p=copypoly(p); for (i=0; i<p->nrows; ++i) make_dominant(p->elm[i]);
Reduce_pol(p);
for (i=0; i<p->nrows; ++i)
if ((l += bigint2entry(Orbitsize(p->elm[i])))<0)
error ("That's too large an orbit");
result=mkpoly(l,p->ncols); res=result->elm;
for (i=0; i<p->nrows; ++i)
{ lie_Index j; matrix* orbit=Weyl_orbit(p->elm[i],NULL); entry** x=orbit->elm;
for (j=0; j<orbit->nrows; ++j)
{ result->coef[k]=p->coef[i]; setshared(p->coef[i]);
copyrow(*x++,res[k++],r);
}
freemem(orbit);
}
assert(k==result->nrows);
return result; /* not sorted, but rows are unique */
}
local poly* vdecomp_irr(entry* lambda)
{ if (type_of(grp)==SIMPGRP) return simp_vdecomp_irr(lambda,&grp->s);
if (simpgroup(grp)) return simp_vdecomp_irr(lambda,Liecomp(grp,0));
{ poly* result;
lie_Index i;
{ lie_Index td=grp->g.toraldim;
lambda+=Ssrank(grp);
result=mkpoly(1,td);
copyrow(lambda,*result->elm,td);
*result->coef=one;
}
for (i=grp->g.ncomp-1; i>=0; --i)
/* traverse simple components in reverse order */
{ simpgrp* g=Liecomp(grp,i);
lambda-=g->lierank;
result= Disjunct_mul_pol_pol(simp_vdecomp_irr(lambda,g),result);
}
return result;
}
}
vector* Highroot(simpgrp* g)
{ matrix* posr=simp_proots(g); _index r=g->lierank; vector* high=mkvector(r);
copyrow(posr->elm[posr->nrows-1],high->compon,r); return 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;
}
}
