The Isomorphism of (Subscript[H, 4]) and (Subscript[E, 8])

J Gregory Moxness

CC BY - NC - SA 4.0 DEED/Attribution-NonCommercial-ShareAlike 4.0 International

www.TheoryOfEverything . org

This paper gives an explicit isomorphic mapping from the 240 real (ℝ^8) roots of the (Subscript[E, 8]) Gosset (Subscript[4, 21]) 8-polytope to two golden ratio scaled copies of the 120 root (Subscript[H, 4]) 600-cell quaternion 4-polytope using a traceless 8×8 rotation matrix 𝕌 with palindromic characteristic polynomial coefficients and a unitary form (ℯ^(i𝕌)). It also shows the inverse map from a single (Subscript[H, 4]) 600-cell to (Subscript[E, 8]) using a 4D↔8D chiral left↔right mapping function, φ -scaling, and (𝕌^(-1)). This approach shows that there are actually four copies of each 600-cell living within (Subscript[E, 8]) in the form of chiral (Subscript[H, 4L])♁φ (Subscript[H, 4L])♁(Subscript[H, 4R])♁φ (Subscript[H, 4R]) roots. In addition, it demonstrates a quaternion Weyl orbit construction of (Subscript[H, 4])-based 4-polytopes that provides an explicit mapping between (Subscript[E, 8]) and four copies of the tri-rectified Coxeter-Dynkin diagram of (Subscript[H, 4]), namely the 120-cell of order 600. Taking advantage of this property promises to open the door to as yet unexplored (Subscript[E, 8])-based Grand Unified Theories or GUTs.

Initializations (snippets)

General Global Initialization

Standard & Others’ Packages

(* Define conditionally applied doPrint, doQuiet and doOff processing *)
print:=If[doPrint,Print@##]&;

quiet[in_]:=If[doQuiet,Quiet[in],in];
Attributes[quiet]={HoldAll};

off[sym_]:=(
print["doOff=",doOff," off=",sym];
If[doOff,Off@sym]);

<< MultivariateStatistics`; 
<< ComputationalGeometry`;

(**)
If[doSuperLie,<<Quaternions`];

Off[General::munfl];

<<NDSolve`FEM`

(* Tetrahedral Mesh Generator package *)
<<TetGenLink`

Off[Set::shape];

Off[TetGenConvexHull::tetfc];

Off[Volume::nmet];

off[Volume::reg];

off[RegionCentroid::reg];

off[ViewPoint::nlist3];

Off[Export::autofix];

Off[General::stop];

Off[AffineTransform::inpf];

Off[BinaryWrite::nocoerce];

Off[XMLElement::attrhs];

off[HighlightMesh::meshreg];

Off[PropertyValue::pvobj];
(**)

off[ConvexHullMesh::affind]

off[ConvexHullMesh::pts]

Off[Show::gtype]
Off[Show::gcomb]
Off[Show::shx]

Off[TetGenTetrahedralize::reterr]

Off[TetGenDelaunay::tetgpts]

This is for either LieART or GroupMath.
Caution : It uses names that can step on my functions unless modified e.g. {An, Bn, Cn, Dn, E(4,5,6,7,8),F4,G2}

(* SuperLie Algebra **)
If[doSuperLie&&working,
off[Solve::svars];
off[ToExpression::sntx]]
(* This is a replacement rule that corrects my code that uses undefined symbols (which SuperLie replaces) *)
slRep:=If[doSuperLie,ToExpression@"{Global`GPlus->Global`Plus,Global`GTimes->Global`Times,Global`GPower->Global`Power,GPlus->Plus,GTimes->Times,GPower->Power}",xxx->1];

(* LieART **)
If[doLieART&&working,
<<LieART`];

(* GroupTheory **)
If[doGroupTheory&&working,
off[Transpose::nmtx];
<<GroupTheory`];

If[doGroupTheory,
Unprotect[ex,a,b,c,d,F4]];

(* GroupMath **)
If[working&&doGroupMath,
(*)Unprotect@C;**)
Unprotect@BlockDiagonalMatrix;
(*)Clear[a,d,f,(* group names *)
e6,e7,e8,so10,so11,so12,so13,so14,so15,so16,so17,so3,so5,so6,so7,so8,so9,su2,su3,su4,su5,su6,su7,su8,u1];**)
<<GroupMath`;(*)
<<Sym2Int`**)];

Global

