(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



BeginPackage["QuantumGroups`RootSystems`",{"QuantumGroups`"}];


CartanMatrix;
CartanFactors;
LacingNumber;
Rank;
KillingForm;
\[Rho];
SimpleRoots;
SimpleReflection;
WeylOrbit;
RootWeightQ;
WeightsModRoots;
WeightInLatticeQ;
IntermediateLattices;
PositiveWeightQ;
InWeylPolytopeQ;
SortWeights;
SortWeightMultiplicities;
MinusculeWeightQ;
MinusculeRepresentationQ;
ReflectIntoPositiveWeylChamber;
DominantRoots;
ShortDominantRoots;
LongDominantRoots;
ShortSimpleRoots;
ShortRoots;
ShortDominantRootQ;DualCoxeterNumber;


Begin["`Private`"];


CartanMatrix[Subscript[A, n_]]:=CartanMatrix[Subscript[A, n]]=Array[Switch[#1-#2,1,-1,0,2,-1,-1,_,0]&,{n,n}]


ElementaryMatrix[n_,i0_,j0_]:=Table[If[i==i0\[And]j==j0,1,0],{i,1,n},{j,1,n}]


CartanMatrix[Subscript[B, n_]]:=CartanMatrix[Subscript[B, n]]=CartanMatrix[Subscript[A, n]]-ElementaryMatrix[n,n,n-1]


CartanMatrix[Subscript[C, n_]]:=CartanMatrix[Subscript[C, n]]=CartanMatrix[Subscript[A, n]]-ElementaryMatrix[n,n-1,n]


CartanMatrix[Subscript[D, n_]]:=CartanMatrix[Subscript[D, n]]=CartanMatrix[Subscript[A, n]]+ElementaryMatrix[n,n,n-1]+ElementaryMatrix[n,n-1,n]-ElementaryMatrix[n,n,n-2]-ElementaryMatrix[n,n-2,n]


CartanMatrix[Subscript[E, 6]]=({
 {2, 0, -1, 0, 0, 0},
 {0, 2, 0, -1, 0, 0},
 {-1, 0, 2, -1, 0, 0},
 {0, -1, -1, 2, -1, 0},
 {0, 0, 0, -1, 2, -1},
 {0, 0, 0, 0, -1, 2}
});


CartanMatrix[Subscript[E, 7]]=({
 {2, 0, -1, 0, 0, 0, 0},
 {0, 2, 0, -1, 0, 0, 0},
 {-1, 0, 2, -1, 0, 0, 0},
 {0, -1, -1, 2, -1, 0, 0},
 {0, 0, 0, -1, 2, -1, 0},
 {0, 0, 0, 0, -1, 2, -1},
 {0, 0, 0, 0, 0, -1, 2}
});


CartanMatrix[Subscript[E, 8]]=\!\(\*
TagBox[
RowBox[{"(", "", GridBox[{
{"2", "0", 
RowBox[{"-", "1"}], "0", "0", "0", "0", "0"},
{"0", "2", "0", 
RowBox[{"-", "1"}], "0", "0", "0", "0"},
{
RowBox[{"-", "1"}], "0", "2", 
RowBox[{"-", "1"}], "0", "0", "0", "0"},
{"0", 
RowBox[{"-", "1"}], 
RowBox[{"-", "1"}], "2", 
RowBox[{"-", "1"}], "0", "0", "0"},
{"0", "0", "0", 
RowBox[{"-", "1"}], "2", 
RowBox[{"-", "1"}], "0", "0"},
{"0", "0", "0", "0", 
RowBox[{"-", "1"}], "2", 
RowBox[{"-", "1"}], "0"},
{"0", "0", "0", "0", "0", 
RowBox[{"-", "1"}], "2", 
RowBox[{"-", "1"}]},
{"0", "0", "0", "0", "0", "0", 
RowBox[{"-", "1"}], "2"}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.7]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}}], "", ")"}],
Function[BoxForm`e$, MatrixForm[BoxForm`e$]]]\);


