//z will be the square root of q //K:=FunctionField(GF(1123)); //n :=4; dmax := 0; KP:=PolynomialRing(GF(1123),1); PR<[y]>:=PolynomialRing(GF(1123),n); K := FieldOfFractions(KP); h := hom GF(1123)|1>; //PX<[x]> := PolynomialRing(GF(1123),n); G := PermutationGroup; name := "A~" cat IntegerToString(n-1); //Type for the extended Weyl group, pi generates the subgroup of length 0 elements. WeType := recformat; //Type for sequence of extended Weyl groups, producted over parabolic subgroups. IndElementType:= recformat; We := rec; function modd(k,n) return ((k-1) mod n) +1; end function; function Shift(w,k,n) return [modd(w[i]+k,n): i in [1..#w]]; end function; procedure InitWe(myname, ~We) We`AG := CoxeterGroup(myname); We`name := myname; We`n := #(Generators(We`AG)); We`S := [1..We`n]; We`pi := map We`S | [:i in [1..#(We`S)]]>; We`G := StandardParabolicSubgroup(We`AG, {1..(We`n)-1}); We`GfAG := homWe`AG | [We`AG.i : i in [1..(We`n)-1]]>; We`RG, We`f := ReflectionGroup(We`G); end procedure; procedure InitInd(groups,parabolics,~IT); IT`groups := groups; IT`parabolics := parabolics; IT`ng := #groups; end procedure; procedure ShrinkIndType(~IndType,k) if k ne IndType`ng then Remove(~(IndType`groups),k); Remove(~(IndType`parabolics),k); else Remove(~(IndType`parabolics),k-1); Remove(~(IndType`groups),k); end if; IndType`ng:=IndType`ng-1; end procedure; InitWe(name, ~We); //returns a subspace of V corresponding to the the list of rows given function subsub(V,VV,rows) M := Morphism(V,VV); return sub; end function; //given a matrix M, return a list of M's rows function RowSequence(M) return [[M[i][c] : c in [1..NumberOfColumns(M)]] : i in [1..NumberOfRows(M)]]; end function; function VecToList(M) return [M[c] : c in [1..NumberOfColumns(M)]]; end function; //construct an nn by nn identity matrix over field F function IdentityMatrix(nn,F) return Matrix([[r eq c select F!1 else F!0: c in [1..nn]] : r in [1..nn]]); end function; //given a vector v and a list of vectors vlist, return the coordinates of v in terms vlist //probably assumes v lies in vlist function ProjectSub(v, vlist) M := Matrix(vlist); // if Type(v) ne Type(Vector([1,1])) then v := Vector(v); // end if; ans := v*Transpose(M)*(M * Transpose(M))^(-1); if ans*M ne v then print "not in subspace"; return 0; end if; return ans; end function; function ProjectSubFast(v, MM) return Vector(v)*MM; end function; //return the multidegree of a monomial p function MDeg(p,nn) return [Degree(p,i): i in [1..nn]]; end function; //q arithmetic functions***************************************************************************** function qN(nn) nn := Integers()!nn; if nn eq 1 then return K!1; else return (&+[z^(2*k) : k in [0..nn-1]])/z^(nn-1) ; end if; end function; function qFact(n) n := Integers()!n; return (&*[(&+[z^(2*k) : k in [0..nn-1]])/z^(nn-1) : nn in [1..n]]); end function; function qBinom(n,k) n := Integers()!n; k := Integers()!k; return qFact(n)/(qFact(k)*qFact(n-k)); end function; function hh(M) M := Matrix(M); return Matrix([[ h(M[r][c]):c in [1..NumberOfColumns(M)] ]: r in [1..NumberOfRows(M)]]); end function; function MyHomComp(p,d) p := KP!(p*z^(1000)); np := HomogeneousComponent(p,d+1000); return K!(np*z^(-1000)); end function; function GetTerm(p,d) p := KP!(p*z^(1000)); np := HomogeneousComponent(p,d+1000); return KP!(np/(z^(d+1000))); end function; //********************************************************************************************* load "combinatorics.txt"; //returns y1^p[1]...yn^p[n] to an extended affine Weyl group element function ytoAG(p, We) if We`name[1] eq "A" then y1 := <1, &*[We`AG.i:i in [(We`n)-1..1 by -1]]>; end if; //deg1 will be [y1 y2...yn] deg1 := [y1]; for i in [1..(We`n)-1] do Append(~deg1, WeMult(We`AG.i, WeMult(deg1[i], We`AG.i, We), We)); end for; //print "in ytoAG and printing p",p; return WeListMult([YesPi(WeListMult([deg1[i]:j in [1..p[i]]], We), We):i in [1..We`n]], We); end function; //converts basis labels of type to function yGtoAG(basis, We) try temp := basis[1][1][1][1]; catch e print "error caught"; print "timing in yGtoAG and basis",basis; mons:=SetToIndexedSet({basis[i][1]:i in [1..#basis]}); ytoAGList:=[ytoAG(mons[i],We):i in [1..#mons]]; time return [YesPi(WeMult(ytoAGList[Position(mons,basis[i][1])], We`GfAG(basis[i][2]), We), We): i in [1..#basis]]; end try; return [[YesPi(WeMult(ytoAG(basis[i][j][1], We), We`GfAG(basis[i][j][2]), We), We):j in [1..#(basis[i])]]: i in [1..#basis]]; end function; function AGtoWord(basis, We) try temp := basis[1][1][1]; catch e return [:i in [1..#basis]]; end try; return [[: j in [1..#(basis[i])]]:i in [1..#basis]]; end function; //*************************************construct Hecke Algebra ****************************** forward ModifyBasis; forward LeftMultTs; //structure and functions to support basis labels and T actions***************************** RFBasis := recformat; //if ghost, then create the structure without any of the matrix computations procedure InitBasis(ldeg,hdeg,~recb,type,IndType:trivial := false,ghost:=false) recb`type := type; recb`IndType := IndType; if trivial then recb`y := []; recb`t := #(recb`y); recb`AG := yGtoAG(recb`y, We); recb`Word := AGtoWord(recb`AG, We); ModifyBasis(~recb); recb`ActT := [ Transpose(Matrix([[K!z]])): s in [1..We`n-1]]; else mons := [MonomialsOfDegree(PR,d) : d in [ldeg..hdeg]]; recb`y := &cat[[: i in [1..#(mons[d])],g in We`RG]: d in [1..(hdeg-ldeg+1)]]; recb`t := #(recb`y); recb`AG := yGtoAG(recb`y, We); recb`Word := AGtoWord(recb`AG, We); ModifyBasis(~recb); if ghost then recb`ActT := [IdentityMatrix(recb`t,K):s in [1..We`n-1]]; else recb`ActT := [Transpose(Matrix([LeftMultTs(s,We,i,recb): i in [1..#(recb`y)]])) :s in [1..We`n-1]]; end if; end if; recb`Length := [Length(recb`AG[i][1][2]):i in [1..recb`t]]; if trivial then recb`Length := [0]; end if; // recb`ActT := [ Transpose(Matrix([LeftMultTs(1,We,i,recb): i in [1..recb`t]])), // Transpose(Matrix([LeftMultTs(2,We,i,recb): i in [1..recb`t]]))]; recb`ActC := [recb`ActT[s] + z^(-1)*IdentityMatrix(recb`t,K) :s in [1..We`n-1]]; end procedure; //returns the index of the basis element b function GetIndex(recb,b) try p := Position(recb`AG,b); catch e p := Position(recb`AG,[b]); end try; return p; end function; function LengthCompare(a,b) if a[2] ne b[2] then return a[2]-b[2]; else return a[3]-b[3]; end if; end function; procedure ReorderBasis(~recb) templength:=[:i in [1..recb`t]]; Sort(~templength,LengthCompare); recb`y := [recb`y[templength[i][1]]:i in [1..recb`t]]; recb`AG := [recb`AG[templength[i][1]]:i in [1..recb`t]]; recb`Word := [recb`Word[templength[i][1]]:i in [1..recb`t]]; recb`Length:= [recb`Length[templength[i][1]]:i in [1..recb`t]]; actt:=true; try temp:=#recb`ActT; catch e actt:=false; end try; if actt then M := Matrix([[templength[i][1] eq j select 1 else 0 :i in [1..recb`t]]:j in [1..recb`t]]); recb`ActT:=[M^(-1)*recb`ActT[s]*M:s in [1..#recb`ActT]]; recb`ActC:=[M^(-1)*recb`ActC[s]*M:s in [1..#recb`ActC]]; end if; end procedure; //form the quotient module obtained by restricting to the basis elements in index set procedure MyQuotientModule(~recb,indexset) indexset:=Sort(SetToIndexedSet(indexset)); print "printing indexset",indexset; for s in [1..#(recb`ActC)] do x := (&+[recb`ActC[s][i][j]:i in indexset,j in [1..recb`t]| not j in indexset]); if x ne K!0 then print "WARNING!!! :This is not a quotient!"; end if; end for; recb`t:=#indexset; myN:=#(recb`ActC); recb`ActT:=[Matrix([[recb`ActT[s][r][c]:c in indexset]:r in indexset]):s in [1..myN]]; recb`ActC:=[Matrix([[recb`ActC[s][r][c]:c in indexset]:r in indexset]):s in [1..myN]]; print "printing recb ActC",recb`ActC; try recb`TtoC:=Matrix([[recb`TtoC[r][c]:c in indexset]:r in indexset]); catch e temp:=1; end try; recb`y := [recb`y[i]:i in indexset]; recb`AG := [recb`AG[i]:i in indexset]; recb`Word := [recb`Word[i]:i in indexset]; recb`Length:= [recb`Length[i]:i in indexset]; end procedure; //form the submodule obtained by restricting to the basis elemetns in indexset procedure MySubModule(~recb,indexset) indexset:=Sort(SetToIndexedSet(indexset)); for s in [1..#recb`ActC] do if &+[recb`ActC[s][i][j]:j in indexset,i in [1..recb`t] | not i in indexset] ne K!0 then print "WARNING!!! :This is not a submodule!"; end if; end for; recb`t:=#indexset; myN:=#(recb`ActC); recb`ActT:=[Matrix([[recb`ActT[s][r][c]:c in indexset]:r in indexset]):s in [1..myN]]; recb`ActC:=[Matrix([[recb`ActC[s][r][c]:c in indexset]:r in indexset]):s in [1..myN]]; try recb`TtoC:=Matrix([[recb`TtoC[r][c]:c in indexset]:r in indexset]); catch e temp:=1; end try; recb`y := [recb`y[i]:i in indexset]; recb`AG := [recb`AG[i]:i in indexset]; recb`Word := [recb`Word[i]:i in indexset]; recb`Length:= [recb`Length[i]:i in indexset]; end procedure; procedure ModifyBasis(~recb) recb`y:=[[recb`y[a]]:a in [1..recb`t]]; recb`AG:=[[recb`AG[a]]:a in [1..recb`t]]; recb`Word:=[[recb`Word[a]]:a in [1..recb`t]]; end procedure; //given a basis label b and an element g of We, return a label for g \tsr b function InduceLabel(g,b) gb := Insert(b,1,g); return gb; end function; //given a basis label g \tsr b of an induced module return function UnInduceLabel(gb) g := gb[1]; b := Remove(gb,1); return ; end function; //end RFBasis stuff************************************************************************** forward CollapseInduced; forward CombCollapseInduced; forward PrintCells; forward PiMult; forward MinCosets; //left multiply by the element T_s, T_s is really (T_s)^hat //returns an element of the group algebra //C is the Coxeter group, g is an element of the group algebra //remember that magma multiplies group elements the opposite of usual way, here left refers to the T_s*T_G in the usual order function LeftMultTs(s,We,i,recbasis) result := [K!0: j in [1..recbasis`t]]; basis := recbasis`AG; g := basis[i][1]; if s in WeLeftDescentSet(g, We) then //print GetIndex(recbasis,g),GetIndex(recbasis,WeMult(We`AG.s, g, We)); result[GetIndex(recbasis,WeMult(We`AG.s, g, We))] := 1; result[GetIndex(recbasis,g)] := (z-z^(-1)); else result[GetIndex(recbasis,WeMult(We`AG.s, g, We))] := 1; //print GetIndex(recbasis,WeMult(We`AG.s, g, We)); end if; return result; end function; function DegChange(g,k) g[1][1]:=g[1][1]+k; return g; end function; procedure ComputeCanBas(recb, We,~CanBas) for i in [1..recb`t] do //g is an element of We g:= recb`AG[i][1]; if #(recb`AG[i]) ne 1 then print "Unexpected behavior in ComputeCanBas"; end if; if not WeLeftDescentSet(g,We) subset {n} and GetIndex(recb,) eq 0 then s := [i:i in WeLeftDescentSet(g,We)][1]; j := GetIndex(recb, WeMult(We`AG.s, g, We)); print "s",s,"g",g; print WeMult(We`AG.s, g, We); print j; if CanBas[j] eq Vector([K!0 :i in [1..recb`t]]) then print "yikes"; end if; cbas := CanBas[j]*Transpose(recb`ActC[s]); coef := [MyHomComp(cbas[i], 0):i in [1..recb`t]]; cbas -:= &+[coef[i]*CanBas[i]:i in [1..recb`t]]; CanBas[i]:=cbas; else if GetIndex(recb,) ne 0 then p:= GetIndex(recb,); cbas:=CanBas[p]; //WARNING:probably only works in type A for k in [1..recb`t] do gg := recb`AG[k]; if cbas[k] ne 0 then CanBas[i][GetIndex(recb,DegChange(gg,1))] := cbas[k]; end if; end for; else print "canonical basis of ", g, " should be trivial!"; cbas:=Vector([K!0 :i in [1..recb`t]]); cbas[i]:=1; CanBas[i]:=cbas; end if; end if; end for; //print CanBas; //return CanBas; end procedure; function FundWeights() //Warning: only works in Type A fweights:=[Vector([j gt i select 0 else 1:j in [1..We`n]]):i in [1..We`n]]; return Transpose(Matrix(fweights)); end function; function CloseDown(ld) ld2:={}; for i in [1..#ld] do ld2:=ld2 join LengthDownOne(ld[i],We:descents:=true); end for; return SetToIndexedSet(ld2); end function; function GetNonCrossing(We:noncrossingonly:=false,yform:=false) //Warning: only works in Type A fweights:=[Vector([j gt i select 0 else 1:j in [1..We`n]]):i in [1..We`n]]; print "fweights",fweights; wnoncrossing := []; for g in We`RG do yy := &+([fweights[i]:i in LeftDescentSet(We`G,g@@We`f)] cat [Vector([0:k in [1..We`n]])]); if yform then yy:=; else gg := WeMult(ytoAG(yy,We) ,We`GfAG(g@@We`f),We); w := PushPiRight(gg,We); end if; Append(~wnoncrossing, ); end for; //given a list of We elements, return all elements in We <= the given ones //the option in LengthDownOne makes sure only those guys with R(w) = {0} are taken if not noncrossingonly then temp:=CloseDown(wnoncrossing); while #temp ne 0 do newguys := [x : x in temp |not x in wnoncrossing]; wnoncrossing := SetToIndexedSet({x: x in wnoncrossing}) join temp; temp := CloseDown(newguys); end while; end if; return wnoncrossing; end function; //assumes that recb is has a basis of the form T_w tsr C_i and seedrec has all the data about the C_i //appears to only be called with noncrossing:=false, so maybe delete this procedure ComputeIndCanBas(recb, seedrec,We,~CanBas : noncrossing:=false) if noncrossing then wnoncrossing:=GetNonCrossing(We); end if; for i in [1..recb`t] do //g is a sequence of elements in We g:= recb`AG[i]; gb := UnInduceLabel(g); if not noncrossing or gb[1] in wnoncrossing then print "about to compute canonical basis for g",g; if gb[1] eq <0,Id(We`AG)> and GetIndex(seedrec,gb[2]) ne 0 then if seedrec`type[1] eq "T" then print "can't handle this case for seedrec"; end if; if seedrec`type[1] eq "C" then cbas:=Vector([K!0 :i in [1..recb`t]]); cbas[i]:=1; CanBas[i]:=cbas; end if; //print "can't compute canonical basis of" , g; else D:= WeLeftDescentSet(gb[1],We); if not D subset {We`n} and GetIndex(recb,DegChange(g,-1)) eq 0 then s := SetToIndexedSet(D)[1]; gg := WeIndMult(s,g,recb`IndType,We); j := GetIndex(recb,gg); print "Compute IndCanBas","s",s,"g",g,"gg",gg; if CanBas[j] eq Vector([K!0 :i in [1..recb`t]]) then print "yikes"; end if; cbas := CanBas[j]*Transpose(recb`ActC[s]); coef := [MyHomComp(cbas[i], 0):i in [1..recb`t]]; cbas -:= &+[coef[i]*CanBas[i]:i in [1..recb`t]]; CanBas[i]:=cbas; else if GetIndex(recb,DegChange(g,-1)) ne 0 then p:= GetIndex(recb,DegChange(g,-1)); cbas:=CanBas[p]; //WARNING:probably only works in type A for k in [1..recb`t] do gg := recb`AG[k]; if cbas[k] ne 0 then print "gg",gg; print "cbas k", cbas[k]; CanBas[i][GetIndex(recb,DegChange(gg,+1))] := cbas[k]; end if; end for; end if; end if; end if; end if; print "Canonical basis for",g,"computed: ",CanBas[i]; end for; end procedure; function ConvertBasisType(type,We,recs,... : noncross:=false) recb := recs[1]; if recb`type[1] eq "T" and type eq "C" then //ReorderBasis(~recb); MyCanBas := [Vector([K!0 :i in [1..recb`t]]):i in [1..recb`t]]; if #recb`type gt 1 and recb`type[2] eq "Induced" then print "this is an unfinished case in ConvertBasisType"; ComputeIndCanBas(recb,We,~MyCanBas); print "Printing MyCanBas",MyCanBas; else ComputeCanBas(recb,We,~MyCanBas); end if; MyCanBas := Transpose(Matrix(MyCanBas)); recb`ActT := [MyCanBas^(-1)*recb`ActT[s]*MyCanBas:s in [1..#recb`ActT]]; recb`ActC := [recb`ActT[s] + z^(-1)*IdentityMatrix(recb`t,K) :s in [1..#recb`ActT]]; recb`Length := [0 : i in [1..recb`t]]; recb`type[1] := type; recb`TtoC := MyCanBas; return recb; end if; //assumes recb is the Ind_W_J (seedrec), where seedrec is of type C seedrec := recs[2]; if recb`type[1] eq "TC" and type eq "C" and seedrec`type[1] eq "C" then //ReorderBasis(~recb); MyCanBas := [Vector([K!0 :i in [1..recb`t]]):i in [1..recb`t]]; ComputeIndCanBas(recb,seedrec,We,~MyCanBas); MyCanBas := Transpose(Matrix(MyCanBas)); if noncross then time alldescents := [WeIndLeftDescentSet(recb`AG[r],recb`IndType,We):r in [1..recb`t]]; print "is time for alldescents"; for s in [1..#recb`ActT] do descents := [s in alldescents[r]:r in [1..recb`t]]; P := RowSequence((z+z^(-1))*IdentityMatrix(recb`t,K)); //C_s*C_w=C_(sw)+sum_(v s.t s in L(v))[C_v * mu(v,w)] //N corresponds to the first term and M to the second term M := [[descents[c] select K!(1)*GetTerm(MyCanBas[c][r],-1) else K!0:c in [1..recb`t]]:r in [1..recb`t]]; time gg := [WeIndMult(s,recb`AG[r],recb`IndType,We):r in [1..recb`t]]; print "is time for WeIndMult comp. in convertbasis"; j := [GetIndex(recb,gg[r]):r in [1..recb`t]]; N := [[j[r] eq c select K!1 else K!0 :c in [1..recb`t]]:r in [1..recb`t]]; MN := RowSequence(Matrix(M)+Matrix(N)); recb`ActC[s] := Transpose(Matrix([descents[r] select P[r] else MN[r]:r in [1..recb`t]])); end for; recb`ActT := [recb`ActC[s] - z^(-1)*IdentityMatrix(recb`t,K) :s in [1..#recb`ActT]]; else //print "Printing MyCanBas",MyCanBas; recb`ActT := [MyCanBas^(-1)*recb`ActT[s]*MyCanBas:s in [1..#recb`ActT]]; recb`ActC := [recb`ActT[s] + z^(-1)*IdentityMatrix(recb`t,K) :s in [1..#recb`ActT]]; end if; recb`Length := [0 : i in [1..recb`t]]; recb`type[1] := type; recb`TtoC := MyCanBas; return recb; end if; if recb`type[1] eq "TC" and type eq "Y" and seedrec`type[1] eq "C" then output := []; PM := PiMult(recb,We); PMi := PiMult(recb,We:inverse:=true); M:= (K!z)*IdentityMatrix(recb`t,K); Tzero:=PM*recb`ActT[We`n-1]*PMi; ys := [CochargeLabel(ListPerm(g@@We`f,We)): g in We`RG]; print "ys",ys; //Ys is an array of pairs such that Y^(w1^-1w2) = T_(w1)^-1T_(w2) FW:=FundWeights(); FWi:=FW^(-1); temp:=[RowSequence(Transpose(FWi*Transpose(Matrix([x]))))[1]:x in ys]; print "Temp",temp; temp:=[<[k lt 0 select -k else 0:k in x],[k gt 0 select k else 0:k in x]>:x in temp]; print "Temp2",temp; Ys:=[:x in temp]; print "Ys",Ys; for a in Ys do v2 := Reverse(PushPiRight(,We)); v1:= GetWord(We`AG,a[1][2]); vec:=Transpose(Matrix([[recb`AG[i][1] eq select K!1 else K!0 :i in [1..recb`t]]])); for s in v2 do tvec := vec; if s eq We`n then vec:=Tzero*vec; else vec:=recb`ActT[s]*vec; end if; if vec eq Transpose(Matrix([[K!0 : i in [1..recb`t]]])) then print s,a; print tvec; end if; end for; for s in v1 do if s eq We`n then vec:=(Tzero+(z^(-2)-1)*M)*vec; else vec:=(recb`ActC[s]-M)*vec; end if; end for; Append(~output,RowSequence(Transpose(vec))[1]); end for; recb`TtoY:=Transpose(Matrix(output)); recb`type[1]:=type; return recb; end if; return 0; end function; function PrintNice (CanBas,i,recb,opt) output:=[* *]; print "Canonical Basis for",recb`AG[i],recb`y[i]; for k in [1..#CanBas] do if CanBas[i][k] ne 0 then if opt eq "AG" then Append(~output,); end if; if opt eq "y" then Append(~output,); end if; end if; end for; return output; end function; function PrintMatrix (M,rlabel,clabel,c) output:=[* *]; for r in [1..NumberOfRows(M)] do if M[r][c] ne 0 then Append(~output,); end if; end for; return [* clabel[c], "goes to", output *]; end function; //Given a parabolic subgroup W_J of W_e, return a list of elements x s.t. x //is minimal in its coset xW_J //if W_e is an extended affine Weyl group with degree, only return those x with ldeg<=deg(x)<=hdeg function MinCosets(ldeg,hdeg,J,We,opt:noncrossing:=false) if noncrossing then wnoncrossing:=GetNonCrossing(We); else mon:=[MonomialsOfDegree(PR,d):d in [ldeg..hdeg]]; ymincosets:=&cat[&cat[[ :i in [1..#(mon[d])]] :g in We`RG]:d in [1..hdeg-ldeg+1]]; print "timing yGtoAG"; time mincosets := yGtoAG(ymincosets,We); end if; if opt eq "y" then if noncrossing then //WARNING: this is a cheat for now, hoping replacing ys with AG shouldnt mess stuff up return [x:x in wnoncrossing | x[1] ge ldeg and hdeg ge x[1]]; else return [ymincosets[i]:i in [1..#ymincosets]|WeRightDescentSet(mincosets[i],We) meet J eq {}]; end if; end if; if opt eq "AG" then if noncrossing then mincosets:= [x:x in wnoncrossing | x[1] ge ldeg and hdeg ge x[1]]; else mincosets:=[mc:mc in mincosets|WeRightDescentSet(mc,We) meet J eq {}]; end if; return mincosets; end if; return 0; end function; procedure UpdateResult(~result,i,value) if i ne 0 then result[i]:=value; end if; end procedure; //g is a label of a basis element of recbasis //return a vector that is T_s times g function InduceHelper(s,g,b,nrecb,recb,J,We) result := [K!0: j in [1..nrecb`t]]; gg,t := MinCosetFactorShort(s,g,J,We); if s in WeLeftDescentSet(g, We) then UpdateResult(~result,GetIndex(nrecb,InduceLabel(gg,b)),1); UpdateResult(~result,GetIndex(nrecb,InduceLabel(g,b)),(z-z^(-1))); else if #t eq 0 then UpdateResult(~result,GetIndex(nrecb,InduceLabel(gg,b)),1); else temp := Vector([i eq GetIndex(recb,b) select K!1 else K!0:i in [1..recb`t]])*Transpose(recb`ActT[t[1]]); for i in [1..NumberOfColumns(temp)] do UpdateResult(~result,GetIndex(nrecb,InduceLabel(gg,recb`AG[i])),temp[i]); end for; end if; end if; print "in inducehelper printing s,g,b,result",s,g,b,result; return result; end function; //Given a basis for an H_n module with matrices act`T defining the module structure, //determine a basis index for the induced module and matrices act`T for the action //if ghost then make a recb structure without any of the large matrix computations function Induce(recb,ldeg,hdeg,J,We:noncross:=false,ghost:=false) nrecb := recb; //mincosets := MinCosets(ldeg, hdeg, J, We,"y":noncrossing:=noncross); //nrecb`y := [InduceLabel(g,recb`y[b]): g in mincosets, b in [1..recb`t]]; mincosets := MinCosets(ldeg, hdeg, J, We,"AG":noncrossing:=noncross); nrecb`AG := [InduceLabel(g,recb`AG[b]): g in mincosets, b in [1..recb`t]]; nrecb`y:=nrecb`AG; nrecb`t := #(nrecb`y); nrecb`Word := AGtoWord(nrecb`AG, We); nrecb`Length := [Length(g[2])+recb`Length[b]: g in mincosets, b in [1..recb`t]]; nrecb`ActT := []; if not ghost then for s in [1..We`n-1] do Append(~(nrecb`ActT), Transpose(Matrix([InduceHelper(s,g,recb`AG[b],nrecb,recb,J,We): g in mincosets, b in [1..recb`t]]))); end for; nrecb`ActC := [nrecb`ActT[s] + z^(-1)*IdentityMatrix(nrecb`t,K) :s in [1..We`n-1]]; nrecb`TtoC := []; else nrecb`ActT := [IdentityMatrix(nrecb`t,K) :s in [1..We`n-1]]; nrecb`ActC := [IdentityMatrix(nrecb`t,K) :s in [1..We`n-1]]; end if; //update labels nrecb`IndType`ng:=nrecb`IndType`ng+1; Insert(~(nrecb`IndType`groups),1,We); Insert(~(nrecb`IndType`parabolics),1,J); if nrecb`type[1] eq "C" then nrecb`type[1] := "TC"; end if; if #nrecb`type eq 1 then Append(~nrecb`type,"Induced"); else nrecb`type[2]:= "Induced"; end if; return nrecb; end function; //returns the matrix that corresponds to left multiplication by pi function PiMult(recb,We:inverse:=false) if inverse then temp := [[GetIndex(recb,DegChange(recb`AG[j],-1)) eq i select K!1 else K!0:i in [1..recb`t]]:j in [1..recb`t]]; else temp := [[GetIndex(recb,DegChange(recb`AG[j],1)) eq i select K!1 else K!0:i in [1..recb`t]]:j in [1..recb`t]]; end if; return Transpose(Matrix(temp)); end function; //Computes a fake action matrix for canonical basis by assuming that all edges //have weight one and edges are zero unless length decreases by one function EasyEdges(recb,We) AGset:={recb`AG[i]:i in [1..recb`t]}; temp2:=[LengthDownOne(recb`AG[i],We) meet AGset:i in [1..recb`t]]; myDescents:=[WeIndLeftDescentSet(recb`AG[r],recb`IndType,We):r in [1..recb`t]]; print "temp2,myDescents",temp2,myDescents; recb`ActC:=[]; for s in [1..We`n-1] do gg := [WeIndMult(s,recb`AG[r],recb`IndType,We):r in [1..recb`t]]; sleftmult := [GetIndex(recb,gg[c]):c in [1..recb`t]]; //this records the length one up edges N := Matrix(SparseMatrix(recb`t,recb`t,[:c in [1..recb`t] | not s in myDescents[c] and sleftmult[c] ne 0])); Append(~(recb`ActC),N+Matrix(SparseMatrix(recb`t,recb`t,&cat[[ :w in temp2[c] | s in myDescents[GetIndex(recb,w)]] :c in [1..recb`t] | not s in myDescents[c]]))); for c in [1..recb`t] do if s in myDescents[c] then recb`ActC[s][c][c]:=z+z^(-1); end if; end for; end for; recb`ActT := [recb`ActC[s] - z^(-1)*IdentityMatrix(recb`t,K) :s in [1..We`n-1]]; recb`Length := [0 : i in [1..recb`t]]; recb`type[1] := "C"; return recb; end function; //Assuming indrecb is Ind_J(recb), then compute the canonical map from indrecb to recb //Also assumes indrecb and recb are modules with basis for Hecke algebra of We //seems to work even if indrecb is not exactly induced of recb, maybe some subquotients taken function CollapseInduced(indrecb,recb,We) if indrecb`type[1] eq "T" or (indrecb`type[1] eq "TC" and recb`type[1] eq "C") then output := [Vector([K!0 :i in [1..recb`t]]):i in [1..indrecb`t]]; PM := PiMult(recb,We); mincosets := {UnInduceLabel(indrecb`AG[i])[1] : i in [1..indrecb`t]}; for g in mincosets do //compute product of matrices corresponding to left multiplication by g w:= PushPiRight(g,We); tempM := ([recb`ActT[w[k]]:k in [1..#w]] cat [PM:d in [1..g[1]]]); if #tempM gt 0 then M:=&*tempM; else M:=IdentityMatrix(recb`t,K); end if; for i in [1..recb`t] do b := recb`AG[i]; for r in [1..recb`t] do index := GetIndex(indrecb,InduceLabel(g,b)); if index ne 0 then output[index][r] := M[r][i]; end if; end for; end for; end for; return Transpose(Matrix(output)); else print "Don't know how to compute collapse induced for this type of module with basis."; return 0; end if; end function; //Assuming indrecb is Ind_J(recb), then compute the canonical map from indrecb to recb //and present it as a map from indCrecb (the same as indrecb, but with canonical basis) //to recb combinatorially function CombCollapseInduced(indCrecb, indrecb, recb,We : CCcells:=[],Ccells:=[],sameshape := false) if indCrecb`type[1] ne "C" or indrecb`type[2] ne "Induced" or recb`type[1] ne "C" then return 0; end if; M := CollapseInduced(indrecb,recb,We); CCtoC := M*indCrecb`TtoC; if #CCcells eq 0 then CCcells := PrintCells(indCrecb,We:FullLabel:=true); end if; if #Ccells eq 0 then Ccells := PrintCells(recb,We); end if; IndCells:=CCcells[2]; //print "printing test in Comb of recb", [:i in [1..recb`t]]; //print "printing test in Comb or indcrecb", [:i in [1..indCrecb`t]]; outM := Matrix([[K!0 : c in [1..#(CCcells[2])]]: r in [1..#(Ccells[2])] ]); for r in [1..#(Ccells[2])], c in [1..#(CCcells[2])] do if sameshape and ToPartition(Ccells[2][r]) ne ToPartition(IndCells[c][1]) then outM[r][c] := K!0; else coefs := {CCtoC[i][j] : i in [1..recb`t],j in [1..indCrecb`t] | Ccells[1][i][2] eq r and CCcells[1][j][2] eq c}; if #coefs gt 2 then print "cells not mapping to cells...probably a bug",coefs,Ccells[2][r],IndCells[c]; print { : i in [1..recb`t],j in [1..indCrecb`t] | Ccells[1][i][2] eq r and CCcells[1][j][2] eq c}; outM[r][c] := 9999 + &+[c:c in coefs]; else outM[r][c] := &+[c:c in coefs]; end if; end if; end for; return ; end function; function ComputeCells(recb:pimult:=false, J:=[1..n-1]) if recb`type[1] eq "C" then if pimult then M:=PiMult(recb,We); Edges:= [ :k in [1..recb`t]]; else Edges:= [ :k in [1..recb`t]]; end if; G := Digraph<{1..recb`t}|Edges>; V := Vertices(G); SCC:=StronglyConnectedComponents(G); //print Edges; //print SCC[1]; SCCGraph:=Digraph<{1..#SCC} | [ :k in [1..#(SCC)]]>; //compute transitive closure of SCCGraph TCSCCGraph:=DistanceMatrix(SCCGraph); return ; else print "warning:basis not of type C so cells probably won't be interesting"; end if; return 0; end function; // b an iterated Weyl group element, compute a z permutation label for it and its insertion tableaux //sb determines whether we will apply Schutzenberger involution to the word function CellLabel(b,IndType,We : sb := true, J:= [1..n-1]) b:= LeftShuffle(b,IndType,We); p := InverseZ(ListZPerm(We`n,PushPiRight(b[1],We))); if sb then p := [We`n+1 - x: x in p]; end if; //print "printing in CellLabel", b,p; res := &join[{i, i+1}:i in J]; //return >; return ; end function; function PrintCells(recb,We:FullLabel:=false,PCpimult := true,PCJ:=[1..n-1]) cells := ComputeCells(recb : pimult:=PCpimult, J:=PCJ); tabs := [CellLabel(b,recb`IndType,We: J:=PCJ):b in recb`AG]; if FullLabel then it:=recb`IndType; ShrinkIndType(~it,1); tabsfull := [CellLabel(UnInduceLabel(b)[2],it,We):b in recb`AG]; end if; ntabs := [ : t in tabs]; V := Vertices(cells[1]); Vmap := map [1..#V] | [ : i in [1..#V] ] >; //print "printing tabs ",tabs; //print "printing vmap ",Vmap; SCC := cells[2]; SCCTab := []; SCCGraphTab := []; for i in [1..#SCC] do c := SCC[i]; nc := [Vmap(x):x in c]; if not &and[tabs[nc[1]][2] eq tabs[k][2]:k in nc] then print "combinatorial cells do not match actual cells"; end if; for k in nc do ntabs[k][2] := i; end for; if FullLabel then Append(~SCCTab,); else Append(~SCCTab,tabs[nc[1]][2]); end if; end for; V := Vertices(cells[3]); Vmap := map [1..#V] | [ : i in [1..#V] ] >; for i in [1..#V] do ON := OutNeighbors(V!i); Append(~SCCGraphTab,[SCCTab[Vmap(x)]:x in ON | x ne V!i]); end for; return ; end function; //compute the minimal quotient containing a given cell, using SCCgraphtab function MinimalQuotientContainingCell(x,cells) try i:=Position(cells[2],x); catch e i:=x; end try; out:=[r:r in [1..NumberOfRows(cells[4])] | cells[4][r][i] ne -1]; return [cells[2][i]:i in out]; end function; //print combinatorial collapse map by degree with all edges leaving one cell printed together //show cells from degree d to degree d+1 function PrintByDegree(d,indCrecb,recb,cells,indcells,CCI:treeonly:=false) degd:={i:i in [1..indCrecb`t] | indCrecb`AG[i][2][1] eq d and indCrecb`AG[i][1][1] eq 1}; //degd1:={i:i in [1..recb`t] | recb`AG[i][1][1] eq d+1}; degdcol:={indcells[1][k][2]:k in degd}; //degd1col:={cells[1][k][2]:k in degd1}; out:=[]; for c in degdcol do if (not treeonly) or ((#[r:r in [1..NumberOfRows(CCI[1])]|CCI[1][r][c] ne 0] eq 1) and (CCI[3][c][1] eq CCI[2][[r:r in [1..NumberOfRows(CCI[1])]|CCI[1][r][c] ne 0][1]])) then Append(~out,PrintMatrix(CCI[1],CCI[2],CCI[3],c)); end if; end for; return out; end function; function adddeg(x,cells) return <1-cells[2][x][1][1],x>; end function; function MakeTree(recb,cells:stand:=false) dcells:={:k in [1..recb`t]}; range:=Sort(SetToIndexedSet({x[1]:x in dcells})); t:=SetToIndexedSet(dcells); dcellslist:=[t[1],t[2],t[3],t[4]] cat [t[i] : i in [5..#t]]; Elist:=[[adddeg(r,cells),adddeg(c,cells)]:r,c in [1..#dcells] | cells[4][r][c] eq 1]; if stand then Tlist:=[[<[],CochargeLabel(cells[2][dcellslist[i][2]]:tab:=true),dcellslist[i][2]> :i in [1..#dcells] | dcellslist[i][1] eq d]:d in range]; else Tlist:=[[<[],cells[2][dcellslist[i][2]],dcellslist[i][2]> :i in [1..#dcells] | dcellslist[i][1] eq d]:d in range]; end if; return Tlist,Elist; end function; /* Bas := rec; BasC := rec; BigBas := rec; IndBasTC := rec; IndBasC := rec; IndType := rec; FromTrivialC2 := rec; FromTrivialC := rec; FromTrivial := rec; FromTrivialY:=rec; InitInd([We],[],~IndType); InitBasis(0,0,~Bas,["C"],IndType: trivial := true); ReorderBasis(~Bas); BasC := Bas; time FromTrivial := Induce(BasC,0,6,{1..We`n-1},We:noncross:=true); print "is the time for Induce from BasC"; ReorderBasis(~FromTrivial); time FromTrivialC := ConvertBasisType("C",We,FromTrivial,BasC:noncross:=true); print "is the time for computing canonical bases FromTrivial"; time FromTrivialY := ConvertBasisType("Y",We,FromTrivial,BasC:noncross:=true); print "is the time for computing canonical bases FromTrivialY"; gnc:=[]; gnc:=GetNonCrossing(We:noncrossingonly:=true); MM := FromTrivialY`TtoY*(Transpose(FromTrivialY`TtoY)*FromTrivialY`TtoY)^(-1); vects := RowSequence(Transpose(FromTrivialC`TtoC)); for v in vects do ans := v*MM; if ans*FromTrivialY`TtoY ne v then print "not in subspace"; else ans; end if; end for; FromTrivialC2:=FromTrivialC; MyQuotientModule(~FromTrivialC,{i:i in [1..FromTrivialC`t] | FromTrivialC`AG[i][1] in gnc}); //[FromTrivialCEasy`ActC[s]-FromTrivialC`ActC[s]:s in [1..We`n-1]]; //MySubModule(~FromTrivialC,{i:i in [1..FromTrivialC`t]|FromTrivialC`AG[i][1][1] eq 2}); //time IndBasTC:=Induce(FromTrivialC,0,1,{1..We`n-1},We); //ReorderBasis(~IndBasTC); //time IndBasC:=ConvertBasisType("C",We,IndBasTC,FromTrivialC); Mycells:=<>; time Mycells := PrintCells(FromTrivialC,We:FullLabel:=false); print "is time to compute Cells of FromTrivialC"; */