(* Alter the Fano UI based on sedenion selection *)
sedTrk=False;
sedUI:=If[sedTrk,{n1,n2,n3,n4},{n1,n2,n3}];
n1n4UI:={(Subscript[ℯ, #])->Style[(Subscript[ℯ, #]),Darker@Cyan]&/@sedUI};

first=If[Length@#==0||#==={{}},#,First@Flatten@#]&;
position[x_,y_]:=first@Position[x,y,1,Heads->False];

(* The symbol φ is the main reference for resolving the Golden Ratios. 
It is only evaluated to a symbolic or numeric value using φRep replacement rules *)
Clear[ϕ,σ,Φ,τ,φ];
(* Upper (and lower) case Phi(Φ=(1+(Sqrt[5]))/2) (and phi ϕ=(1-(Sqrt[5]))/2)) represent large (and small) Golden Ratio (respectively) *)
ϕ=1/φ;
(* σ & τ are Galois conjugates, this will get stepped on from the CKM UI *)
σ=-1/φ/.slRep;
τ=Φ=φ;

(* 𝕌Det1f is a scale factor to make Det@𝕌=1 *)𝕌Det1f=2(Sqrt[ϕ]) /.slRep;

(* Create assumptions and replacement rules for φ and ω for automated symbolics *)
φAssumptions:={φ∈(Reals),(φ^(1/2))∈(Reals),(φ^(3/2))∈(Reals),N[((Sqrt[5])+1)/2]≥φ>N[((Sqrt[5])+1)/2]-(chop^2)(*),ω∈(Complexes)**)};
φRep:={φ->((Sqrt[5])+1)/2,ω->(E^(I 2π/3))};

(* GroupMath steps on CircleTimes *)
If[working&&!doGroupMath,
CircleTimes[a_,b_]:=KroneckerProduct[a,b]];

KroneckerSum[a_,b_]/;MatrixQ[a]&&MatrixQ[b]:=Catch@
Module[{n,p,m,q},
{n,p}=Dimensions[a];
{m,q}=Dimensions[b];
If[n≠p||m≠q,Throw[Failed]];
KroneckerProduct[a,IM@m]+
KroneckerProduct[IM@n,b]];

fb:=Fibonacci;

σP@i_:=PauliMatrix@i;
MatrixForm[σP@#⊗IdentityMatrix@#]&/@Range@3

(* Tetration as (^n)a := (a^(a^(a^(...n)))) *)
tetration[a_?NumericQ,0]:=1;
tetration[a_?NumericQ,n_]:=(a^(Sign@n tetration[a,n-Sign@n]));
tetration[a_?ListQ,n_]:=MatrixPower[a,n];
MakeExpression[RowBox[{SuperscriptBox["",n_],a_}],StandardForm]:=
MakeExpression[RowBox[{"tetration","[",a,",",n,"]"}],StandardForm];

n=4;
Table[(^i)2,{i,-n,n}]

(* Fibonacci *)
(^6)(({{1, 1}, {1, 0}}))

Clear[fF,hyperV]
(* Complex Double Factorial *)
fF@k_:=(Sqrt[((2^(k+1))/π)])(k/2)!;

fF@Range[0,8]

(* HyperDimensional volumes for nSpheres (𝕊^(n-1)) *)
hyperV[n_,r_:1]:=((2 (((2π))^((n-1)/2)))/(fF@n))(r^n);
hyperV[#,r]&/@Range@8

hyperV/@Range@8

fixDo@initGlobal;

Demonstration CodeBase (snippets)

Fano

Pane Inits

(* Option to use Mathematica IJK quaternion style for octonions - works with sedenions as well
notice the K=IJ and L prefixes I/J/K on octonions *)
(* Use the integer (Subscript[ℯ, 0])=1 last to make Fano plane calculations easier, since they only deal in the imaginary parts *)
octIJKL:=If[sedenions,{I,J,I J,K,I K,J K,I J K,L,I L,J L,I J L,K L,I K L,J K L,I J K L, (Subscript[ℯ, 0])},
{I,J,K,L,L I,L J,L K,(Subscript[ℯ, 0])}];
oct:=If[sedenions,{(Subscript[ℯ, 1]),(Subscript[ℯ, 2]),(Subscript[ℯ, 3]),(Subscript[ℯ, 4]),(Subscript[ℯ, 5]),(Subscript[ℯ, 6]),(Subscript[ℯ, 7]),(Subscript[ℯ, 8]),(Subscript[ℯ, 9]),(Subscript[ℯ, 10]),(Subscript[ℯ, 11]),(Subscript[ℯ, 12]),(Subscript[ℯ, 13]),(Subscript[ℯ, 14]),(Subscript[ℯ, 15]),(Subscript[ℯ, 0])},
{(Subscript[ℯ, 1]),(Subscript[ℯ, 2]),(Subscript[ℯ, 3]),(Subscript[ℯ, 4]),(Subscript[ℯ, 5]),(Subscript[ℯ, 6]),(Subscript[ℯ, 7]),(Subscript[ℯ, 0])}];
octN:=RotateRight@oct;

(* Octonion math from the matrix using 8D vector representations for x and y, this has the (Subscript[ℯ, 0])=1 first *)
octProduct[a_,b_]:=Block[{c3=Array[0&,Length@fm]},
Do[c3[[If[i≠j,fMult[[i,j]]+1,1]]]+=fSign[[i,j]] a[[i]] b[[j]],
{i,Length@fm},{j,Length@fm}];
Chop@c3]/.slRep;

(* Complex, quaternion and octonian multiplication (Subscript[ℯ, a])∘(Subscript[ℯ, b]) *)
quat2Oct@in_:=Block[{(**)a3(**)},
If[nonLocalDeploy,Print@"Quaternions disabled";in,
If[!QuaternionQ@in,Print@"not Quaternion";in,
a3=FromQuaternion@in;
Switch[Length@a3,
(* Length=0 implies Head=Complex and no K element *)
0,Re@a3+Im@a3 (Subscript[ℯ, 1]),
(* Length=2 and Head=Plus, etc., then convert and return the Complex first part along with the other part already converted *)
2,If[Head@a3===Plus&&Head@a3[[1]]===Complex&&Head@a3[[2]]===Times/.slRep,
Re@a3[[1]]+Im@a3[[1]](Subscript[ℯ, 1])+a3[[2]],
(* Length=2 with a non-Plus Head, etc. and non-zero length first part (i.e not complex), 
it may be a Real product so just return the already converted a3 *)
If[Length@a3[[1]]>0,a3,
(* otherwise assume it is a sum of a Complex first part and already converted second ?Real? part *)
1∘(Re@a3[[1]]+Im@a3[[1]](Subscript[ℯ, 1]))+a3[[2]]]],
(* Length=3 return the Complex first part and other 2 parts already converted *)
3,Re@a3[[1]]+Im@a3[[1]](Subscript[ℯ, 1])+a3[[2;;]]
]/.slRep
]/.
(* This replaces the JKL of Quaternion with the appropriate (Subscript[ℯ, n]), 
the Imaginary part is problematic so we do that manually *)
Most@Thread[octIJKL->oct]]];

(* Convert any list of complex numbers or symbols to a Re@L/Im@R octonion or (Bi)Quaternion list.
Put in[[;;4]] into Re@L/Im@R halves.
BTW - this will also reformat any <8D input to an 8D list *)
biQuaternion@in_List:=FullSimplify[#/.slRep,Assumptions->φAssumptions]&@Join[Re@#,(*)Reverse@**)Im@#]&@(in[[;;4]]/.(Subscript[ℯ, 1])->I);
biQuaternion@in_:=biQuaternion@oct2List@in;

(* Convert an octonion to a quaternion 4D list *)
oct2Quat@in_:=oct2List[in][[;;4]];
(* Convert an octonion to an Imaginary quaternion 3D list {(Subscript[ℯ, 1]),(Subscript[ℯ, 2]),(Subscript[ℯ, 3])} *)
oct2ImQuat@in_:=oct2List[in][[2;;4]];

(* Octonion math with conversions, leave final as octonion *)
SmallCircle[a_List,b_List]:=octonion@octProduct[a,b];

(* Conditionally set Quaternion and Complex to Octonion conversions *)
(* On localized deployments (!nonLocalDeploy) or using splitOctonions as (Bi)Quaternion, we can't/don't use MTM quaternions so we don't do quat2Oct either.
If we want splitOctonions (e.g. (BiQuaternions->L/R Octonions or BiOctonion->L/R Sedenions),
 we exclude ToQuaternion conversion for Complex and Quaternion math.
  We can also convert the complex quaternions to Left/Right octonion halves, and might also want to put complex octonions into sedenions (??) *)
If[!(nonLocalDeploy(*)||splitOctonion**)),
SmallCircle[a_Quaternion,b_Quaternion]:=quat2Oct@a∘quat2Oct@b;
SmallCircle[a_,b_Quaternion]:=a∘quat2Oct@b;
SmallCircle[a_Quaternion,b_]:=quat2Oct@a∘b;
If[!splitOctonion,
SmallCircle[a_Complex,b_Complex]:=ToQuaternion@a∘ToQuaternion@b;
SmallCircle[a_,b_Complex]:=a∘ToQuaternion@b;
SmallCircle[a_Complex,b_]:=ToQuaternion@a∘b]];

SmallCircle[a_,b_]:=oct2List@a∘oct2List@b;
(*)SmallCircle[a_,1]:=a;
SmallCircle[1,b_]:=b; **)

(* The associator vanishes or =0 where there are non-commuting structure constants (f^(A,B,C)) =1  *)
associator[a_List,b_List,c_List]:=(a∘b)∘c-a∘(b∘c)/.slRep;
associator[a_,b_,c_]:=associator[oct2List@a,oct2List@b,oct2List@c];

associatorQ[a_List,b_List,c_List]:=associator[a,b,c]==0;
associatorQ[a_,b_,c_]:=associatorQ[oct2List@a,oct2List@b,oct2List@c];

(* Jacobi Identity = -associator[a,b,c]3/2 *)
jacobi[a_List,b_List,c_List]:=a∘(b∘c)+b∘(c∘a)+c∘(a∘b)/.slRep;
jacobi[a_,b_,c_]:=jacobi[oct2List@a,oct2List@b,oct2List@c];

(* Moufang identities *)
moufangLR[a_List,b_List,c_List]:=(a∘(b∘a))∘c-a∘(b∘(a∘c))/.slRep//N//Chop;
moufangLR[a_,b_,c_]:=moufangLR[oct2List@a,oct2List@b,oct2List@c];

moufangM[a_List,b_List,c_List]:=(a∘b)∘(c∘a)-(a∘(b∘c))∘a/.slRep//N//Chop;
moufangM[a_,b_,c_]:=moufangM[oct2List@a,oct2List@b,oct2List@c];

moufangQ[a_List,b_List,c_List]:=moufangLR[a,b,c]==moufangM[a,b,c]==0;
moufangQ[a_,b_,c_]:=moufangQ[oct2List@a,oct2List@b,oct2List@c];

normedDivisor[a_,b_,c_,(Subscript[D, 4])]:=(a+b)∘(c+d);

octConjugate@p_:=Total[oct2List[p/.slRep] octN Diagonal@fSign]/.slRep;
octConjugatePattern:(SuperStar[p_]):=octConjugate@p;

octConjugateTranspose@p_:=((SuperStar[p])^\[Transpose]);
(* Take in a List:
either a symbolic list of octonions or an 8x8 matrix of oct2List octonions,
  and perform an octonionic ConjugateTranspose on it ((m^\[Transpose])^\[Conjugate])=(m^\[ConjugateTranspose]) w/\[ConjugateTranspose]=ConjugateTranspose *)
octConjugateTranspose@p_List:=Transpose[
(* Need to make the input matrix a list if input is a symbolic octonion,
then take the octonion conjugate *)
If[Head@testQuat[[1]]===List,(SuperStar[p]),(SuperStar[oct2List[#]])&/@p]];

octConjugateTransposePattern:(SuperDagger[p_]):=octConjugateTranspose@p;

octRe@p_:=Simplify@Chop@((octonion@p+(SuperStar[p]))/2)/.slRep;
octIm@p_:=Simplify@Chop@((octonion@p-(SuperStar[p]))/2)/.slRep;
 
octAbs@p_:=p∘(SuperStar[p])/.slRep;
octNorm@p_:=(Sqrt[octAbs@p])/.slRep;
octInv@p_:=FullSimplify@((SuperStar[p])/(octAbs@p))/.slRep;

scalarProd[x_,y_]:=Simplify@Chop[(SuperStar[x])∘y+(SuperStar[y])∘x ]/2/.slRep;

scalarProdMinus[x_,y_]:=Simplify@Chop[(SuperStar[x])∘y-(SuperStar[y])∘x ]/2/.slRep;


CirclePlus[x_,y_]:=((scalarProd[x,y])/(octNorm[x] octNorm[y]))/.slRep;(**)

CircleMinus[x_,y_]:=((scalarProdMinus[x,y])/(octNorm[x] octNorm[y]))/.slRep;(**)

commutator[x_,y_]:=Simplify@Chop[x∘y-y∘x]/.slRep ;
CircleDot[x_,y_]:=commutator[x,y]/.slRep;

antiCommutator[x_,y_]:=Simplify@Chop[x∘y+y∘x]/.slRep;
Wedge[x_,y_]:=antiCommutator[x,y];

(* This is an alternate form when CircleDot is already used (**)
derivation[x_,y_][a_]:=commutator[commutator[x,y],a]-3associator[x,y,a]/.slRep; 
**)
derivation[x_,y_][a_]:=(x⊙y)⊙a-3associator[x,y,a]/.slRep;
Square[{x_,y_,a_}]:=derivation[x,y][a];

(* Derivation matrix and vector *)
derMatrix[x_,y_]:=Table[Coefficient[\[Square]{x,y,oct[[i]]},oct[[j]]],{j,7},{i,7}]/.slRep;
derMatrix[{x_,y_}]:=derMatrix[x,y];
derVector := Flatten@derMatrix@##&;

(* Define the "checking" function for the derivation (Subscript[D, 4]){x,y} *)
checkD[a_,b_][x_,y_]:=(\[Square]{a,b,x∘y}==\[Square]{a,b,x}∘y+x∘\[Square]{a,b,y});

Polytopes and Lie Groups

Define Permutations

(* Functions to generate positional and ± sign permutations of lists *)
EvenPermutationQ@p_:=Signature@p==-1;
OddPermutationQ@p_:=Signature@p==1;

pm@n_:=Flatten[Outer[List,Sequence@@Table[{-1,1},{n}]],n-1];
pm2@n_:=pm@n/2;

EvenPermutations@p_List:=Module[{(**)i,j(**)},
i=Range@Length@p;
j=Permutations@i;
(j/.Inner[Rule,i,p,List])[[Flatten@Position[j,_?EvenPermutationQ,1,Heads->False]]]];
OddPermutations@p_List:=Module[{(**)i,j(**)},
i=Range@Length@p;
j=Permutations@i;
(j/.Inner[Rule,i,p,List])[[Flatten@Position[j,_?OddPermutationQ,1,Heads->False]]]];

Eperms@in_List:=EvenPermutations[Inner[Times,in,Array[1&,Length@in],List]];
Operms@in_List:=  OddPermutations[Inner[Times,in,Array[1&,Length@in],List]];

(* Quaternion permutations in 3 or 4D 
Code in 14 types of permutations:
"AllNoSign",                 all permutations of position and no ± sign permutations (just like Permutations[]),
  "NoneNoSign",                no permutation of position or sign,
  "None",                      no permutation of position (just ± sign permutations on each position),
  "NoneEsign",                 no permutation of position (just Even ± sign permutations on each position),
  "NoneOsign",                 no permutation of position (just Odd ± sign permutations on each position),
  "All",                       full set of ± sign and positional permutations,
  "Rotate",                    RightRotations of {(Subscript[ℯ, 1]),(Subscript[ℯ, 2]),(Subscript[ℯ, 3])} with ± permutations on each position (cyclic with sign),
  "NoSign",                    no sign permutations, just RightRotation of positions            (cyclic only),
  "NoSignEpos" & "NoSignOpos", no sign permutations,  Even (or Odd) positional permutations,
  "Epos"       & "Opos",       full set of ± sign and Even (or Odd) positional permutations,
  "Esign"      & "Osign",      ± sign Permutation by count of Even (or Odd) + signs,
  "EsignEpos"  & "EsignOpos" & "OsignEPos"   & "OsignOPos" 
                             ± sign Permutation by count of Even (or Odd) + signs and Even (or Odd) position permutations *)
permRotate@in_List:=Module[{out=in},
Join[{out},(out=RotateRight@out)&/@Range[Length@in-1]]];

(* Permute in_List with a given (Subscript[permTypE, 8])String and use select_List to pull out selected indices *)
Clear@perms;

perms[in_List,select_List:{},(Subscript[permTypE, 8])String:"All"]:=Module[{inLength,noSelect, signPerms,permList,outList},
inLength=Length@in;
(* set noSelect if the permType needs all ± permutations *)
noSelect=permType=="Epos"||permType=="Opos"||permType=="Rotate"||permType=="All"||permType=="None";
(* If the permType contains "NoSign", return Array of +1s,
   If the permType doesn't require selecting Even or Odd sign counts, send all signPerms, 
       otherwise do the Select *)
signPerms=If[StringContainsQ[permType,"NoSign"],Array[1&,inLength],
If[noSelect,pm@inLength,
Select[pm@inLength,If[StringContainsQ[permType,"Osign"],OddQ,EvenQ]@Count[Sign@#,1]&]]];
(* Do the position perms *)
permList=Which[
StringTake[permType,3]=="Non",List,
StringContainsQ[permType,"All"]||permType=="Esign"||permType=="Osign",Permutations,
permType=="Rotate"||permType=="NoSign",permRotate,
(* Eperms and Operms processes all positional permutations of Even or Odd Signature (+1,-1) *)
StringContainsQ[permType,"Epos"],Eperms,
StringContainsQ[permType,"Opos"],Operms]@in;
(* Apply the sign perms and delete duplicates, not using Union due to it sorting, which may not be desired *)
outList=DeleteDuplicates@FullSimplify@Flatten[Table[# permList[[i]]&/@signPerms,{i,Length@permList}],1];
(* Apply the select list if needed *)
outList[[If[select=={},Range@Length@outList,select]]]];

(* This will allow us to process sign permutations of sums of symbolic octonion elements *)
octPerm[in_,select_List:{},(Subscript[permTypE, 8])String:"All",noUnion_:False]:=
If[noUnion,Flatten,Union]@(octSimplify/@Flatten[Total/@perms[
print["in=",in," nonList Head@in=",Head@in," Length@in=",Length@in];
List@in[[#]]&/@Range@Length@in,select,permType]]);

octPerms[in_List,select_List:{},(Subscript[permTypE, 8])String:"All",noUnion_:False]:=Module[{(*)inP,outP**)},
print["list Head@in=",Head@in," Length@in=",Length@in];
If[noUnion,Flatten,Union]@Flatten[
(* If # is not a sum Total (Head=List) but a single dimension ((Subscript[ℯ, 0])=1 w/Head==Integer or (Subscript[ℯ, n]) with Head==Subscript ), 
just permute it without changing it to a sum Total list of individual octonion dimension elements *)
{print["in[[#]]=",in[[#]]];
inP=oct2List@in[[#]];
If[Count[inP,0]==7,
print["7 zeros"];
outP=Flatten@perms[{in[[#]]},select,permType];
print["outP=",outP];
outP,
outP=octPerm[octonion@inP,select,permType,noUnion];
print["outP=",outP];
outP]
}&/@Range@Length@in]];

{#,outp=Union@perms[{x,y,z},(*){1,2},**)#],Length@outp}&/@{"AllNoSign","NoneNoSign","None","NoneEsign","NoneOsign","All","Rotate","NoSign","NoSignEpos","NoSignOpos","Epos","Opos","Esign","Osign","EsignEpos","EsignOpos","OsignEpos","OsignOpos"}//MatrixForm

(**)
{#,outp=Union@perms[{x,y,z,w},#],Length@outp}&/@{"AllNoSign","NoneNoSign","None","NoneEsign","NoneOsign","All","Rotate","NoSign","NoSignEpos","NoSignOpos","Epos","Opos","Esign","Osign","EsignEpos","EsignOpos","OsignEpos","OsignOpos"}//MatrixForm

ds=3;
dims=8;
dp={{-1,-1},{1,-1},{1,1}};
dn@n_:=Join[#,Array[0&,dims-n]]&/@Sort@Flatten[Permutations@Join[#,Array[0&,n-2]]&/@dp,1];

nOrtho@n_:=Join[#,Array[0&,dims-n]]&/@Sort@Flatten[Permutations@Join[{#},Array[0&,n-1]]&/@dp[[2]],1];

Cell600

(* Other than Cell600, these group names get over-written later when finding them inside E8 *)
d4=dn[4][[All,;;4]]
Length@%

d4=Sort@perms[{1,1,0,0},"Epos"]
Length@%

tesseract=pm2@4
Length@%

cell16=nOrtho[4][[All,;;4]]
Length@%

cell24=tesseract⋃cell16
Length@%

(* Use this for Transpose non-symmetric QC CNOT/CSWAP generated 𝕌 **)
seqSnub=If[nonTranspose𝕌,{0,Φ,1,ϕ},{0,ϕ,1,Φ}];

snub24cell=FullSimplify@perms[seqSnub,"Epos"]

Cell600=(2 cell24)⋃snub24cell;
Length@%

snub24cellRev=DeleteDuplicates@FullSimplify@perms[Reverse@seqSnub,"Epos"];
Length@%

Cell600Rev=(2 cell24)⋃snub24cellRev;

snub24cellMix=perms[{Φ,ϕ,1,0},"Epos"];
Length@%

Cell600Mix=(2 cell24)⋃snub24cellMix;

Cell120

(* Cell120 is accessed via the VisibLie-E8 menu and selects the dynkin diagram for the H4, which uses feedList to get the cooordinates. *)
(* Re-sort 120-cell (J) values into partititioned JΦ generated via quaternion/octonion math based on Koca's work **)
cell120base=DeleteDuplicates@Join[
2 dn[4][[All,;;4]],
Flatten[perms[#,"Epos"]&/@{{(Sqrt[5]),ϕ,Φ,0},{(Sqrt[5]),1,1,1},{Φ,Φ,Φ,(ϕ^2)},{(Φ^2),ϕ,ϕ,ϕ},{(Φ^2),(ϕ^2),1,0},{2,1,Φ,ϕ}}/.slRep,1]]/.slRep;

Cell120=cell120base;
Cell120N=#/.φRep&/@%;
Cell120NRnd=rndOct/@(biQuaternion/@%/(Sqrt[8]));
Cell120NRndQuat=oct2Quat/@%;

E8 based definitions

Define up to 16 orbit perms & their names (perms1D, 2D, 3D, and 4D, plus perms8D)

(* The 15 binary orbit permutations using only {0,1}'s *)
perms8D=Permutations@Range@8;

perms1D={1,0};
perms1DNames={
(* 1 ringed *)
"Parent",
(* No ringed *)
"Snub"};

perms2D={{1,0},{0,1}{1,1},{0,0}};
perms2DNames=Flatten@Join[{perms1DNames[[;;1]]},#&/@{
(* 1 ringed *)
"Rectified",
(* All ringed *)
"OmniTruncated"},{perms1DNames[[-1;;]]}]

perms3D=Flatten[Permutations/@{{1,0,0},{1,1,0},{1,1,1},{0,0,0}},1]
perms3DNames=Flatten@Join[{perms2DNames[[;;2]]},#&/@{
(* 1 ringed *)
"BiRectified",
(* 2 ringed *)
"Truncated",
"Cantellated",
"Runcinated"},{perms2DNames[[-2;;]]}]
Length@%%
Length@%%

perms4D=Flatten[Permutations/@{{1,0,0,0},{1,1,0,0},{1,1,1,0},{1,1,1,1},{0,0,0,0}},1]
perms4DNames=Flatten@Join[{perms3DNames[[;;3]]},#&/@{
(* 1 ringed *)
"TriRectified",
(* 2 ringed *)
"Truncated",
"Cantellated",
"Runcinated",
"BiTruncated",
"BiCantellated",
"TriTruncated",
(* 3 ringed *)
"CantiTruncated",
"RunciTruncated",
"BiCantiTruncated",
"CantiRuncinated"
},{perms3DNames[[-2;;]]}]
Length@%%
Length@%%

Binary Pascal Triangle / Clifford Algebra list and E8 Lie Algebra list

(* Split Real Even *)
binList=(*)ToPackedArray@**)Join[
e8b1={zeros},                                                               (*  1 Fermion-(Subscript[(Subscript[ν, e]), (Overscript[R, ⋁])]) (1st gen,no charge or color *)
e8b2=Permutations@{1,0,0,0,0,0,0,0},(*  8 Bosons-Ex (1's represent individual binary dims) *)
e8b3=Permutations@{1,1,0,0,0,0,0,0},(* 28 Fermions=even (0,1)'s (2/6) *)
e8b4=Permutations@{1,1,1,0,0,0,0,0},(* 56 Bosons=odd(0,1)'s (5/3) (w/32 (half) 2nd gen fermions) *)
e8b5=Permutations@{1,1,1,1,0,0,0,0},(* 70 Fermions=even (0,1)'s (4/4) (w/35 anti particles) *)
e8b6=Permutations@{1,1,1,1,1,0,0,0},(* 56 Bosons-anti of (0,1)'s (5/3)(w/32 (half) 2nd gen fermions) *)
e8b7=Permutations@{1,1,1,1,1,1,0,0},(* 28 Fermions-anti of (0,1)'s (6/2) *)
e8b8=Permutations@{1,1,1,1,1,1,1,0},(*  8 Bosons-(OverBar[Ex]) or {0,0,0,0,0,0,0,-1} *)
e8b9={zeros+1}                                                             (* 1 Fermion-(Subscript[(OverBar[ν]), e]) *)];

permPset=Array[0&,9];

fermion1=e8b1-1/2;(* 0/8 binary inverse=anti *)
permPset[[1]]=Length@fermion1;
fermion3=e8b3-1/2;(* 2/6 binary inverse=anti *)
permPset[[3]]=Length@fermion3;
fermion5=e8b5-1/2;(* 4/4 binary (even fermion w/±1/2's)-contains 35 anti's *)
permPset[[5]]=Length@fermion5;
fermion7=e8b7-1/2;(* 6/2 binary (even fermion w/±1/2's) *)
permPset[[7]]=Length@fermion7;
fermion9=e8b9-1/2;(* 8/0 binary (even fermion w/±1/2's) *)
permPset[[9]]=Length@fermion9;

perm62m=Permutations@{0,0,0,0,0,0,-1,-1}; (* 2/6 binary anti (reversed) *)
perm26=e8b3; (* 2/6 binary (even fermion w/1,0's) *)
perm18m=Permutations@{1,0,0,0,0,0,0,-1};(* 6/2 3 valued 28-28anti (reversed) *)
perm18ma=perm18m[[;;Length@perm18m/2]];
perm18mb=perm18m[[Length@perm18m/2+1;;]];

boson4=perm62m⋃perm18mb;
permPset[[4]]=Length@boson4;
boson6=perm18ma⋃perm26;
permPset[[6]]=Length@boson6;

exception2=e8b8-1;
permPset[[2]]=Length@exception2;
exception8=e8b2;
permPset[[8]]=Length@exception8;

e8List=(*)ToPackedArray@**)Join[
fermion1,                          (*  1= 1      *)
exception2,                     (*  8= 2- 9   *)
fermion3,                          (* 28= 10- 37 *)
boson4,                              (* 56= 38- 93 *)
fermion5,                          (* 70= 94-163 *)
boson6,                              (* 56=164-219 *)
fermion7,                          (* 28=220-247 *)
exception8,                     (*  8=248-255 *)
fermion9                              (*  1=    256 *)];

pE8@p_:=e8List[[pMin@p]];
pAnti@p_:=position[e8List,-pE8@p];

Lie Algebra Simple Roots, Cartan matrix and Cell 600 H4 list

srE8Base=srE8=(({{1, -1, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 1, -1, 0, 0, 0}, {0, 0, 1, -1, 0, 0, 0, 0}, {0, 1, -1, 0, 0, 0, 0, 0}, {-(1/2), -(1/2), -(1/2), -(1/2), -(1/2), -(1/2), -(1/2), -(1/2)}, {0, 0, 0, 0, 0, 1, 1, 0}, {0, 0, 0, 0, 1, -1, 0, 0}, {0, 0, 0, 0, 0, 1, -1, 0}}))//StandardForm;

srE8mix:=If[palindromicE8,
(* Best for (de)constructiong groups using srE8 off the ends (aka. palindromic construction, 
keeping the Left/Right Tr@Im[EI𝕌.%.EI𝕌Inv]==0  *)
perms8D[[20428]],
(* WP page example #1575 *)
{1,4,3,2,7,6,5,8}]

srE8:=srE8Base[[srE8mix]];
srE8

srEn:=srE8[[9-#;;,9-#;;]]&;

(* Cartan matrix 
srE8=(Sqrt[cmE8]) *)
cmE8:=srE8.srE8\[Transpose];

pRoot@p_:=Inverse@srE8\[Transpose].pE8@p;
pWeight@p_:=cmE8.pRoot@p;
pHeight@p_:=Abs@Total@pRoot@p;

If[palindromicE8,
(* palindromicE8 *)
(* Direct from srE8 *)
srD7=srE8[[2;;,;;7]];
(* Modified to D8 *)
srD8=ReplacePart[RotateRight/@srE8,1->{1,-1,0,0,0,0,0,0}];
srDn:=srD8[[9-#;;,9-#;;]]&;
srDn/@Range[3,8];

CMDn:=srDn@#.Transpose@srDn@#&;
CMDn/@Range[3,8];
(* B/C2 - B/C8 from E8->D8 *)
(* Direct from srE8 *)
srB7=ReplacePart[srE8[[2;;,;;7]],{{7,6}->0}];

(* Modified from D8 *)
srB8=ReplacePart[srD8,{{8,7}->0}];
srBn:=srB8[[9-#;;,9-#;;]]&;
srBn/@Range[2,8];

CMBn:=ReplacePart[srBn@#.Transpose@srBn@#,{{#-1,#}->-2,{#,#}->2}]&;
CMBn/@Range[2,8];

(* Direct from srE8->B7 *)
srC7=ReplacePart[srB7,{{7,7}->2}];
(* Modified from E8->D8->B8->C8 *)
srC8=ReplacePart[srB8,{{8,8}->2}];
srCn:=srC8[[9-#;;,9-#;;]]&;
srCn/@Range[2,8];

CMCn:=ReplacePart[srCn@#.Transpose@srCn@#,{{#-1,#}->-1,{#,#}->2}]&;
CMCn/@Range[2,8];

(* A2 - A8 from E8->D8->B8 *)
srA8=srB8;
srAn=srBn;
srAn/@Range[2,8];

CMAn:=ReplacePart[srAn@#.Transpose@srAn@#,{#,#}->2]&;
CMAn/@Range[2,8];

(* G2 & F4 *)
(* WP - maybe wrong *)
srF4=ReplacePart[srE8[[;;4,;;4]],{4,4}->0];
(* Better and consistent with GroupMath & LieART *)
srF4=ReplacePart[srE8[[4;;7,4;;7]],{3,4}->0];
srFn@4=srF4;

CMFn@4=ReplacePart[srFn[4].Transpose@srFn@4,{1,1}->2];
(* WP - maybe wrong *)
srG2=ReplacePart[srAn[3][[;;2,;;3]],{{2,1}->-1,{2,2}->2}];
srGn@2=srG2;

srGn[2].Transpose@srGn@2;
CMGn@2=ReplacePart[srGn[2].Transpose@srGn@2,{{2,1}->-1,{2,2}->2}],

(* Regular E8 *)
srD8=ReplacePart[srE8[[{1,2,3,4,5,8,7,6}]],{7->RotateRight@srE8[[8]],8->{0,0,0,0,0,0,(*)0**)1(**),1}}];
srDn:=srD8[[9-#;;,9-#;;]]&;
CMDn:=ReplacePart[srDn@#.Transpose@srDn@#,{#-1,#-1}->2]&;

(* B/C2 - B/C8 from E8->D8 *)
srB8=ReplacePart[srD8,{(**){8,7}->0,(**){8,8}->1}];
srC8=ReplacePart[srD8,{(**){8,7}->0,(**){8,8}->2}];
srBn:=srB8[[9-#;;,9-#;;]]&;
CMBn:=ReplacePart[srBn@#.Transpose@srBn@#,{{#,#-1}->-2,{#,#}->2}]&;
srCn:=srC8[[9-#;;,9-#;;]]&;
CMCn:=ReplacePart[srCn@#.Transpose@srCn@#,{{#,#-1}->-1,{#,#}->2}]&;

(* A2 - A8 from E8->D8->B8 *)
srA8=srB8;
srAn:=srA8[[9-#;;,9-#;;]]&;
CMAn:=ReplacePart[srAn@#.Transpose@srAn@#,{{#-1,#}->-1,{#,#-1}->-1}]&;

(* G2 & F4 *)
srF4=ReplacePart[srE8[[4;;7,4;;7]],{3,4}->0];
srFn@4=srF4;
srG2=ReplacePart[srAn@2,{2,2}->1];
srGn@2=srG2];

{#,CartanMatrix[Sequence@@#]}&/@If[doGroupMath,
{{"A",8},{"B",8},{"C",8},{"D",8},{"E",8},{"F",4},{"G",2}},
If[doLieART,{{A8},{B8},{C8},{D8},{E8},{F4},{G2}},
{"No package CartanMatrix"}]]

(* Calculate the simple root matrix - used in the Hasse viz and simpleRoots.
Uses ToExpression so it won't work in cloud deployments *)
srMatrix:=If[(*)MemberQ[CharacterRange["A","G"],StringTake[alg,1]]&&**)
MemberQ[weylGroupListDynkin,ToUpperCase@alg],
(* Will need to correct for cloud if we get that far... *)
ToExpression["sr"<>StringTake[alg,1]<>"n@"<>ToString@rank],
(* Don't have srHn defined, so we kluge it... *)
Array[""&,rank]];

(* Output for the Dynkin main UI *)
simpleRoots:=If[!MemberQ[CharacterRange["A","G"],StringTake[alg,1]]||StringTake[alg,2]=="BC",Row@{""},
Row@{" Simple Roots ",MatrixForm@srMatrix}];

(* Build a simplfied h4List & pC600 from 𝕌.pE8 4D projection with φ  evaluated -
this gets unset later in a more flexible definition of h4List *)
h4List=(*)ToPackedArray@**)Table[(*)N@Chop[**)𝕌Det1f (*)Re@**)#/.φRep&/@𝕌.pE8@i(*)]**),{i,dsLength}];

(* Now define the 600 Cell values from h4List positions *)
pC600@p_:=h4List[[pMin@p]];

FullSimplify@h4List;

Set up Quaternionic/Octonionic CP=T H4/H4Φ

Define the Quaternion (Octonion) Multiplication

Define Quaternion and orbit functions

mapστ (σ⟷τ) and[p,q]:r (eq .6)

(* This processes only symbolic *)
mapστ@in_:=in/. { 1/φ->-xστ, -φ->1/φ, φ->-1/φ}/.{xστ->φ}/.slRep;
#->mapστ@#&/@{τ,-τ,1/τ,-1/τ}/.slRep//MatrixForm

[p,q]:r is defined for any combinations of inputs as elements or lists

(* Adding a commutative order parameter: right *)
Clear@prq
(*)prq[p_,r_,q_,left_:False]:=FullSimplify[If[left,(r∘p)∘q,p∘(r∘q)]/.slRep];**)
(*)prq[p_,r_,q_,left_:False]:=FullSimplify[If[left,q∘(p∘r),p∘(r∘q)]/.slRep];**)
prq[p_,r_,q_,left_:False]:=FullSimplify[If[left,(p∘r)∘q,p∘(r∘q)]/.slRep];

prq[p_List,r_,q_,left_:False]:=prq[p[[#]],r,q,left]&/@Range@Length@p;prq[p_,r_List,q_,left_:False]:=prq[p,r[[#]],q,left]&/@Range@Length@r;prq[p_,r_,q_List,left_:False]:=prq[p,r,q[[#]],left]&/@Range@Length@q;

prq[p_List,r_List,q_,left_:False]:=Table[prq[p[[i]],r[[j]],q,left],{i,Length@p},{j,Length@r}];prq[p_List,r_,q_List,left_:False]:=Table[prq[p[[i]],r,q[[j]],left],{i,Length@p},{j,Length@q}];prq[p_,r_List,q_List,left_:False]:=Table[prq[p,r[[i]],q[[j]],left],{i,Length@r},{j,Length@q}];

prq[p_List,r_List,q_List,left_:False]:=Table[prq[p[[i]],r[[j]],q[[k]],left],{i,Length@p},{j,Length@r},{k,Length@q}];

Define Set & Reset 𝕌 and other data

(* Set h4List to h4List/2 for Norm=1 and in symbolic form (**)
h4List=Table[# 𝕌Det1f(**)/2(**)&/@𝕌.pE8@i/.φRuleList,{i,dsLength}];**)
h4List:=FullSimplify[If[useH4L,
Join[
Re[𝕌.pE8@#][[;;4]],
Im[𝕌.pE8@#][[;;4]]],
Join[
Re[𝕌.pE8@#][[5;;]],
Im[𝕌.pE8@#][[5;;]]]]/.If[speed||superSpeed,φRep,slRep],
Assumptions->φAssumptions]&/@Range@256;

(* 𝕌.pE8  (4D Re@p & 4D Im@p) *)
pC600@p_:=FullSimplify[
If[doUnitary,
If[useH4L,
Join[
Re[𝕌.pE8@p][[;;4]],
Im[𝕌.pE8@p][[;;4]]],
Join[
Re[𝕌.pE8@p][[5;;]],
Im[𝕌.pE8@p][[5;;]]]],
𝕌.pE8@p]/.If[speed||superSpeed,φRep,slRep],Assumptions->φAssumptions];

h4ListReset:=(
(* Set h4List to h4List/2 for Norm=1 and in symbolic form (**)
h4List=Table[# 𝕌Det1f(**)/2(**)&/@𝕌.pE8@i/.φRuleList,{i,dsLength}];**)
h4=Select[Range@256,MemberQ[rndMat[Cell600/.φRep],rndMat[Φ If[curr𝕌==11,1,𝕌Det1f] 𝕌[[;;4]].pE8@#/.φRep]]&];
Print@Length@h4;
h4Φ=Select[Range@256,MemberQ[rndMat[Cell600/.φRep],rndMat[If[curr𝕌==11,1,𝕌Det1f] 𝕌[[;;4]].pE8@#/.φRep]]&];
Print@Length@h4Φ);

set𝕌:=(
E82H4=𝕌List[[curr𝕌]];
(* RotateLeft four times. This swaps L⟷R swapping H4⟷H4Φ vertex numbers *)
If[doRotateLeft,
E82H4=(RotateLeft/@(RotateLeft/@(RotateLeft/@(RotateLeft/@E82H4))))];
h4ListReset);

These are functions involved in resolving the orbits of a given group (e.g. A3, B3, H3, A4, C4, D4, F4, H4, E8)

(*  Λ processes 3D orbit specifications.
It defaults to the irregular A3 Icosahedron, on A3 we take default perms as "Rotate" *)
Λ[f_,group_(*)String|group_List**):"A3",orbit_List:{1,1,1},(Subscript[permTypE, 8])String:"Rotate"]:=f[doW@group/.aRule@orbit,permType];

Define the aω & av Λ functions for A4

doW@"A4";

(* aωΛA4rep & avΛA4rep take in a list of A4 Λ0..4 indices and creates a permuted list for "NoneNoSign" oScaleListDo processing *)
aωΛA4rep[ΛIndexlist_,orbit_:{1,0,0,0},A3inA4IndxList_:Range@4]:={#/.aRule@orbit,"NoneNoSign"}&/@{oct2Quat@Total@aωΛ04[[#]]&/@(ΛIndexlist+1)};
(* Name shortened for Mamone analysis publication *)
ΛA4[ΛIndexlist_,orbit_:{1,0,0,0},A3inA4IndxList_:Range@4]:=aωΛA4rep[ΛIndexlist,orbit,A3inA4IndxList];

(* Evaluate avΛIndexlist = k one at a time in order to process against each r# *)
avΛA4repTotal[avΛIndexlist_,orbit_]:=Total[avΛ04[[#]]/.aRule@orbit]&/@avΛIndexlist;

(* Take each octonion->quaternion Total@avΛ(#) in the avΛIndexlist and apply it to each of the 3 generators in each of the 5 A3 embeddings of A3inA4
Return the unique set of possibilities  *)
avΛA4rep[ΛIndexlist_,orbit_:{1,0,0,0},A3inA4IndxList_:Range@4]:=Module[{(**)out2,out3,out4(**)},
out2=(*)DeleteDuplicates@**)Join[Flatten[
Table[Table[Table[
print["i=",i," j=",j," k=",k," A3inA4[[i,j]]= ",A3inA4[[i,j]]];
(* Do one avΛIndexlist = k at a time *)
out3=avΛA4repTotal[{k},orbit][[1]];
print["avΛA4repTotal[{k}]= ",out3];
(* Process it against each r# in the A3inA4IndxList *)
out4=oct2Quat@A3inA4[[i,j]]@out3;
print[A3inA4[[i,j]],"@%= ",out4,(*)out4=**)Chop@rndMat[out4/.φRep]];out4,
(* avΛ04[[#]] *)
{k,ΛIndexlist+1}],
(*r# in A3inA4[[i]] *)
{j,3}],
(* A3inA4[[i]] *)
{i,A3inA4IndxList}],2]];
{{out2,"NoneNoSign"}}];

Define the A3, B3, H3 Weyl Orbit 3D Platonic, Archimedean, Catalan Solids

TruncatedTetrahedron=TruncatedTetrahedronA={
{"A3",{1,1,0},"Osign"}};
(*)hulls3D@oScaleListDo@%**)

TruncatedTetrahedronB={
{"A3",{0,1,1},"Osign"}};
(*)hulls3D@oScaleListDo@%**)

TriakisTetrahedron={
{"A3",{1,0,0},"Osign"},
{"A3",{0,0,1}5/3,"Osign"}};
(*)hulls3D@oScaleListDo@%**)

IrregularSmallRhombicuboctahedron={
{"A3",{1,1,0},"Osign"},
{"A3",{0,1,1},"Osign"}};
(*)hulls3D@oScaleListDo@%**)

Cuboctahedron=CuboctahedronA={
{"A3",{1,0,1},"Osign"}};
(*)hulls3D@oScaleListDo@%**)
RhombicDodecahedron=RhombicDodecahedronA={
{"A3",{0,1,0},"Osign"},
{"A3",{0,0,1}}};
(*)hulls3D@oScaleListDo@%**)

TruncatedOctahedron=TruncatedOctahedronA={
{"A3",{1,1,1},"Osign"}};
(*)hulls3D@oScaleListDo@%**)
TetrakisHexahedron=TetrakisHexahedronA={
{"A3",{0,1,0},"Osign"},
{"A3",{0,0,1}2/(Sqrt[3]),"Osign"}};
(*)hulls3D@oScaleListDo@%**)

CuboctahedronB={
{"B3",{0,1,0},"Osign"}};
(*)hulls3D@oScaleListDo@%**)
RhombicDodecahedronB={
{"B3",{1,0,0},"Osign"},
{"B3",{0,0,1}/(Sqrt[2])}};
(*)hulls3D@oScaleListDo@%**)

TruncatedOctahedronB={
{"B3",{1,1,0},"All"}};
(*)hulls3D@oScaleListDo@%**)
IrregularIcosahedron={
{"B3",{1,1,0},"EsignEpos"}};
(*)hulls3D@oScaleListDo@%**)
TetrakisHexahedronB={
{"B3",{1,0,0},"Osign"},
{"B3",(Sqrt[2/3]){0,0,1},"Osign"}};
(*)hulls3D@oScaleListDo@%**)

TruncatedCube ={
{"B3",{0,1,1}}};
(*)hulls3D@oScaleListDo@%**)
TriakisOctahedron={
{"B3",{1,0,0}},
{"B3",(2-(Sqrt[2])){0,0,1}}};
(*)hulls3D@oScaleListDo@%**)

SmallRhombicuboctahedron ={
{"B3",{1,0,1}}};
(*)hulls3D@oScaleListDo@%**)

DeltoidalIcositetrahedron={
{"B3",{1,0,0},"Osign"},
{"B3",{0,1,0}/(Sqrt[2]),"Osign"},
{"B3",{0,0,1}((2+2(Sqrt[8]))/(7(Sqrt[2])))}};
(*)hulls3D@oScaleListDo@%**)

TruncatedCuboctahedron=GreatRhombicuboctahedron={
{"B3",{1,1,1},"All"}};
(*)hulls3D@oScaleListDo@%**)
DisdyakisDodecahedron={
{"B3",{1,0,0}},
{"B3",{0,1,0}(5-1/(Sqrt[2]))/7,"Osign"},
{"B3",{0,0,1}((Sqrt[2])-2/3)}};
(*)hulls3D@oScaleListDo@%**)

MyDodecahedron={
{"H3",{σ,0,0}},
{"H3",{1,-1,1}}};
(*)hulls3D@oScaleListDo@%**)

MyIcosahedron={{"H3",{0,0,1}}};
(*)hulls3D@oScaleListDo@%**)

Icosidodecahedron={
{"H3",{0,σ,0}},
{"H3",{-1,τ,σ}}};
(*)hulls3D@oScaleListDo@%**)
RhombicTriacontahedron={
{"H3",{σ,0,0}},
{"H3",{1,-1,1},"None"},
{"H3",{0,0,1}}};
(*)hulls3D@oScaleListDo@%**)

TruncatedDodecahedron ={
{"H3",{σ,σ,0},"OsignOpos"},
{{τ,σ,2τ}/2},
{{τ,(τ^2),2}/2}}/.slRep;
(*)hulls3D@oScaleListDo@%**)
iNorm=1/FullSimplify[Norm@{0,1,1/ϕ}/.slRep,Assumptions->φAssumptions];

tiNorm=(((1/2)(Sqrt[(3/2)(3+(Sqrt[5]))]))/((Sqrt[(13/8)+(19/(8(Sqrt[5])))])((Sqrt[3])/2)));
TriakisIcosahedron={
{"H3",2iNorm{0,0,1}},
{"H3",tiNorm{σ,0,0}},
{"H3",tiNorm{1,-1,1},"None"}}/.slRep;
(*)hulls3D@oScaleListDo@%**)

TruncatedIcosahedron={
{"H3",{0,2,2},"OsignOpos"},
{{2 τ,1,1+(τ^2)}},
{{ 2,(τ^3),τ}/.slRep}}/.slRep;
(*)hulls3D@oScaleListDo@%**)
PentakisDodecahedron={
{((3τ)/(σ+4)){0,1,σ}p},
{{0,σ,τ}},
{{1,1,1}}}/(Sqrt[3])/.slRep;
(*)hulls3D@oScaleListDo@%**)

SmallRhombicosidodecahedron={
{σ{1,1,(τ^3)}},
{{ τ-σ,τ,0}},
{{2,1,τ}}}/2/.slRep;
(*)hulls3D@oScaleListDo@%**)
diScale1=(Sqrt[(3/4)(5+(11/(Sqrt[5])))]);
diScale2=(Sqrt[((85+31 (Sqrt[5]))/20)]);
diNorm=(Sqrt[((147+65 (Sqrt[5]))/36)])((Sqrt[3])/2);
DeltoidalHexacontahedron={
{"H3",2iNorm{0,0,1}},
{"H3",(diScale1/diNorm){σ,0,0}},
{"H3",(diScale1/diNorm){1,-1,1},"None"},
{"H3",(diScale2/diNorm) {0,σ,0}},
{"H3",(diScale2/diNorm){-1,τ,σ}}}/.slRep;
(*)hulls3D@oScaleListDo@%**)

GreatRhombicosidodecahedron={
{{σ,σ,τ+3}},
{{3 ,τ,2τ}},
{{2 ,τ-σ,τ+2}},
{{ 2σ,(τ^3),τ}},
{{σ,3τ-1,(τ^2)}}}/2/.slRep;
hulls3D@oScaleListDo@%

λ1=((τ+3)/5);
η1=((2σ+3)/3);
q1=( τ (Subscript[ℯ, 1])-2σ (Subscript[ℯ, 2])+(τ^3) (Subscript[ℯ, 3]))/2/.slRep;
q1p=( 2(Subscript[ℯ, 1])+(Sqrt[5]) (Subscript[ℯ, 2])+(τ+2) (Subscript[ℯ, 3]))/2/.slRep;
A1n=λ1(-σ (Subscript[ℯ, 2])+(Subscript[ℯ, 3]))/.slRep;
B1n=η1(-σ (Subscript[ℯ, 1])+τ (Subscript[ℯ, 3]))/.slRep;
C1n=( (Subscript[ℯ, 1])-σ (Subscript[ℯ, 2])+τ (Subscript[ℯ, 3]))/2/.slRep;
aNorm=FullSimplify@octNorm[A1n/.slRep];
bNorm=FullSimplify@octNorm[B1n/.slRep];
cNorm=FullSimplify@octNorm[C1n/.slRep];

DisdyakisTriacontahedron=FullSimplify[Join[{
(* 62=32+30=12+20+30 Norms *)

(* Unit scaled Icosahedron (12) **)
(* Scales 10 valent  **)
{"H3",2iNorm{0,0,1}},

(* Dodecahedron (20=Icosahedron (12) + Cube (8)) **)
(* Scales 6 valent **)
(* Icosahedron (12) *)
{"H3",(bNorm/aNorm)(2/(Sqrt[3])){σ,0,0}},
(* Cube (8) *)
{"H3",(bNorm/aNorm) (2/(Sqrt[3])){1,-1,1},"None"},

(* Icosidodecahedron (30=Octahedron (6)+Rhombicuboctahedron (24)) **)
(* Scales 4 valent **)
(* Octahedron (6) **)
{"H3",(1/aNorm) {0,σ,0}},
(* Rhombicuboctahedron (24) **)
{"H3",(1/aNorm) {-1,τ,σ}}}]/.slRep,Assumptions->φAssumptions];
hulls3D@oScaleListDo@%

ρσ=((205-280σ)/1210){σ,τ-2σ,0};
Pyritohedron={
{ρσ},
{{1 ,1,1}/2}}/.slRep;
(*)hulls3D@oScaleListDo@%**)

SnubCubeL={
{{x,1,(1/x)}/.xRep,"EsignEpos"},
{{x,1,(1/x)}/.xRep,"OsignOpos"}}/.slRep;
(*)hulls3D@oScaleListDo@%**)
SnubCubeR={
{{1,x,(1/x)}/.xRep,"EsignEpos"},
{{1,x,(1/x)}/.xRep,"OsignOpos"}}/.slRep;
(*)hulls3D@oScaleListDo@%**)
IrregularTruncatedCuboctahedron=IrregularGreatRhombicuboctahedron=Join[SnubCubeL,SnubCubeR];
(**)hulls3D@oScaleListDo@%(**)

PentagonalIcositetrahedron={
{ x ω13{1 ,0,0}},
{ω13 {1,1,1}},
{(x^(-2))ω13 c2x,"EsignEpos"},
{(x^(-2))ω13 c2x,"OsignOpos"}}/.xRep/.slRep;
(*)hulls3D@oScaleListDo@%**)

prm1="EsignEpos";
prm2="OsignEpos";

prm1="OsignEpos";
prm2="EsignEpos";

(* This is used to redefine the GreatRhombicosidodecahedron above in terms of mirrored Irregular Snub Dodecahedrons *)
isdNorm=(2(Sqrt[(33/8)+((5 (Sqrt[5]))/8)]));
myIrregularSnubDodecahedron[prm1_,prm2_]:={
{{-σ ,-σ,3+τ}/isdNorm,prm1},
{{-σ,(τ^2),-1+3τ}/isdNorm,prm1},
{{2τ-1,2,2+τ}/isdNorm,prm1},
{{-2σ,τ,1+2τ}/isdNorm,prm2},
{{τ,3 ,2τ}/isdNorm,prm2}}/.slRep;

IrregularSnubDodecahedronL=myIrregularSnubDodecahedron["EsignEpos","OsignEpos"];
(**)hulls3D@oScaleListDo@%(**)

IrregularSnubDodecahedronR=myIrregularSnubDodecahedron["OsignOpos","EsignOpos"];
(*)hulls3D@oScaleListDo@%**)

GreatRhombicosidodecahedron=myIrregularSnubDodecahedron["Opos","Opos"];
(*)hulls3D@oScaleListDo@%**)

GreatRhombicosidodecahedron2=myIrregularSnubDodecahedron["Epos","Epos"];
(**)hulls3D@oScaleListDo@%(**)

myIrregularSnubDodecahedron["All","All"];
(*)hulls3D@oScaleListDo@%**)

(* Close, but no cigar *)
myIrregularSnubDodecahedron["EsignOpos","OsignEpos"];
(**)hulls3D@oScaleListDo@%(**)

phScale=Root[700569-1795770((#)^2)+1502955((#)^4)-423900((#)^6)+14175((#)^8)-2250((#)^10)+125((#)^12)/.slRep&,5,0];

(* Get the symbolic even and odd permutations of I aka. Alternating group A5=H3/C2 *)
(* Chiral snub dodecahedron ? *)
IL60even=Select[IL,EvenQ[Count[Sign[#]==1&/@oct2List@#,True]]&];
IL60odd=Select[IL,OddQ[Count[Sign[#]==1&/@oct2List@#,True]]&];

ρc2=FullSimplify[{(2σ-1)(x^2)-τ x-1,-(x^2)+3τ x+3,-(τ^3) ((x^3)+σ)} FullSimplify[ω13 ((3 τ (x^2)+(τ^3) x+τ+2)/((21τ+20)(x^2)+(21τ+17)x+21τ+11))]]/.xRep2/.slRep;
ρc2Oct=octonion@Join[{0},ρc2,{0,0,0,0}];
ρc2OctN=N[ρc2Oct/.φRep];

(*)
ρc2Norm=FullSimplify[Norm@ρc2,Assumptions->{x>0,ϕ>0}];**)
ρc2NormN=N@(*)ρc2Norm**)Norm@N[ρc2/.φRep];
ρc2N=FullSimplify@((ρc2OctN)/(ρc2NormN));

(* Use the new prqI type functions that evaluate groups (**)
ρc2OctEven=ρc2Octs=prqIeven[ρc2N,1,False,True][[All,1]];
ρc2OctOdd                        = prqIodd[ρc2N,1,False,True][[All,1]];

(*)
ρc2OctList=ρc2OctListEven=oct2ImQuat@oct2List@#&/@ρc2OctEven[[All,1]];
ρc2OctListOdd=oct2ImQuat@oct2List@#&/@ρc2OctOdd[[All,1]];
ρc2OctList=phScale Join[ρc2OctListOdd[[;;4]],ρc2OctListEven[[5;;]]]/.slRep//StandardForm;

ρc2OctList={{0.25559102438416975`,0.840303177555567`,0.3716560529944439`},{-0.25559102438416975`,0.840303177555567`,-0.3716560529944438`},{-0.2555910243841697`,-0.840303177555567`,0.3716560529944438`},{0.25559102438416975`,-0.840303177555567`,-0.3716560529944438`},{0.840303177555567`,-0.3716560529944438`,-0.25559102438416975`},{-0.840303177555567`,0.3716560529944438`,-0.25559102438416975`},{0.840303177555567`,0.3716560529944439`,0.25559102438416975`},{-0.840303177555567`,-0.3716560529944438`,0.2555910243841697`},{-0.3716560529944439`,-0.25559102438416975`,0.840303177555567`},{0.3716560529944439`,-0.25559102438416975`,-0.840303177555567`},{0.3716560529944439`,0.25559102438416975`,0.840303177555567`},{-0.3716560529944439`,0.25559102438416975`,-0.840303177555567`},{0.1688018647409932`,0.7866415476749534`,-0.5120510756085466`},{-0.41501374054053713`,-0.7417345163591129`,-0.432537629004017`},{0.43253762900401704`,-0.4150137405405372`,0.7417345163591129`},{-0.6881092284703336`,0.5729689936099541`,-0.32818823890552623`},{-0.9445968007443705`,-0.09850479815495991`,-0.08676973472532348`},{0.572968993609954`,0.3281882389055262`,0.6881092284703337`},{0.7866415476749535`,0.5120510756085467`,-0.16880186474099318`},{0.08676973472532336`,-0.9445968007443702`,0.09850479815495998`},{0.5120510756085466`,0.1688018647409932`,-0.7866415476749534`},{-0.09850479815495983`,0.08676973472532343`,0.9445968007443702`},{0.32818823890552634`,-0.6881092284703336`,-0.5729689936099541`},{-0.741734516359113`,0.432537629004017`,0.41501374054053713`},{0.432537629004017`,0.4150137405405372`,-0.7417345163591129`},{0.5120510756085466`,-0.1688018647409932`,0.7866415476749534`},{0.1688018647409932`,-0.7866415476749534`,0.5120510756085467`},{-0.09850479815495983`,-0.08676973472532343`,-0.9445968007443702`},{-0.6881092284703336`,-0.5729689936099541`,0.32818823890552623`},{0.32818823890552634`,0.6881092284703336`,0.5729689936099541`},{0.08676973472532336`,0.9445968007443702`,-0.09850479815495998`},{-0.7417345163591131`,-0.432537629004017`,-0.4150137405405372`},{0.7866415476749535`,-0.5120510756085466`,0.1688018647409932`},{0.572968993609954`,-0.3281882389055262`,-0.6881092284703337`},{-0.9445968007443705`,0.09850479815495991`,0.08676973472532348`},{-0.4150137405405372`,0.741734516359113`,0.432537629004017`},{0.6881092284703336`,0.5729689936099541`,0.32818823890552623`},{-0.5120510756085466`,0.1688018647409932`,0.7866415476749534`},{-0.432537629004017`,-0.4150137405405372`,-0.7417345163591129`},{0.09850479815495983`,0.08676973472532343`,-0.9445968007443702`},{-0.08676973472532336`,-0.9445968007443702`,-0.09850479815495997`},{0.741734516359113`,0.432537629004017`,-0.4150137405405372`},{-0.1688018647409932`,0.7866415476749534`,0.5120510756085467`},{-0.32818823890552634`,-0.6881092284703335`,0.5729689936099541`},{0.41501374054053713`,-0.741734516359113`,0.43253762900401704`},{0.9445968007443705`,-0.09850479815495991`,0.0867697347253235`},{-0.572968993609954`,0.3281882389055262`,-0.6881092284703336`},{-0.7866415476749535`,0.5120510756085466`,0.16880186474099318`},{-0.08676973472532336`,0.9445968007443702`,0.09850479815495997`},{-0.5729689936099541`,-0.3281882389055262`,0.6881092284703337`},{-0.432537629004017`,0.4150137405405372`,0.7417345163591129`},{0.6881092284703336`,-0.5729689936099541`,-0.32818823890552623`},{-0.7866415476749535`,-0.5120510756085466`,-0.16880186474099318`},{0.9445968007443705`,0.09850479815495991`,-0.08676973472532348`},{0.41501374054053713`,0.741734516359113`,-0.43253762900401704`},{-0.1688018647409932`,-0.7866415476749534`,-0.5120510756085467`},{-0.5120510756085466`,-0.1688018647409932`,-0.7866415476749534`},{0.09850479815495983`,-0.08676973472532343`,0.9445968007443704`},{-0.32818823890552634`,0.6881092284703335`,-0.5729689936099541`},{0.741734516359113`,-0.432537629004017`,0.4150137405405372`}};

PentagonalHexacontahedron={
{"H3",{0,0,1}/((1/2) (Sqrt[1+(1/(ϕ^2))])),"OsignOpos"},
{"H3",phScale{σ,0,0}2/(Sqrt[3])},
{ "H3",phScale{1,-1,1}2/(Sqrt[3]),"None"},
{ρc2OctList,"NoneNoSign"}}/.slRep;
(**)hulls3D@oScaleListDo@%(**)

m1Sym=octSym/@RotationMatrix[((2π)/5),{0,1,τ}]
m1=N[m1Sym/.φRep];
%//MatrixForm

ξSym=Solve[(x^3)+2(x^2)-(τ^2)==0/.slRep,{x}][[1,1,2]]
ξ=N[ξSym/.φRep]

p1Sym=τ{τ(1-ξSym),-(τ^2)+ ξSym(1+2 ξSym),ξSym/τ}/.slRep;
%//MatrixForm
p1=N[p1Sym/.φRep]

pOct=Join[{0},p1,{0,0,0,0}];
octonion@pOct

otp=p1Sym/.φRep;
m1PointsSym=Table[otp=(otp.m1Sym/.φRep),{i,5}];
m1Points=N[m1PointsSym]

m1PointsNormSym=Simplify@Norm@m1PointsSym[[1]]
m1PointsNorm=N[m1PointsNormSym]

m1NormalizedSym=Simplify@(m1PointsSym/m1PointsNormSym)
m1Normalized=N[m1NormalizedSym/.φRep]

SnubDodecahedronL={#,"OsignOpos"}&/@m1Normalized

(*)hulls3D@oScaleListDo@%**)
SnubDodecahedronR={-#,"OsignOpos"}&/@m1Normalized;

(*)hulls3D@oScaleListDo@%**)
IrregularGreatRhombicosidodecahedron=Join[SnubDodecahedronL,SnubDodecahedronR];
(*)hulls3D@oScaleListDo@%**)

Show[(* SnubDodecahedron *)


,(* IrregularSnubDodecahedron *)
]

Show[(* GreatRhombicosidodecahedron *)


,(* IrregularGreatRhombicosidodecahedron *)
]

Define the A4 SU5 Weyl Orbit 4D Solids

Single Ring Orbits

(*) {1,0,0,0} **)
FiveCell=perms4D[[1]];
(*) Negation Dual **)
Dual5Cell=-TriRectified5Cell;
(*) -{0,0,0,1} **)

(*) {0,1,0,0} **)
Rectified5Cell=perms4D[[2]];
(*) Negation Dual **)
DualRectified5Cell=-BiRectified5Cell;
(*) -{0,0,1,0} **)

(*) {0,0,1,0} **)
BiRectified5Cell=perms4D[[3]];
(*) Negation Dual **)
DualBiRectified5Cell=-Rectified5Cell;
(*) -{0,0,1,0} **)

(*) {0,0,0,1} **)
TriRectified5Cell=perms4D[[4]];
(*) Negation Dual **)
DualTriRectified5Cell=-FiveCell;
(*)-{0,0,0,1} **)

Dual Ring Orbits

(* {1,1,0,0} *)
Truncated5Cell =perms4D[[5]];
(*) Negation Dual **)
DualTruncated5Cell=-TriTruncated5Cell;
(*)-{0,0,1,1}=**)

(* {1,0,1,0} *)
Cantellated5Cell =perms4D[[6]];
(*) Negation Dual **)
DualCantellated5Cell=-BiCantellated5Cell;
(*)-{1,0,1,0} **)

(*) {1,0,0,1} **)
Runcinated5Cell=perms4D[[7]];
(*) Self Dual **)
DualRuncinated5Cell=-Runcinated5Cell;

(*) {0,1,1,0} **)
BiTruncated5Cell=perms4D[[8]];
(*) Self Dual **)
DualBiTruncated5Cell=-BiTruncated5Cell;

(*) {0,1,0,1} **)
BiCantellated5Cell=perms4D[[9]];
(*) Negation Dual **)
DualBiCantellated5Cell=Cantellated5Cell;
(*)-{0,1,0,1} **)

(*) {0,0,1,1} **)
TriTruncated5Cell=perms4D[[10]];
(*) Negation Dual **)
DualTriTruncated5Cell=-Truncated5Cell;
(*)-{0,0,1,1} **)

Triple Ring Orbits

(*) {1,1,1,0} **)
CantiTruncated5Cell=perms4D[[11]];
(*) Negation Dual **)
DualCantiTruncated5Cell=-CantiRuncinated5Cell;
(*)-{0,1,1,1} **)

(*) {1,1,0,1} **)
RunciTruncated5Cell=perms4D[[12]];
(*) Negation Dual **)
DualRunciTruncated5Cell=-BiCantiTruncated5Cell;
(*)-{1,0,1,1} **)

(*) {1,0,1,1} **)
BiCantiTruncated5Cell=perms4D[[13]];
(*) Negation Dual **)
DualBiCantiTruncated5Cell=-RunciTruncated5Cell;
(*)-{1,1,0,1} **)

(*) Not listed {0,1,1,1} **)
CantiRuncinated5Cell=perms4D[[14]];
(*) Negation Dual **)
DualCantiRuncinated5Cell=-CantiTruncated5Cell;
(*)-{1,1,1,0}  **)

Quad  & No Ring Orbit

(*) {1,1,1,1} **)
OmniTruncated5Cell=perms4D[[15]];
(*) Self Dual **)
DualOmniTruncated5Cell=-OmniTruncated5Cell;

(*) {0,0,0,0} **)
Snub5Cell=perms4D[[16]];
(*) Self Dual **)
DualSnub5Cell=-Snub5Cell;

Pre-evaluate 3D multiOrbit Platonic, Archimedean, Catalan Solids

solidsList={{},
TruncatedTetrahedronA,TriakisTetrahedron,CuboctahedronA,RhombicDodecahedronA,TruncatedOctahedronA,TetrakisHexahedronA,CuboctahedronB,RhombicDodecahedronB,TruncatedOctahedronB,IrregularIcosahedron,TetrakisHexahedronB,TruncatedCube,TriakisOctahedron,SmallRhombicuboctahedron,DeltoidalIcositetrahedron,TruncatedCuboctahedron,GreatRhombicuboctahedron,DisdyakisDodecahedron,MyDodecahedron,MyIcosahedron,Icosidodecahedron,RhombicTriacontahedron,TruncatedDodecahedron,TriakisIcosahedron,TruncatedIcosahedron,PentakisDodecahedron,SmallRhombicosidodecahedron,DeltoidalHexacontahedron,GreatRhombicosidodecahedron,DisdyakisTriacontahedron,Pyritohedron,SnubCubeL,SnubCubeR,IrregularTruncatedCuboctahedron,IrregularGreatRhombicuboctahedron,PentagonalIcositetrahedron,IrregularSnubDodecahedronL,IrregularSnubDodecahedronR,PentagonalHexacontahedron,SnubDodecahedronL,SnubDodecahedronR,IrregularGreatRhombicosidodecahedron,TruncatedTetrahedronB,IrregularSmallRhombicuboctahedron};

solidsListStr= {"None","A3 110 Truncated Tetrahedron A","A3 100 Triakis Tetrahedron","A3 (101) Cuboctahedron A","A3 001 Rhombic Dodecahedron A","A3 (111) Truncated Octahedron A","A3 010 Tetrakis Hexahedron A","B3 010  Cuboctahedron B","B3 100 Rhombic Dodecahedron B","B3 (110 All) Truncated Octahedron B","B3 (110 EsignEpos) Irregular Icosahedron","B3 100 Tetrakis Hexahedron B","B3 011 Truncated Cube","B3 100 Triakis Octahedron","B3 101 Small Rhombicuboctahedron","B3 100 Deltoidal Icositetrahedron","B3 111 Truncated Cuboctahedron *","B3 111 (Great) Rhombicuboctahedron *","B3 100 Disdyakis Dodecahedron","H3 Dodecahedron","H3 Icosahedron","H3 Icosidodecahedron","H3 Rhombic Triacontahedron","H3 Truncated Dodecahedron","H3 Triakis Icosahedron","H3 Truncated Icosahedron","H3 Pentakis Dodecahedron","H3 (Small) Rhombicosidodecahedron","H3 Deltoidal Hexacontahedron","H3 (Great) Rhombicosidodecahedron **","H3 Disdyakis Triacontahedron","H3 Pyritohedron","H3 SnubCube L","H3 SnubCube R","H3 Irregular Truncated Cuboctahedron ***","H3 Irregular (Great) Rhombicuboctahedron ***","H3 Pentagonal Icositetrahedron","H3 Irregular SnubDodecahedron L","H3 Irregular SnubDodecahedron R","H3 Pentagonal Hexacontahedron","H3 Snub Dodecahedron L","H3 Snub Dodecahedron R","H3 Irregular Truncated Icosidodecahedron **","A3 011 Truncated Tetrahedron B","Irregular Small Rhombicuboctahedron"};

(* Don't process these if we are going to load the pre-defined results below **)
opacity=.75;
addNullPoints=False;

If[MemberQ[paneList,"Dynkin"],
(* Generate the scaled vertices from the orbit definitions *)
solidsListScaled=Join[{""},(Print[#,"  ",solidsListStr[[#]]];
oScaleListDo[solidsList[[#]]]/.slRep)&/@Range[2,Length@solidsList]];
(* Generate the hulls from the vertices *)
solids3D=  Join[{""},(print[#,"  ",solidsListStr[[#]]];
hulls3D[solidsListScaled[[#]]]/.slRep)&/@Range[2,Length@solidsListScaled]]/.slRep];
solids3D=(solids3D[[#]]/.slRep&/@Range@Length@solids3D);

Pre-evaluate the A4 5-Cell multiOrbit 4D Solids (and their duals)

A4OrbitList4D={{},
FiveCell,Rectified5Cell,BiRectified5Cell,TriRectified5Cell,Truncated5Cell,Cantellated5Cell,Runcinated5Cell,BiTruncated5Cell,BiCantellated5Cell,TriTruncated5Cell,CantiTruncated5Cell,RunciTruncated5Cell,BiCantiTruncated5Cell,CantiRuncinated5Cell,OmniTruncated5Cell,Snub5Cell,

Dual5Cell,DualRectified5Cell,DualBiRectified5Cell,DualTriRectified5Cell,DualTruncated5Cell,DualCantellated5Cell,DualRuncinated5Cell,DualBiTruncated5Cell,DualBiCantellated5Cell,DualTriTruncated5Cell,DualCantiTruncated5Cell,DualRunciTruncated5Cell,DualBiCantiTruncated5Cell,DualCantiRuncinated5Cell,DualOmniTruncated5Cell,DualSnub5Cell};

A4OrbitList4DStr= {"None","5-Cell","Rectified 5-Cell","BiRectified 5-Cell","TriRectified 5-Cell","Truncated 5-Cell","Cantellated 5-Cell","Runcinated 5-Cell","BiTruncated 5-Cell","BiCantellated 5-Cell","TriTruncated 5-Cell","CantiTruncated 5-Cell","RunciTruncated 5-Cell","BiCantiTruncated 5-Cell","CantiRuncinated 5-Cell","OmniTruncated 5-Cell","Snub 5-Cell",

"Dual 5-Cell","Dual Rectified 5-Cell","Dual BiRectified 5-Cell","Dual TriRectified 5-Cell","Dual Truncated 5-Cell","Dual Cantellated 5-Cell","Dual Runcinated 5-Cell","Dual BiTruncated 5-Cell","Dual BiCantellated 5-Cell","Dual TriTruncated 5-Cell","Dual CantiTruncated 5-Cell","Dual RunciTruncated 5-Cell","Dual BiCantiTruncated 5-Cell","Dual CantiRuncinated 5-Cell","Dual OmniTruncated 5-Cell","Dual Snub 5-Cell"};

(* Don't process these if we are going to load the pre-defined results below (**)
addNullPoints=False;
A4OrbitHulls3D   ={""};
A4OrbitHulls4D   ={""};
A4OrbitHulls4DOverall  ={""};

If[MemberQ[paneList,"Dynkin"],
(**)doPrint=False;(**)
(Print["Starting ",#,"  ",A4OrbitList4DStr[[1+#]]];
doPP3D=True;
AppendTo[A4OrbitHulls3D,Row@{MatrixForm@Transpose@Table[{
{"","","SU4 x U1","",""}[[i]],
Abs/@avΛOrbit[[i,;;3]]/.aRule@perms4D[[Mod[#-1,16,1]]],
getSU4Hull[Mod[#-1,16,1],i]},{i,5}]}];
doPP3D=False; (* Use the Dual basis ω if the name is a Dual **)
oScaleListOut=DeleteDuplicates@ΛnD[If[StringStartsQ[A4OrbitList4DStr[[#]],"Dual"],aωΛ[[1]],avΛ[[1]]],oCalc,"A4",A4OrbitList4D[[#]],"Osign"]/.slRep;
AppendTo[A4OrbitHulls4D,hulls3DPerms["oScaleListOut",False,,(**)1(*)4**)]];
AppendTo[A4OrbitHulls4DOverall,Row@{combinedHull,overallHull}](**))&/@Range[2,(*)8**)Length@A4OrbitList4D(**)]];
doPrint=False;
doPP3D=True;

Section I: Introduction

Introduction

Fig. 1 is the Petrie projection of the Gosset (Subscript[4, 21]) 8-polytope derived from the Split Real Even (SRE) form of the (Subscript[E, 8]) Lie group with unimodular lattice in (ℝ^8) It has 240 vertices and 6,720 edges of 8-dimensional (8D) length (Sqrt[2]). (Subscript[E, 8]) is the largest of the exceptional simple Lie algebras, groups, lattices, and polytopes related to octonions (𝕆 ), (8,4) Hamming codes, and 3-qubit (8 basis state) Hadamard matrix gates. An important and related higher dimensional structure is the (ℝ^24)((ℂ^24)) Leech lattice ((Subscript[Λ, 24])⊃ (Subscript[E, 8]) ♁ (Subscript[E, 8]) ♁ (Subscript[E, 8]) ) with its binary (ternary) Golay code construction.

showEdges=True;
doImage

Fig. 1 (Subscript[E, 8]) (Subscript[4, 21]) Petrie projection

It is widely known [1]-[14] that the (Subscript[E, 8]) can be projected, mapped, or "folded" (as shown in Fig. 2) to two golden ratio φ=(1/2)(1+(Sqrt[5]))≈1.618 scaled copies of the 4 dimensional 120 vertex 720 edge (Subscript[H, 4]) 600-cell. Folding an 8D object into a 4D one can be done by projecting each vertex using its dot product with a 4×8 matrix\cite{Moxness2014-006}. This produces (Subscript[H, 4])♁φ (Subscript[H, 4]), where (Subscript[H, 4]) is the binary icosahedral group 2I of order 120, a subgroup of Spin(3). It covers (Subscript[H, 3]) as the full icosahedral group (Subscript[I, h]) of order 120, a subgroup of SO(3). The binary icosahedral group is the double cover of the alternating group (Subscript[A, 5]).

Defining φ:

(* The symbol φ is the main reference for resolving the Golden Ratios. 
It is only evaluated to a symbolic or numeric value using φRep replacement rules *)
Clear[ϕ,σ,Φ,τ,φ];
(* Upper (and lower) case Phi(Φ=(1+(Sqrt[5]))/2) (and phi ϕ=(1-(Sqrt[5]))/2)) represent large (and small) Golden Ratio (respectively) *)
ϕ=1/φ;
(* σ & τ are Galois conjugates *)
σ=-1/φ/.slRep;
τ=Φ=φ;

(* 𝕌Det1f is a scale factor to make Det@𝕌=1 *)𝕌Det1f=2(Sqrt[ϕ]) /.slRep;

(* φRep are replacement rules used when needing to evaluate φ and ω *)
?φRep

(* Note: slRep is are replacement rules when using the SuperLie' package, which redifines operators such as Plus, Times,... 
*)

?slRep

Despite others'[2][9] recent attempts, the inverse morphism or "unfolding” from (Subscript[H, 4]) to (Subscript[E, 8]) is less trivial given that the matrix is not square and lacks an inverse. Yet, a real (ℝ) symmetric volume preserving Det(𝕌)=1 rotation matrix(\ref{eqn:H4foldUnitary}) was derived in 2012 and documented [11][12][13]. The quadrant structure of 𝕌 rotates (Subscript[E, 8]) into four 4D copies of (Subscript[H, 4]) 600-cells, with the original two (L)eft and (R)ight side unit scaled 4D copies related to the two L/R φ scaled copies which we now identify as (Subscript[H, 4])(L♁R♁1♁φ). This traceless form of 𝕌 has palindromic characteristic coefficients and provides for an explicit isomorphic mapping of (Subscript[E, 8])↔(Subscript[H, 4])(L♁R♁1♁φ). This involves using a bidirectional L↔R mapping function (mapLR) and (𝕌^(-1))(2). The process is described and visualized in Section II. It is interesting to note the exchange of 1↔φ in 𝕌↔ (𝕌^(-1)), excluding -(φ^2).

Constructing the E8 to H4 Folding Matrix from Quantum Computing (QC) CNOT (eqn. (3) and SWAP (eqn. (4) gates

(* Define CNOT and SWAP as Hermitian Matrices *)

CNOT:=(({{1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 0, 1}, {0, 0, 1, 0}}));
CNOT==(CNOT^\[Transpose])
CNOT.(CNOT^\[Transpose])==IM@4

SWAP:=(({{1, 0, 0, 0}, {0, 0, 1, 0}, {0, 1, 0, 0}, {0, 0, 0, 1}}));
SWAP==(SWAP^\[Transpose])
SWAP.(SWAP^\[Transpose])==IM@4

(* This is the non-Det=1 palindromic form of 𝕌 (curr𝕌=11) *)

Transpose@Join[SWAP-ϕ CNOT,Reverse[SWAP+ϕ CNOT]]/.slRep;
𝕌Base=Join[%,Reverse[Reverse/@%]];
%//MatrixForm

N[%/.φRep]//MatrixForm

Det@%

(* This is 𝕌 scaled to Det=1 (curr𝕌=9) *)

E82H4=𝕌Base/𝕌Det1f/.slRep;
%//MatrixForm

N[%/.φRep]//MatrixForm

(* Redefining from the Localized Manipulate (above) 
Here are a few different forms for using the E8↔H4 (un)folding matrix 𝕌, 
which is now selectable and set from curr𝕌 **)
EI𝕌:=FullSimplify@MatrixExp[I E82H4];
EI𝕌Inv:=Inverse@EI𝕌;
EI𝕌Rev:=Reverse/@EI𝕌
EI𝕌InvRev:=Inverse@EI𝕌Rev;

𝕌:=If[doUnitary,EI𝕌,E82H4];
𝕌Inv:=Rationalize@Inverse@𝕌;
𝕌Rev:=Reverse/@𝕌;
𝕌InvRev:=Inverse@𝕌Rev;

Equations (1) and (2):

(* Note: the two 120 print outputs confirm by evaluation the (Subscript[H, 4]) & (Subscript[φH, 4]) 600-Cell membership in (Subscript[E, 8]) **)
curr𝕌=9;set𝕌;
2(Sqrt[φ])𝕌//MatrixForm

(* Note: octSym performs a symbolic simplification related to φ ratios *)
octSym/@(2(Sqrt[φ])𝕌Inv)//MatrixForm

Generating Polytopes

The quaternion (ℍ) Weyl group orbit O(Λ)=W((Subscript[H, 4]))=I of order 120 is constructed from the parent orbit (1000) of the Coxeter-Dynkin diagram for (Subscript[H, 4]) shown in Fig. 2b. This results in the 600-cell 4-polytope of order 120 labeled here and in [3] as I. In addition, 𝕌 provides for a direct mapping from (Subscript[E, 8]) to four L♁R♁1♁φ copies of the tri-rectified parent of (Subscript[H, 4]) (i.e. the filled node 1 is shifted right 3 times giving 0001), which is the 120-cell of order 600 labeled here and in \cite{Koca_2011} as J. Both of these 4-polytopes are shown in Appendix 14-16. The detail of the quaternion Weyl orbit construction is described in Section III.

Import@"folding.png"

Fig. 2 Dynkin diagrams in folding orientation

a) (Subscript[E, 8 ]) Dynkin diagram in folding orientation 
b) The associated Coxeter-Dynkin diagram of (Subscript[H, 4]) 
c) (Subscript[D, 6]) Dynkin diagram in folding orientation 
d) The associated Coxeter-Dynkin diagram of (Subscript[H, 3])

In addition to the 240 root (Subscript[4, 21]) (Subscript[E, 8]) 8-polytope identified by its Coxeter-Dynkin diagram in Fig. 2a, there are (2^8) possible orbits using only 0’s↔1's, empty↔filled, or ringed nodes of the (Subscript[E, 8]) Coxeter-Dynkin diagram, including the snub (00000000) orbit. Several other orbit permutations are commonly represented visually using the Petrie projection basis. They are the 2,160 root (Subscript[2, 41]) and 17,280 root (Subscript[1, 42]) 8-polytopes, which are constructed by generating the resulting roots by moving the filled (or ringed) node to each of the two other ends of the Dynkin diagram, as shown in Figs. 3b and 3c respectively.

Fig. 3 (Subscript[E, 8])Dynkin diagrams a)(Subscript[4, 21]),b)(Subscript[2, 41]),c)(Subscript[1, 42])

Also shown are the Cartan and simple root matrices which correspond to the common Coxeter-Dynkin representation of the diagrams

8D Platonic Rotation

Interestingly from [13], 𝕌 can be generated using a combination of the unimodular matrices commonly used for Quantum Computing (QC) qubit logic, namely those of the 2 qubit CNOT (3) and SWAP (4) gates. Taking these patterns, combined with the recursive functions that build φ from the Fibonacci sequence, it is straightforward to derive 𝕌 from scaled QC logic gates.[14]

𝕌 from recursively applied Fibonacci numbers & 
Quantum Computing Logic Gates

nC@0:=CNOT.SWAP/.slRep;
nC@0//MatrixForm

nC@1:=((nC[0])^\[Transpose])/.slRep;
nC@1//MatrixForm

nC@i_:=nC[i-2]+nC[i-1]/.slRep;
MatrixForm[nC@#]&/@Range[2,8]

nCInv:=Inverse@((nC[#])^\[Transpose])&/.slRep;
MatrixForm[nCInv@#]&/@Range[0,8]

qc𝕌=First[{mat=((Join[
                   {-1,1,1,1}  ((fb[#+1])/(fb[#]))  (((2nC[#-1].nCInv@#-IM@4))^\[Transpose])[[{1,4,3,2}]],
Reverse[{-1,1,1,1}(((fb[#-1])/(fb[#+1]))(((2nC[#+1].nCInv@#+ nC@1))^\[Transpose])[[{1,3,2,4}]])]])^\[Transpose]);
rndMat/@Join[mat,Reverse/@Reverse@mat]
}/.slRep&/@Range[13,13]][[1]];
%//MatrixForm

Det[qc𝕌/𝕌Det1f/.φRep]

2D and 3D Projection

Projection of (Subscript[E, 8]) to 2D (or 3D) requires 2 (or 3) basis vectors {X,Y,Z}. For the Petrie projection shown in Fig. 1, we start with the basis vectors in (5), which are simply the two 2D Petrie projection basis vectors of the 600-cell (a.k.a. the Van Oss projection), with an optional 3rd (z) basis vector added for an interesting 3D projection[11].

Equation (5):

(* The 4D (Subscript[H, 4]) {x,y,z} Van-Oss projection (5) are {H3a,V3a,Z3a} *)
Chop@PadRight[#,8]&/@{H3a,V3a,Z3a}//MatrixForm

Equation (6):

(* {X,Y,Z}=(𝕌^\[Transpose]).{x,y,z} (6) *)
Chop@N[(𝕌^\[Transpose]).#/.φRep]&/@%//MatrixForm

3D Platonic Solid Projection

This basis is derived from the icosahedral symmetry of the (Subscript[H, 3])-based Platonic solid. The twelve vertices of the icosahedron can be decomposed into three mutually-perpendicular golden rectangles (as shown in Fig. 4), whose boundaries are linked in the pattern of the Borromean rings. Rows (or columns) 2-4 (or 5-8) of 𝕌 contain 6 of the 12 vertices of this icosahedron, including 2 at the origin with the other 6 of 12 icosahedron vertices being the antipodal reflection of these through the origin. These 2 (or 3) rows can then used as a kind of “Platonic solid projection prism” to form the 2 (or 3) 8D basis vectors used in the 2D (or 3D) projection of (Subscript[4, 21]), (Subscript[2, 41]), and (Subscript[1, 42]).

Import@"Icosahedron-golden-rectangles.png"

Fig. 4 The icosahedron formed from 3 mutually perpendicular golden rectangles

Orthogonal projection to 3D after 𝕌 folding (i.e. selecting one of 56 unique subsets of any 3 dimensions, here we use {1,2,3}) manifests a large number of concentric hulls with Platonic and Archimedean solid related structures. The eight projected 3D hulls of (Subscript[4, 21]) include two φ scaled sets of four hulls from two 600-cells ((Subscript[H, 4])♁φ (Subscript[H, 4])) as shown in Appendix A Fig. 14. (Subscript[2, 41]) and (Subscript[1, 42]) projections of (Subscript[E, 8]) are shown in Figs. 5-6.

Fig. 5 (Subscript[2, 41])projections of its 2,160 vertices

(* a) *)

Import@"E8_241_Petrie_Projection.png"

(* b) *)

Column[{tallyList[[#]],plys[[#]]}]&/@Range@Length@plys
MatrixForm@Partition[%,UpTo[4]]

(* c) *)

doImage

a) 2D to the (Subscript[E, 8]) Petrie projection using basis vectors X and Y from (6) with 8-polytope radius 2(Sqrt[2]) and 69,120 edges of length (Sqrt[2]). 
b) 3D projections with vertices sorted and tallied by their 3D norm generating the increasingly transparent hulls for each set of tallied norms. Notice the last two outer hulls are a combination of two overlapped Icosahedrons (24) and a Icosidodecahedron (30). 
c) Combined 3D hulls with the overlapping vertices color coded by overlap count. Also shown is a list (in red) of the normed hull distance and the number of vertices in the group.

Fig. 6 (Subscript[1, 42])projections of its 17,280 vertices

(* a) *)

Import@"E8_142_Petrie_Projection.png"

(* b) *)

Partition[plys,4]

(* c) *)

Show@plys[[;;16]]

Column[{"Overlaps="<>ToString[Transpose[{vertexTally2[[#,1]],vertexTally2[[#,2]],
getColor[Length@vertexTally1+#]}&/@Range@Length@vertexTally2],TraditionalForm],
"verts="<>ToString@Length@verts2},Center]

doImage

a) 2D to the (Subscript[E, 8]) Petrie projection using basis vectors X and Y from (6) with 8-polytope radius 2(Sqrt[2]) and 483,840 edges of length (Sqrt[2])(with 53% of inner edges culled for display clarity).
b) 3D projections with vertices sorted and tallied by their 3D norm generating the increasingly transparent hulls for each set of tallied norms. Notice the last two outer hulls are a combination of two overlapped Dodecahedra (40) and a irregular Rhombicosidodecahedron (60).

Section II: The palindromic unitary matrix

The particular maximal embedding of (Subscript[E, 8]) at height 248 that we are interested in for this work is shown in Appendix C Fig. 19 as the special orthogonal group of SO(16)=(Subscript[D, 8]) at height (120=112+4+4)+128’, where 112 is interpreted as the subgroup embeddings of SO(8)×SO(8)=(Subscript[D, 4])×(Subscript[D, 4]) and 128' is interpreted as symplectic subgroup embeddings of (Subscript[C, 8]) where Sp(8)×Sp(8)=(Subscript[C, 4])×(Subscript[C, 4]) at height 136=128+4+4. These selected embeddings correspond to the 112 integer (Subscript[D, 8]) vertices and the 128 half-integer (Subscript[BC, 8]) vertices given by SRE (Subscript[E, 8]), in addition to the 8♁(OverBar[8]) generator roots for a total of (2^8). This is in 1::1 correspondence with the canonical root vertex ordering from the 9th row of the palindromic Pascal triangle {1,8,28,56,35(OverBar[35]),(OverBar[56]),(OverBar[28]),(OverBar[8]),(OverBar[1])}, where each entry in the list gives the number of vertices that alternate between half-integer (Subscript[BC, 8]) and integer (Subscript[D, 4]) vertex sets, with the right 5 overbar sets of 128 vertices being the negated vertices of the left 5 sets of 128 in reverse order.

These embeddings have an isomorphic connection to 𝕌 and provide the (Subscript[E, 8])↔(Subscript[H, 4])(L♁R♁1♁φ) mapping via mapLR. The (Mathematica^TM) code for mapLR and the code to validate the (Subscript[E, 8])↔(Subscript[H, 4]) isomorphism is shown in Appendix D Fig. 21. It demonstrates that (Subscript[E, 8]) rotates into four 4D copies of (Subscript[H, 4]) 600-cells, with the original two (L)eft side φ scaled 4D copies related to the two (R)ight side unscaled 4D copies.

Due to the palindromic structure of 𝕌, the (Subscript[H, 4 L]) and (Subscript[H, 4 R]) are also palindromic with each R vertex being the reverse order of the L vertex, along with mapLR exchanges in the (S)nub 24-cell vertices. For each L vertex that is not a member of the (T)etrahedral group's self-dual (Subscript[D, 4]) 24-cell (or φT), the R vertex will be a member of the scaled φS (or S) respectively. This is due to the exchange of (φ^(3/2))↔(φ^(-3/2)) in mapLR which changes the norm (i.e. to/from a small norm=1/(Sqrt[φ]) or a large norm=(Sqrt[φ])). The 24-cell T vertices are unaffected by mapLR exchange and have L and R vertex values of the same norm and palindromic opposite entries, with the larger φ(Subscript[H, 4]) having the same signs and the smaller unit scaled (Subscript[H, 4]) having opposite signs.

It is clear that 𝕌 is traceless, but it is not unitary. Since 𝕌 is Hermitian, it is easily made unitary as (ℯ^(i𝕌)). While that is unitary it is not traceless, so it is not an (Subscript[A, 7]) group SU(8) symmetry. For the identification of their palindromic characteristic polynomial coefficients, see Figs. 7-8.

Fig. 7 The trace, determinant, Eigenvalues, Eigenvector matrix, and characteristic polynomial coefficients of  𝕌

The eigenvalues of an element satisfy the characteristic polynomial
((((1+σ (x^2))(1-τ (x^2))))^2)==0

(* Show it is traceless *)
Chop@FullSimplify[Tr[𝕌/.φRep],Assumptions->φAssumptions]

(* Get the Characteristic coefficients *)
FullSimplify[CharacteristicPolynomial[𝕌,x],Assumptions->φAssumptions]

((((1+σ (x^2))(1-τ (x^2))))^2)/.slRep;
FullSimplify[%==%%];
Expand@%%;
Collect[%,x]

(* The palindrome of coefficients in the characteristic matrix of 𝕌 *)
         {1,0,   2(σ-τ),      0,      7,      0,     2(σ-τ),        0,     1};
c𝕌=1+0 x+2(σ-τ)(x^2) +0 (x^3)+7(x^4) +0 (x^5)+2(σ-τ)(x^6) +0 (x^7)+(x^8)/.slRep;
FullSimplify[%==%%%,Assumptions->φAssumptions]

Chop@N[%/.φRep]

Fig. 8 The Eigenvalues, Eigenvector matrix, and characteristic polynomial coefficients of the unitary form of 𝕌 as (ℯ^(i𝕌)) showing a Tr@Re@(ℯ^(i𝕌))≈ 4 and a traceless imaginary part

EI𝕌//MatrixForm

Det@%
ToRadicals@FullSimplify[Tr[%%/.φRep],Assumptions->φAssumptions]
Chop@N@%

N[2 (E^(-I (Sqrt[2+(Sqrt[5])])))]
N[(E^(I (Sqrt[(1/2) (-1+(Sqrt[5]))])))+(E^(I (Sqrt[(1/2) (1+(Sqrt[5]))])))+(E^(I (Sqrt[(5/2) (1+(Sqrt[5]))])))+(E^(I (Sqrt[(1/2) (11+5 (Sqrt[5]))])))]
%% %

(* Show the Determinant of EI𝕌=1 *)
Det@EI𝕌
Chop@N[%/.φRep]

(* Show the Trace of EI𝕌=0 *)
Tr@EI𝕌
Chop@N[%/.φRep]

CharacteristicPolynomial[EI𝕌,x];
ToRadicals@FullSimplify[%,Assumptions->φAssumptions]

Expand@%;
Collect[%,x];

octSimplify/@FullSimplify[Eigenvalues@EI𝕌, Assumptions->φAssumptions]
Total@N[%/.φRep]
FullSimplify[Eigenvectors@EI𝕌, Assumptions->φAssumptions]

Cf1=Cos[(1/(Sqrt[ϕ]))]+Cos[(Sqrt[ϕ])];
Cf2=Cos[(1/(Sqrt[ϕ]))]Cos[(Sqrt[ϕ])];
Cf3=((Cos[(1/(Sqrt[ϕ]))])^2) Cos[(Sqrt[ϕ])]+Cos[(1/(Sqrt[ϕ]))]((Cos[(Sqrt[ϕ])])^2);
Cf4=((Cos[(1/(Sqrt[ϕ]))])^2)+((Cos[(Sqrt[ϕ])])^2);

(* The palindrome of coefficients in the characteristic matrix of EI𝕌 *)
               {1,-4Cf1,    4(1+4Cf2+Cf4),   -4(3Cf1+4Cf3),      2(3+4(Cf4+2Cf2(Cf2+2))),  -4(3Cf1+4Cf3),      4(1+4Cf2+Cf4),   -4 Cf1,     1};
cEI𝕌=  1   -4 Cf1 x+4(1+4Cf2+Cf4)(x^2)-4(3Cf1+4Cf3)(x^3)+2(3+4(Cf4+2Cf2(Cf2+2)))(x^4)-4(3Cf1+4Cf3)(x^5)+4(1+4Cf2+Cf4)(x^6)-4 Cf1 (x^7)+(x^8)/.slRep;
N[%/.φRep]

(* Re@EI𝕌 *)
FullSimplify[Re@EI𝕌,Assumptions->φAssumptions]//MatrixForm

Tr@%
N[%/.φRep]

(* Im@EI𝕌 *)
FullSimplify[Im@EI𝕌,Assumptions->φAssumptions]//MatrixForm

Tr@%
Chop@N[%/.φRep]

(* Re@EI𝕌 *)
N@FullSimplify[Re@EI𝕌/.φRep,Assumptions->φAssumptions]//MatrixForm

(* Im@EI𝕌 *)
N@FullSimplify[Im@EI𝕌/.φRep,Assumptions->φAssumptions]//MatrixForm

See Appendix D Figs. 22-23 showing the detail of the (Subscript[E, 8])↔(Subscript[H, 4])(L♁R♁1♁φ) isomorphism and the patterns within their respective vertex roots.

Section III: Quaternionic Weyl orbit construction

The content within this paper was generated using a computational environment the author has written in (Mathematica^TM) by Wolfram Research, Inc. In order to deal effectively with quaternions, it supplants the native Quaternion package with a more flexible symbolic octonion (𝕆 ) capability. This allows for the selection of a multiplication table from any of the 480 possible octonion tables, including their split and bi-octonion forms. It also handles the sedenion forms as well and has been used to verify the octonion forms of (Subscript[E, 8]) from Koca[1], Dixon[15], Pushpa and Bisht[16], R. A. Wilson, Dray, and Monague[17], including the complexified octonions of Günaydin-Gürsey[18] and Furey[19]. To ensure that our quaternion (and bi-quaternion) math is consistent with the standard multiplication convention related to quaternions, we need to select one of the 48 octonions with a first triad of 123 and a Cayley-Dickson construction where (Subscript[ℯ, 4])-(Subscript[ℯ, 7]) quadrant multiplication remains within the quadrant. See Fig. 9 showing the selected triads, Fano plane, and multiplication table of the octonion used in this and several of the referenced (papers^1).

(( )^1) It is interesting to note that this particular octonion is close to (but not) palindromic. Using an algorithmic identification and construction of all of the possible 480 unique permutations of octonions\cite{Moxness2013-005}, we find that a small change in triads to {123,145,167,264,257,347,356} with 5↔7 ordering swaps creates a palindromic (Subscript[E, 8]). This octonion is shown in Fig. 10.

Fig. 9 The selected octonion Fano plane mnemonic and multiplication table based on its 7 structure constant triads . 
The first triad (123) defines standard convention for quaternions..

We need to pick an octonion that has the first triad={1,2,3} (i.e. strict quaternion),
and  strict Cayley-Dickson construction where  (Subscript[ℯ, 4]) to (Subscript[ℯ, 7]) quadrant multiplication remains within the quadrant. 
So we find the one (of 48) with first triad={1,2,3} and the one with Cayley-Dickson construction.

flip=True;
allOcts=Table[setFM[i,flip,0];triads,{i,240}];
fn=position[allOcts,{{1,2,3},{1,4,7},{1,6,5},{2,4,6},{2,5,7},{3,5,4},{3,6,7}}]

(* This sets the type of octonion split for negative split numbers (where Abs@split selects a triad):
 False implies the first of 4 non-triad imaginary dimensions becomes real (or +1), giving a 1+3I + 1+3I octonion
True implies the first 3 become real, giving a 1+3I + 3+1I octonion **)
split3Real=(**)False(*)True**);
setFM[(*)85**)fn(**),flip(*)=True**),split=0];(**)
triads//MatrixForm

fanoPlane
fmDispN

Fig. 10 An alternative set of structure constant triads, octonion Fano plane mnemonic, and multiplication table, with decorations showing the palindromic multiplication.

flip=True;
allOcts=Table[setFM[i,flip,0];triads,{i,240}];
fn=position[allOcts,{{1,2,3},{1,4,5},{1,6,7},{2,6,4},{2,5,7},{3,4,7},{3,5,6}}]

(* This sets the type of octonion split for negative split numbers (where Abs@split selects a triad):
 False implies the first of 4 non-triad imaginary dimensions becomes real (or +1), giving a 1+3I + 1+3I octonion
True implies the first 3 become real, giving a 1+3I + 3+1I octonion **)
split3Real=(**)False(*)True**);
setFM[fn,flip(*)=True**),split=0];(**)
triads//MatrixForm

fanoPlane
fmDispN

Fig. 11 The values of the (Subscript[D, 4]) 24-cell T and its alternate T’

TpL=octonion[pE8@#/(Sqrt[2])]&/@so8
TpLΦ=oct2List/@%;
TpLΦRnd=rndOct/@%;
NTpLΦ=%%/.φRep;
TpLΦList=FullSimplify[Chop@N@#]&/@%
showInfo@%%

(* From the original study I did *)
excluded={2,3,4,5,6,7,8,9,255,254,253,252,251,250,249,248};
TL=octonion/@Join[
biQuaternion/@pm2@4,
pE8/@excluded[[Join[Range[5,8],Range[13,16]]]]]

TLΦ=oct2List/@%;
TLΦRnd=rndOct/@%;
NTLΦ=%%/.φRep;
TLΦList=FullSimplify[Chop@N@#]&/@%;
showInfo@%%

Define c, α, & β  (L only )

cLlist=TL;
cL=octonion@cLlist[[13]]
NcL=octonion@FullSimplify[N@%/.φRep]
octNorm@%

cpLlist=TpL;
cpL=octonion@cpLlist[[13]]
NcpL=octonion@FullSimplify[N@%/.φRep]
octNorm@%

(* This gives S=I-T (See SLΦ defined below), with 4D odd position permutations with odd ± Sign permutations where τ=φ and σ=-1/φ.  *)

Slist=αLlist=FullSimplify[biQuaternion/@perms[{-σ,1,τ,0},"OSignOpos"]/2/.slRep,Assumptions->φAssumptions];
SlistOct=αLlistOct=octonion/@oct2List@Slist;
Length@%

αLOct=αLlistOct[[8]]
αL=αLlist[[8]]
NαL=rndOct[%/.φRep/.slRep]

(* This gives S'=I'-T' (See SpLΦ defined below). 
This wasn't given explicity, but perms[{-τ,1,σ,0}] was used in 1106.3433 with mapστ (σ⟷τ) from Slist above.
This is different with a (Sqrt[5]) factor vs. 1 *)
SpList=βLlist=FullSimplify[biQuaternion/@perms[{-τ,(Sqrt[5]),σ,0},"ESignEpos"]/(Sqrt[8])/.slRep,Assumptions->φAssumptions];
SpListOct=βLlistOct=octonion/@oct2List@SpList;
Length@%

βLOct=βLlistOct[[8]]
βL=βLlist[[8]]
NβL=rndOct[%/.φRep/.slRep]

(* Speed processing by evaluating (α^(n=1..4)),
    which is effectively another coordinate set for a 4D 5-cell,
      when projected into 3-space becomes a 2D pentagon. *)
octExpαL=octSimplify@#&/@(octExp[αLOct,#]&/@Range[0,4])
(* Speed processing by evaluating ((α†)^(n=1..4)) *)

octExpαLsw=octSimplify@#&/@(octExp[mapστ@(SuperStar[αL]),#]&/@Range[0,4])
octExpαLswRnd=rndOct/@%

(* Convert to an 8D octonion list, with only the quaternion part being non-zero *)
octExpαLlist=oct2List/@%;
%//MatrixForm

(* Convert symbols to rounded integer rationals *)
octExpαLRnd=rndOct/@%;
%//MatrixForm

(* Visualize 5-cell in 3D using the 4 orthogonal projections wxy, wxz, wyz, xyz **)
addNullPoints=True;
hulls3DPerms["octExpαLlist",False,,4]
addNullPoints=False;

doW@"A4"

(* Set some short variable names for Mamone paper analysis
LieART steps on T *)
T=TL;
Tlist=TLΦ;
Tp=TpL;
IpList=IpLΦ;
octExpα=octExpαL;
(*)Clear[𝔸,α,β,c];**)
cp=cpL;

It has been shown that the 3D symmetry groups of (Subscript[A, 3]), (Subscript[B, 3]), and (Subscript[H, 3 ])[3] and 4D symmetry groups of (Subscript[A, 4]), (Subscript[D, 4]),(Subscript[F, 4]),and (Subscript[H, 4 ]) are related to the higher dimensional groups of (Subscript[D, 6]) and (Subscript[E, 8])[5][9]. A quaternionic Weyl group orbit O(Λ)=W((Subscript[H, 4]))=I of order 120 can be constructed from (Subscript[H, 3]) which generates some of the Platonic, Archimedean and dual Catalan solids shown in Appendix B Fig. 18, including their irregular and chiral forms\cite{koca2011chiral}. The polytopes for a particular orbit of O(Λ)=W(group) are generated using a function Λ[group_,orbit_,perm_:"Rotate"]}, where perm can be one of 18 combinations of sign and position permutation functions (e.g. "oSign" gives all odd sign permutations and cyclic rotations of position and the default "Rotate" gives all sign permutations of cyclically rotated positions). The first column in these figures show the set of calls to the Λ function. This same method is used to generate the (Subscript[H, 4])-based 4-polytopes of the 120-cell and 600-cell shown in Appendix A Figs. 14-16.

The (Subscript[A, 3]) in (Subscript[A, 4]) group embedding of SU(5)⊃SU(4)×(Subscript[U, 1])[5] are shown in Appendix C Fig. 20 in combination with these 3 and 4-polytope (visualizations^2).

(( )^2) In the methods and coding descriptions, since Mamone[6] identifies the 5-cell as S, but Koca uses S to identify the (S)nub 24-cell (a convention which we use here), Mamone's A_4-based 5-cell is now identified as A which is the 4D version of the tetrahedron.

We identify the rectified parent orbit (0100) of W((Subscript[D, 4])4) as the self-dual 24-cell T, which is the combination of the 4D octahedron (aka. 16-cell) and the 4D cube (aka. 8-cell with a 3D hull of the cuboctahedron derived from the tri-rectified (0001) W((Subscript[BC, 4]))). Due to the W((Subscript[D, 4])) Coxeter-Dynkin diagram triality symmetry, T' is identified with any of 3 end nodes as parent and others as bi-rectified and tri-rectified orbits {(1000), (0010), (0001)} each with 8 vertices of 2-component (vector) quaternions and has a 3D hull of the rhombic dodecahedron. See Fig. 11 for their specific symbolic and numeric values. Of course, it has also been shown that the root system of (Subscript[F, 4])=T♁T'.

From T (and T') we can take any one vertex to define a c (and c'=cp) respectively. For this paper, we use as an example c=(Subscript[t, 1]) from eq. (18) from Koca[3] T (and T') shown as #13 in Fig. 11 such that c=(1/2) (1+ℯ_1-ℯ_2-ℯ_3) (and c‘=((Subscript[ℯ, 2])-(Subscript[ℯ, 3]))/(Sqrt[2])). Here c' is used with A' to generate the parent W((Subscript[A, 4])), or simply A as the 5-cell[3]. Specifically, A=(SuperStar[(c'∘ A')]) with A'=ΛA4[{0,1,4,2,3},{1,0,0,0}]^3.

(( )^3)The 4-polytopes for a particular orbit of O(\mathtt{Λ})=W(\mathtt{group}) are generated using a function Λ[group_,orbit_,perm_] which is called by Λ A4[Λ_,orbit_] for the subgroup embeddings in (Subscript[A, 4]) as described in [5]. In addition, SmallCircle(∘) is the symbolic operator for quaternion (octonion) multiplication that operates across lists, along with the expected symbolic exponentials (* and †) for Conjugate and ConjugateTranspose respectively. The function prq[p_,r_,q_,left_:False]:=If[left,(p∘ r)∘ q,p∘ (r∘ q)]} implements the operation of [p,q]:r from eq. (6) in [3], which is defined for any combinations of inputs as elements or lists in order to add flexibility to quaternion and octonion operators, including left or right (default) non-commutative multiplication ordering. Other operators are also available for scalar product+(♁), scalar product-(⊖), commutator(\[PermutationProduct]), anti-commutator(⋀), derivation(□), Kronecker product(⊗), and octExp for exponential powers of octonions.

See Fig. 12 for the explicit (Mathematica^TM) computation related to A and A'.

Fig. 12 Explicit (Mathematica^TM) computation of A from the ΛA4[Λ_,orbit_] generated A’

(* Generate the A' parent Weyl orbit *)
ΛA4[{0,1,4,2,3},{1,0,0,0}]

(* Scale by -((Sqrt[5])/2) to match conventional A scaling *)
ApList=oct2List@biQuaternion[-((Sqrt[5])/2)#]&/@%[[1,1]]

(* Put it into symbolic octonion form *)
Ap=octSimplify@octonion/@%;
%//MatrixForm

(* Display vertex valuse *)
checkVertices[%,False,True,True,False,False,False]

(* The Alternate generation of A4 *)
altA=octSimplify/@prq[octExpαL[[#]],1,octExpαLsw[[#]]]&/@Range[1,5]

(* Simplify quaternion multiplication using p∘r∘q which also handles lists,
   We scale up/down by 4 for symbolic clarity. 
Please note the double struck A to avoid stepping on LieArt *)
𝔸=((1/4)(SuperStar[octonion[biQuaternion[#/.φRep]]])/.slRep)&/@
(* φRep replaces the symbolic forms ϕ->((Sqrt[5])+1)/2, also note the conjugation using ^* *)
(4oct2Quat@#&/@Flatten@prq[cp,1,Ap])

AList=oct2List/@%;

checkVertices[𝔸/.(Subscript[ℯ, 0])->1,False,True,True,False,False,False]

The snub orbit (0000) of W((Subscript[D, 4])) will generate the vertices of the snub 24-cell or S=I-T, as with the alternate snub 24-cell S'=I'-T' as shown in (7) and (8). We can generate S (or S') by taking the odd (or even) sign and cyclic position permutations of a seed quaternion p\inS (or S') to be assigned to α (or β) for generating S (or S') respectively. There are only 48 that satisfy the necessary constraint where a unit normed p^5=\pm 1. Those quaternions that satisfy the constraint are identified with an * in Appendix D. For this paper, we selected from the 96 permutations of S α=(1/2)((1/φ)+φ(Subscript[ℯ, 2])+(Subscript[ℯ, 1])) (and S' for β=(1/(Sqrt[8]))(-φ -(Subscript[ℯ, 2])/φ+(Sqrt[5]) (Subscript[ℯ, 1]))). This process of generating the snub 24-cell can be visualized as generating four quaternion 4D rotations of T (and T'). The 3D hulls of I'are shown in Fig. 15.

Equation (7):

S=(∑_(i=1)^4)(p^i)∘T
or
S=I-T=(∑_(i=1)^4) (α^i)∘ T
or
I=prq[(α^(0-4)),1,T]

Equation (8):

S'=(∑_(i=1)^4)(p^i)∘((SuperDagger[((OverBar[p])^i)])∘T')
or 
S‘=I’-T’=(∑_(i=1)^4) (β^i)∘ T'
or
I'=prq[(β^(0-4)),1,T']

Fig. 13 Visualization of the 144 root vertices of S’+T+T’ now identified as the dual snub 24-cell

Snub 24-Cell (96) S=(∑_(i=1)^4)(p^i)∘T

SL=octSimplify@#&/@Flatten@Table[
prq[octExpαL[[i]],TL,1],
{i,2,5}];
SLΦ=oct2List/@%;
NSLΦ=%/.φRep;
SLList=SLΦList=FullSimplify[Chop@N@#]&/@%;
showInfo@%%

SList=biQuaternion/@perms[{-σ,1,τ,0},"OSignOpos"]/2;
SListOct=octonion/@oct2List@SList;
Length@%

Alt. T' based Snub 24-Cell (96) S'=(∑_(i=1)^4)(p^i)∘((SuperDagger[((OverBar[p])^i)])∘T')

SpL=octSimplify@#&/@Flatten@Table[
prq[octExpαL[[i]],octExpαLsw[[i]],TpL],
{i,2,5}];
SpLΦ=oct2List/@%;
NSpL=NSpLΦ=%/.φRep;
SpLList=SpLΦList=FullSimplify[Chop@N@#]&/@%;
showInfo@%%

SpList=biQuaternion/@perms[{-τ,(Sqrt[5]),σ,0},"ESignEpos"]/(Sqrt[8]);
SpListOct=octonion/@oct2List@SpList;
Length@%

Dual Snub 24-Cell (144)                    T⊕T'⊕S'

dualSnub24L=dualSnub24LΦ=Join[TLΦ,TpLΦ,SpLΦ];
NdualSnub24L=NdualSnub24LΦ=Join[NTLΦ,NTpLΦ,NSpLΦ];
showInfo@%

Alt. S based Dual Snub 24-Cell (144)  T⊕T'⊕S

AltdualSnub24L=AltdualSnub24LΦ=Join[TLΦ,TpLΦ,SLΦ];
NAltdualSnub24L=NAltdualSnub24LΦ=Join[NTLΦ,NTpLΦ,NSLΦ];
showInfo@%

The 3D hulls for one copy of I (or φI) are represented in Fig. 14 hulls {2,3,5} (or {6,7,8}) respectively plus 1/2 of the vertices in hull 4. The vertex values of I are listed in either of the center columns of Appendix D Fig. 22 or Fig. 23.

Koca[3] has also identified the dual to the snub 24-cell as being made up of the 144 root vertices of S'+T+T'. This 4-polytope is visualized in Fig. 13.

The equations for the generation of J (and J') are shown in (9) and (10). As it was for I (and I') vertices each mapping to 5 quaternion rotations of T (and T'), J (and J') vertices each map to 5 quaternion rotations of I (and I') or 25 quaternion rotations of T (and T'). Given the isomorphism between each (Subscript[E, 8]) root vertex and 4 copies of I (i.e. L and R each at unit and φ scales) as demonstrated in Section \ref{sec:The palindromic unitary matrix}, this means quaternionic Weyl orbit construction, when used with 𝕌 and mapLR, provides for an explicit map between each of the 240 (Subscript[E, 8]) root vertices and 20 J (or J') vertices (i.e. 20=4(L♁R♁1♁φ)×5 quaternion rotation copies of each I (or I') vertex).

Equation (9):

J=(∑_(i=1)^4) c’∘ (SuperDagger[((OverBar[α])^i)]) ∘ (α^i)∘ T
or
J=prq[A’,(α^(0-4)),T]

Equation (10):

J’=(∑_(i=1)^4)c∘  (SuperDagger[((OverBar[β])^i)]) ∘ (β^i)∘ T'
or
J'=\mathtt{prq[A’,(β^(0-4)),T']

See Appendix A Figs. 16-17 for the 120-cell (J) and its alternate (J') as generated by J=prq[A',1,I] and J'=prq[A',1,I'] respectively.

Section IV: Conclusion

This paper has given an explicit isomorphic mapping from the 240 (ℝ^8) root (Subscript[E, 8]) Gosset (Subscript[4, 21]) 8-polytope to two φ scaled copies of the 120 root (Subscript[H, 4]) 600-cell quaternion 4-polytope using 𝕌. It has also shown the inverse map from a single (Subscript[H, 4]) 600-cell to (Subscript[E, 8]) using a 4D↔8D chiral L↔R mapping function, φ scaling, and (𝕌^(-1)). This approach has shown that there are actually four copies of each 600-cell living within (Subscript[E, 8]) in the form of chiral (Subscript[H, 4L])♁φ (Subscript[H, 4L])♁(Subscript[H, 4R])♁φ (Subscript[H, 4R]) roots. In addition, it has demonstrated a quaternion Weyl orbit construction of (Subscript[H, 4])-based 4-polytopes that provides an explicit map from (Subscript[E, 8]) to four copies of the tri-rectified Coxeter-Dynkin diagram of (Subscript[H, 4]), namely the 120-cell of order 600. Taking advantage of this property promises to open the door to as yet unexplored chiral (Subscript[E, 8])-based Grand Unified Theories or GUTs. It is anticipated that these visualizations and connections will be useful in discovering new insights into unifying the mathematical symmetries as they relate to unification in theoretical physics.

Bibliography

[1] M . Koca, E8 Lattice with Octonions and Icosians, CERN, 1211 Geneva 23, Switzerland (1989) . 
[2] M . Koca and N . Koca, Quaternionic Roots of E8 Related Coxeter Graphs and Quasicrystals, Turkish Journal of Physics 22, 421 (1998) . 
[3] M . Koca, M . Al - Ajmi, and N . O . Koca, Quaternionic representation of snub 24 - cell and its dual polytope derived from e8 root system, Linear Algebra and its Applications 434, 977 (2011) . 
[4] M . Koca, N . O . Koca, and M . Al - Shueili, Chiral Polyhedra Derived From Coxeter Diagrams and Quaternions, ArXiv e - prints math . ph (2011), arXiv : 1006.3149[mathph] . 
[5] M . Koca, N . O . Koca, and M . Al - Ajmi, 4 d - polytopes and their dual polytopes of the coxeter group a4 represented by quaternions, International Journal of Geometric Methods in Modern Physics 09, 1250035 (2012) . 
[6] S . Mamone, G . Pileio, and M . H . Levitt, Orientational sampling schemes based on four dimensional polytopes, Symmetry 2, 1423 (2010) . 
[7] J . H . Conway, R . H . Hardin, and N . J . A . Sloane, Packing Lines, Planes, etc . : Packings in Grassmannian Space, ArXiv e - prints math . CO (2002), arXiv : math/0208004 [math . CO] . 
[8] D . A . Richter, Triacontagonal coordinates for the E8 root system, ArXiv e - prints math . GM (2007), arXiv : 0704.3091[math . GM] . 
[9] P . P . Dechant, The birth of E8 out of the spinors of the icosahedron, Proceedings of the Royal Society of London Series A 472, 20150504 (2016), arXiv : 1602.05985[mathph] . 
[10] J . C . Baez, From the Icosahedron to E8, ArXiv e - prints math . HO (2017), arXiv : 1712.06436[math . HO] . 
[11] J . G . Moxness, The 3 D Visualization of E8 using an H4 Folding Matrix, www . vixra . org/abs/1411.0130 (2014) . 
[12] J . G . Moxness, Mapping the fourfold H4 600 - cells emerging from E8, www . vixra . org/abs/1808.0107 (2018) . 
[13] J . G . Moxness, Unimodular rotation of E8 to H4 600 - cells, www . vixra . org/abs/1910.0345 (2019) . 
[14] J . G . Moxness, 3 D Polytope Hulls of E8 4 - 21, 2 - 41, and 1 - 42, www . vixra . org/abs/2005.0200 (2020) . 
[15] G . Dixon, Integral octonions, octonion xy - product, and the leech lattice, ArXiv e - prints math . th (2010), arXiv : 1011.2541[hep - th] . 
[16] Pushpa, P . S . Bisht, T . Li, and O . P . S . Negi, Quaternion octonion reformulation of grand unified theories, International Journal of Theoretical Physics 51, 3228 (2012) . 
[17] R . A . Wilson, T . Dray, and C . A . Manogue, An octonionic construction of e8 and the lie algebra magic square, Innovations in Incidence Geometry : Algebraic, Topological and Combinatorial 20, 611 (2023) . 
[18] M . GNunaydin and F . GNursey, Quark structure and octonions, Journal of Mathematical Physics 14, 1651 (2003), https : // pubs . aip . org/aip/jmp/articlepdf/14/11/1651/8805448/1651 1 online . pdf . 
[19] C . Furey, Su (3) c*su (2) l*u (1) y (*u (1) x) as a symmetry of division algebraic ladder operators, The European Physical Journal C 78, 10.1140/epjc/s10052 - 018 - 5844 - 7 (2018) . 
[20] J . G . Moxness, The Comprehensive Split Octonions and their Fano Planes, vixra . org/abs/1503.0228 (2013) . 
[21] R . M . Fonseca, GroupMath : A mathematica package for group theory calculations, Computer Physics Communications 267, 108085 (2021) . 
[22] P . Grozman and D . Leites, Lie superalgebra structures, Czechoslovak Journal of Physics 54, 1313 (2004) .

Appendix A:

Concentric hulls from Platonic 3D projection with numeric and symbolic norm distances Figs. 14-17

Fig. 14 Concentric hulls of (Subscript[4, 21]) in Platonic 3D projection with numeric and symbolic norm distances

hulls3D[pC600[#][[;;3]]&/@e8]

More visualizations related to constructing I using T:

(* ILϕ  *)

ILϕ=octSimplify/@Flatten@prq[octExpαL,1,TLϕ];
ILϕSymList:=oct2List/@ILϕ;

(* Rounded numeric *)
ILϕRnd=rndOct/@ILϕ;
(* Octonion list form *)
ILϕN=oct2List/@ILϕ/.φRep;
ILϕNRnd=rndMat/@%;
ILϕList=FullSimplify[Chop@N@#]&/@%%;
ILϕNRndQuat=oct2Quat/@%%;
hulls3D[oct2ImQuat@#&/@ILϕ]

(* IR=IRΦ  *)

(* Using switchScale=Φ produces the  Pentakis Icosidodecahedron, but this does not match the Left-handed vertices H4LΦList (splits by 24-cell/snub 24-cell), but does match ILΦ,
   using switchScale of=1 produces the Rhombic Dodecahedron and matches vertices of ILΦ (splits by 24-cell/snub 24-cell), but does not match H4LΦList *)
IR=IRΦ=octonion@mapLR[#,1(**)Φ(**),False]&/@ILΦSymList;

(*)
IR=IRΦ=Φ IRϕ/.slRep;

IRΦSymList:=oct2List/@IR;

(* Rounded numeric *)
IRΦRnd=rndOct/@IRΦ;
(* Octonion list form *)
IRN=IRΦN=oct2List/@IRΦ/.φRep;
IRNRnd=IRΦNRnd=rndMat/@%;
IRList=IRΦList=FullSimplify[Chop@N@#]&/@%%;
IRNRndQuat=IRΦNRndQuat=oct2Quat/@%%;

(* Visualize in 3D using the Imaginary quaternions {(Subscript[ℯ, 1]),(Subscript[ℯ, 2]),(Subscript[ℯ, 3])} or yzw with (Subscript[ℯ, 0])=x=0 *)
hulls3D@IRN[[All,;;3]]

(* IRϕ  *)

(* Using switchScale=ϕ produces the  Pentakis Icosidodecahedron, but this does not match the Left-handed vertices H4LϕList (splits by 24-cell/snub 24-cell), but does match ILϕ,
   using switchScale of=1 produces the Rhombic Dodecahedron and matches vertices of ILϕ (splits by 24-cell/snub 24-cell), but does not match H4LϕList *)
IRϕ=octSimplify@mapLR[#,1(**)ϕ(**),False]&/@ILϕSymList;

IRϕSymList:=oct2List/@IRϕ;

(* Rounded numeric *)
IRϕRnd=rndOct/@IRϕ;
(* Octonion list form *)
IRϕN=oct2List/@IRϕ/.φRep;
IRϕNRnd=rndMat/@%;
IRϕList=FullSimplify[Chop@N@#]&/@%%;
IRϕNRndQuat=oct2Quat/@%%;
(* Visualize in 3D *)
hulls3DPerms["IRϕSymList",False,,1]

Fig. 15 Concentric hulls of I' as the parent (Subscript[H, 4]) 600-cell of order 120 in Platonic 3D projection with numeric and symbolic norm distances . 
This is generated by I' = prq[(α^(0-4)), 1, T'].

TpL;
Tpϕ=TpLϕ=octSimplify/@(TpL ϕ/.slRep);

(* Ip=IpLΦ  *)

(* Simplify the resulting p∘r∘q octonions *)
Ip=IpL=IpLΦ=octSimplify/@Flatten@prq[octExpαLsw,1(*)ϕ**),TpL];
%[[Range[25,30]]]//MatrixForm

IpLΦSymList:=oct2List/@IpL;

(* Rounded numeric *)
IpRnd=IpLRnd=IpLΦRnd=rndOct/@IpLΦ;
(* Octonion list form *)
IpN=IpNL=IpLΦN=oct2List/@IpLΦ/.φRep;
IpNRnd=IpLNRnd=IpLΦNRnd=rndMat/@%;
IpList=IpLList=IpLΦList=FullSimplify[Chop@N@#]&/@%%;
IpNRndQuat=IpLNRndQuat=IpLΦNRndQuat=oct2Quat/@%%;
(* Visualize in 3D using the fully symbolic Imaginary quaternions {(Subscript[ℯ, 1]),(Subscript[ℯ, 2]),(Subscript[ℯ, 3])} or yzw with (Subscript[ℯ, 0])=x=0 *)
hulls3D[oct2ImQuat@#&/@Ip]

(* IpR=IpRΦ  *)

(**)
IpR=IpRΦ=octSimplify/@Flatten@prq[octonion@mapLR[#,ϕ,False]&/@oct2List/@octExpαLsw,1,TpL];

IpRΦSymList:=oct2List/@IpRΦ;

(* Rounded numeric *)
IpRΦRnd=rndOct/@IpRΦ;
(* Octonion list form *)
IpRN=IpRΦN=oct2List/@IpRΦ/.φRep;
IpRNRnd=rndIpRΦNRnd=rndMat/@%;
IpRList=IpRΦList=FullSimplify[Chop@N@#]&/@%%;
IpRNRndQuat=rndIpRΦNRndQuat=oct2Quat/@%%;
(* Visualize in 3D *)
hulls3DPerms["IpRΦSymList",False,,1]

Fig. 16 Concentric hulls of J as the tri-rectified (Subscript[H, 4]) 120-cell of order 600 in Platonic 3 D projection with numeric and symbolic norm distances. 
This is generated by J = prq[A', 1, I] = prq[A’,(α^(0-4)),T]
Note : The numeric and symbolic tally list of unpermuted vertex values in the lower-right corner

J=JL=JLΦ=octSimplify/@Flatten@prq[IpL,1,octExpαLsw];

JLΦSymList:=oct2List/@JLΦ;

(* Rounded numeric *)
JRnd=JLRnd=JLΦRnd=rndOct/@JLΦ;
(* Octonion list form *)
JN=JLN=JLΦN=oct2List/@JLΦ/.φRep;
JNRnd=JLNRnd=JLΦNRnd=rndMat/@%;
JList=JLList=JLΦList=FullSimplify[Chop@N@#]&/@%%;
JNRndQuat=JLNRndQuat=JLΦNRndQuat=oct2Quat/@%%;

(**)
hulls3DPerms["JLΦSymList",False,,1]

Fig. 17 Concentric hulls of J' as the tri-rectified (Subscript[H, 4]) 120-cell of order 600 in Platonic 3 D projection with numeric and symbolic norm distances. 
This is generated by J' = prq[A', 1, I'] = prq[A’,(β^(0-4)), T']
Note : The numeric and symbolic tally list of unpermuted vertex values in the lower-right corner

(**)
Jp=JpL=JpLΦ=octSimplify/@Flatten@prq[octExpαLsw,1,IL];
JpLΦSymList:=oct2List/@JpLΦ;

(* Rounded numeric *)
JpLΦRnd=rndOct/@JpLΦ;
(* Octonion list form *)
JpN=JpNL=JpLΦN=oct2List/@JpLΦ/.φRep;
JpNRnd=JpNLRnd=JpLΦNRnd=rndMat/@%;
JpList=JpLList=JpLΦList=FullSimplify[Chop@N@#]&/@%%;
JpNRndQuat=JpLNRndQuat=JpLΦNRndQuat=oct2Quat/@%%;

(**)
hulls3DPerms["JpLΦSymList",False,,1]

Appendix B:

Fig. 18 Archimedean and dual Catalan solids, including their irregular and chiral forms . 
These were created using quaternion Weyl orbits directly from the (Subscript[A, 3]), (Subscript[B, 3]),and (Subscript[H, 3]) group symmetries[4] listed in the first column .

Grid[Prepend[
(* Format the Data *)
{Column[{#[[1]],solidsListStr[[#[[1]]]],MatrixForm@solidsList[[#[[1]]]]},Center],solids3D[[#[[1]]]],
Column[{#[[2]],solidsListStr[[#[[2]]]],MatrixForm@solidsList[[#[[2]]]]},Center],solids3D[[#[[2]]]]}&/@Partition[{
(* Platonic Solids **)
20,21(*11**),
(* Archimedean / Catalan Solids *)
2,3,
44,3,
45,32,
4,5,
8,9,
6,7,
10,12,
13,14,
15,16,
17,19,
22,23,
24,25,
26,27,
28,29,
30,31,
36,43,
33,37,
42,40},2],
(* Add the column headers *)
Style[#,Bold]&/@{
Column[{"Index #","Archimedean Name","Quaternion Weyl Orbit Definition"},Center],"Archimedean Hulls w/Symbolic/Numeric Norms",
Column[{"Index #","Catalan Dual Name","Quaternion Weyl Orbit Definition"},Center],"Catalan Hulls w/Symbolic/Numeric Norms"}],
Frame->All,FrameStyle->LightGray,Alignment->Center]

Appendix C:

Maximal SO(16)=(Subscript[D, 8]) related embeddings of (Subscript[E, 8]) at height 248 Figs. 19-20

Import@"CombinedMaximalEmbeddings.png"

Fig.19 Breakdown of(Subscript[E, 8])maximal embeddings at height 248 of content SO (16)=(Subscript[D, 8])(120,128')

a) Height 248 SO (16) content 120 = (112 + 4 + 4) + 128'
b) Height 120 and 128' SO(8)⊗SO(8) content w/(Subscript[8, v,c,s]^(⊗2)) triality  
c) Height 136 Sp(8)⊗Sp(8) content (32 + 4)⊗1, 1⊗(32 + 4), (8^(⊗2)) 
Note : This output was created in (Mathematica^TM) with support from the GroupMath[21] and SuperLie[22] packages.

More content showing all (Subscript[E, 8]), (Subscript[D, 8]), and (Subscript[C, 8]), embeddings up to  orbitMax height:

orbitMax=248;
alg="E8";
showAllSGContent

orbitMax=136;
alg="SO16";
showAllSGContent

alg="Sp16";
showAllSGContent

Fig. 20 (Subscript[A, 3]) in (Subscript[A, 4 ])embeddings of SU(5)⊃SU(4)⊗(Subscript[U, 1]).  
These include the specified 3D quaternion Weyl orbit hulls for each subgroup identified .

Transpose@showGroups[avΛOrbit,1,perms4D[[;;15]]]

More visualizations related to Weyl Orbits

weylOrbitOut:=Row[{
Column[{
"A4 SU(5) 4D orbit="<>ToString@perms4D[[#]],
oScaleListOut=DeleteDuplicates@oE8List[doW@"A4"/.aRule@perms4D[[#]],"Osign"][[All,;;4]];
hulls3DPerms["oScaleListOut",False,,1]}],

doPP3D=False;
Column[{
"A4 SU(5) 4D→{(Subscript[ℯ, 1]),(Subscript[ℯ, 2]),(Subscript[ℯ, 3])} avΛ orbit="<>ToString@perms4D[[#]],
oScaleListOut=ΛnD[avΛ[[1]],oCalc,"A4",perms4D[[#]],"Osign"];
hulls3DPerms["oScaleListOut",False,,1]}],

doPP3D=True;
Column[{"A4 SU(4)xU(1) 4D→{(Subscript[ℯ, 1]),(Subscript[ℯ, 2]),(Subscript[ℯ, 3])} avΛ 3D orbit="<>ToString@perms4D[[#]],
Row@{MatrixForm@Transpose@Table[{
{"","","SU4 x U1","",""}[[i]],
Abs/@avΛOrbit[[i,;;3]]/.aRule@perms4D[[#]],
getSU4Hull[Mod[#-1,15,1],i]},{i,5}]}}]}]&;

weylOrbitOut/@Range@15//TableForm

Appendix D:

Fig. 21 (Mathematica^TM) code to generate the output showing (Subscript[E, 8])↔(Subscript[H, 4]) isomorphism

(* This switches the H4 (L)eft side scale to the (R)ight side scale (and vice-versa).
We don't use scaleBy if it is a snub 24-cell vertices. *)
switchScale[in_,scaleBy_:1]:= (* We don't use scaleBy if it is a snub 24-cell vertices. *)
If[Length@Union@Flatten@Abs@oct2List@N[in/.φRep]==2,
in,scaleBy in/.slRep];

(* Replacement order is critical *)
mapLRrep=#/.slRep&/@{
(* (φ^(±3)) Scale changing: Exchange the ±(φ^2)↔±1/φ  and ±(φ^(±3/2))↔±(φ^(∓3/2)) *)
(1/((ϕsw)^2))->φ,((ϕsw)^2)->(1/φ), ((ϕsw)^(-3/2))->(φ^(3/2)),((ϕsw)^(3/2))->(φ^(-3/2)),
(* Sign changing: Exchange the ±(Sqrt[φ])↔∓(Sqrt[φ]) & ±1/(Sqrt[φ])↔∓1/(Sqrt[φ]), and ±1/φ↔∓1/φ*)
(Sqrt[ϕsw])->-(Sqrt[φ]),(Sqrt[(1/(ϕsw))])->-(Sqrt[(1/φ)]),(1/(ϕsw))->-(1/φ),
(* Final (φ^(±3)) Scale changing: ±φ↔±1/(φ^2) *)
ϕsw->(1/(φ^2))(**)};

(* This processes only individual vertices with a symbolic list input. *)
mapLR[in_,scaleBy_:1,𝕌Det1fCorrection_:True]:=Module[{(*)input,output**)},
(* Correct for use of (Sqrt[ϕ]) in 𝕌 which produces I values (which may be desired?) *)
input=If[curr𝕌==11||!𝕌Det1fCorrection,in,FullSimplify[in 𝕌Det1f/.slRep,Assumptions->φAssumptions]];
output=FullSimplify[switchScale[octSym@input /.φ->ϕsw/.mapLRrep/.slRep,scaleBy]×
(* Correct back *)
If[curr𝕌==11||!𝕌Det1fCorrection,1,1/𝕌Det1f]/.slRep,Assumptions->φAssumptions]/.slRep;
(* curr𝕌<9 don't reverse the L↔R ordering *)
If[curr𝕌<9,output,Join[Reverse[output[[;;4]]],Array[0&,Length[output]-4]]]];

(* List and verify the operation of mapLR - one for h4Φ and one for h4 *)
genE8fromH4@in_String:=Module[{indx,inH4=If[in=="H4Φ",h4Φ,h4],i,j,left,right,h4LR},
(* Style the Heading in Bold, 24-cell rows in Red, and p48 constraint members marked with an * *)
Style[#,
{If[MemberQ[If[in=="H4Φ",h4Φcell24,h4cell24],indx],Red,Black],
If[Head@indx===String,Bold,Plain]}]&/@(indx=#[[2]];#)&/@
Join[
(* The Heading row *)
{{"#",in<>" #",If[labels,"pLbl",Nothing],
Column[{"E8 vertex","E8.𝕌="<>in<>"\!\(\*SubscriptBox[\(\\ \), \(L\)]\)"<>"⊕"<>in<>"\!\(\*SubscriptBox[\(\\ \), \(R\)]\)"},Center],
Column[{If[curr𝕌==11,"","2 "]<>in<>"\!\(\*SubscriptBox[\(\\ \), \(\(L\)\(\\ \)\)]\)","mapLR("<>in<>"\!\(\*SubscriptBox[\(\\ \), \(L\)]\))="<>in<>"\!\(\*SubscriptBox[\(\\ \), \(R\)]\)"},Center],
Column[{If[curr𝕌==11,"","2 "]<>in<>"\!\(\*SubscriptBox[\(\\ \), \(R\)]\)","mapLR("<>in<>"\!\(\*SubscriptBox[\(\\ \), \(R\)]\))="<>in<>"\!\(\*SubscriptBox[\(\\ \), \(L\)]\)"},Center],
Column[{"","("<>in<>"\!\(\*SubscriptBox[\(\\ \), \(L\)]\)"<>"⊕"<>in<>"\!\(\*SubscriptBox[\(\\ \), \(R\)]\)"<>").(𝕌^(-1))=E8 vertex"},Center],
Column[{"E8→"<>in<>"\!\(\*SubscriptBox[\(\\ \), \(L\)]\)"<>"⊕"<>in<>"\!\(\*SubscriptBox[\(\\ \), \(R\)]\)"<>"≡",in<>"\!\(\*SubscriptBox[\(\\ \), \(L\)]\)"<>"⊕"<>in<>"\!\(\*SubscriptBox[\(\\ \), \(R\)]\)"<>"→E8"},Center]}},
(* Generate data row content *)
{ToString@#<>If[MemberQ[If[in=="H4Φ",p48LΦ,p48L],#],"*"," "],
(* h4Φ[[#]] is an E8 index number to an E8 element in h4Φ *)
inH4[[#]],If[labels,pLbl@inH4[[#]],Nothing],
(* Show the E8 vertex *)
i=pE8@inH4[[#]],
(* pC600 is converts from E8->H4 using 𝕌, here we take the H4 4D left side *)
If[curr𝕌==11,1,2](left=octSym[pC600[inH4[[#]]][[;;4]]]/.φRuleList),
(* mapLR converts the H4 4D left side vertex to its corresponding H4 4D right-side vertex, 
which when Joined gives the 8D H4 that can be converted back to E8 by using 𝕌Inv *)
If[curr𝕌==11,1,2](right=mapLR@left/.φRuleList),
(* Conditionally print some cross-checks *)
print["#=",#," h4[[#]]=",inH4[[#]]," E8.𝕌=",octSym[pC600[inH4[[#]]]]/.φRuleList," left=",left," right=",Reverse@right];
print["   E8.𝕌==Join[left,mapLR@left]=",N@Join[left,right]==N@octSym[pC600[inH4[[#]]]]/.φRuleList];
print["   mapLR@right",If[curr𝕌==11,1,2](mapLR@right/.φRuleList)];
print["   left==mapLR@right=",N@left==N@mapLR@right/.φRuleList];
(* Show the (Subscript[H4, L])⊕(Subscript[H4, R]).𝕌Inv vertex *)
h4LR=Join[left,right];
j=Rationalize@FullSimplify[Chop[h4LR.𝕌Inv/.φRep,chop],Assumptions->φAssumptions],
(* Check that E8->H4->(Subscript[H4, L])⊕(Subscript[H4, R])→E8 *)
j==N@i}/.slRep&/@Range@120]//MatrixForm];

Before showing the isomorphism, we need to define and visualize the 48 p, where:
  ((OverBar[p])^1)==±(p^4) && ((OverBar[p])^4)==±p&&
 ((OverBar[p])^2)==(p^3) && ((OverBar[p])^3)==(p^2) &&
 ((OverBar[p])^5)==±(p^5)==±((OverBar[p])^0)==±(p^0)==±1

curr𝕌=9;set𝕌;

h4L=octSimplify@biQuaternion[pC600[#][[;;4]](Sqrt[φ])]&/@h4;
h4LList=oct2List/@%;
h4LListN=%/.φRep;
h4LListRnd=rndMat@%;

h4LΦ=octSimplify@biQuaternion[pC600[#][[;;4]]/(Sqrt[φ])]&/@h4Φ;
h4LΦList=oct2List/@%;
h4LΦListN=%/.φRep;
h4LΦListRnd=rndMat@%;

Clear@doP48;
doP48@in_String:=Module[{inExp=ToExpression@in,p1c,p1,p2c,p2,p3c,p3,p4c,p4,p5(*),out**)},
out={#,
(* 120 h4LΦ Icosians (I[[#]]=p) *)
p1c=octSimplify@octExp[(SuperStar[inExp[[#]]]),1];
p1=octSimplify@inExp[[#]];inExp[[#]],
(* (P^2) *)
p2c=octSimplify@octExp[(SuperStar[inExp[[#]]]),2];
p2=octSimplify@octExp[inExp[[#]],2],
(* (P^3) *)
p3c=octSimplify@octExp[(SuperStar[inExp[[#]]]),3];
p3=octSimplify@octExp[inExp[[#]],3],
(* (P^4) *)
p4c=octSimplify@octExp[(SuperStar[inExp[[#]]]),4];
p4=octSimplify@octExp[inExp[[#]],4],
(* (P^5) *)
p5=octSimplify@octExp[inExp[[#]],5],
p5===1||p5===-1,
(*  ((OverBar[p])^1)==±(p^4) && ((OverBar[p])^4)==±p *)
(p1c===p4||p1c===-p4)&&(p4c===p1||p4c===-p1),
(* ((OverBar[p])^2)==(p^3) && ((OverBar[p])^3)==(p^2) *)
(p2c===p3||p2c===-p3)&&(p3c===p2||p3c===-p2)
}&/@Range@(*)2**)Length@inExp(**);
Join[{{"#","120 "<>in<>" Icosians (I[[#]]=p)","(P^2)","(P^3)","(P^4)","(P^5)","(P^5)=±1",Column[{"((OverBar[p])^1)=±(p^4)","((OverBar[p])^4)=±p"}],Column[{"((OverBar[p])^2)=(p^3)","((OverBar[p])^3)=(p^2)"}]}},
out]]//MatrixForm;

doP48@"h4L"
Select[out,#[[7]]==True&][[All,1]];
Length@%
(* Takeout the 2 trivial cases for p=±1 *)
p48L=Select[out,Abs@octSimplify@#[[2]]=!=1&&#[[7]]==True&][[All,1]]
Length@%
Complement[Select[out,#[[7]]==True&][[All,1]],p48L]

p48L={4,5,6,7,8,10,13,14,15,16,17,18,20,21,22,23,24,25,48,53,56,58,59,60,61,62,63,65,68,73,96,97,98,99,100,101,103,104,105,106,107,108,111,113,114,115,116,117};
Length@%

doP48@"h4LΦ"
Select[out,#[[7]]==True&][[All,1]];
Length@%
(* Takeout the 2 trivial cases for p=±1 *)
p48LΦ=Select[out,Abs@octSimplify@#[[2]]=!=1&&#[[7]]==True&][[All,1]]
Length@%
Complement[Select[out,#[[7]]==True&][[All,1]],p48LΦ]

p48LΦ={2,3,4,10,14,17,21,22,28,29,34,35,39,40,42,43,44,45,46,48,50,53,55,58,63,66,68,71,73,75,76,77,78,79,81,82,86,87,92,93,99,100,104,107,111,117,118,119};
Length@%

Fig. 22 Output showing detail of  (Subscript[E, 8])↔(Subscript[H, 4])(L♁R♁1♁φ) isomorphism for each vertex   
Note : Red rows indicate (Subscript[D, 4 ]) 24 - cell membership and the (*) identifies those satisfying the constraint for p

curr𝕌=9;set𝕌;
(octSym@#->mapLR@#/.slRep)&/@({
{1/τ,0,-1,1/(τ^2)},
{-1/τ,0,1,-1/(τ^2)},
{τ,0,-1,1/τ},
{-τ,0,1,-1/τ}}/If[curr𝕌==11,1,𝕌Det1f]/.slRep)//MatrixForm

(* 24-cell rows in Red and p48 constraint members marked with an * *)
genE8fromH4@"H4"

Fig. 23 Output showing detail of  (Subscript[E, 8])↔(Subscript[φH, 4])(L♁R♁1♁φ) isomorphism for each vertex   
Note : Red rows indicate (Subscript[D, 4 ]) 24 - cell membership and the (*) identifies those satisfying the constraint for p

(* 24-cell rows in Red and p48 constraint members marked with an * *)
genE8fromH4@"H4Φ"