CartanMatrix[Subscript[F, 4]]=\!\(\*
TagBox[
RowBox[{"(", "", GridBox[{
{"2", 
RowBox[{"-", "1"}], "0", "0"},
{
RowBox[{"-", "1"}], "2", 
RowBox[{"-", "1"}], "0"},
{"0", 
RowBox[{"-", "2"}], "2", 
RowBox[{"-", "1"}]},
{"0", "0", 
RowBox[{"-", "1"}], "2"}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.7]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}}], "", ")"}],
Function[BoxForm`e$, MatrixForm[BoxForm`e$]]]\);


CartanMatrix[Subscript[G, 2]]=\!\(\*
TagBox[
RowBox[{"(", "", GridBox[{
{"2", 
RowBox[{"-", "3"}]},
{
RowBox[{"-", "1"}], "2"}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.7]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}}], "", ")"}],
Function[BoxForm`e$, MatrixForm[BoxForm`e$]]]\);


CartanFactors[Subscript[A, n_]]:=CartanFactors[Subscript[A, n]]=Table[1,{n}]


CartanFactors[Subscript[B, n_]]:=CartanFactors[Subscript[B, n]]=Table[2,{n-1}]~Join~{1}


CartanFactors[Subscript[C, n_]]:=CartanFactors[Subscript[C, n]]=Table[1,{n-1}]~Join~{2}


CartanFactors[Subscript[D, n_]]:=CartanFactors[Subscript[D, n]]=Table[1,{n}]


CartanFactors[Subscript[G, 2]]={1,3};


CartanFactors[Subscript[F, 4]]={2,2,1,1};


CartanFactors[Subscript[E, n_]]:=CartanFactors[Subscript[E, n]]=Table[1,{n}]


LacingNumber[Subscript[(A|D|E), _]]=1;
LacingNumber[Subscript[(B|C|F), _]]=2;
LacingNumber[Subscript[G, 2]]=3;


Rank[Subscript[\[CapitalGamma]_, n_]]:=n


InverseCartanMatrix[\[CapitalGamma]_]:=InverseCartanMatrix[\[CapitalGamma]]=Inverse[CartanMatrix[\[CapitalGamma]]]


(*KillingForm[\[CapitalGamma]_][x_,y_]:=Simplify[x.InverseCartanMatrix[\[CapitalGamma]].y]*)


KillingForm[\[CapitalGamma]_][x_,y_]:=Simplify[x.Inverse[CartanFactors[\[CapitalGamma]]CartanMatrix[\[CapitalGamma]]].y]


KillingForm[\[CapitalGamma]_][x_,y_]:=Simplify[x.Inverse[Transpose[CartanMatrix[\[CapitalGamma]]]].DiagonalMatrix[CartanFactors[\[CapitalGamma]]].y]


\[Rho][\[CapitalGamma]_]:=Table[1,{Rank[\[CapitalGamma]]}]


SimpleRoots[\[CapitalGamma]_]:=Transpose[CartanMatrix[\[CapitalGamma]]]


SimpleReflection[\[CapitalGamma]_,i_][x_]:=
With[{\[Lambda]=SimpleRoots[\[CapitalGamma]][[i]]},x-2 KillingForm[\[CapitalGamma]][\[Lambda],x]/KillingForm[\[CapitalGamma]][\[Lambda],\[Lambda]] \[Lambda]]


AllSimpleReflections[\[CapitalGamma]_][x_]:=Table[SimpleReflection[\[CapitalGamma],i][x],{i,1,Rank[\[CapitalGamma]]}]


WeylOrbit[\[CapitalGamma]_,\[Lambda]_]:=FixedPoint[Union[Flatten[AllSimpleReflections[\[CapitalGamma]]/@#,1],#]&,{\[Lambda]}]


RootWeightQ[\[CapitalGamma]_,\[Lambda]_]:=And@@(IntegerQ/@Table[(2KillingForm[\[CapitalGamma]][\[Lambda],UnitVector[Rank[\[CapitalGamma]],k]])/KillingForm[\[CapitalGamma]][SimpleRoots[\[CapitalGamma]][[k]],SimpleRoots[\[CapitalGamma]][[k]]],{k,1,Rank[\[CapitalGamma]]}])


WeightsModRoots[\[CapitalGamma]_]:=WeightsModRoots[\[CapitalGamma]]={ZeroVector[Rank[\[CapitalGamma]]]}~Join~DeleteCases[IdentityMatrix[Rank[\[CapitalGamma]]],\[Lambda]_/;RootWeightQ[\[CapitalGamma],\[Lambda]]]


WeightInLatticeQ[\[CapitalGamma]_,\[Lambda]_,sublattice_]:=
Or@@(RootWeightQ[\[CapitalGamma],#+\[Lambda]]&/@WeightsModRoots[\[CapitalGamma]][[sublattice]])


IntermediateLatticeQ[\[CapitalGamma]_,subset_]:=And@@Flatten[Outer[WeightInLatticeQ[\[CapitalGamma],WeightsModRoots[\[CapitalGamma]][[#1]]+WeightsModRoots[\[CapitalGamma]][[#2]],subset]&,subset,subset]]


IntermediateLattices[\[CapitalGamma]_]:=Cases[{1}~Join~#&/@Subsets[Range[2,Length[WeightsModRoots[\[CapitalGamma]]]]],subset_/;IntermediateLatticeQ[\[CapitalGamma],subset]]


PositiveWeightQ[\[CapitalGamma]_][\[Lambda]_]:=And@@(NonNegative/@\[Lambda])


ReflectIntoPositiveWeylChamber[\[CapitalGamma]_][\[Lambda]_]:=With[{p=Position[\[Lambda],_?Negative]}, If[Length[p]==0,\[Lambda],ReflectIntoPositiveWeylChamber[\[CapitalGamma]][SimpleReflection[\[CapitalGamma],p[[1,1]]][\[Lambda]]]]]


WeightsOrderedQ[\[CapitalGamma]_][\[Lambda]_,\[Mu]_]:=And@@(NonNegative[KillingForm[\[CapitalGamma]][\[Lambda]-\[Mu],#]]&/@IdentityMatrix[Rank[\[CapitalGamma]]])


InWeylPolytopeQ[\[CapitalGamma]_,\[Lambda]_,\[Mu]_]:=InWeylPolytopeQ[\[CapitalGamma],\[Lambda],\[Mu]]=WeightsOrderedQ[\[CapitalGamma]][\[Lambda],ReflectIntoPositiveWeylChamber[\[CapitalGamma]][\[Mu]]]


OrderingWeight[Subscript[A, n_]]:=OrderingWeight[Subscript[A, n]]=Table[1+10^(-5-i),{i,1,n}]


WeightsOrderedComplete[\[CapitalGamma]_][\[Lambda]_,\[Mu]_]:=With[{\[Theta]=OrderingWeight[\[CapitalGamma]]},KillingForm[\[CapitalGamma]][\[Lambda],\[Theta]]>KillingForm[\[CapitalGamma]][\[Mu],\[Theta]]]


SortWeights[\[CapitalGamma]_][weights_]:=With[{\[Theta]=OrderingWeight[\[CapitalGamma]]},weights[[Ordering[-KillingForm[\[CapitalGamma]][#,\[Theta]]&/@(weights/.Irrep[_][\[Lambda]_]:>\[Lambda])]]]]


SortWeightMultiplicities[\[CapitalGamma]_][l_]:=With[{\[Theta]=OrderingWeight[\[CapitalGamma]]},l[[Ordering[-KillingForm[\[CapitalGamma]][#[[1]],\[Theta]]&/@(l/.Irrep[_][\[Lambda]_]:>\[Lambda])]]]]


MinusculeWeightQ[Subscript[A, n_],\[Lambda]_]:=UnitVectorQ[\[Lambda]]


MinusculeWeightQ[Subscript[B, n_],\[Lambda]_]:=\[Lambda]===UnitVector[n,n]
MinusculeWeightQ[Subscript[C, n_],\[Lambda]_]:=\[Lambda]===UnitVector[n,1]
MinusculeWeightQ[Subscript[D, n_],\[Lambda]_]:=MemberQ[{UnitVector[n,1],UnitVector[n,n-1],UnitVector[n,n]},\[Lambda]]


MinusculeWeightQ[Subscript[E, 6],{1,0,0,0,0,0}]=True;
MinusculeWeightQ[Subscript[E, 6],{0,0,0,0,0,1}]=True;


MinusculeWeightQ[Subscript[E, 7],{1,0,0,0,0,0,0}]=False;
MinusculeWeightQ[Subscript[E, 7],{0,1,0,0,0,0,0}]=False;
MinusculeWeightQ[Subscript[E, 7],{0,0,1,0,0,0,0}]=False;
MinusculeWeightQ[Subscript[E, 7],{0,0,0,1,0,0,0}]=False;
MinusculeWeightQ[Subscript[E, 7],{0,0,0,0,1,0,0}]=False;
MinusculeWeightQ[Subscript[E, 7],{0,0,0,0,0,1,0}]=False;
MinusculeWeightQ[Subscript[E, 7],{0,0,0,0,0,0,1}]=True;


MinusculeWeightQ[_,_]:=False


MinusculeRepresentationQ[\[CapitalGamma]_,Irrep[\[CapitalGamma]_][\[Lambda]_]]:=MinusculeWeightQ[\[CapitalGamma],\[Lambda]]


MinusculeRepresentations[\[CapitalGamma]_]:=Irrep[\[CapitalGamma]]/@Select[IdentityMatrix[Rank[\[CapitalGamma]]],MinusculeWeightQ[\[CapitalGamma],#]&]


DominantRoots[\[CapitalGamma]_]:=DominantRoots[\[CapitalGamma]]=Union[ReflectIntoPositiveWeylChamber[\[CapitalGamma]]/@SimpleRoots[\[CapitalGamma]]]


ShortDominantRoots[\[CapitalGamma]_]:=ShortDominantRoots[\[CapitalGamma]]=Module[{dr=DominantRoots[\[CapitalGamma]],shortLength},
shortLength=Min[KillingForm[\[CapitalGamma]][#,#]&/@dr];
Select[dr,KillingForm[\[CapitalGamma]][#,#]==shortLength&]
]


LongDominantRoots[\[CapitalGamma]_]:=LongDominantRoots[\[CapitalGamma]]=Module[{dr=DominantRoots[\[CapitalGamma]],longLength},
longLength=Max[KillingForm[\[CapitalGamma]][#,#]&/@dr];
Select[dr,KillingForm[\[CapitalGamma]][#,#]==longLength&]
]


ShortSimpleRoots[\[CapitalGamma]_]:=ShortSimpleRoots[\[CapitalGamma]]=Module[{shortLength},
shortLength=Min[KillingForm[\[CapitalGamma]][#,#]&/@SimpleRoots[\[CapitalGamma]]];
Select[SimpleRoots[\[CapitalGamma]],KillingForm[\[CapitalGamma]][#,#]==shortLength&]
]


ShortRoots[\[CapitalGamma]_]:=ShortRoots[\[CapitalGamma]]=ShortRoots[\[CapitalGamma]]=Union@@(WeylOrbit[\[CapitalGamma],#]&/@ShortDominantRoots[\[CapitalGamma]])


ShortDominantRootQ[\[CapitalGamma]_,\[Lambda]_]:=MemberQ[ShortDominantRoots[\[CapitalGamma]],\[Lambda]]


DualCoxeterNumber[Subscript[A, n_]]:=n+1
DualCoxeterNumber[Subscript[B, n_]]:=2n-1
DualCoxeterNumber[Subscript[C, n_]]:=n+1
DualCoxeterNumber[Subscript[D, n_]]:=2n-2
DualCoxeterNumber[Subscript[E, 6]]=12;
DualCoxeterNumber[Subscript[E, 7]]=18;
DualCoxeterNumber[Subscript[E, 8]]=30;
DualCoxeterNumber[Subscript[F, 4]]=9;
DualCoxeterNumber[Subscript[G, 2]]=4;


End[];


EndPackage[];



